xml/xmls-compat.lisp

   1 ;;;; xml-compat.lisp -- XMLS-compatible data structures
   2 ;;;;
   3 ;;;; This file is part of the CXML parser, released under Lisp-LGPL.
   4 ;;;; See file COPYING for details.
   5 ;;;;
   6 ;;;; Developed 2004 for headcraft - http://headcraft.de/
   7 ;;;; Copyright: David Lichteblau
   8
   9 (defpackage cxml-xmls
  10   (:use :cl :runes)
  11   (:export #:make-node #:node-name #:node-ns #:node-attrs #:node-children
  12            #:make-xmls-builder #:map-node #:make-xpath-navigator))
  13
  14 (in-package :cxml-xmls)
  15
  16
  17 ;;;; Knoten
  18
  19 (defun make-node (&key name ns attrs children)
  20   `(,(if ns (cons name ns) name)
  21        ,attrs
  22        ,@children))
  23
  24 (defun node-name (node)
  25   (let ((car (car node)))
  26     (if (consp car)
  27         (car car)
  28         car)))
  29
  30 (defun (setf node-name) (newval node)
  31   (let ((car (car node)))
  32     (if (consp car)
  33         (setf (car car) newval)
  34         (setf (car node) newval))))
  35
  36 (defun node-ns (node)
  37   (let ((car (car node)))
  38     (if (consp car)
  39         (cdr car)
  40         nil)))
  41
  42 (defun (setf node-ns) (newval node)
  43   (let ((car (car node)))
  44     (if (consp car)
  45         (setf (cdr car) newval)
  46         (setf (car node) (cons car newval)))
  47     newval))
  48
  49 (defun node-attrs (node)
  50   (cadr node))
  51
  52 (defun (setf node-attrs) (newval node)
  53   (setf (cadr node) newval))
  54
  55 (defun node-children (node)
  56   (cddr node))
  57
  58 (defun (setf node-children) (newval node)
  59   (setf (cddr node) newval))
  60
  61
  62 ;;;; SAX-Handler (Parser)
  63
  64 (defclass xmls-builder (sax:default-handler)
  65     ((element-stack :initform nil :accessor element-stack)
  66      (root :initform nil :accessor root)
  67      (include-default-values :initform t
  68                              :initarg :include-default-values
  69                              :accessor include-default-values)
  70      (include-namespace-uri :initform t
  71                             :initarg :include-namespace-uri
  72                             :accessor include-namespace-uri)))
  73
  74 (defun make-xmls-builder (&key (include-default-values t)
  75                                (include-namespace-uri t))
  76   "Make a XMLS style builder.  When 'include-namespace-uri is true a modified
  77   XMLS tree is generated that includes the element namespace URI rather than
  78   the qualified name prefix and also includes the namespace URI for attributes."
  79   (make-instance 'xmls-builder
  80                  :include-default-values include-default-values
  81                  :include-namespace-uri include-namespace-uri))
  82
  83 (defmethod sax:end-document ((handler xmls-builder))
  84   (root handler))
  85
  86 (defmethod sax:start-element
  87     ((handler xmls-builder) namespace-uri local-name qname attributes)
  88   (let* ((include-default-values (include-default-values handler))
  89          (include-namespace-uri (include-namespace-uri handler))
  90          (attributes
  91           (loop
  92               for attr in attributes
  93               for attr-namespace-uri = (sax:attribute-namespace-uri attr)
  94               for attr-local-name = (sax:attribute-local-name attr)
  95               when (and (or (sax:attribute-specified-p attr)
  96                             include-default-values)
  97                         #+(or)
  98                         (or (not include-namespace-uri)
  99                             (not attr-namespace-uri)
 100                             attr-local-name))
 101               collect
 102                 (list (cond (include-namespace-uri
 103                              (cond (attr-namespace-uri
 104                                     (cons attr-local-name attr-namespace-uri))
 105                                    (t
 106                                     (sax:attribute-qname attr))))
 107                             (t
 108                              (sax:attribute-qname attr)))
 109                       (sax:attribute-value attr))))
 110          (namespace (when include-namespace-uri namespace-uri))
 111          (node (make-node :name local-name
 112                           :ns namespace
 113                           :attrs attributes))
 114          (parent (car (element-stack handler))))
 115     (if parent
 116         (push node (node-children parent))
 117         (setf (root handler) node))
 118     (push node (element-stack handler))))
 119
 120 (defmethod sax:end-element
 121     ((handler xmls-builder) namespace-uri local-name qname)
 122   (declare (ignore namespace-uri local-name qname))
 123   (let ((node (pop (element-stack handler))))
 124     (setf (node-children node) (reverse (node-children node)))))
 125
 126 (defmethod sax:characters ((handler xmls-builder) data)
 127   (let* ((parent (car (element-stack handler)))
 128          (prev (car (node-children parent))))
 129     ;; Be careful to accept both rods and strings here, so that xmls can be
 130     ;; used with strings even if cxml is configured to use octet string rods.
 131     (if (typep prev '(or rod string))
 132         ;; um entities herum wird SAX:CHARACTERS mehrfach aufgerufen fuer
 133         ;; den gleichen Textknoten.  Hier muessen wir den bestehenden Knoten
 134         ;; erweitern, sonst ist das Dokument nicht normalisiert.
 135         ;; (XXX Oder sollte man besser den Parser entsprechend aendern?)
 136         (setf (car (node-children parent))
 137               (concatenate `(vector ,(array-element-type prev))
 138                            prev
 139                            data))
 140         (push data (node-children parent)))))
 141
 142
 143 ;;;; SAX-Treiber (fuer Serialisierung)
 144
 145 (defun map-node
 146     (handler node
 147      &key (include-xmlns-attributes sax:*include-xmlns-attributes*)
 148           (include-namespace-uri t))
 149   (if include-namespace-uri
 150       (map-node/lnames (cxml:make-namespace-normalizer handler)
 151                        node
 152                        include-xmlns-attributes)
 153       (map-node/qnames handler node include-xmlns-attributes)))
 154
 155 (defun map-node/lnames (handler node include-xmlns-attributes)
 156   (sax:start-document handler)
 157   (labels ((walk (node)
 158              (unless (node-ns node)
 159                (error "serializing with :INCLUDE-NAMESPACE-URI, but node ~
 160                        was created without namespace URI"))
 161              (let* ((attlist
 162                      (compute-attributes/lnames node include-xmlns-attributes))
 163                     (uri (node-ns node))
 164                     (lname (node-name node))
 165                     (qname lname)       ;let the normalizer fix it
 166                     )
 167                (sax:start-element handler uri lname qname attlist)
 168                (dolist (child (node-children node))
 169                  (typecase child
 170                    (list (walk child))
 171                    ((or string rod)
 172                     (sax:characters handler (string-rod child)))))
 173                (sax:end-element handler uri lname qname))))
 174     (walk node))
 175   (sax:end-document handler))
 176
 177 (defun map-node/qnames (handler node include-xmlns-attributes)
 178   (sax:start-document handler)
 179   (labels ((walk (node)
 180              (when (node-ns node)
 181                (error "serializing without :INCLUDE-NAMESPACE-URI, but node ~
 182                        was created with a namespace URI"))
 183              (let* ((attlist
 184                      (compute-attributes/qnames node include-xmlns-attributes))
 185                     (qname (string-rod (node-name node)))
 186                     (lname (nth-value 1 (cxml::split-qname qname))))
 187                (sax:start-element handler nil lname qname attlist)
 188                (dolist (child (node-children node))
 189                  (typecase child
 190                    (list (walk child))
 191                    ((or string rod)
 192                     (sax:characters handler (string-rod child)))))
 193                (sax:end-element handler nil lname qname))))
 194     (walk node))
 195   (sax:end-document handler))
 196
 197 (defun compute-attributes/lnames (node xmlnsp)
 198   (remove nil
 199           (mapcar (lambda (a)
 200                     (destructuring-bind (name value) a
 201                       (unless (listp name)
 202                         (setf name (cons name nil)))
 203                       (destructuring-bind (lname &rest uri) name
 204                         (cond
 205                           ((not (equal uri "http://www.w3.org/2000/xmlns/"))
 206                            (sax:make-attribute
 207                             ;; let the normalizer fix the qname
 208                             :qname (if uri
 209                                        (string-rod (concatenate 'string
 210                                                          "dummy:"
 211                                                          lname))
 212                                        (string-rod lname))
 213                             :local-name (string-rod lname)
 214                             :namespace-uri uri
 215                             :value (string-rod value)
 216                             :specified-p t))
 217                           (xmlnsp
 218                            (sax:make-attribute
 219                             :qname (string-rod
 220                                     (if lname
 221                                         (concatenate 'string "xmlns:" lname)
 222                                         "xmlns"))
 223                             :local-name (string-rod lname)
 224                             :namespace-uri uri
 225                             :value (string-rod value)
 226                             :specified-p t))))))
 227                   (node-attrs node))))
 228
 229 (defun compute-attributes/qnames (node xmlnsp)
 230   (remove nil
 231           (mapcar (lambda (a)
 232                     (destructuring-bind (name value) a
 233                       (when (listp name)
 234                         (error "serializing without :INCLUDE-NAMESPACE-URI, ~
 235                                 but attribute was created with a namespace ~
 236                                 URI"))
 237                       (if (or xmlnsp
 238                               (not (cxml::xmlns-attr-p (string-rod name))))
 239                           (sax:make-attribute :qname (string-rod name)
 240                                               :value (string-rod value)
 241                                               :specified-p t)
 242                           nil)))
 243                   (node-attrs node))))
 244
 245 ;;;; XPath
 246
 247 (defun make-xpath-navigator ()
 248   (make-instance 'xpath-navigator))
 249
 250 (defclass xpath-navigator ()
 251   ((parents :initform (make-hash-table))
 252    (prefixes :initform (make-hash-table))
 253    (children :initform (make-hash-table))
 254    (attributes :initform (make-hash-table))
 255    (namespaces :initform (make-hash-table))))
 256
 257 (defmethod initialize-instance :after ((instance xpath-navigator) &key)
 258   (with-slots (prefixes) instance
 259     (setf (gethash "http://www.w3.org/XML/1998/namespace" prefixes)
 260           "xml")))