DOM 2 Core. Ungetestet, aber die 1er tests laufen wieder, daher rein damit.

README.html

@@ -96,6 +96,7 @@
         reported as instances of <tt>well-formedness-violation</tt>.  We
         also print line number information.
       </li>
+      <li>Support internal subset serialization.</li>
       <li>Gilbert Baumann has clarified the license as Lisp-LGPL.</li>
     </ul>
     <p class="nomargin"><tt>rel-2005-06-25</tt></p>

doc/installation.html

@@ -103,7 +103,8 @@ $ cvs co cxml</pre>
 
     <p>
       <b>Prerequisites.</b>
-      CXML needs the <a href="http://www.cliki.net/Puri">puri</a> library.
+      CXML needs the <a href="http://www.cliki.net/Puri">puri</a> library
+      as well as <a href="http://www.common-lisp.net/project/cl-plus-ssl/#trivial-gray-streams">trivial-gray-streams</a>.
     </p>
 
     <p>
@@ -125,7 +126,7 @@ $ cvs co cxml</pre>
 $ cvs login    # password is "anonymous"
 $ cvs co 2001/XML-Test-Suite/xmlconf
 $ cvs co -D '2005-05-06 23:00' 2001/DOM-Test-Suite
-$ cd 2001/DOM-Test-Suite && ant dom1-dtd</pre>
+$ cd 2001/DOM-Test-Suite && ant dom1-dtd dom2-dtd</pre>
     <p>
       Omit <tt>-D</tt> to get the latest version, which may not work
       with cxml yet.  The <tt>ant</tt> step is necessary to run the DOM

doc/using.html

@@ -613,6 +613,8 @@ NIL</pre>
       <br/>
       <div class="def">Function SAX:START-DTD (handler name public-id system-id)</div>
       <div class="def">Function SAX:END-DTD (handler)</div>
+      <div class="def">Function SAX:START-INTERNAL-SUBSET (handler)</div>
+      <div class="def">Function SAX:END-INTERNAL-SUBSET (handler)</div>
       <div class="def">Function SAX:UNPARSED-ENTITY-DECLARATION (handler name public-id system-id notation-name)</div>
       <div class="def">Function SAX:EXTERNAL-ENTITY-DECLARATION (handler kind name public-id system-id)</div>
       <div class="def">Function SAX:INTERNAL-ENTITY-DECLARATION (handler kind name value)</div>
@@ -623,9 +625,9 @@ NIL</pre>
       <div class="def">Accessor SAX:ATTRIBUTE-PREFIX (attribute)</div>
       <div class="def">Accessor SAX:ATTRIBUTE-NAMESPACE-URI (attribute)</div>
       <div class="def">Accessor SAX:ATTRIBUTE-LOCAL-NAME (attribute)</div>
-      <div class="def">Accessor SAX:ATTRIBUTE-VALUE (attribute)</div>
       <div class="def">Accessor SAX:ATTRIBUTE-QNAME (attribute)</div>
       <div class="def">Accessor SAX:ATTRIBUTE-SPECIFIED-P (attribute)</div>
+      <div class="def">Accessor SAX:ATTRIBUTE-VALUE (attribute)</div>
     </p>
     <p>
       The entity declaration methods are similar to Java SAX

dom/dom-builder.lisp

