klacks fixes

cxml.asd

@@ -127,7 +127,7 @@
                "test/"
                (make-pathname :name nil :type nil :defaults *load-truename*))
     :components ((:file "domtest") (:file "xmlconf"))
-    :depends-on (:cxml-xml :cxml-dom))
+    :depends-on (:cxml-xml :cxml-klacks :cxml-dom))
 
 (asdf:defsystem :cxml
     :components ()

doc/klacks.xml

@@ -215,4 +215,11 @@ NIL</pre>
       Call <tt>klacks:close-source</tt> to close the source after
       exiting <tt>body</tt>, whether normally or abnormally.
     </p>
+
+    <h3>Bridging Klacks and SAX</h3>
+    <p>
+      <div class="def">Function KLACKS:SERIALIZE-SOURCE (source handler)</div>
+      Read all klacks events from <tt>source</tt> and send them as SAX
+      events to the SAX <tt>handler</tt>.
+    </p>
 </documentation>

dom/dom-builder.lisp

@@ -37,10 +37,11 @@
     (setf (document handler) document)
     (push document (element-stack handler))))
 
+;; fixme
+(defmethod sax::dtd ((handler dom-builder) dtd)
+  (setf (slot-value (document handler) 'dtd) dtd))
+
 (defmethod sax:end-document ((handler dom-builder))
-  (setf (slot-value (document handler) 'dtd)
-	;; FIXME!
-	(and cxml::*ctx* (cxml::dtd cxml::*ctx*)))
   (let ((doctype (dom:doctype (document handler))))
     (when doctype
       (setf (slot-value (dom:entities doctype) 'read-only-p) t)

klacks/klacks-impl.lisp

@@ -31,7 +31,7 @@
      (current-values)
      (current-attributes)
      (cdata-section-p :reader klacks:current-cdata-section-p)
-     ;; extra with-source magic
+     ;; extra WITH-SOURCE magic
      (data-behaviour :initform :DTD)
      (namespace-stack :initform (list *initial-namespace-bindings*))
      (temporary-streams :initform nil)
@@ -126,13 +126,18 @@
 	(apply #'make-source xstream args)))
     (pathname
       (let* ((xstream
-	      (make-xstream (open input :element-type '(unsigned-byte 8))))
+	      (make-xstream (open input :element-type '(unsigned-byte 8)))))
-	     (source (apply #'make-source
+	(setf (xstream-name xstream)
+	      (make-stream-name
+	       :entity-name "main document"
+	       :entity-kind :main
+	       :uri (pathname-to-uri (merge-pathnames input))))
+	(let ((source (apply #'make-source
 			     xstream
 			     :pathname input
 			     args)))
 	  (push xstream (slot-value source 'temporary-streams))
-	source))
+	  source)))
     (rod
       (let ((xstream (string->xstream input)))
 	(setf (xstream-name xstream)
@@ -152,8 +157,7 @@
   (check-type entity-resolver (or null function symbol))
   (check-type disallow-internal-subset boolean)
   (let* ((context
-	  (make-context :handler nil
+	  (make-context :main-zstream input
-			:main-zstream input
 			:entity-resolver entity-resolver
 			:disallow-internal-subset disallow-internal-subset))
 	 (source
@@ -167,6 +171,7 @@
 	    :scratch-pad-2 *scratch-pad-2*
 	    :scratch-pad-3 *scratch-pad-3*
 	    :scratch-pad-4 *scratch-pad-4*)))
+    (setf (handler context) (make-instance 'klacks-dtd-handler :source source))
     (setf (slot-value source 'continuation)
 	  (lambda () (klacks/xmldecl source input)))
     source))
@@ -208,25 +213,26 @@
 (defun klacks/doctype (source input)
   (with-source (source current-key current-values validate dtd)
     (let ((cont (lambda () (klacks/finish-doctype source input)))
-	  ignoreme name extid)
+	  l)
       (prog1
 	  (cond
 	    ((eq (peek-token input) :<!DOCTYPE)
-	      (setf (values ignoreme name extid)
+	      (setf l (cdr (p/doctype-decl input dtd)))
-		    (p/doctype-decl input dtd))
 	      (lambda () (klacks/misc*-2 source input cont)))
 	    (dtd
-	      (setf (values ignoreme name extid)
+	      (setf l (cdr (synthesize-doctype dtd input)))
-		    (synthesize-doctype dtd input))
 	      cont)
 	    ((and validate (not dtd))
 	      (validity-error "invalid document: no doctype"))
 	    (t
 	      (return-from klacks/doctype
 		(funcall cont))))
+	(destructuring-bind (&optional name extid) l
 	  (setf current-key :dtd)
 	  (setf current-values
-	      (list name (extid-public extid) (extid-system extid)))))))
+		(list name
+		      (and extid (extid-public extid))
+		      (and extid (extid-system extid)))))))))
 
 (defun klacks/finish-doctype (source input)
   (with-source (source current-key current-values root data-behaviour)
@@ -323,7 +329,7 @@
 	      (klacks/entity-reference source input name recurse)))
 	  ((:<!\[)
 	    (setf current-key :characters)
-	    (setf current-values (list (process-cdata-section input sem)))
+	    (setf current-values (list (process-cdata-section input)))
 	    (setf cdata-section-p t)
 	    recurse)
 	  ((:PI)
@@ -376,6 +382,58 @@
     (set-full-speed input)
     (klacks/content source input cont)))
 
+
+;;;; terrible kludges
+
+(defclass klacks-dtd-handler ()
+    ((handler-source :initarg :source :reader handler-source)
+     (internal-subset-p :initform nil :accessor handler-internal-subset-p)))
+
+(defmethod sax:start-internal-subset ((handler klacks-dtd-handler))
+  (setf (slot-value (handler-source handler) 'internal-declarations) '())
+  (setf (handler-internal-subset-p handler) t))
+
+(defmethod sax:end-internal-subset ((handler klacks-dtd-handler))
+  (setf (handler-internal-subset-p handler) nil))
+
+(defmethod sax:entity-resolver ((handler klacks-dtd-handler) fn)
+  (setf (slot-value (handler-source handler) 'dom-impl-entity-resolver) fn))
+
+(defmethod sax::dtd ((handler klacks-dtd-handler) dtd)
+  (setf (slot-value (handler-source handler) 'dom-impl-dtd) dtd))
+
+(defmethod sax:end-dtd ((handler klacks-dtd-handler))
+  (let ((source (handler-source handler)))
+    (when (slot-boundp source 'internal-declarations)
+      (setf (slot-value source 'internal-declarations)
+	    (reverse (slot-value source 'internal-declarations)))
+      (setf (slot-value source 'external-declarations)
+	    (reverse (slot-value source 'external-declarations))))))
+
+(macrolet
+    ((defhandler (name &rest args)
+	 `(defmethod ,name ((handler klacks-dtd-handler) ,@args)
+	    (let ((source (handler-source handler))
+		  (spec (list ',name ,@args)))
+	      (if (handler-internal-subset-p handler)
+		  (push spec (slot-value source 'internal-declarations))
+		  (push spec (slot-value source 'external-declarations)))))))
+  (defhandler sax:unparsed-entity-declaration
+      name public-id system-id notation-name)
+  (defhandler sax:external-entity-declaration
+      kind name public-id system-id)
+  (defhandler sax:internal-entity-declaration
+      kind name value)
+  (defhandler sax:notation-declaration
+      name public-id system-id)
+  (defhandler sax:element-declaration
+      name model)
+  (defhandler sax:attribute-declaration
+      element-name attribute-name type default))
+
+
+;;;; debugging
+
 #+(or)
 (trace CXML::KLACKS/DOCTYPE 
        CXML::KLACKS/EXT-PARSED-ENT 

klacks/klacks.lisp

@@ -18,7 +18,13 @@
 
 (in-package :cxml)
 
-(defclass klacks:source () ())
+(defclass klacks:source ()
+    (
+     ;; fixme, terrible DTD kludges
+     (internal-declarations)
+     (external-declarations :initform nil)
+     (dom-impl-dtd :initform nil)
+     (dom-impl-entity-resolver :initform nil)))
 
 (defgeneric klacks:close-source (source))
 
@@ -83,7 +89,19 @@
 	  (sax:comment handler a))
 	(:dtd
 	  (sax:start-dtd handler a b c)
-	  (sax:end-dtd handler))
+	  (when (slot-boundp source 'internal-declarations)
+	    (sax:start-internal-subset handler)
+	    (serialize-declaration-kludge
+	     (slot-value source 'internal-declarations)
+	     handler)
+	    (sax:end-internal-subset handler))
+	  (serialize-declaration-kludge
+	   (slot-value source 'external-declarations)
+	   handler)
+	  (sax:end-dtd handler)
+	  (sax:entity-resolver handler
+			       (slot-value source 'dom-impl-entity-resolver))
+	  (sax::dtd handler (slot-value source 'dom-impl-dtd)))
 	(:start-element
 	  (sax:start-element handler a b c (klacks:list-attributes source)))
 	(:end-element
@@ -93,3 +111,8 @@
 	(t
 	  (error "unexpected klacks key: ~A" key)))
       (klacks:consume source))))
+
+(defun serialize-declaration-kludge (list handler)
+  (loop
+      for (fn . args) in list
+      do (apply fn handler args)))

test/xmlconf.lisp

@@ -75,8 +75,19 @@
 		     :if-exists :supersede)
       (run-all-tests directory))))
 
-(defun run-all-tests (directory)
+(defvar *parser-fn* 'sax-test)
-  (let* ((pathname (merge-pathnames "xmlconf.xml" directory))
+
+(defun sax-test (filename handler &rest args)
+  (apply #'cxml:parse-file filename handler :recode nil args))
+
+(defun klacks-test (filename handler &rest args)
+  (klacks:with-open-source
+      (s (apply #'cxml:make-source (pathname filename) args))
+    (klacks:serialize-source s handler)))
+
+(defun run-all-tests (parser-fn directory)
+  (let* ((*parser-fn* parser-fn)
+	 (pathname (merge-pathnames "xmlconf.xml" directory))
          (builder (rune-dom:make-dom-builder))
          (xmlconf (cxml:parse-file pathname builder :recode nil))
          (ntried 0)
@@ -123,10 +134,9 @@
 
 (defmethod run-test ((class null) pathname output description &rest args)
   (declare (ignore description))
-  (let ((document (apply #'cxml:parse-file
+  (let ((document (apply *parser-fn*
                          pathname
                          (rune-dom:make-dom-builder)
-			 :recode nil
                          args)))
     (cond
       ((null output)
@@ -163,9 +173,9 @@
        (handler-case
            (progn
              (format t " [validating:]")
-             (cxml:parse-file pathname
+             (funcall *parser-fn*
+		      pathname
 		      (rune-dom:make-dom-builder)
-			      :recode nil
 		      :validate t)
              (error "validity error not detected")
              nil)
@@ -179,9 +189,9 @@
   (handler-case
       (progn
          (format t " [not validating:]")
-	(cxml:parse-file pathname
+	(funcall *parser-fn*
+		 pathname
 		 (rune-dom:make-dom-builder)
-			 :recode nil
 		 :validate nil)
 	(error "well-formedness violation not detected")
       nil)
@@ -191,9 +201,9 @@
   (handler-case
       (progn
 	(format t " [validating:]")
-	(cxml:parse-file pathname
+	(funcall *parser-fn*
+		 pathname
 		 (rune-dom:make-dom-builder)
-			 :recode nil
 		 :validate t)
 	(error "well-formedness violation not detected")
       nil)
@@ -206,4 +216,9 @@
       t)))
 
 #+(or)
-(xmlconf::run-all-tests "/home/david/2001/XML-Test-Suite/xmlconf/")
+(xmlconf::run-all-tests 'xmlconf::sax-test
+			"/home/david/2001/XML-Test-Suite/xmlconf/")
+
+#+(or)
+(xmlconf::run-all-tests 'xmlconf::klacks-test
+			"/home/david/2001/XML-Test-Suite/xmlconf/")