Added new functions attribute*, unparse-attribute, and macro with-element*,

with-namespace* to the SAX generation wrapper API.

doc/index.xml

@@ -69,7 +69,9 @@
       emitting them as SAX events to a user-specified handler at the
       same time.</li>
       <li>Changed attributes to carry an lname even when occurring
-      without a namespace.</li>
+      without a namespace.  Added new functions attribute*,
+      unparse-attribute, and macro with-element*, with-namespace* to
+      the SAX generation wrapper API.</li>
       <li>Klacks improvements: Incompatibly changed
       klacks:find-element and find-event to consider the current event
       as a result.  Added klacks-error, klacks:expect, klacks:skip,

doc/sax.xml

@@ -291,8 +291,12 @@
 
     <p>
       <div class="def">Macro CXML:WITH-XML-OUTPUT (sink &amp;body body) => sink-specific result</div>
+      <div class="def">Macro CXML:WITH-NAMESPACE ((prefix uri) &amp;body body) => result</div>
       <div class="def">Macro CXML:WITH-ELEMENT (qname &amp;body body) => result</div>
-      <div class="def">Function CXML:ATTRIBUTE (name value) => value</div>
+      <div class="def">Macro CXML:WITH-ELEMENT* ((prefix lname) &amp;body body) => result</div>
+      <div class="def">Function CXML:ATTRIBUTE (qname value) => value</div>
+      <div class="def">Generic Function CXML:UNPARSE-ATTRIBUTE (value) => string</div>
+      <div class="def">Function CXML:ATTRIBUTE* (prefix lname value) => value</div>
       <div class="def">Function CXML:TEXT (data) => data</div>
       <div class="def">Function CXML:CDATA (data) => data</div>
       Convenience syntax for event-based serialization.

xml/package.lisp

@@ -50,8 +50,12 @@
    #:make-character-stream-sink/utf8
 
    #:with-xml-output
+   #:with-namespace
    #:with-element
+   #:with-element*
    #:attribute
+   #:attribute*
+   #:unparse-attribute
    #:cdata
    #:text
 

xml/unparse.lisp

@@ -509,13 +509,17 @@
 
 (defvar *current-element*)
 (defvar *sink*)
+(defvar *unparse-namespace-bindings*)
+(defvar *current-namespace-bindings*)
 
 (defmacro with-xml-output (sink &body body)
   `(invoke-with-xml-output (lambda () ,@body) ,sink))
 
 (defun invoke-with-xml-output (fn sink)
   (let ((*sink* sink)
-        (*current-element* nil))
+        (*current-element* nil)
+	(*unparse-namespace-bindings* *initial-namespace-bindings*)
+	(*current-namespace-bindings* nil))
     (sax:start-document *sink*)
     (funcall fn)
     (sax:end-document *sink*)))
@@ -523,37 +527,86 @@
 (defmacro with-element (qname &body body)
   `(invoke-with-element (lambda () ,@body) ,qname))
 
+(defmacro with-element* ((prefix lname) &body body)
+  `(invoke-with-element* (lambda () ,@body) ,prefix ,lname))
+
+(defmacro with-namespace ((prefix uri) &body body)
+  `(invoke-with-namespace (lambda () ,@body) ,prefix ,uri))
+
 (defun maybe-emit-start-tag ()
   (when *current-element*
     ;; starting child node, need to emit opening tag of parent first:
-    (destructuring-bind (qname &rest attributes) *current-element*
+    (destructuring-bind ((uri lname qname) &rest attributes) *current-element*
-      (sax:start-element *sink* nil nil qname (reverse attributes)))
+      (sax:start-element *sink* uri lname qname (reverse attributes)))
     (setf *current-element* nil)))
 
+(defun invoke-with-namespace (fn prefix uri)
+  (let ((*unparse-namespace-bindings*
+	 (acons prefix uri *unparse-namespace-bindings*))
+	(*current-namespace-bindings*
+	 (acons prefix uri *current-namespace-bindings*)))
+    (sax:start-prefix-mapping *sink* prefix uri)
+    (multiple-value-prog1
+	(funcall fn)
+      (sax:end-prefix-mapping *sink* prefix))))
+
 (defun invoke-with-element (fn qname)
   (setf qname (rod qname))
+  (multiple-value-bind (prefix lname)
+      (split-qname qname)
+    (invoke-with-element* fn prefix lname qname)))
+
+(defun find-unparse-namespace (prefix)
+  (cdr (assoc prefix *unparse-namespace-bindings* :test 'equal)))
+
+(defun invoke-with-element* (fn prefix lname &optional qname)
+  (setf prefix (when prefix (rod prefix)))
+  (setf lname (rod lname))
   (maybe-emit-start-tag)
-  (let ((*current-element* (list qname)))
+  (let* ((qname (or qname
+		    (if prefix (concatenate 'rod prefix #":" lname) lname)))
+	 (uri (find-unparse-namespace (or prefix #"")))
+	 (*current-element*
+	  (cons (list uri lname qname)
+		(mapcar (lambda (x)
+			  (destructuring-bind (prefix &rest uri) x
+			    (sax:make-attribute
+			     :namespace-uri #"http://www.w3.org/2000/xmlns/"
+			     :local-name prefix
+			     :qname (if (zerop (length prefix))
+					#"xmlns"
+					(concatenate 'rod #"xmlns:" prefix))
+			     :value uri)))
+			*current-namespace-bindings*))))
     (multiple-value-prog1
-        (funcall fn)
+        (let ((*current-namespace-bindings* nil))
+	  (funcall fn))
       (maybe-emit-start-tag)
-      (sax:end-element *sink* nil nil qname))))
+      (sax:end-element *sink* uri lname qname))))
 
-(defun attribute-1 (name value)
+(defgeneric unparse-attribute (value))
-  (push (sax:make-attribute :qname (rod name) :value (rod value))
+(defmethod unparse-attribute ((value string)) value)
-        (cdr *current-element*))
+(defmethod unparse-attribute ((value null)) nil)
-  value)
+(defmethod unparse-attribute ((value integer)) (write-to-string value))
 
-(defgeneric attribute (name value))
+(defun attribute (qname value)
+  (setf qname (rod qname))
+  (multiple-value-bind (prefix lname)
+      (split-qname qname)
+    (attribute* prefix lname value qname)))
 
-(defmethod attribute (name (value string))
+(defun attribute* (prefix lname value &optional qname)
-  (attribute-1 name value))
+  (setf value (unparse-attribute value))
-
+  (when value
-(defmethod attribute (name (value null))
+    (setf prefix (when prefix (rod prefix)))
-  (declare (ignore name)))
+    (setf lname (rod lname))
-
+    (push (sax:make-attribute
-(defmethod attribute (name (value integer))
+	   :namespace-uri (find-unparse-namespace prefix)
-  (attribute-1 name (write-to-string value)))
+	   :local-name lname
+	   :qname (or qname
+		      (if prefix (concatenate 'rod prefix #":" lname) lname))
+	   :value (rod value))
+	  (cdr *current-element*))))
 
 (defun cdata (data)
   (maybe-emit-start-tag)