xml/xmlns-normalizer.lisp

   1 ;;;; xmlns-normalizer.lisp -- DOM 3-style namespace normalization
   2 ;;;;
   3 ;;;; This file is part of the CXML parser, released under Lisp-LGPL.
   4 ;;;; See file COPYING for details.
   5 ;;;;
   6 ;;;; Copyright (c) 2005 David Lichteblau
   7
   8 ;;;; Hier eine Variante des reichlich furchtbaren Algorithmus zur
   9 ;;;; Namespace-Normalisierung aus DOM 3 Core.[1]
  10 ;;;;
  11 ;;;; Gebraucht wir die Sache, weil Element- und Attributknoten in DOM
  12 ;;;; zwar ein Prefix-Attribut speichern, massgeblich fuer ihren Namespace
  13 ;;;; aber nur die URI sein soll.  Und eine Anpassung der zugehoerigen
  14 ;;;; xmlns-Attribute findet bei Veraenderungen im DOM-Baum nicht statt,
  15 ;;;; bzw. wird dem Nutzer ueberlassen.
  16 ;;;;
  17 ;;;; Daher muss letztlich spaetestens beim Serialisieren eine
  18 ;;;; Namespace-Deklaration fuer die angegebene URI nachgetragen und das
  19 ;;;; Praefix ggf. umbenannt werden, damit am Ende doch etwas
  20 ;;;; Namespace-konformes heraus kommt.
  21 ;;;;
  22 ;;;; Und das nennen sie dann Namespace-Support.
  23 ;;;;
  24 ;;;; [1] http://www.w3.org/TR/2004/REC-DOM-Level-3-Core-20040407/namespaces-algorithms.html#normalizeDocumentAlgo
  25
  26 (in-package :cxml)
  27
  28 (defclass namespace-normalizer (sax-proxy)
  29     ((xmlns-stack :initarg :xmlns-stack :accessor xmlns-stack)))
  30
  31 (defvar *xmlns-namespace* #"http://www.w3.org/2000/xmlns/")
  32
  33 (defun make-namespace-normalizer (chained-handler)
  34   "@arg[chained-handler]{A @class{SAX handler}.}
  35    @return{A @class{SAX handler}.}
  36
  37    Return a SAX handler that performs @a[http://www.w3.org/TR/2004/REC-DOM-Level-3-Core-20040407/namespaces-algorithms.html#normalizeDocumentAlgo]{DOM
  38      3-style namespace normalization} on attribute lists in
  39    @fun{sax:start-element} events before passing them on the next handler."
  40   (make-instance 'namespace-normalizer
  41     :xmlns-stack (list (mapcar (lambda (cons)
  42                                  (make-xmlns-attribute (car cons) (cdr cons)))
  43                                *initial-namespace-bindings*))
  44     :chained-handler chained-handler))
  45
  46 (defun normalizer-find-prefix (handler prefix)
  47   (when (zerop (length prefix))
  48     (setf prefix #"xmlns"))
  49   (block t
  50     (dolist (bindings (xmlns-stack handler))
  51       (dolist (attribute bindings)
  52         (when (rod= (sax:attribute-local-name attribute) prefix)
  53           (return-from t attribute))))))
  54
  55 (defun normalizer-find-uri (handler uri)
  56   (block t
  57     (dolist (bindings (xmlns-stack handler))
  58       (dolist (attribute bindings)
  59         (when (and (rod= (sax:attribute-value attribute) uri)
  60                    ;; default-namespace interessiert uns nicht
  61                    (not (rod= (sax:attribute-qname attribute) #"xmlns")))
  62           (return-from t attribute))))))
  63
  64 (defun make-xmlns-attribute (prefix uri)
  65   (if (and (plusp (length prefix)) (not (equal prefix #"xmlns")))
  66       (sax:make-attribute
  67        :qname (concatenate 'rod #"xmlns:" prefix)
  68        :namespace-uri *xmlns-namespace*
  69        :local-name prefix
  70        :value uri)
  71       (sax:make-attribute
  72        :qname #"xmlns"
  73        :namespace-uri *xmlns-namespace*
  74        :local-name #"xmlns"
  75        :value uri)))
  76
  77 (defun rename-attribute (a new-prefix)
  78   (setf (sax:attribute-qname a)
  79         (concatenate 'rod new-prefix #":" (sax:attribute-local-name a))))
  80
  81 (defmethod sax:start-element
  82     ((handler namespace-normalizer) uri lname qname attrs)
  83   (when (null uri)
  84     (setf uri #""))
  85   (let ((normal-attrs '()))
  86     (push nil (xmlns-stack handler))
  87     (dolist (a attrs)
  88       (if (rod= *xmlns-namespace* (sax:attribute-namespace-uri a))
  89           (push a (car (xmlns-stack handler)))
  90           (push a normal-attrs)))
  91     (flet ((push-namespace (prefix uri)
  92              (let ((new (make-xmlns-attribute prefix uri)))
  93                (unless (find (sax:attribute-qname new)
  94                              attrs
  95                              :test #'rod=
  96                              :key #'sax:attribute-qname)
  97                  (push new (car (xmlns-stack handler)))
  98                  (push new attrs)))))
  99       (multiple-value-bind (prefix local-name) (split-qname qname)
 100         (setf lname local-name)
 101         (let ((binding (normalizer-find-prefix handler prefix)))
 102           (cond
 103             ((null binding)
 104               (unless (and (null prefix) (zerop (length uri)))
 105                 (push-namespace prefix uri)))
 106             ((rod= (sax:attribute-value binding) uri))
 107             ((member binding (car (xmlns-stack handler)))
 108               (setf (sax:attribute-value binding) uri))
 109             (t
 110               (push-namespace prefix uri)))))
 111       (dolist (a normal-attrs)
 112         (let ((u (sax:attribute-namespace-uri a)))
 113           (when u
 114             (let* ((prefix (split-qname (sax:attribute-qname a)))
 115                    (prefix-binding
 116                     (when prefix
 117                       (normalizer-find-prefix handler prefix))))
 118               (when (or (null prefix-binding)
 119                         (not (rod= (sax:attribute-value prefix-binding) u)))
 120                 (let ((uri-binding (normalizer-find-uri handler u)))
 121                   (cond
 122                     (uri-binding
 123                       (rename-attribute
 124                        a
 125                        (sax:attribute-local-name uri-binding)))
 126                     ((and prefix (null prefix-binding))
 127                       (push-namespace prefix u))
 128                     (t
 129                       (loop
 130                           for i from 1
 131                           for prefix = (rod (format nil "NS~D" i))
 132                           unless (normalizer-find-prefix handler prefix)
 133                           do
 134                             (push-namespace prefix u)
 135                             (rename-attribute a prefix)
 136                             (return))))))))))))
 137   (sax:start-element (proxy-chained-handler handler) uri lname qname attrs))
 138
 139 (defmethod sax:end-element ((handler namespace-normalizer) uri lname qname)
 140   (pop (xmlns-stack handler))
 141   (sax:end-element (proxy-chained-handler handler) (or uri #"") lname qname))