unparse.lisp

   1 ;;; -*- show-trailing-whitespace: t; indent-tabs-mode: nil -*-
   2
   3 ;;; Copyright (c) 2007,2008 David Lichteblau, Ivan Shvedunov.
   4 ;;; Copyright (c) 2004 David Lichteblau (for headcraft.de)
   5 ;;; All rights reserved.
   6
   7 ;;; Redistribution and use in source and binary forms, with or without
   8 ;;; modification, are permitted provided that the following conditions
   9 ;;; are met:
  10 ;;;
  11 ;;;   * Redistributions of source code must retain the above copyright
  12 ;;;     notice, this list of conditions and the following disclaimer.
  13 ;;;
  14 ;;;   * Redistributions in binary form must reproduce the above
  15 ;;;     copyright notice, this list of conditions and the following
  16 ;;;     disclaimer in the documentation and/or other materials
  17 ;;;     provided with the distribution.
  18 ;;;
  19 ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
  20 ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
  21 ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
  22 ;;; ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
  23 ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
  24 ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
  25 ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
  26 ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
  27 ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
  28 ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
  29 ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
  30
  31 (in-package :xuriella)
  32
  33
  34 ;;; Convenience functions for serialization to SAX, similar in syntax
  35 ;;; to what cxml offers, but with namespace handling as required for XSLT.
  36
  37 (defvar *current-element*)
  38 (defvar *sink*)
  39 (defvar *start-tag-written-p*)
  40
  41 (defmacro with-xml-output (sink &body body)
  42   `(invoke-with-xml-output (lambda () ,@body) ,sink))
  43
  44 (defmacro with-output-sink-bound ((var) &body body)
  45   `(invoke-with-output-sink-bound (lambda (,var) ,@body)))
  46
  47 (defun invoke-with-xml-output (fn sink)
  48   (let ((*sink* sink)
  49         (*current-element* nil)
  50         (*start-tag-written-p* t))
  51     (sax:start-document *sink*)
  52     (funcall fn)
  53     (sax:end-document *sink*)))
  54
  55 (defun invoke-with-output-sink-bound (fn)
  56   (maybe-emit-start-tag)
  57   (funcall fn *sink*))
  58
  59 (defmacro with-element ((local-name uri &key suggested-prefix extra-namespaces)
  60                         &body body)
  61   `(invoke-with-element (lambda () ,@body)
  62                         ,local-name
  63                         ,uri
  64                         :suggested-prefix ,suggested-prefix
  65                         :extra-namespaces ,extra-namespaces))
  66
  67 (defun doctype (name public-id system-id &optional internal-subset)
  68   (sax:start-dtd *sink* name public-id system-id)
  69   (when internal-subset
  70     (sax:unparsed-internal-subset *sink* internal-subset))
  71   (sax:end-dtd *sink*))
  72
  73 (defun maybe-emit-start-tag ()
  74   (let ((elt *current-element*))
  75     (when (and elt (not *start-tag-written-p*))
  76       (setf *start-tag-written-p* t)
  77       (let* ((local-name (sink-element-local-name elt))
  78              (uri (sink-element-uri elt))
  79              (suggested-prefix (sink-element-suggested-prefix elt))
  80              (prefix (ensure-prefix-for-uri elt uri suggested-prefix))
  81              (qname (if (plusp (length prefix))
  82                         (concatenate 'string prefix ":" local-name)
  83                         local-name))
  84              (attrs '()))
  85         (setf (sink-element-actual-qname elt) qname)
  86         (dolist (attr (sink-element-attributes elt))
  87           (push (convert-attribute elt attr) attrs))
  88         (loop
  89            for (prefix . uri) in (sink-element-new-namespaces elt) do
  90              (sax:start-prefix-mapping *sink* prefix uri)
  91              (push (make-xmlns-attribute prefix uri) attrs))
  92         (sax:start-element *sink* uri local-name qname attrs)))))
  93
  94 (defun convert-attribute (elt attr)
  95   (let* ((local-name (sink-attribute-local-name attr))
  96          (uri (sink-attribute-uri attr))
  97          (suggested-prefix (sink-attribute-suggested-prefix attr))
  98          (prefix (ensure-prefix-for-uri elt uri suggested-prefix))
  99          (qname (if (plusp (length prefix))
 100                     (concatenate 'string prefix ":" local-name)
 101                     local-name)))
 102     (sax:make-attribute :namespace-uri uri
 103                         :local-name local-name
 104                         :qname qname
 105                         :value (sink-attribute-value attr))))
 106
 107 (defun sink-element-find-uri (prefix elt)
 108   (cdr
 109    (find prefix
 110          (sink-element-all-namespaces elt)
 111          :key #'car
 112          :test #'equal)))
 113
 114 (defun ensure-prefix-for-uri (elt uri &optional suggested-prefix)
 115   (let* ((prefix-cons
 116           (find uri
 117                 (sink-element-all-namespaces elt)
 118                 :key #'cdr
 119                 :test #'equal))
 120          (prefix (car prefix-cons))
 121          (cross-check
 122           (when prefix-cons
 123             (sink-element-find-uri prefix elt))))
 124     (if (and prefix-cons (equal cross-check uri))
 125         prefix
 126         (loop
 127            for i from 0
 128            for prefix = suggested-prefix then (format nil "ns-~D" i)
 129            while
 130              (sink-element-find-uri prefix elt)
 131            finally
 132              (push-sink-element-namespace elt prefix uri)
 133              (return prefix)))))
 134
 135 (defun make-xmlns-attribute (prefix uri)
 136   (sax:make-attribute
 137    :namespace-uri #"http://www.w3.org/2000/xmlns/"
 138    :local-name prefix
 139    :qname (if (zerop (length prefix))
 140               "xmlns"
 141               (concatenate 'string "xmlns:" prefix))
 142    :value uri))
 143
 144 (defstruct sink-element
 145   local-name
 146   uri
 147   suggested-prefix
 148   all-namespaces
 149   new-namespaces
 150   attributes
 151   actual-qname)
 152
 153 (defstruct sink-attribute
 154   local-name
 155   uri
 156   suggested-prefix
 157   value)
 158
 159 (defparameter *initial-namespaces*
 160   '((nil . "")
 161     ("xmlns" . #"http://www.w3.org/2000/xmlns/")
 162     ("xml" . #"http://www.w3.org/XML/1998/namespace")))
 163
 164 (defun invoke-with-element
 165     (fn local-name uri &key suggested-prefix extra-namespaces)
 166   (check-type local-name string)
 167   (check-type uri string)
 168   (check-type suggested-prefix (or null string))
 169   (maybe-emit-start-tag)
 170   (setf uri (unalias-uri uri))
 171   (let* ((parent *current-element*)
 172          (elt (make-sink-element
 173                :local-name local-name
 174                :uri uri
 175                :suggested-prefix suggested-prefix
 176                :all-namespaces (if parent
 177                                    (sink-element-all-namespaces parent)
 178                                    *initial-namespaces*)
 179                :new-namespaces nil
 180                :attributes nil))
 181          (*current-element* elt)
 182          (*start-tag-written-p* nil))
 183     (process-extra-namespaces elt extra-namespaces)
 184     (multiple-value-prog1
 185         (funcall fn)
 186       (maybe-emit-start-tag)
 187       (sax:end-element *sink* uri local-name (sink-element-actual-qname elt))
 188       (loop
 189          for (prefix . uri) in (sink-element-new-namespaces elt) do
 190          (sax:end-prefix-mapping *sink* prefix)))))
 191
 192 (defun process-extra-namespace (elt prefix uri)
 193   (setf uri (unalias-uri uri))
 194   (unless
 195       ;; allow earlier conses in extra-namespaces to hide later ones.
 196       (find prefix
 197             (sink-element-new-namespaces elt)
 198             :key #'car
 199             :test #'equal)
 200     (let ((previous (sink-element-find-uri prefix elt)))
 201       (unless
 202           ;; no need to declare what has already been done
 203           (equal uri previous)
 204         (push-sink-element-namespace elt prefix uri)))))
 205
 206 (defun process-extra-namespaces (elt extra-namespaces)
 207   (loop for (prefix . uri) in extra-namespaces do
 208        (process-extra-namespace elt prefix uri)))
 209
 210 (defun push-sink-element-namespace (elt prefix uri)
 211   (cond
 212     ((equal prefix "xml")
 213      (assert (equal uri "http://www.w3.org/XML/1998/namespace")))
 214     ((equal prefix "xmlns")
 215      (assert (equal uri "http://www.w3.org/2000/xmlns/")))
 216     (t
 217      (let ((cons (cons prefix uri)))
 218        (push cons (sink-element-all-namespaces elt))
 219        (push cons (sink-element-new-namespaces elt))))))
 220
 221 (defun write-attribute (local-name uri value &key suggested-prefix)
 222   (check-type local-name string)
 223   (check-type uri string)
 224   (check-type value string)
 225   (check-type suggested-prefix (or null string))
 226   (setf uri (unalias-uri uri))
 227   (cond
 228     ((null *current-element*)
 229      (xslt-error "attribute outside of element"))
 230     (*start-tag-written-p*
 231      (xslt-cerror "attribute after start tag"))
 232     ((equal local-name "xmlns")
 233      (xslt-error "attribute named xmlns"))
 234     (t
 235      (setf (sink-element-attributes *current-element*)
 236            (cons (make-sink-attribute :local-name local-name
 237                                       :uri uri
 238                                       :suggested-prefix suggested-prefix
 239                                       :value value)
 240                  (delete-if (lambda (x)
 241                               (and (equal (sink-attribute-local-name x)
 242                                           local-name)
 243                                    (equal (sink-attribute-uri x) uri)))
 244                             (sink-element-attributes *current-element*)))))))
 245
 246 (defun write-extra-namespace (prefix uri)
 247   (check-type prefix string)
 248   (check-type uri string)
 249   (cond
 250     ((null *current-element*)
 251      (xslt-error "attribute outside of element"))
 252     (*start-tag-written-p*
 253      (xslt-cerror "namespace after start tag"))
 254     (t
 255      (process-extra-namespace *current-element* prefix uri))))
 256
 257 (defun write-text (data)
 258   (maybe-emit-start-tag)
 259   (sax:characters *sink* data)
 260   data)
 261
 262 (defun write-comment (data)
 263   (maybe-emit-start-tag)
 264   (sax:comment *sink* data)
 265   data)
 266
 267 (defun write-processing-instruction (target data)
 268   (maybe-emit-start-tag)
 269   (sax:processing-instruction *sink* target data)
 270   data)
 271
 272 (defun write-unescaped (str)
 273   (maybe-emit-start-tag)
 274   (sax:unescaped *sink* str))