From 41ee5ae24d3b2b415b4743b9ff405eb135320ef4 Mon Sep 17 00:00:00 2001 From: dlichteblau Date: Tue, 1 May 2007 20:06:59 +0000 Subject: [PATCH] Added new functions attribute*, unparse-attribute, and macro with-element*, with-namespace* to the SAX generation wrapper API. --- doc/index.xml | 4 ++- doc/sax.xml | 6 +++- xml/package.lisp | 4 +++ xml/unparse.lisp | 91 ++++++++++++++++++++++++++++++++++++++---------- 4 files changed, 84 insertions(+), 21 deletions(-) diff --git a/doc/index.xml b/doc/index.xml index 9203051..0792bc3 100644 --- a/doc/index.xml +++ b/doc/index.xml @@ -69,7 +69,9 @@ emitting them as SAX events to a user-specified handler at the same time.
  • Changed attributes to carry an lname even when occurring - without a namespace.
    • + without a namespace. Added new functions attribute*, + unparse-attribute, and macro with-element*, with-namespace* to + the SAX generation wrapper API.
  • 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, diff --git a/doc/sax.xml b/doc/sax.xml index e68ead7..93124f3 100644 --- a/doc/sax.xml +++ b/doc/sax.xml @@ -291,8 +291,12 @@

    Macro CXML:WITH-XML-OUTPUT (sink &body body) => sink-specific result
    +
    Macro CXML:WITH-NAMESPACE ((prefix uri) &body body) => result
    Macro CXML:WITH-ELEMENT (qname &body body) => result
    -
    Function CXML:ATTRIBUTE (name value) => value
    +
    Macro CXML:WITH-ELEMENT* ((prefix lname) &body body) => result
    +
    Function CXML:ATTRIBUTE (qname value) => value
    +
    Generic Function CXML:UNPARSE-ATTRIBUTE (value) => string
    +
    Function CXML:ATTRIBUTE* (prefix lname value) => value
    Function CXML:TEXT (data) => data
    Function CXML:CDATA (data) => data
    Convenience syntax for event-based serialization. diff --git a/xml/package.lisp b/xml/package.lisp index c082be1..5518d48 100644 --- a/xml/package.lisp +++ b/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 diff --git a/xml/unparse.lisp b/xml/unparse.lisp index 4cfbb06..f8194ed 100644 --- a/xml/unparse.lisp +++ b/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* - (sax:start-element *sink* nil nil qname (reverse attributes))) + (destructuring-bind ((uri lname qname) &rest attributes) *current-element* + (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) - (push (sax:make-attribute :qname (rod name) :value (rod value)) - (cdr *current-element*)) - value) +(defgeneric unparse-attribute (value)) +(defmethod unparse-attribute ((value string)) value) +(defmethod unparse-attribute ((value null)) nil) +(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)) - (attribute-1 name value)) - -(defmethod attribute (name (value null)) - (declare (ignore name))) - -(defmethod attribute (name (value integer)) - (attribute-1 name (write-to-string value))) +(defun attribute* (prefix lname value &optional qname) + (setf value (unparse-attribute value)) + (when value + (setf prefix (when prefix (rod prefix))) + (setf lname (rod lname)) + (push (sax:make-attribute + :namespace-uri (find-unparse-namespace prefix) + :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)