From ee394c591db7cd69319f7fb6d77307a343d794df Mon Sep 17 00:00:00 2001
From: dlichteblau <dlichteblau>
Date: Sat, 16 Jun 2007 11:07:58 +0000
Subject: [PATCH]         XMLS compatibility is not
 <i>bug-for-bug</i>-compatible with         XMLS any more.  There is now a
 mode using pairs of local name         and namespace URI, and a second mode
 using qualified names         only.  The old behaviour using pairs of prefix
 and local names         was removed.  (Thanks to Douglas Crosher.)

---
 doc/index.xml             |   7 ++
 doc/xmls-compat.xml       |  43 ++++++++----
 xml/xmlns-normalizer.lisp |  11 +--
 xml/xmls-compat.lisp      | 140 ++++++++++++++++++++++++++++++--------
 4 files changed, 156 insertions(+), 45 deletions(-)

diff --git a/doc/index.xml b/doc/index.xml
index 02f8236..7a983f6 100644
--- a/doc/index.xml
+++ b/doc/index.xml
@@ -61,6 +61,13 @@
     <ul class="nomargin">
       <li>Serialization no longer defaults to canonical form.</li>
       <li>Fixed octet array argument to make-source.</li>
+      <li>
+	XMLS compatibility is not <i>bug-for-bug</i>-compatible with
+	XMLS any more.  There is now a mode using pairs of local name
+	and namespace URI, and a second mode using qualified names
+	only.  The old behaviour using pairs of prefix and local names
+	was removed.  (Thanks to Douglas Crosher.)
+      </li>
     </ul>
     <p class="nomargin"><tt>rel-2007-05-26</tt></p>
     <ul class="nomargin">
diff --git a/doc/xmls-compat.xml b/doc/xmls-compat.xml
index 54a54a3..5acfa14 100644
--- a/doc/xmls-compat.xml
+++ b/doc/xmls-compat.xml
@@ -16,7 +16,28 @@
       DOM functions cannot be implemented on them.
     </p>
     <p>
-      <div class="def">Function CXML-XMLS:MAKE-XMLS-BUILDER (&amp;key include-default-values)</div>
+      <b>New namespace handling:</b>
+      XMLS compatibility is not <i>bug-for-bug</i>-compatible with
+      XMLS any more.  There is now a mode using pairs of local name
+      and namespace URI, and a second mode using qualified names
+      only.  The old behaviour using pairs of prefix and local names
+      was removed.
+    </p>
+    <p>
+      <strike>
+	fixme: It is unclear to me how namespaces are meant to
+	work in xmls, since xmls documentation differs from how xmls
+	actually works in current releases.  Usually applications need to
+	know both the namespace prefix <em>and</em> the namespace URI.  We
+	currently follow the xmls <em>implementation</em> and use the
+	namespace prefix instead of following its <em>documentation</em> which
+	shows the URI.  We do not follow xmls in munging xmlns attribute
+	values.  Attributes themselves have namespaces and it is not clear
+	to me how that works in xmls.
+      </strike>
+    </p>
+    <p>
+      <div class="def">Function CXML-XMLS:MAKE-XMLS-BUILDER (&amp;key include-default-values include-namespace-uri)</div>
       Create a SAX handler which builds XMLS list structures.&#160;
       If <tt>include-default-values</tt> is true, default values for
       attributes declared in a DTD are included as attributes in the
@@ -24,12 +45,19 @@
       and can be set to <tt>nil</tt> to suppress inclusion of default
       values.
     </p>
+    <p>
+      If <tt>include-namespace-uri</tt> is true (the default), node
+      names and attribute names are pairs of local name and namespace
+      URI. (Except for attributes without a namespace, which are named
+      using a string.) Otherwise, nodes and attributes are named by
+      their qualified name.
+    </p>
     <p>
       Example:
     </p>
     <pre>(cxml:parse-file "test.xml" (cxml-xmls:make-xmls-builder))</pre>
     <p>
-      <div class="def">Function CXML-XMLS:MAP-NODE (handler node &amp;key include-xmlns-attributes)</div>
+      <div class="def">Function CXML-XMLS:MAP-NODE (handler node &amp;key include-xmlns-attributes include-namespace-uri)</div>
       Traverse an XMLS document/node and call SAX functions as if an XML
       representation of the document were processed by a SAX parser.
     </p>
@@ -51,17 +79,6 @@
       The node list's <tt>car</tt> can also be a cons of local <tt>name</tt>
       and namespace prefix <tt>ns</tt>.
     </p>
