[cxml-cvs] CVS update: cxml/dom/dom-builder.lisp cxml/dom/dom-impl.lisp

[David Lichteblau]

Update of /project/cxml/cvsroot/cxml/dom
In directory common-lisp.net:/tmp/cvs-serv31930/dom

Modified Files:
	dom-builder.lisp dom-impl.lisp 
Log Message:
am dom rumgeschraubt und sax-defaults geaendert
vielleicht teilweise verkehrt

Date: Sun Dec  4 21:35:15 2005
Author: dlichteblau

Index: cxml/dom/dom-builder.lisp
diff -u cxml/dom/dom-builder.lisp:1.4 cxml/dom/dom-builder.lisp:1.5
--- cxml/dom/dom-builder.lisp:1.4	Sun Dec  4 19:43:54 2005
+++ cxml/dom/dom-builder.lisp	Sun Dec  4 21:35:15 2005
@@ -22,6 +22,10 @@
   (vector-push-extend new-element vector (max 1 (array-dimension vector 0))))
 
 (defmethod sax:start-document ((handler dom-builder))
+  (when (and sax:*namespace-processing*
+	     (not (and sax:*include-xmlns-attributes*
+		       sax:*use-xmlns-namespace*)))
+    (error "SAX configuration is incompatible with DOM: *namespace-processing* is activated, but *include-xmlns-attributes* or *use-xmlns-namespace* are not"))
   (let ((document (make-instance 'dom-impl::document)))
     (setf (slot-value document 'dom-impl::owner) nil
 	  (slot-value document 'dom-impl::doc-type) nil)
@@ -86,7 +90,9 @@
           (anodes '()))
       (dolist (attr attributes)
 	(let ((anode
-               (dom:create-attribute document (sax:attribute-qname attr)))
+               (dom:create-attribute-ns document
+					(sax:attribute-namespace-uri attr)
+					(sax:attribute-qname attr)))
               (text
                (dom:create-text-node document (sax:attribute-value attr))))
           (setf (slot-value anode 'dom-impl::specified-p)


Index: cxml/dom/dom-impl.lisp
diff -u cxml/dom/dom-impl.lisp:1.5 cxml/dom/dom-impl.lisp:1.6
--- cxml/dom/dom-impl.lisp:1.5	Sun Dec  4 19:43:56 2005
+++ cxml/dom/dom-impl.lisp	Sun Dec  4 21:35:15 2005
@@ -39,7 +39,7 @@
 (defmethod dom:namespace-uri ((node node)) nil)
 
 (defclass namespace-mixin ()
-  ((prefix        :initarg :prefix        :reader dom:prefix)
+  ((prefix        :initarg :prefix        :accessor dom:prefix)
    (local-name    :initarg :local-name    :reader dom:local-name)
    (namespace-uri :initarg :namespace-uri :reader dom:namespace-uri)))
 
@@ -267,11 +267,11 @@
 	(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")))
+      (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/")))
+      (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)))
 
@@ -335,6 +335,7 @@
     :prefix nil
     :namespace-uri nil
     :specified-p t
+    :owner-element nil
     :owner document))
 
 (defmethod dom:create-attribute-ns ((document document) uri qname)
@@ -348,6 +349,7 @@
       :local-name local-name
       :prefix prefix
       :specified-p t
+      :owner-element nil
       :owner document)))
 
 (defmethod dom:create-entity-reference ((document document) name)
@@ -361,7 +363,7 @@
 (defmethod get-elements-by-tag-name-internal (node tag-name)
   (setf tag-name (rod tag-name))
   (let ((result (make-node-list))
-	(wild-p (rod= tag-name '#.(string-rod "*"))))
+	(wild-p (rod= tag-name #"*")))
     (labels ((walk (n)
 	       (dovector (c (dom:child-nodes n))
 		 (when (dom:element-p c)
@@ -375,8 +377,8 @@
   (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 "*"))))
+	(wild-uri-p (rod= uri #"*"))
+	(wild-lname-p (rod= lname #"*")))
     (labels ((walk (n)
 	       (dovector (c (dom:child-nodes n))
 		 (when (dom:element-p c)
@@ -1030,6 +1032,12 @@
 (defmethod dom:remove-named-item :after ((self attribute-node-map) name)
   (maybe-add-default-attribute (slot-value self 'element) name))
 
+(defmethod dom:remove-named-item-ns
+    ((self attribute-node-map) uri lname)
+  (let ((k (call-next-method)))
+    (maybe-add-default-attribute (slot-value self 'element) (dom:node-name k))
+    k))
+
 (defmethod dom:get-elements-by-tag-name ((element element) name)
   (assert-writeable element)
   (get-elements-by-tag-name-internal element name))
@@ -1039,6 +1047,10 @@
   (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:set-named-item-ns :after ((self attribute-node-map) arg)
   (setf (slot-value arg 'owner-element)
 	(slot-value self 'element)))