namespace normalization

xml/package.lisp

@@ -74,4 +74,5 @@
    
    #:make-recoder
    #:sax-proxy
-   #:proxy-chained-handler))
+   #:proxy-chained-handler
+   #:make-namespace-normalizer))

xml/sax-proxy.lisp

@@ -29,6 +29,8 @@
   (define-proxy-method sax:end-cdata ())
   (define-proxy-method sax:start-dtd (name public-id system-id))
   (define-proxy-method sax:end-dtd ())
+  (define-proxy-method sax:start-internal-subset ())
+  (define-proxy-method sax:end-internal-subset ())
   (define-proxy-method sax:unparsed-entity-declaration (name pub sys not))
   (define-proxy-method sax:external-entity-declaration (kind name pub sys))
   (define-proxy-method sax:internal-entity-declaration (kind name value))

xml/xmlns-normalizer.lisp

@@ -0,0 +1,130 @@
+;;;; 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)
+  (make-instance 'namespace-normalizer
+    :xmlns-stack (list (mapcar (lambda (cons)
+				 (make-xmlns-attribute (car cons) (cdr cons)))
+			       *namespace-bindings*))
+    :chained-handler chained-handler))
+
+(defun normalizer-find-prefix (handler prefix)
+  (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 prefix
+      (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)
+  (declare (ignore qname))
+  (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)))
+	       (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)
+	      (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)))
+		    ((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)
+  (declare (ignore qname))
+  (pop (xmlns-stack handler))
+  (sax:end-element (proxy-chained-handler handler) (or uri #"") lname qname))