-    <p>
-      <em>fixme:</em> It is unclear to me how namespaces are meant to
-      work in xmls, since xmls documentation differs from how xmls
-      actually works in current releases.  Usually applications need to
-      know both the namespace prefix <em>and</em> the namespace URI.  We
-      currently follow the xmls <em>implementation</em> and use the
-      namespace prefix instead of following its <em>documentation</em> which
-      shows the URI.  We do not follow xmls in munging xmlns attribute
-      values.  Attributes themselves have namespaces and it is not clear
-      to me how that works in xmls.
-    </p>
     <p>
       <div class="def">Accessor CXML-XMLS:NODE-NAME (node)</div>
       <div class="def">Accessor CXML-XMLS:NODE-NS (node)</div>
diff --git a/xml/xmlns-normalizer.lisp b/xml/xmlns-normalizer.lisp
index 60cb51b..b4f4444 100644
--- a/xml/xmlns-normalizer.lisp
+++ b/xml/xmlns-normalizer.lisp
@@ -34,7 +34,7 @@
   (make-instance 'namespace-normalizer
     :xmlns-stack (list (mapcar (lambda (cons)
 				 (make-xmlns-attribute (car cons) (cdr cons)))
-			       *namespace-bindings*))
+			       *initial-namespace-bindings*))
     :chained-handler chained-handler))
 
 (defun normalizer-find-prefix (handler prefix)
@@ -74,7 +74,6 @@
 
 (defmethod sax:start-element
     ((handler namespace-normalizer) uri lname qname attrs)
-  (declare (ignore qname))
   (when (null uri)
     (setf uri #""))
   (let ((normal-attrs '()))
@@ -85,8 +84,12 @@
 	  (push a normal-attrs)))
     (flet ((push-namespace (prefix uri)
 	     (let ((new (make-xmlns-attribute prefix uri)))
-	       (push new (car (xmlns-stack handler)))
-	       (push new attrs))))
+	       (unless (find (sax:attribute-qname new)
+			     attrs
+			     :test #'rod=
+			     :key #'sax:attribute-qname)
+		 (push new (car (xmlns-stack handler)))
+		 (push new attrs)))))
       (multiple-value-bind (prefix local-name) (split-qname qname)
 	(setf lname local-name)
 	(let ((binding (normalizer-find-prefix handler prefix)))
diff --git a/xml/xmls-compat.lisp b/xml/xmls-compat.lisp
index 3af2468..3b9f2e9 100644
--- a/xml/xmls-compat.lisp
+++ b/xml/xmls-compat.lisp
@@ -69,32 +69,50 @@
      (root :initform nil :accessor root)
      (include-default-values :initform t
                              :initarg :include-default-values
-                             :accessor include-default-values)))
+                             :accessor include-default-values)
+     (include-namespace-uri :initform t
+			    :initarg :include-namespace-uri
+			    :accessor include-namespace-uri)))
 
-(defun make-xmls-builder (&key (include-default-values t))
-  (make-instance 'xmls-builder :include-default-values include-default-values))
+(defun make-xmls-builder (&key (include-default-values t)
+		               (include-namespace-uri t))
+  "Make a XMLS style builder.  When 'include-namespace-uri is true a modified
+  XMLS tree is generated that includes the element namespace URI rather than
+  the qualified name prefix and also includes the namespace URI for attributes."
+  (make-instance 'xmls-builder
+		 :include-default-values include-default-values
+		 :include-namespace-uri include-namespace-uri))
 
 (defmethod sax:end-document ((handler xmls-builder))
   (root handler))
 
 (defmethod sax:start-element
     ((handler xmls-builder) namespace-uri local-name qname attributes)
-  (declare (ignore namespace-uri))
-  (setf local-name (or local-name qname))
-  (let* ((attributes
+  (let* ((include-default-values (include-default-values handler))
+	 (include-namespace-uri (include-namespace-uri handler))
+	 (attributes
           (loop
               for attr in attributes
-              when (or (sax:attribute-specified-p attr)
-                       (include-default-values handler))
+	      for attr-namespace-uri = (sax:attribute-namespace-uri attr)
+	      for attr-local-name = (sax:attribute-local-name attr)
+              when (and (or (sax:attribute-specified-p attr)
+			    include-default-values)
+			#+(or)
+			(or (not include-namespace-uri)
+			    (not attr-namespace-uri)
+			    attr-local-name))
               collect
-                (list (sax:attribute-qname attr)
+                (list (cond (include-namespace-uri
+			     (cond (attr-namespace-uri
+				    (cons attr-local-name attr-namespace-uri))
+				   (t
+				    (sax:attribute-qname attr))))
+                            (t
+                             (sax:attribute-qname attr)))
                       (sax:attribute-value attr))))
+	 (namespace (when include-namespace-uri namespace-uri))
          (node (make-node :name local-name
-                          :ns (let ((lq (length qname))
-                                    (ll (length local-name)))
-                                (if (eql lq ll)
-                                    nil
-                                    (subseq qname 0 (- lq ll 1))))
+                          :ns namespace
                           :attrs attributes))
          (parent (car (element-stack handler))))
     (if parent
@@ -129,34 +147,100 @@
 
 (defun map-node
     (handler node
-     &key (include-xmlns-attributes sax:*include-xmlns-attributes*))
+     &key (include-xmlns-attributes sax:*include-xmlns-attributes*)
+          (include-namespace-uri t))
+  (if include-namespace-uri
+      (map-node/lnames (cxml:make-namespace-normalizer handler)
+		       node
+		       include-xmlns-attributes)
+      (map-node/qnames handler node include-xmlns-attributes)))
+
+(defun map-node/lnames (handler node include-xmlns-attributes)
   (sax:start-document handler)
   (labels ((walk (node)
+	     (unless (node-ns node)
+	       (error "serializing with :INCLUDE-NAMESPACE-URI, but node ~
+                       was created without namespace URI"))
+	     (let* ((attlist
+		     (compute-attributes/lnames node include-xmlns-attributes))
+		    (uri (node-ns node))
+		    (lname (node-name node))
+		    (qname lname)	;let the normalizer fix it
+		    )
+	       (sax:start-element handler uri lname qname attlist)
+	       (dolist (child (node-children node))
+		 (typecase child
+		   (list (walk child))
+		   ((or string rod)
+		    (sax:characters handler (string-rod child)))))
+	       (sax:end-element handler uri lname qname))))
+    (walk node))
+  (sax:end-document handler))
+
+(defun map-node/qnames (handler node include-xmlns-attributes)
+  (sax:start-document handler)
+  (labels ((walk (node)
+	     (when (node-ns node)
+	       (error "serializing without :INCLUDE-NAMESPACE-URI, but node ~
+                       was created with a namespace URI"))
              (let* ((attlist
-                     (compute-attributes node include-xmlns-attributes))
-                    (lname (rod (node-name node)))
-                    (qname (if (node-ns node)
-			       (concatenate 'rod
-				 (rod (node-ns node))
-				 (rod ":")
-				 lname)
-			       lname)))
+		     (compute-attributes/qnames node include-xmlns-attributes))
+		    (qname (string-rod (node-name node)))
+                    (lname (nth-value 1 (cxml::split-qname qname))))
                (sax:start-element handler nil lname qname attlist)
                (dolist (child (node-children node))
                  (typecase child
                    (list (walk child))
-                   ((or string rod) (sax:characters handler (rod child)))))
+                   ((or string rod)
+		    (sax:characters handler (string-rod child)))))
                (sax:end-element handler nil lname qname))))
     (walk node))
   (sax:end-document handler))
 
-(defun compute-attributes (node xmlnsp)
+(defun compute-attributes/lnames (node xmlnsp)
   (remove nil
           (mapcar (lambda (a)
                     (destructuring-bind (name value) a
-                      (if (or xmlnsp (not (cxml::xmlns-attr-p (rod name))))
-                          (sax:make-attribute :qname (rod name)
-                                              :value (rod value)
+		      (unless (listp name)
+			(setf name (cons name nil)))
+                      (destructuring-bind (lname &rest uri) name
+			(cond
+			  ((not (equal uri "http://www.w3.org/2000/xmlns/"))
+			   (sax:make-attribute
+			    ;; let the normalizer fix the qname
+			    :qname (if uri
+				       (string-rod (concatenate 'string
+							 "dummy:"
+							 lname))
+				       (string-rod lname))
+			    :local-name (string-rod lname)
+			    :namespace-uri uri
+			    :value (string-rod value)
+			    :specified-p t))
+			  (xmlnsp
+			   (sax:make-attribute
+			    :qname (string-rod
+				    (if lname
+					(concatenate 'string "xmlns:" lname)
+					"xmlns"))
+			    :local-name (string-rod lname)
+			    :namespace-uri uri
+			    :value (string-rod value)
+			    :specified-p t))))))
+                  (node-attrs node))))
+
+(defun compute-attributes/qnames (node xmlnsp)
+  (remove nil
+          (mapcar (lambda (a)
+                    (destructuring-bind (name value) a
+		      (when (listp name)
+			(error "serializing without :INCLUDE-NAMESPACE-URI, ~
+                                but attribute was created with a namespace ~
+                                URI"))
+                      (if (or xmlnsp
+			      (not (cxml::xmlns-attr-p (string-rod name))))
+                          (sax:make-attribute :qname (string-rod name)
+                                              :value (string-rod value)
                                               :specified-p t)
                           nil)))
                   (node-attrs node))))