OSCL/CXML
2
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

XMLS compatibility is not <i>bug-for-bug</i>-compatible with

Browse Source 
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.)
This commit is contained in:
dlichteblau
2007-06-16 11:07:58 +00:00
parent 0d4ab8c766
commit ee394c591d
4 changed files with 156 additions and 45 deletions
Download Patch File Download Diff File Expand all files Collapse all files

11
xml/xmlns-normalizer.lisp
View File

@ -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)))

140
xml/xmls-compat.lisp
View File

@ -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))))