Update of /project/cxml/cvsroot/cxml/xml In directory clnet:/tmp/cvs-serv16419/xml

Modified Files: xmlns-normalizer.lisp xmls-compat.lisp Log Message: 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.)

--- /project/cxml/cvsroot/cxml/xml/xmlns-normalizer.lisp 2006/08/20 14:59:35 1.3 +++ /project/cxml/cvsroot/cxml/xml/xmlns-normalizer.lisp 2007/06/16 11:07:58 1.4 @@ -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))) --- /project/cxml/cvsroot/cxml/xml/xmls-compat.lisp 2006/05/15 21:57:47 1.3 +++ /project/cxml/cvsroot/cxml/xml/xmls-compat.lisp 2007/06/16 11:07:58 1.4 @@ -69,32 +69,50 @@ (root :initform nil :accessor root) (include-default-values :initform t :initarg :include-default-values - :accessor include-default-values))) - -(defun make-xmls-builder (&key (include-default-values t)) - (make-instance 'xmls-builder :include-default-values 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) + (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 + (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 - (if (or xmlnsp (not (cxml::xmlns-attr-p (rod name)))) - (sax:make-attribute :qname (rod name) - :value (rod value) + (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))))