142 lines
5.1 KiB
Common Lisp
142 lines
5.1 KiB
Common Lisp
;;;; xmlns-normalizer.lisp -- DOM 3-style namespace normalization
|
|
;;;;
|
|
;;;; This file is part of the CXML parser, released under Lisp-LGPL.
|
|
;;;; See file COPYING for details.
|
|
;;;;
|
|
;;;; Copyright (c) 2005 David Lichteblau
|
|
|
|
;;;; Hier eine Variante des reichlich furchtbaren Algorithmus zur
|
|
;;;; Namespace-Normalisierung aus DOM 3 Core.[1]
|
|
;;;;
|
|
;;;; Gebraucht wir die Sache, weil Element- und Attributknoten in DOM
|
|
;;;; zwar ein Prefix-Attribut speichern, massgeblich fuer ihren Namespace
|
|
;;;; aber nur die URI sein soll. Und eine Anpassung der zugehoerigen
|
|
;;;; xmlns-Attribute findet bei Veraenderungen im DOM-Baum nicht statt,
|
|
;;;; bzw. wird dem Nutzer ueberlassen.
|
|
;;;;
|
|
;;;; Daher muss letztlich spaetestens beim Serialisieren eine
|
|
;;;; Namespace-Deklaration fuer die angegebene URI nachgetragen und das
|
|
;;;; Praefix ggf. umbenannt werden, damit am Ende doch etwas
|
|
;;;; Namespace-konformes heraus kommt.
|
|
;;;;
|
|
;;;; Und das nennen sie dann Namespace-Support.
|
|
;;;;
|
|
;;;; [1] http://www.w3.org/TR/2004/REC-DOM-Level-3-Core-20040407/namespaces-algorithms.html#normalizeDocumentAlgo
|
|
|
|
(in-package :cxml)
|
|
|
|
(defclass namespace-normalizer (sax-proxy)
|
|
((xmlns-stack :initarg :xmlns-stack :accessor xmlns-stack)))
|
|
|
|
(defvar *xmlns-namespace* #"http://www.w3.org/2000/xmlns/")
|
|
|
|
(defun make-namespace-normalizer (chained-handler)
|
|
"@arg[chained-handler]{A @class{SAX handler}.}
|
|
@return{A @class{SAX handler}.}
|
|
|
|
Return a SAX handler that performs @a[http://www.w3.org/TR/2004/REC-DOM-Level-3-Core-20040407/namespaces-algorithms.html#normalizeDocumentAlgo]{DOM
|
|
3-style namespace normalization} on attribute lists in
|
|
@fun{sax:start-element} events before passing them on the next handler."
|
|
(make-instance 'namespace-normalizer
|
|
:xmlns-stack (list (mapcar (lambda (cons)
|
|
(make-xmlns-attribute (car cons) (cdr cons)))
|
|
*initial-namespace-bindings*))
|
|
:chained-handler chained-handler))
|
|
|
|
(defun normalizer-find-prefix (handler prefix)
|
|
(when (zerop (length prefix))
|
|
(setf prefix #"xmlns"))
|
|
(block t
|
|
(dolist (bindings (xmlns-stack handler))
|
|
(dolist (attribute bindings)
|
|
(when (rod= (sax:attribute-local-name attribute) prefix)
|
|
(return-from t attribute))))))
|
|
|
|
(defun normalizer-find-uri (handler uri)
|
|
(block t
|
|
(dolist (bindings (xmlns-stack handler))
|
|
(dolist (attribute bindings)
|
|
(when (and (rod= (sax:attribute-value attribute) uri)
|
|
;; default-namespace interessiert uns nicht
|
|
(not (rod= (sax:attribute-qname attribute) #"xmlns")))
|
|
(return-from t attribute))))))
|
|
|
|
(defun make-xmlns-attribute (prefix uri)
|
|
(if (and (plusp (length prefix)) (not (equal prefix #"xmlns")))
|
|
(sax:make-attribute
|
|
:qname (concatenate 'rod #"xmlns:" prefix)
|
|
:namespace-uri *xmlns-namespace*
|
|
:local-name prefix
|
|
:value uri)
|
|
(sax:make-attribute
|
|
:qname #"xmlns"
|
|
:namespace-uri *xmlns-namespace*
|
|
:local-name #"xmlns"
|
|
:value uri)))
|
|
|
|
(defun rename-attribute (a new-prefix)
|
|
(setf (sax:attribute-qname a)
|
|
(concatenate 'rod new-prefix #":" (sax:attribute-local-name a))))
|
|
|
|
(defmethod sax:start-element
|
|
((handler namespace-normalizer) uri lname qname attrs)
|
|
(when (null uri)
|
|
(setf uri #""))
|
|
(let ((normal-attrs '()))
|
|
(push nil (xmlns-stack handler))
|
|
(dolist (a attrs)
|
|
(if (rod= *xmlns-namespace* (sax:attribute-namespace-uri a))
|
|
(push a (car (xmlns-stack handler)))
|
|
(push a normal-attrs)))
|
|
(flet ((push-namespace (prefix uri)
|
|
(let ((new (make-xmlns-attribute prefix uri)))
|
|
(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)))
|
|
(cond
|
|
((null binding)
|
|
(unless (and (null prefix) (zerop (length uri)))
|
|
(push-namespace prefix uri)))
|
|
((rod= (sax:attribute-value binding) uri))
|
|
((member binding (car (xmlns-stack handler)))
|
|
(setf (sax:attribute-value binding) uri))
|
|
(t
|
|
(push-namespace prefix uri)))))
|
|
(dolist (a normal-attrs)
|
|
(let ((u (sax:attribute-namespace-uri a)))
|
|
(when u
|
|
(let* ((prefix (split-qname (sax:attribute-qname a)))
|
|
(prefix-binding
|
|
(when prefix
|
|
(normalizer-find-prefix handler prefix))))
|
|
(when (or (null prefix-binding)
|
|
(not (rod= (sax:attribute-value prefix-binding) u)))
|
|
(let ((uri-binding (normalizer-find-uri handler u)))
|
|
(cond
|
|
(uri-binding
|
|
(rename-attribute
|
|
a
|
|
(sax:attribute-local-name uri-binding)))
|
|
((and prefix (null prefix-binding))
|
|
(push-namespace prefix u))
|
|
(t
|
|
(loop
|
|
for i from 1
|
|
for prefix = (rod (format nil "NS~D" i))
|
|
unless (normalizer-find-prefix handler prefix)
|
|
do
|
|
(push-namespace prefix u)
|
|
(rename-attribute a prefix)
|
|
(return))))))))))))
|
|
(sax:start-element (proxy-chained-handler handler) uri lname qname attrs))
|
|
|
|
(defmethod sax:end-element ((handler namespace-normalizer) uri lname qname)
|
|
(pop (xmlns-stack handler))
|
|
(sax:end-element (proxy-chained-handler handler) (or uri #"") lname qname))
|