@@ -12,7 +12,8 @@
 
 (defclass dom-builder ()
   ((document      :initform nil :accessor document)
-   (element-stack :initform '() :accessor element-stack)))
+   (element-stack :initform '() :accessor element-stack)
+   (internal-subset             :accessor internal-subset)))
 
 (defun dom:make-dom-builder ()
   (make-instance 'dom-builder))
@@ -39,26 +40,48 @@
   (setf (slot-value (document handler) 'entity-resolver) resolver))
 
 (defmethod sax:start-dtd ((handler dom-builder) name publicid systemid)
-  (declare (ignore publicid systemid))
   (let* ((document (document handler))
-         (doctype (make-instance 'dom-impl::document-type
+         (doctype
-                    :name name
+	  (dom:create-document-type 'implementation name publicid systemid)))
-                    :notations (make-instance 'dom-impl::named-node-map
-                                 :element-type :notation
-                                 :owner document)
-                    :entities (make-instance 'dom-impl::named-node-map
-                                :element-type :entity
-                                :owner document))))
     (setf (slot-value doctype 'dom-impl::owner) document
+	  (slot-value (dom:notations doctype) 'dom-impl::owner) document
+	  (slot-value (dom:entities doctype) 'dom-impl::owner) document
 	  (slot-value document 'dom-impl::doc-type) doctype)))
 
+(defmethod sax:start-internal-subset ((handler dom-builder))
+  (setf (internal-subset handler) nil))
+
+(defmethod sax:end-internal-subset ((handler dom-builder))
+  (setf (internal-subset (slot-value (document handler) 'dom-impl::doc-type))
+	(nreverse (internal-subset handler)))
+  (slot-makunbound handler 'internal-subset))
+
+(macrolet ((defhandler (name &rest args)
+	     `(defmethod ,name ((handler dom-builder) ,@args)
+		(when (slot-boundp handler 'internal-subset)
+		  (push (list ',name ,@args) (internal-subset handler))))))
+  (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))
+
 (defmethod sax:start-element
     ((handler dom-builder) namespace-uri local-name qname attributes)
-  (declare (ignore namespace-uri local-name))
   (with-slots (document element-stack) handler
     (let ((element (make-instance 'element 
                      :tag-name qname
-                     :owner document))
+                     :owner document
+		     :namespace-uri namespace-uri
+		     :local-name local-name
+		     :prefix (cxml::split-qname (cxml::rod qname))))
 	  (parent (car element-stack))
           (anodes '()))
       (dolist (attr attributes)
@@ -68,6 +91,7 @@
                (dom:create-text-node document (sax:attribute-value attr))))
           (setf (slot-value anode 'dom-impl::specified-p)
                 (sax:attribute-specified-p attr))
+	  (setf (slot-value anode 'dom-impl::owner-element) element)
           (dom:append-child anode text)
           (push anode anodes)))
       (setf (slot-value element 'dom-impl::parent) parent)

dom/dom-impl.lisp

@@ -8,7 +8,8 @@
 ;;;; Author: knowledgeTools Int. GmbH
 
 (defpackage :dom-impl
-  (:use :cl :runes))
+  (:use :cl :runes)
+  (:export #:create-document))
 
 (in-package :dom-impl)
 
@@ -33,6 +34,15 @@
    (read-only-p :initform nil           :reader read-only-p)
    (map         :initform nil)))
 
+(defmethod dom:prefix ((node node)) nil)
+(defmethod dom:local-name ((node node)) nil)
+(defmethod dom:namespace-uri ((node node)) nil)
+
+(defclass namespace-mixin ()
+  ((prefix        :initarg :prefix        :reader dom:prefix)
+   (local-name    :initarg :local-name    :reader dom:local-name)
+   (namespace-uri :initarg :namespace-uri :reader dom:namespace-uri)))
+
 (defclass document (node)
   ((doc-type    :initarg :doc-type     :reader dom:doctype)
    (dtd         :initform nil          :reader dtd)
@@ -44,8 +54,9 @@
 (defclass character-data (node)
   ((value       :initarg :data          :reader dom:data)))
 
-(defclass attribute (node)
+(defclass attribute (namespace-mixin node)
   ((name        :initarg :name          :reader dom:name)
+   (owner-element :initarg :owner-element :reader dom:owner-element)
    (specified-p :initarg :specified-p   :reader dom:specified)))
 
 (defmethod print-object ((object attribute) stream)
@@ -54,7 +65,7 @@
             (rod-string (dom:name object))
             (rod-string (dom:value object)))))
 
-(defclass element (node)
+(defclass element (namespace-mixin node)
   ((tag-name    :initarg :tag-name      :reader dom:tag-name)
    (attributes  :initarg :attributes    :reader dom:attributes)))
 
@@ -73,8 +84,11 @@
 
 (defclass document-type (node)
   ((name          :initarg :name          :reader dom:name)
+   (public-id     :initarg :public-id     :reader dom:public-id)
+   (system-id     :initarg :system-id     :reader dom:system-id)
    (entities      :initarg :entities      :reader dom:entities)
-   (notations     :initarg :notations     :reader dom:notations)))
+   (notations     :initarg :notations     :reader dom:notations)
+   (internal-subset                       :accessor internal-subset)))
 
 (defclass notation (node)
   ((name          :initarg :name          :reader dom:name)
@@ -176,6 +190,45 @@
     (:NOT_SUPPORTED_ERR                 9)
     (:INUSE_ATTRIBUTE_ERR               10)))
 
+;; dom-implementation protocol
+
+(defmethod dom:has-feature ((factory (eql 'implementation)) feature version)
+  (and (or (string-equal (rod-string feature) "xml")
+	   (string-equal (rod-string feature) "core"))
+       (or (string-equal (rod-string version) "1.0")
+	   (string-equal (rod-string version) "2.0"))))
+
+(defmethod dom:create-document-type
+    ((factory (eql 'implementation)) name publicid systemid)
+  (make-instance 'dom-impl::document-type
+    :name name
+    :notations (make-instance 'dom-impl::named-node-map
+		 :element-type :notation
+		 :owner nil)
+    :entities (make-instance 'dom-impl::named-node-map
+		:element-type :entity
+		:owner nil)
+    :public-id publicid
+    :system-id systemid))
+
+(defmethod dom:create-document
+    ((factory (eql 'implementation)) uri qname doctype)
+  (let ((document (make-instance 'dom-impl::document)))
+    (setf (slot-value document 'owner) nil
+	  (slot-value document 'doc-type) doctype
+	  (slot-value document 'namespace-uri) uri)
+    (setf (values (slot-value document 'prefix)
+		  (slot-value document 'local-name))
+	  (safe-split-qname qname uri))
+    (when doctype
+      (unless (typep doctype 'document-type)
+	(dom-error :WRONG_DOCUMENT_ERR
+		   "doctype was created by a different dom implementation"))
+      (setf (slot-value doctype 'dom-impl::owner) document
+	    (slot-value (dom:notations doctype) 'dom-impl::owner) document
+	    (slot-value (dom:entities doctype) 'dom-impl::owner) document))
+    document))
+
 ;; document-fragment protocol
 ;; document protocol
 
@@ -193,6 +246,9 @@
     (dom-error :INVALID_CHARACTER_ERR "not a name: ~A" (rod-string tag-name)))
   (let ((result (make-instance 'element
                   :tag-name tag-name
+		  :namespace-uri nil
+		  :local-name nil
+		  :prefix nil
                   :owner document)))
     (setf (slot-value result 'attributes)
           (make-instance 'attribute-node-map
@@ -202,6 +258,41 @@
     (add-default-attributes result)
     result))
 
+(defun safe-split-qname (qname uri)
+  (unless (cxml::valid-name-p qname)
+    (dom-error :INVALID_CHARACTER_ERR "not a name: ~A" (rod-string qname)))
+  (multiple-value-bind (prefix local-name)
+      (handler-case
+	  (cxml::split-qname qname)
+	(cxml:well-formedness-violation (c)
+	  (dom-error :NAMESPACE_ERR "~A" c)))
+    (when prefix
+      (when (and (rod= prefix "xml")
+		 (not (rod= uri "http://www.w3.org/XML/1998/namespace")))
+	(dom-error :NAMESPACE_ERR "invalid uri for prefix `xml'"))
+      (when (and (rod= prefix "xmlns")
+		 (not (rod= uri "http://www.w3.org/2000/xmlns/")))
+	(dom-error :NAMESPACE_ERR "invalid uri for prefix `xmlns'")))
+    (values prefix local-name)))
+
+(defmethod dom:create-element-ns ((document document) uri qname)
+  (setf qname (rod qname))
+  (multiple-value-bind (prefix local-name)
+      (safe-split-qname qname uri)
+    (let ((result (make-instance 'element
+		    :tag-name qname
+		    :namespace-uri uri
+		    :local-name local-name
+		    :prefix prefix
+		    :owner document)))
+      (setf (slot-value result 'attributes)
+	    (make-instance 'attribute-node-map
+	      :element-type :attribute
+	      :owner document
+	      :element result))
+      (add-default-attributes result)
+      result)))
+
 (defmethod dom:create-document-fragment ((document document))
   (make-instance 'document-fragment
     :owner document))
@@ -240,9 +331,25 @@
     (dom-error :INVALID_CHARACTER_ERR "not a name: ~A" (rod-string name)))
   (make-instance 'attribute
     :name name
+    :local-name nil
+    :prefix nil
+    :namespace-uri nil
     :specified-p t
     :owner document))
 
+(defmethod dom:create-attribute-ns ((document document) uri qname)
+  (setf uri (rod uri))
+  (setf qname (rod qname))
+  (multiple-value-bind (prefix local-name)
+      (safe-split-qname qname uri)
+    (make-instance 'attribute
+      :name qname
+      :namespace-uri uri
+      :local-name local-name
+      :prefix prefix
+      :specified-p t
+      :owner document)))
+
 (defmethod dom:create-entity-reference ((document document) name)
   (setf name (rod name))
   (unless (cxml::valid-name-p name)
@@ -253,23 +360,66 @@
 
 (defmethod get-elements-by-tag-name-internal (node tag-name)
   (setf tag-name (rod tag-name))
-  (let ((result (make-node-list)))
+  (let ((result (make-node-list))
-    (setf tag-name (rod tag-name))
+	(wild-p (rod= tag-name '#.(string-rod "*"))))
-    (let ((wild-p (rod= tag-name '#.(string-rod "*"))))
+    (labels ((walk (n)
-      (labels ((walk (n)
+	       (dovector (c (dom:child-nodes n))
-                 (dovector (c (dom:child-nodes n))
+		 (when (dom:element-p c)
-                   (when (dom:element-p c)
+		   (when (or wild-p (rod= tag-name (dom:node-name c)))
-                     (when (or wild-p (rod= tag-name (dom:node-name c)))
+		     (vector-push-extend c result (extension result)))
-                       (vector-push-extend c result (extension result)))
+		   (walk c)))))
-                     (walk c)))))
+      (walk node))
-        (walk node)))
+    result))
+
+(defmethod get-elements-by-tag-name-internal-ns (node uri lname)
+  (setf uri (rod uri))
+  (setf lname (rod lname))
+  (let ((result (make-node-list))
+	(wild-uri-p (rod= uri '#.(string-rod "*")))
+	(wild-lname-p (rod= lname '#.(string-rod "*"))))
+    (labels ((walk (n)
+	       (dovector (c (dom:child-nodes n))
+		 (when (dom:element-p c)
+		   (when (and (or wild-lname-p (rod= lname (dom:local-name c)))
+			      (or wild-uri-p (rod= uri (dom:namespace-uri c))))
+		     (vector-push-extend c result (extension result)))
+		   (walk c)))))
+      (walk node))
     result))
 
 (defmethod dom:get-elements-by-tag-name ((document document) tag-name)
   (get-elements-by-tag-name-internal document tag-name))
 
+(defmethod dom:get-elements-by-tag-name-ns ((document document) uri lname)
+  (get-elements-by-tag-name-internal-ns document uri lname))
+
+(defmethod dom:get-element-by-id ((document document) id)
+  (block nil
+    (unless (dtd document)
+      (return nil))
+    (setf id (rod id))
+    (labels ((walk (n)
+	       (dovector (c (dom:child-nodes n))
+		 (when (dom:element-p c)
+		   (let ((e (cxml::find-element
+			     (cxml::rod (dom:tag-name c))
+			     (dtd document))))
+		     (when e
+		       (dolist (a (cxml::elmdef-attributes e))
+			 (when (eq :ID (cxml::attdef-type a))
+			   (let* ((name (rod (cxml::attdef-name a)))
+				  (value (dom:get-attribute c name)))
+			     (when (and value (rod= value id))
+			       (return c)))))))
+		   (walk c)))))
+      (walk document))))
+
+
 ;;; Node
 
+(defmethod dom:is-supported ((node node) feature version)
+  (dom:has-feature 'implementation feature version))
+
 (defmethod dom:parent-node ((node node))
   (slot-value node 'parent))
 
@@ -544,29 +694,50 @@
   (setf name (rod name))
   (with-slots (items) self
     (dolist (k items nil)
-      (cond ((rod= name (dom:node-name k))
+      (when (rod= name (dom:node-name k))
-             (return k))))))
+	(return k)))))
 
-(defmethod dom:set-named-item ((self named-node-map) arg)
+(defmethod dom:get-named-item-ns ((self named-node-map) uri lname)
-  (assert-writeable self)
+  (setf uri (rod uri))
-  (unless (eq (dom:node-type arg) (slot-value self 'element-type))
+  (setf lname (rod lname))
+  (with-slots (items) self
+    (dolist (k items nil)
+      (when (and (equal uri (dom:namespace-uri k))
+		 (equal lname (dom:local-name k)))
+	(return k)))))
+
+(defun %set-named-item (map arg test)
+  (assert-writeable map)
+  (unless (eq (dom:node-type arg) (slot-value map 'element-type))
     (dom-error :HIERARCHY_REQUEST_ERR
                "~S cannot adopt ~S, since it is not of type ~S."
-               self arg (slot-value self 'element-type)))
+               map arg (slot-value map 'element-type)))
-  (unless (eq (dom:owner-document self) (dom:owner-document arg))
+  (unless (eq (dom:owner-document map) (dom:owner-document arg))
     (dom-error :WRONG_DOCUMENT_ERR
                "~S cannot adopt ~S, since it was created by a different document."
-               self arg))
+               map arg))
   (let ((old-map (slot-value arg 'map)))
-    (when (and old-map (not (eq old-map self)))
+    (when (and old-map (not (eq old-map map)))
       (dom-error :INUSE_ATTRIBUTE_ERR "Attribute node already mapped" arg)))
-  (setf (slot-value arg 'map) self)
+  (setf (slot-value arg 'map) map)
+  (with-slots (items) map
+    (dolist (k items (progn (setf items (cons arg items)) nil))
+      (when (funcall test k)
+	(setf items (cons arg (delete k items)))
+	(return k)))))
+
+(defmethod dom:set-named-item ((self named-node-map) arg)
   (let ((name (dom:node-name arg)))
-    (with-slots (items) self
+    (%set-named-item self arg (lambda (k) (rod= name (dom:node-name k))))))
-      (dolist (k items (progn (setf items (cons arg items))nil))
+
-        (cond ((rod= name (dom:node-name k))
+(defmethod dom:set-named-item-ns ((self named-node-map) arg)
-               (setf items (cons arg (delete k items)))
+  (let ((uri (dom:namespace-uri arg))
-               (return k)))))))
+	(lname (dom:local-name arg)))
+    (%set-named-item self
+		     arg
+		     (lambda (k)
+		       (and (rod= lname (dom:local-name k))
+			    (rod= uri (dom:namespace-uri k)))))))
 
 (defmethod dom:remove-named-item ((self named-node-map) name)
   (assert-writeable self)
@@ -577,6 +748,18 @@
              (setf items (delete k items))
              (return k))))))
 
+(defmethod dom:remove-named-item-ns ((self named-node-map) uri lname)
+  (assert-writeable self)
+  (setf uri (rod uri))
+  (setf lname (rod lname))
+  (with-slots (items) self
+    (dolist (k items
+	      (dom-error :NOT_FOUND_ERR "~A not found in ~A" lname self))
+      (when (and (rod= lname (dom:local-name k))
+		 (rod= uri (dom:namespace-uri k)))
+	(setf items (delete k items))
+	(return k)))))
+
 (defmethod dom:length ((self named-node-map))
   (with-slots (items) self
     (length items)))
@@ -743,6 +926,15 @@
 
 ;;; ELEMENT
 
+(defmethod dom:has-attributes ((element element))
+  (plusp (length (dom:items (dom:attributes element)))))
+
+(defmethod dom:has-attribute ((element element) name)
+  (and (dom:get-named-item (dom:attributes element) name) t))
+
+(defmethod dom:has-attribute-ns ((element element) uri lname)
+  (and (dom:get-named-item-ns (dom:attributes element) uri lname) t))
+
 (defmethod dom:get-attribute-node ((element element) name)
   (dom:get-named-item (dom:attributes element) name))
 
@@ -750,24 +942,51 @@
   (assert-writeable element)
   (dom:set-named-item (dom:attributes element) new-attr))
 
+(defmethod dom:get-attribute-node-ns ((element element) uri lname)
+  (dom:get-named-item-ns (dom:attributes element) uri lname))
+
+(defmethod dom:set-attribute-node-ns ((element element) (new-attr attribute))
+  (assert-writeable element)
+  (dom:set-named-item-ns (dom:attributes element) new-attr))
+
 (defmethod dom:get-attribute ((element element) name)
   (let ((a (dom:get-attribute-node element name)))
     (if a
         (dom:value a)
         #.(string-rod ""))))
 
+(defmethod dom:get-attribute-ns ((element element) uri lname)
+  (let ((a (dom:get-attribute-node-ns element uri lname)))
+    (if a
+        (dom:value a)
+        #.(string-rod ""))))
+
 (defmethod dom:set-attribute ((element element) name value)
   (assert-writeable element)
   (with-slots (owner) element
     (let ((attr (dom:create-attribute owner name)))
+      (setf (slot-value attr 'owner-element) element)
       (setf (dom:value attr) value)
       (dom:set-attribute-node element attr))
     (values)))
 
+(defmethod dom:set-attribute-ns ((element element) uri lname value)
+  (assert-writeable element)
+  (with-slots (owner) element
+    (let ((attr (dom:create-attribute-ns owner uri lname)))
+      (setf (slot-value attr 'owner-element) element)
+      (setf (dom:value attr) value)
+      (dom:set-attribute-node-ns element attr))
+    (values)))
+
 (defmethod dom:remove-attribute ((element element) name)
   (assert-writeable element)
   (dom:remove-attribute-node element (dom:get-attribute-node element name)))
 
+(defmethod dom:remove-attribute-ns ((elt element) uri lname)
+  (assert-writeable elt)
+  (dom:remove-attribute-node elt (dom:get-attribute-node-ns elt uri lname)))
+
 (defmethod dom:remove-attribute-node ((element element) (old-attr attribute))
   (assert-writeable element)
   (with-slots (items) (dom:attributes element)
@@ -781,14 +1000,18 @@
 
 (defun maybe-add-default-attribute (element name)
   (let* ((dtd (dtd (slot-value element 'owner)))
-         (e (when dtd (cxml::find-element (dom:tag-name element) dtd)))
+         (e (when dtd (cxml::find-element
+		       (cxml::rod (dom:tag-name element))
+		       dtd)))
          (a (when e (cxml::find-attribute e name))))
     (when (and a (listp (cxml::attdef-default a)))
       (add-default-attribute element a))))
 
 (defun add-default-attributes (element)
   (let* ((dtd (dtd (slot-value element 'owner)))
-         (e (when dtd (cxml::find-element (dom:tag-name element) dtd))))
+         (e (when dtd (cxml::find-element
+		       (cxml::rod (dom:tag-name element))
+		       dtd))))
     (when e
       (dolist (a (cxml::elmdef-attributes e))
         (when (and a (listp (cxml::attdef-default a)))
@@ -799,7 +1022,8 @@
          (owner (slot-value element 'owner))
          (anode (dom:create-attribute owner (cxml::attdef-name adef)))
          (text (dom:create-text-node owner value)))
-    (setf (slot-value anode 'dom-impl::specified-p) nil)
+    (setf (slot-value anode 'specified-p) nil)
+    (setf (slot-value anode 'owner-element) element)
     (dom:append-child anode text)
     (push anode (slot-value (dom:attributes element) 'items))))
 
@@ -810,8 +1034,16 @@
   (assert-writeable element)
   (get-elements-by-tag-name-internal element name))
 
-(defmethod dom:normalize ((element element))
+(defmethod dom:get-elements-by-tag-name-ns ((element element) uri lname)
   (assert-writeable element)
+  (get-elements-by-tag-name-internal-ns element uri lname))
+
+(defmethod dom:set-named-item :after ((self attribute-node-map) arg)
+  (setf (slot-value arg 'owner-element)
+	(slot-value self 'element)))
+
+(defmethod dom:normalize ((node node))
+  (assert-writeable node)
   (labels ((walk (n)
              (when (eq (dom:node-type n) :element)
                (map nil #'walk (dom:items (dom:attributes n))))
@@ -837,7 +1069,7 @@
                        (setf previous child)
                        (incf i)))))) 
              (map nil #'walk (dom:child-nodes n))))
-    (walk element))
+    (walk node))
   (values))
 
 ;;; TEXT
@@ -856,7 +1088,17 @@
 ;;; COMMENT -- nix
 ;;; CDATA-SECTION -- nix
 
-;;; DOCUMENT-TYPE -- missing
+;;; DOCUMENT-TYPE
+
+(defmethod dom:internal-subset ((node document-type))
+  ;; FIXME: encoding ist falsch, anderen sink nehmen!
+  (if (slot-boundp node 'internal-subset)
+      (with-output-to-string (stream)
+	(let ((sink (cxml:make-character-stream-sink stream)))
+	  (dolist (def (internal-subset node))
+	    (apply (car def) sink (cdr def)))))
+      nil))
+
 ;;; NOTATION -- nix
 ;;; ENTITY -- nix
 
@@ -978,6 +1220,9 @@
                        :owner document))
          (result (import-node-internal 'element document node deep
                                        :attributes attributes
+				       :namespace-uri (dom:namespace-uri node)
+				       :local-name (dom:local-name node)
+				       :prefix (dom:prefix node)
                                        :tag-name (dom:tag-name node))))
     (setf (slot-value attributes 'element) result)
     (dolist (attribute (dom:items (dom:attributes node)))
@@ -1034,7 +1279,7 @@
 
 ;;; Erweiterung
 
-(defun dom:create-document (&optional document-element)
+(defun dom-impl:create-document (&optional document-element)
   ;; Um ein neues Dokumentenobject zu erzeugen, parsen wir einfach ein
   ;; Dummydokument.
   (let* ((handler (dom:make-dom-builder))

dom/dom-sax.lisp

@@ -11,26 +11,41 @@
 (defun dom:map-document
     (handler document
      &key (include-xmlns-attributes sax:*include-xmlns-attributes*)
+	  include-doctype
           include-default-values)
   (sax:start-document handler)
-  (let ((doctype (dom:doctype document)))
+  (when include-doctype
-    (when doctype
+    (let ((doctype (dom:doctype document)))
-      (sax:start-dtd handler (dom:name doctype) nil nil)
+      (when doctype
-      ;; need notations for canonical mode 2
+	(sax:start-dtd handler
-      (let* ((ns (dom:notations doctype))
+		       (dom:name doctype)
-             (a (make-array (dom:length ns))))
+		       (dom:public-id doctype)
-        ;; get them
+		       (dom:system-id doctype))
-        (dotimes (k (dom:length ns))
+	(ecase include-doctype
-          (setf (elt a k) (dom:item ns k)))
+	  (:full-internal-subset
-        ;; sort them 
+	    (when (slot-boundp doctype 'internal-subset)
-        (setf a (sort a #'rod< :key #'dom:name))
+	      (sax:start-internal-subset handler)
-        (loop for n across a do
+	      (dolist (def (internal-subset doctype))
-              (sax:notation-declaration handler
+		(apply (car def) handler (cdr def)))
-                                        (dom:name n)
+	      (sax:end-internal-subset handler)))
-                                        (dom:public-id n)
+	  (:canonical-notations
-                                        (dom:system-id n)))
+	    ;; need notations for canonical mode 2
-        ;; fixme: entities!
+	    (let* ((ns (dom:notations doctype))
-        (sax:end-dtd handler))))
+		   (a (make-array (dom:length ns))))
+	      (when (plusp (dom:length ns))
+		(sax:start-internal-subset handler)
+		;; get them
+		(dotimes (k (dom:length ns))
+		  (setf (elt a k) (dom:item ns k)))
+		;; sort them 
+		(setf a (sort a #'rod< :key #'dom:name))
+		(loop for n across a do
+		      (sax:notation-declaration handler
+						(dom:name n)
+						(dom:public-id n)
+						(dom:system-id n)))
+		(sax:end-internal-subset handler)))))
+	(sax:end-dtd handler))))
   (labels ((walk (node)
              (dom:do-node-list (child (dom:child-nodes node))
                (ecase (dom:node-type child)

dom/package.lisp

@@ -12,7 +12,33 @@
    ;; lisp-specific extensions
    #:make-dom-builder
 
-   ;; methods
+   ;; DOM 2 functions
+   #:owner-element
+   #:import-node
+   #:create-element-ns
+   #:create-attribute-ns
+   #:get-elements-by-tag-name-ns
+   #:get-element-by-id
+   #:get-named-item-ns
+   #:set-named-item-ns
+   #:remove-named-item-ns
+   #:is-supported
+   #:has-attributes
+   #:namespace-uri
+   #:prefix
+   #:local-name
+   #:internal-subset
+   #:create-document-type
+   #:create-document
+   #:get-attribute-ns
+   #:set-attribute-ns
+   #:remove-attribute-ns
+   #:get-attribute-node-ns
+   #:set-attribute-node-ns
+   #:has-attribute
+   #:has-attribute-ns
+
+   ;; DOM 1 functions
    #:has-feature
    #:doctype
    #:implementation
@@ -72,7 +98,6 @@
    #:system-id
    #:notation-name
    #:target
-   #:import-node
    #:code
    
    ;; protocol classes

dom/simple-dom.lisp

@@ -1,46 +0,0 @@
-(in-package :xml)
-
-;;; Implementation of a simple but faster DOM.
-
-(defclass simple-document () 
-  ((children :initform nil :accessor simple-document-children)))
-
-(defstruct node 
-  parent)
-
-(defstruct (processing-instruction (:include node))
-  target
-  data)
-
-(defstruct (text (:include node)
-                 (:constructor make-text-boa (parent data)))
-  data)
-
-(defstruct (element (:include node))
-  gi
-  attributes
-  children)
-
-(defmethod dom:create-processing-instruction ((document simple-document) target data)
-  (make-processing-instruction :target target :data data))
-
-(defmethod dom:append-child ((node element) child)
-  (setf (node-parent child) node)
-  (push child (element-children node)))
-
-(defmethod dom:append-child ((node simple-document) child)
-  (push child (simple-document-children node))
-  nil)
-
-(defmethod dom:create-element ((document simple-document) name)
-  (make-element :gi name))
-
-(defmethod dom:set-attribute ((node element) name value)
-  (push (cons name value)
-        (element-attributes node)))
-
-(defmethod dom:create-text-node ((document simple-document) data)
-  (make-text-boa nil data))
-
-(defmethod dom:create-cdata-section ((document simple-document) data)
-  (make-text-boa nil data))

dom/string-dom.lisp

@@ -1,66 +0,0 @@
-;;; A wrapper package STRING-DOM around the ordinary DOM presents
-;;; DOMString as Lisp STRING.  This was a workaround until
-;;; RUNE-IS-CHARACTER was implemented, but might still be useful on
-;;; Lisps without Unicode support.
-
-(defpackage :string-dom
-  (:use))
-
-(eval-when (:compile-toplevel :load-toplevel :execute)
-  (do-external-symbols (var :dom)
-    (let* ((home-package
-            (if (member var '(dom:data dom:name dom:value dom:tag-name
-                              dom:node-name dom:node-value
-                              dom:substring-data dom:get-attribute
-                              dom:set-attribute dom:public-id dom:system-id
-                              dom:notation-name dom:target))
-                :string-dom
-                :dom))
-           (symbol (intern (symbol-name var) home-package)))
-      (import symbol :string-dom)
-      (export (list symbol) :string-dom))))
-
-(defpackage :string-dom-impl (:use :cl))
-(in-package :string-dom-impl)
-
-(defun rod-to-string (frob)
-  (if (null frob)
-      nil
-      (map 'string #'code-char frob)))
-
-(defun string-dom:data (node)		(rod-to-string (dom:data node)))
-(defun string-dom:name (node)		(rod-to-string (dom:name node)))
-(defun string-dom:value (node)		(rod-to-string (dom:value node)))
-(defun string-dom:tag-name (node)	(rod-to-string (dom:tag-name node)))
-(defun string-dom:node-name (node)	(rod-to-string (dom:node-name node)))
-(defun string-dom:node-value (node)	(rod-to-string (dom:node-value node)))
-
-(defun (setf string-dom:data) (newval node)
-  (setf (dom:data node) newval))
-
-(defun (setf string-dom:value) (newval node)
-  (setf (dom:value node) newval))
-
-(defun (setf string-dom:node-value) (newval node)
-  (setf (dom:node-value node) newval))
-
-(defun string-dom:substring-data (node offset count)
-  (rod-to-string (dom:substring-data node offset count)))
-
-(defun string-dom:get-attribute (elt name)
-  (rod-to-string (dom:get-attribute elt name)))
-
-(defun string-dom:set-attribute (elt name value)
-  (dom:set-attribute elt (runes:rod name) (runes:rod value)))
-
-(defun string-dom:public-id (node)
-  (rod-to-string (dom:public-id node)))
-
-(defun string-dom:system-id (node)
-  (rod-to-string (dom:system-id node)))
-
-(defun string-dom:notation-name (node)
-  (rod-to-string (dom:notation-name node)))
-
-(defun string-dom:target (node)
-  (rod-to-string (dom:target node)))

dom/unparse.lisp

@@ -1,9 +1,20 @@
 (in-package :cxml)
 
-(defun unparse-document-to-octets (doc &rest initargs)
+(defun %unparse-document (sink doc canonical)
-  (let ((sink (apply #'make-octet-vector-sink initargs)))
+  (dom:map-document sink
-    (dom:map-document sink doc :include-default-values t)))
+		    doc
+		    :include-doctype (if (and canonical (>= canonical 2))
+					 :canonical-notations
+					 nil)
+		    :include-default-values t))
 
-(defun unparse-document (doc character-stream &rest initargs)
+(defun unparse-document-to-octets (doc &rest initargs &key canonical)
-  (let ((sink (apply #'make-character-stream-sink character-stream initargs)))
+  (%unparse-document (apply #'make-octet-vector-sink initargs)
-    (dom:map-document sink doc :include-default-values t)))
+		     doc
+		     canonical))
+
+(defun unparse-document (doc character-stream &rest initargs &key canonical)
+  (%unparse-document
+   (apply #'make-character-stream-sink character-stream initargs)
+   doc
+   canonical))

test/domtest.lisp

@@ -142,11 +142,14 @@
                (c = (elt str i))
                :until (runes:rune= c #.(runes:char-rune #\")))
             (if (runes:rune= c #.(runes:char-rune #\\))
-                (ecase (progn
+                (let ((frob
+		       (progn
                          (incf i)
-                         (elt str i))
+                         (elt str i))))
-                  ;; ...
+		  (ecase frob
-                  (#/n (vector-push-extend #/newline v (length v))))
+		    ;; ...
+		    (#/n (vector-push-extend #/newline v (length v)))
+		    ((#/\\ #/\") (vector-push-extend #/\\ v (length v)))))
                 (vector-push-extend c v (length v))))
         (coerce v 'runes::simple-rod)))
     (t
@@ -163,13 +166,14 @@
 
 ;;;; dom1-interfaces.xml auslesen
 
-(defvar *methods* '())
+(defparameter *methods* '())
-(defvar *fields* '())
+(defparameter *fields* '())
 
 (declaim (special *directory*))
+(declaim (special *files-directory*))
 
-(defun read-members ()
+(defun read-members (&optional (directory *directory*))
-  (let* ((pathname (merge-pathnames "patches/dom1-interfaces.xml" *directory*))
+  (let* ((pathname (merge-pathnames "build/dom2-interfaces.xml" directory))
          (builder (dom:make-dom-builder))
          (library (dom:document-element (cxml:parse-file pathname builder)))
          (methods '())
@@ -554,8 +558,15 @@
 (defun assert-have-implementation-attribute (element)
   (let ((attribute (runes:rod-string (dom:get-attribute element "name"))))
     (string-case attribute
+      ;; fixme: expandEntityReferences sollten wir auch mal anschalten, wo
+      ;; wir uns schon die muehe machen...
       ("validating"
         (setf cxml::*validate* t))
+      ("namespaceAware"
+	;; ???  dom 2 ohne namespace-support gibt's doch gar nicht,
+	;; ausser vielleicht in html-only implementationen, und dann sollen
+	;; sie halt auf hasFeature "XML" testen.
+        )
       (t
         (format t "~&implementationAttribute ~A not supported, skipping test~%"
                 attribute)
@@ -606,12 +617,9 @@
 (defun load-file (name &optional will-be-modified-p)
   (declare (ignore will-be-modified-p))
   (setf name (runes:rod-string name))
-  (let* ((directory (merge-pathnames "tests/level1/core/files/" *directory*))
+  (cxml:parse-file
-         (document
+   (make-pathname :name name :type "xml" :defaults *files-directory*)
-          (cxml:parse-file
+   (dom:make-dom-builder)))
-           (make-pathname :name name :type "xml" :defaults directory)
-           (dom:make-dom-builder))))
-    document))
 
 (defparameter *bad-tests*
     '("hc_elementnormalize2.xml"
@@ -628,39 +636,57 @@
 
 (defun run-all-tests (*directory* &optional verbose)
   (let* ((cxml::*redefinition-warning* nil)
-         (test-directory (merge-pathnames "tests/level1/core/" *directory*))
-         (all-tests (merge-pathnames "alltests.xml" test-directory))
-         (builder (dom:make-dom-builder))
-         (suite (dom:document-element (cxml:parse-file all-tests builder)))
          (n 0)
          (i 0)
          (ntried 0)
          (nfailed 0))
-    (do-child-elements (member suite)
+    (flet ((parse (test-directory)
-      (unless
+	     (let* ((all-tests (merge-pathnames "alltests.xml" test-directory))
-          (or (equal (dom:tag-name member) "metadata")
+		    (builder (dom:make-dom-builder))
-              (member (runes:rod-string (dom:get-attribute member "href"))
+		    (suite (dom:document-element
-                      *bad-tests*
+			    (cxml:parse-file all-tests builder)))
-                      :test 'equal))
+		    (*files-directory*
-        (incf n)))
+		     (merge-pathnames "files/" test-directory)))
-    (do-child-elements (member suite)
+	       (do-child-elements (member suite)
-      (let ((href (runes:rod-string (dom:get-attribute member "href"))))
+		 (unless
-        (unless (or (runes:rod= (dom:tag-name member) #"metadata")
+		     (or (equal (dom:tag-name member) "metadata")
-                    (member href *bad-tests* :test 'equal))
+			 (member (runes:rod-string
-          (format t "~&~D/~D ~A~%" i n href)
+				  (dom:get-attribute member "href"))
-          (let ((lisp (slurp-test (merge-pathnames href test-directory))))
+				 *bad-tests*
-            (when verbose
+				 :test 'equal))
-              (print lisp))
+		   (incf n)))
-            (when lisp
+	       suite))
-              (incf ntried)
+	   (run (test-directory suite)
-              (with-simple-restart (skip-test "Skip this test")
+	     (print test-directory)
-                (handler-case
+	     (let ((*files-directory*
-                    (let ((cxml::*validate* nil))
+		    (merge-pathnames "files/" test-directory)))
-                      (funcall (compile nil lisp)))
+	       (do-child-elements (member suite)
-                  (serious-condition (c)
+		 (let ((href (runes:rod-string
-                    (incf nfailed)
+			      (dom:get-attribute member "href"))))
-                    (warn "test failed: ~A" c))))))
+		   (unless (or (runes:rod= (dom:tag-name member) #"metadata")
-          (incf i))))
+			       (member href *bad-tests* :test 'equal))
+		     (format t "~&~D/~D ~A~%" i n href)
+		     (let ((lisp (slurp-test
+				  (merge-pathnames href test-directory))))
+		       (when verbose
+			 (print lisp))
+		       (when lisp
+			 (incf ntried)
+			 (with-simple-restart (skip-test "Skip this test")
+			   (handler-case
+			       (let ((cxml::*validate* nil))
+				 (funcall (compile nil lisp)))
+			     (serious-condition (c)
+			       (incf nfailed)
+			       (warn "test failed: ~A" c))))))
+		     (incf i)))))))
+      (let* ((d1 (merge-pathnames "tests/level1/core/" *directory*))
+	     (d2 (merge-pathnames "tests/level2/core/" *directory*))
+	     (suite1 (parse d1))
+	     (suite2 (parse d2)))
+	(run d1 suite1)
+	#+(or)
+	(run d2 suite2)))
     (format t "~&~D/~D tests failed; ~D test~:P were skipped"
             nfailed ntried (- n ntried))))
 

xml/sax-handler.lisp

@@ -1,11 +1,13 @@
-;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: SAX; readtable: glisp; Encoding: utf-8; -*-
+;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: SAX; readtable: runes; Encoding: utf-8; -*-
 ;;; ---------------------------------------------------------------------------
 ;;;     Title: A SAX2-like API for the xml parser
 ;;;   Created: 2003-06-30
 ;;;    Author: Henrik Motakef <hmot@henrik-motakef.de>
+;;;    Author: David Lichteblau (DTD-related changes)
 ;;;   License: BSD
 ;;; ---------------------------------------------------------------------------
 ;;;  <20> copyright 2003 by Henrik Motakef
+;;;  <20> copyright 2004 knowledgeTools Int. GmbH
 
 ;;; Redistribution and use  in source and binary   forms, with or  without
 ;;; modification, are permitted provided that the following conditions are
@@ -40,17 +42,9 @@
 ;;   * document-locator/(setf document-locator)
 ;;     (probably implies a handler class with an appropriate slot)
 ;;   * skipped-entity
-;;   * notation-declaration
-;;   * unparsed-entity-declaration
 ;;   * The whole ErrorHandler class, this is better handled using
 ;;     conditions (but isn't yet)
-;;   * The LexicalHandler (start-cdata etc) would be nice
+;;   * The LexicalHandler (start-cdata etc) would be nice  [-- partly done]
-;;   * The DeclHandler interface (element-decl, attribute-decl...)
-;;     is useful, but the Java interface sucks.
-;; o Despite all the namespace-uri etc arguments, namespaces are not
-;;   really supported yet, the xml parser always passes nil. This will
-;;   hopefully change Real Soon Now, and I didn't want to have to
-;;   rewrite the interface then
 
 (defpackage :sax
   (:use :common-lisp)
@@ -58,6 +52,13 @@
 	   #:*include-xmlns-attributes*
 	   #:*use-xmlns-namespace*
 
+           #:make-attribute
+           #:attribute-namespace-uri
+           #:attribute-local-name
+           #:attribute-qname
+           #:attribute-value
+           #:attribute-specified-p
+	   
 	   #:start-document
 	   #:start-prefix-mapping
 	   #:start-element
@@ -68,7 +69,18 @@
 	   #:end-document
 	   #:comment
 	   #:start-cdata
-	   #:end-cdata))
+	   #:end-cdata
+	   #:start-dtd
+	   #:end-dtd
+	   #:start-internal-subset
+	   #:end-internal-subset
+           #:unparsed-entity-declaration
+           #:external-entity-declaration
+           #:internal-entity-declaration
+           #:notation-declaration
+           #:element-declaration
+           #:attribute-declaration
+           #:entity-resolver))
 
 (in-package :sax)
 
@@ -118,6 +130,13 @@ qname:                 #\"xmlns:ex\"
 Setting this variable has no effect unless both
 `*namespace-processing*' and `*include-xmlns-attributes*' are non-nil.")
 
+(defstruct attribute
+  namespace-uri
+  local-name
+  qname
+  value
+  specified-p)
+
 (defgeneric start-document (handler)
   (:documentation "Called at the beginning of the parsing process,
 before any element, processing instruction or comment is reported.
@@ -126,9 +145,6 @@ Handlers that need to maintain internal state may use this to perform
 any neccessary initializations.")
   (:method ((handler t)) nil))
 
-;; How should attributes be represented?
-;; Currently its just a (name . value) alist, but this isn't too
-;; useful wrt namespaced attributes. Probably a struct.
 (defgeneric start-element (handler namespace-uri local-name qname attributes)
   (:documentation "Called to report the beginning of an element.
 
@@ -147,7 +163,9 @@ local-name properties, the same rules as for the element name
 apply. Additionally, namespace-declaring attributes (those whose name
 is \"xmlns\" or starts with \"xmlns:\") are only included if
 *namespace-prefixes* is non-nil.")
-  (:method ((handler t) namespace-uri local-name qname attributes) nil))
+  (:method ((handler t) namespace-uri local-name qname attributes)
+    (declare (ignore namespace-uri local-name qname attributes))
+    nil))
 
 (defgeneric start-prefix-mapping (handler prefix uri)
   (:documentation "Called when the scope of a new prefix -> namespace-uri mapping begins.
@@ -159,7 +177,7 @@ Clients don't usually have to implement this except under special
 circumstances, for example when they have to deal with qualified names
 in textual content. The parser will handle namespaces of elements and
 attributes on its own.")
-  (:method ((handler t) prefix uri) nil))
+  (:method ((handler t) prefix uri) (declare (ignore prefix uri)) nil))
 
 (defgeneric characters (handler data)
   (:documentation "Called for textual element content.
@@ -167,13 +185,13 @@ attributes on its own.")
 The data is passed as a rod, with all entity references resolved.
 It is possible that the character content of an element is reported
 via multiple subsequent calls to this generic function.")
-  (:method ((handler t) data) nil))
+  (:method ((handler t) data) (declare (ignore data)) nil))
 
 (defgeneric processing-instruction (handler target data)
   (:documentation "Called when a processing instruction is read.
 
 Both target and data are rods.")
-  (:method ((handler t) target data) nil))
+  (:method ((handler t) target data) (declare (ignore target data)) nil))
 
 (defgeneric end-prefix-mapping (handler prefix)
   (:documentation "Called when a prefix -> namespace-uri mapping goes out of scope.
@@ -186,14 +204,16 @@ Clients don't usually have to implement this except under special
 circumstances, for example when they have to deal with qualified names
 in textual content. The parser will handle namespaces of elements and
 attributes on its own.")
-  (:method ((handler t) prefix) nil))
+  (:method ((handler t) prefix) prefix nil))
 
 (defgeneric end-element (handler namespace-uri local-name qname)
   (:documentation "Called to report the end of an element.
 
 See the documentation for `start-element' for a description of the
 parameters.")
-  (:method ((handler t) namespace-uri local-name qname) nil))
+  (:method ((handler t) namespace-uri local-name qname)
+    (declare (ignore namespace-uri local-name qname))
+    nil))
 
 (defgeneric end-document (handler)
   (:documentation "Called at the end of parsing a document.
@@ -206,7 +226,7 @@ is significant, it will be returned by the parse-file/stream/string function.")
 ;; LexicalHandler
 
 (defgeneric comment (handler data)
-  (:method ((handler t) data) nil))
+  (:method ((handler t) data) data nil))
 
 (defgeneric start-cdata (handler)
   (:documentation "Called at the beginning of parsing a CDATA section.
@@ -225,3 +245,87 @@ lexical structure of the parsed document. The content of the CDATA
 section is reported via the `characters' generic function like all
 other textual content.")
   (:method ((handler t)) nil))
+
+(defgeneric start-dtd (handler name public-id system-id)
+  (:documentation "Called at the beginning of parsing a DTD.")
+  (:method ((handler t) name public-id system-id)
+    (declare (ignore name public-id system-id))
+    nil))
+
+(defgeneric end-dtd (handler)
+  (:documentation "Called at the end of parsing a DTD.")
+  (:method ((handler t)) nil))
+
+(defgeneric start-internal-subset (handler)
+  (:documentation "Reports that an internal subset is present.  Called before
+any definition from the internal subset is reported.")
+  (:method ((handler t)) nil))
+
+(defgeneric end-internal-subset (handler)
+  (:documentation "Called after processing of the internal subset has
+finished, if present.")
+  (:method ((handler t)) nil))
+
+(defgeneric unparsed-entity-declaration
+    (handler name public-id system-id notation-name)
+  (:documentation
+   "Called when an unparsed entity declaration is seen in a DTD.")
+  (:method ((handler t) name public-id system-id notation-name)
+    (declare (ignore name public-id system-id notation-name))
+    nil))
+
+(defgeneric external-entity-declaration
+    (handler kind name public-id system-id)
+  (:documentation
+   "Called when a parsed external entity declaration is seen in a DTD.")
+  (:method ((handler t) kind name public-id system-id)
+    (declare (ignore kind name public-id system-id))
+    nil))
+
+(defgeneric internal-entity-declaration
+    (handler kind name value)
+  (:documentation
+   "Called when an internal entity declaration is seen in a DTD.")
+  (:method ((handler t) kind name value)
+    (declare (ignore kind name value))
+    nil))
+
+(defgeneric notation-declaration
+    (handler name public-id system-id)
+  (:documentation
+   "Called when a notation declaration is seen while parsing a DTD.")
+  (:method ((handler t) name public-id system-id)
+    (declare (ignore name public-id system-id))
+    nil))
+
+(defgeneric element-declaration (handler name model)
+  (:documentation
+   "Called when a element declaration is seen in a DTD.  Model is not a string,
+    but a nested list, with *, ?, +, OR, and AND being the operators, rods
+    as names, :EMPTY and :PCDATA as special tokens.  (AND represents
+    sequences.)")
+  (:method ((handler t) name model)
+    (declare (ignore name model))
+    nil))
+
+(defgeneric attribute-declaration
+    (handler element-name attribute-name type default)
+  (:documentation
+   "Called when an attribute declaration is seen in a DTD.
+    type        one of :CDATA, :ID, :IDREF, :IDREFS,
+                :ENTITY, :ENTITIES, :NMTOKEN, :NMTOKENS,
+                (:NOTATION <name>*), or (:ENUMERATION <name>*)
+    default     :REQUIRED, :IMPLIED, (:FIXED content), or (:DEFAULT content)")
+  (:method ((handler t) element-name attribute-name type value)
+    (declare (ignore element-name attribute-name type value))
+    nil))
+
+(defgeneric entity-resolver
+    (handler resolver)
+  (:documentation
+   "Called between sax:end-dtd and sax:end-document to register an entity
+    resolver, a function of two arguments: An entity name and SAX handler.
+    When called, the resolver function will parse the named entities data.")
+  (:method ((handler t) resolver)
+    (declare (ignore resolver))
+    nil))

xml/unparse.lisp

@@ -7,9 +7,9 @@
 ;;;    Author: David Lichteblau <david@lichteblau.com>
 ;;;   License: Lisp-LGPL (See file COPYING for details).
 ;;; ---------------------------------------------------------------------------
-;;;  © copyright 1999 by Gilbert Baumann
+;;;  <EFBFBD><EFBFBD> copyright 1999 by Gilbert Baumann
-;;;  © copyright 2004 by knowledgeTools Int. GmbH
+;;;  <EFBFBD><EFBFBD> copyright 2004 by knowledgeTools Int. GmbH
-;;;  © copyright 2004 by David Lichteblau (for headcraft.de)
+;;;  <EFBFBD><EFBFBD> copyright 2004 by David Lichteblau (for headcraft.de)
 
 ;;; This library is free software; you can redistribute it and/or
 ;;; modify it under the terms of the GNU Library General Public
@@ -184,42 +184,185 @@
         (unparse-string public-id sink)
         (write-rod #"\"" sink)))))
 
+(defmethod sax:start-internal-subset ((sink sink))
+  (ensure-doctype sink)
+  (write-rod #" [" sink)
+  (write-rune #/U+000A sink))
+
+(defmethod sax:end-internal-subset ((sink sink))
+  (ensure-doctype sink)
+  (write-rod #"]" sink))
+
 (defmethod sax:notation-declaration ((sink sink) name public-id system-id)
-  (when (and (canonical sink) (>= (canonical sink) 2))
+  (let ((prev (previous-notation sink)))
-    (let ((prev (previous-notation sink)))
+    (when (and (and (canonical sink) (>= (canonical sink) 2))
-      (cond
+	       prev
-        (prev
+	       (not (rod< prev name)))
-          (unless (rod< prev name)
+      (error "misordered notations; cannot unparse canonically"))
-            (error "misordered notations; cannot unparse canonically")))
+    (setf (previous-notation sink) name)) 
-        (t
+  (write-rod #"<!NOTATION " sink)
-          (ensure-doctype sink)
+  (write-rod name sink)
-          (write-rod #" [" sink)
+  (cond
-          (write-rune #/U+000A sink)))
+    ((zerop (length public-id))
-      (setf (previous-notation sink) name)) 
+      (write-rod #" SYSTEM '" sink)
-    (write-rod #"<!NOTATION " sink)
+      (write-rod system-id sink)
+      (write-rune #/' sink))
+    ((zerop (length system-id))
+      (write-rod #" PUBLIC '" sink)
+      (write-rod public-id sink)
+      (write-rune #/' sink))
+    (t 
+      (write-rod #" PUBLIC '" sink)
+      (write-rod public-id sink)
+      (write-rod #"' '" sink)
+      (write-rod system-id sink)
+      (write-rune #/' sink)))
+  (write-rune #/> sink)
+  (write-rune #/U+000A sink))
+
+(defmethod sax:unparsed-entity-declaration
+    ((sink sink) name public-id system-id notation-name)
+  (unless (and (canonical sink) (< (canonical sink) 3))
+    (write-rod #"<!ENTITY " sink)
     (write-rod name sink)
     (cond
       ((zerop (length public-id))
-        (write-rod #" SYSTEM '" sink)
+	(write-rod #" SYSTEM '" sink)
-        (write-rod system-id sink)
+	(write-rod system-id sink)
-        (write-rune #/' sink))
+	(write-rune #/' sink))
       ((zerop (length system-id))
-        (write-rod #" PUBLIC '" sink)
+	(write-rod #" PUBLIC '" sink)
-        (write-rod public-id sink)
+	(write-rod public-id sink)
-        (write-rune #/' sink))
+	(write-rune #/' sink))
       (t 
-        (write-rod #" PUBLIC '" sink)
+	(write-rod #" PUBLIC '" sink)
-        (write-rod public-id sink)
+	(write-rod public-id sink)
-        (write-rod #"' '" sink)
+	(write-rod #"' '" sink)
-        (write-rod system-id sink)
+	(write-rod system-id sink)
-        (write-rune #/' sink)))
+	(write-rune #/' sink)))
+    (write-rod #" NDATA " sink)
+    (write-rod notation-name sink)
     (write-rune #/> sink)
     (write-rune #/U+000A sink)))
 
+(defmethod sax:external-entity-declaration
+    ((sink sink) kind name public-id system-id)
+  (when (canonical sink)
+    (error "cannot serialize parsed entities in canonical mode"))
+  (write-rod #"<!ENTITY " sink)
+  (when (eq kind :parameter)
+    (write-rod #" % " sink))
+  (write-rod name sink)
+  (cond
+    ((zerop (length public-id))
+      (write-rod #" SYSTEM '" sink)
+      (write-rod system-id sink)
+      (write-rune #/' sink))
+    ((zerop (length system-id))
+      (write-rod #" PUBLIC '" sink)
+      (write-rod public-id sink)
+      (write-rune #/' sink))
+    (t 
+      (write-rod #" PUBLIC '" sink)
+      (write-rod public-id sink)
+      (write-rod #"' '" sink)
+      (write-rod system-id sink)
+      (write-rune #/' sink)))
+  (write-rune #/> sink)
+  (write-rune #/U+000A sink))
+
+(defmethod sax:internal-entity-declaration ((sink sink) kind name value)
+  (when (canonical sink)
+    (error "cannot serialize parsed entities in canonical mode"))
+  (write-rod #"<!ENTITY " sink)
+  (when (eq kind :parameter)
+    (write-rod #" % " sink))
+  (write-rod name sink)
+  (write-rune #/U+0020 sink)
+  (write-rune #/\" sink)
+  (unparse-string value sink)
+  (write-rune #/\" sink)
+  (write-rune #/> sink)
+  (write-rune #/U+000A sink))
+
+(defmethod sax:element-declaration ((sink sink) name model)
+  (when (canonical sink)
+    (error "cannot serialize element type declarations in canonical mode"))
+  (write-rod #"<!ELEMENT " sink)
+  (write-rod name sink)
+  (write-rune #/U+0020 sink)
+  (labels ((walk (m)
+	     (cond
+	       ((eq m :EMPTY)
+		 (write-rod "EMPTY" sink))
+	       ((eq m :PCDATA)
+		 (write-rod "#PCDATA" sink))
+	       ((atom m)
+		 (unparse-string m sink))
+	       (t
+		 (ecase (car m)
+		   (and
+		     (write-rune #/\( sink)
+		     (loop for (n . rest) on (cdr m) do
+			   (walk n)
+			   (when rest
+			     (write-rune #\, sink)))
+		     (write-rune #/\) sink))
+		   (or
+		     (write-rune #/\( sink)
+		     (loop for (n . rest) on (cdr m) do
+			   (walk n)
+			   (when rest
+			     (write-rune #\| sink)))
+		     (write-rune #/\) sink))
+		   (*
+		     (walk (second m))
+		     (write-rod #/* sink))
+		   (+
+		     (walk (second m))
+		     (write-rod #/+ sink))
+		   (?
+		     (walk (second m))
+		     (write-rod #/? sink)))))))
+    (walk model))
+  (write-rune #/> sink)
+  (write-rune #/U+000A sink))
+
+(defmethod sax:attribute-declaration ((sink sink) ename aname type default)
+  (when (canonical sink)
+    (error "cannot serialize attribute type declarations in canonical mode"))
+  (write-rod #"<!ATTLIST " sink)
+  (write-rod ename sink)
+  (write-rune #/U+0020 sink)
+  (write-rod aname sink)
+  (write-rune #/U+0020 sink)
+  (cond
+    ((atom type)
+      (write-rod (rod (string-upcase (symbol-name type))) sink))
+    (t
+      (when (eq :NOTATION (car type))
+	(write-rod #"NOTATION " sink))
+      (write-rune #/\( sink)
+      (loop for (n . rest) on (cdr type) do
+	    (write-rod n sink)
+	    (when rest
+	      (write-rune #\| sink)))
+      (write-rune #/\) sink)))
+  (cond
+    ((atom default)
+      (write-rune #/# sink)
+      (write-rod (rod (string-upcase (symbol-name default))) sink))
+    (t
+      (when (eq :FIXED (car default))
+	(write-rod #"#FIXED " sink))
+      (write-rune #/\" sink)
+      (unparse-string (second default) sink)
+      (write-rune #/\" sink)))
+  (write-rune #/> sink)
+  (write-rune #/U+000A sink))
+
 (defmethod sax:end-dtd ((sink sink))
   (when (have-doctype sink)
-    (when (previous-notation sink)
-      (write-rod #"]" sink))
     (write-rod #">" sink)
     (write-rune #/U+000A sink)))
 

xml/xml-parse.lisp

@@ -1517,7 +1517,6 @@
                           delim))))))
 
 (defun read-character-reference (input)
-  ;; xxx eof handling
   ;; The #/& is already read
   (let ((res
          (let ((c (read-rune input)))
@@ -2080,9 +2079,9 @@
 ;;;     to indicate whether the end tag is valid.
 ;;;
 ;;; Function B will be called with the character data rod as its argument, it
-;;; returns a boolean indicating whether this text element is allowed.
+;;; returns a boolean indicating whether this text node is allowed.
 ;;;
-;;; That is, if one of the functions ever returns NIL, the element is
+;;; That is, if one of the functions ever returns NIL, the node is
 ;;; rejected as invalid.
 
 (defun cmodel-done (actual-value)
@@ -2471,6 +2470,7 @@
           (wf-error input "document includes an internal subset"))
         (ensure-dtd)
         (consume-token input)
+	(sax:start-internal-subset (handler *ctx*))
         (while (progn (p/S? input)
                       (not (eq (peek-token input) :\] )))
           (if (eq (peek-token input) :PE-REFERENCE)
@@ -2487,6 +2487,7 @@
               (let ((*expand-pe-p* t))
                 (p/markup-decl input))))
         (consume-token input)
+	(sax:end-internal-subset (handler *ctx*))
         (p/S? input))
       (expect input :>)
       (when extid