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 defun/unparse (name (&rest args) &body body)
  60   `(defun ,name ,args
  61      (with-profile-counter (*unparse-xml-counter*)
  62        (let ((*unparse-xml-counter* nil))
  63          ,@body))))
  64
  65 (defmacro with-element
  66     ((local-name uri &key suggested-prefix extra-namespaces process-aliases)
  67      &body body)
  68   `(invoke-with-element (lambda () ,@body)
  69                         ,local-name
  70                         ,uri
  71                         :suggested-prefix ,suggested-prefix
  72                         :extra-namespaces ,extra-namespaces
  73                         :process-aliases ,process-aliases))
  74
  75 (defun/unparse doctype (name public-id system-id &optional internal-subset)
  76   (sax:start-dtd *sink* name public-id system-id)
  77   (when internal-subset
  78     (sax:unparsed-internal-subset *sink* internal-subset))
  79   (sax:end-dtd *sink*))
  80
  81 (defun maybe-emit-start-tag ()
  82   (let ((elt *current-element*))
  83     (when (and elt (not *start-tag-written-p*))
  84       (setf *start-tag-written-p* t)
  85       (let* ((local-name (sink-element-local-name elt))
  86              (uri (sink-element-uri elt))
  87              (suggested-prefix (sink-element-suggested-prefix elt))
  88              (prefix (ensure-prefix-for-uri elt uri suggested-prefix))
  89              (qname (if (plusp (length prefix))
  90                         (concatenate 'string prefix ":" local-name)
  91                         local-name))
  92              (attrs '()))
  93         (setf (sink-element-actual-qname elt) qname)
  94         (dolist (attr (sink-element-attributes elt))
  95           (push (convert-attribute elt attr) attrs))
  96         (loop
  97            for (prefix . uri) in (sink-element-new-namespaces elt) do
  98              (sax:start-prefix-mapping *sink* prefix uri)
  99              (push (make-xmlns-attribute prefix uri) attrs))
 100         (sax:start-element *sink* uri local-name qname attrs)))))
 101
 102 (defun convert-attribute (elt attr)
 103   (let* ((local-name (sink-attribute-local-name attr))
 104          (uri (sink-attribute-uri attr))
 105          (suggested-prefix (sink-attribute-suggested-prefix attr))
 106          (prefix (ensure-prefix-for-uri elt uri suggested-prefix t))
 107          (qname (if (plusp (length prefix))
 108                     (concatenate 'string prefix ":" local-name)
 109                     local-name)))
 110     (sax:make-attribute :namespace-uri uri
 111                         :local-name local-name
 112                         :qname qname
 113                         :value (sink-attribute-value attr))))
 114
 115 (defun sink-element-find-uri (prefix elt)
 116   (assert prefix)
 117   (cdr
 118    (find prefix
 119          (sink-element-all-namespaces elt)
 120          :key #'car
 121          :test #'equal)))
 122
 123 (defun ensure-prefix-for-uri (elt uri suggested-prefix &optional attributep)
 124   (check-type uri string)
 125   (setf suggested-prefix (or suggested-prefix "")) ;zzz
 126   (when (or (equal suggested-prefix "xmlns")
 127             (equal suggested-prefix "xml"))
 128     (setf suggested-prefix ""))
 129   (let* ((prefix-cons
 130           (find uri
 131                 (sink-element-all-namespaces elt)
 132                 :key #'cdr
 133                 :test #'equal))
 134          (prefix (car prefix-cons))
 135          (cross-check
 136           (when prefix-cons
 137             (sink-element-find-uri prefix elt))))
 138     (cond
 139       ((equal uri "")
 140        (unless (or attributep
 141                    (equal (sink-element-find-uri "" elt) ""))
 142          (push-sink-element-namespace elt "" ""))
 143        "")
 144       ((and (or (plusp (length suggested-prefix))
 145                 (not attributep))
 146             (not (find suggested-prefix
 147                        (sink-element-new-namespaces elt)
 148                        :key #'car
 149                        :test #'equal))
 150             (not (find suggested-prefix
 151                        (sink-element-used-prefixes elt)
 152                        :test #'equal)))
 153        (push-sink-element-namespace elt suggested-prefix uri)
 154        suggested-prefix)
 155       ((and prefix-cons
 156             (equal cross-check uri)
 157             (or (plusp (length prefix))
 158                 (not attributep)))
 159        (pushnew prefix (sink-element-used-prefixes elt) :test #'equal)
 160        prefix)
 161       (t
 162        (loop
 163            for i from 0
 164            for prefix = (format nil "ns-~D" i)
 165            while (sink-element-find-uri prefix elt)
 166            finally
 167              (push-sink-element-namespace elt prefix uri)
 168              (return prefix))))))
 169
 170 (defun make-xmlns-attribute (prefix uri)
 171   (sax:make-attribute
 172    :namespace-uri #"http://www.w3.org/2000/xmlns/"
 173    :local-name prefix
 174    :qname (if (zerop (length prefix))
 175               "xmlns"
 176               (concatenate 'string "xmlns:" prefix))
 177    :value uri))
 178
 179 (defstruct sink-element
 180   local-name
 181   uri
 182   suggested-prefix
 183   all-namespaces
 184   new-namespaces
 185   used-prefixes
 186   attributes
 187   actual-qname)
 188
 189 (defstruct sink-attribute
 190   local-name
 191   uri
 192   suggested-prefix
 193   value)
 194
 195 (defparameter *initial-unparse-namespaces*
 196   '(("" . "")
 197     ("xmlns" . #"http://www.w3.org/2000/xmlns/")
 198     ("xml" . #"http://www.w3.org/XML/1998/namespace")))
 199
 200 (defun unalias-attribute-uri (uri)
 201   (if (zerop (length uri))
 202       uri
 203       (unalias-uri uri)))
 204
 205 (defun invoke-with-element
 206     (fn local-name uri &key suggested-prefix extra-namespaces process-aliases)
 207   ;; fixme: don't litter this function with calls to with-profile-counter
 208   (with-profile-counter (*unparse-xml-counter*)
 209     (check-type local-name string)
 210     (check-type uri string)
 211     (check-type suggested-prefix (or null string))
 212     (maybe-emit-start-tag)
 213     (when process-aliases
 214       (setf uri (unalias-uri uri))))
 215   (let* ((parent *current-element*)
 216          (elt (make-sink-element
 217                :local-name local-name
 218                :uri uri
 219                :suggested-prefix suggested-prefix
 220                :all-namespaces (if parent
 221                                    (sink-element-all-namespaces parent)
 222                                    *initial-unparse-namespaces*)
 223                :new-namespaces nil
 224                :attributes nil))
 225          (*current-element* elt)
 226          (*start-tag-written-p* nil))
 227     (with-profile-counter (*unparse-xml-counter*)
 228       ;; always establish explicitly copied namespaces first
 229       ;; (not including declarations of the default namespace)
 230       (process-extra-namespaces elt extra-namespaces process-aliases)
 231       ;; establish the element's prefix (which might have to be the default
 232       ;; namespace if it's the empty URI)
 233       (ensure-prefix-for-uri elt uri suggested-prefix))
 234     ;; we'll do attributes incrementally
 235     (multiple-value-prog1
 236         (funcall fn)
 237       (with-profile-counter (*unparse-xml-counter*)
 238         (maybe-emit-start-tag)
 239         (sax:end-element *sink* uri local-name (sink-element-actual-qname elt))
 240         (loop
 241            for (prefix . uri) in (sink-element-new-namespaces elt) do
 242            (sax:end-prefix-mapping *sink* prefix))))))
 243
 244 (defun process-extra-namespace (elt prefix uri process-aliases)
 245   (when process-aliases
 246     (setf uri (unalias-uri uri)))
 247   (unless
 248       (or
 249        ;; don't touch the empty prefix, since we might need it for the empty
 250        ;; URI
 251        (zerop (length prefix))
 252        ;; don't touch the empty URI
 253        (zerop (length uri))
 254        ;; allow earlier conses in extra-namespaces to hide later ones.
 255        ;; FIXME: add a good explanation here why we need to do this both
 256        ;; here and in remove-extra-namespaces.
 257        (find prefix
 258              (sink-element-new-namespaces elt)
 259              :key #'car
 260              :test #'equal))
 261     (let ((previous (sink-element-find-uri prefix elt)))
 262       (if (equal uri previous) ;no need to declare what has already been done
 263           (pushnew prefix (sink-element-used-prefixes elt) :test #'equal)
 264           (push-sink-element-namespace elt prefix uri)))))
 265
 266 (defun process-extra-namespaces (elt extra-namespaces process-aliases)
 267   (loop for (prefix . uri) in extra-namespaces do
 268        (process-extra-namespace elt prefix uri process-aliases)))
 269
 270 (defun push-sink-element-namespace (elt prefix uri)
 271   (assert prefix)
 272   (cond
 273     ((equal prefix "xml")
 274      (assert (equal uri "http://www.w3.org/XML/1998/namespace")))
 275     ((equal prefix "xmlns")
 276      (assert (equal uri "http://www.w3.org/2000/xmlns/")))
 277     (t
 278      (let ((cons (cons prefix uri)))
 279        (push cons (sink-element-all-namespaces elt))
 280        (push cons (sink-element-new-namespaces elt))))))
 281
 282 (defun/unparse write-attribute
 283     (local-name uri value &key suggested-prefix process-aliases)
 284   (check-type local-name string)
 285   (check-type uri string)
 286   (check-type value string)
 287   (check-type suggested-prefix (or null string))
 288   (when process-aliases
 289     (setf uri (unalias-attribute-uri uri)))
 290   (cond
 291     ((null *current-element*)
 292      (xslt-cerror "attribute outside of element"))
 293     (*start-tag-written-p*
 294      (xslt-cerror "attribute after start tag"))
 295     ((and (equal local-name "xmlns") (equal uri ""))
 296      (xslt-error "attribute named xmlns"))
 297     (t
 298      (setf (sink-element-attributes *current-element*)
 299            (cons (make-sink-attribute :local-name local-name
 300                                       :uri uri
 301                                       :suggested-prefix suggested-prefix
 302                                       :value value)
 303                  (delete-if (lambda (x)
 304                               (and (equal (sink-attribute-local-name x)
 305                                           local-name)
 306                                    (equal (sink-attribute-uri x) uri)))
 307                             (sink-element-attributes *current-element*)))))))
 308
 309 (defun/unparse write-extra-namespace (prefix uri process-aliases)
 310   (check-type prefix string)
 311   (check-type uri string)
 312   (cond
 313     ((null *current-element*)
 314      (xslt-error "attribute outside of element"))
 315     (*start-tag-written-p*
 316      (xslt-cerror "namespace after start tag"))
 317     ((zerop (length prefix))
 318      (xslt-cerror "refusing to copy declaration for default namespace"))
 319     (t
 320      (process-extra-namespace *current-element* prefix uri process-aliases))))
 321
 322 (defun/unparse write-text (data)
 323   (maybe-emit-start-tag)
 324   (sax:characters *sink* data)
 325   data)
 326
 327 (defun/unparse write-comment (data)
 328   (maybe-emit-start-tag)
 329   ;; kludge: rewrite this in a nicer way
 330   (setf data (cl-ppcre:regex-replace-all "--" data "- -"))
 331   (setf data (cl-ppcre:regex-replace-all "--" data "- -"))
 332   (setf data (cl-ppcre:regex-replace "-$" data "- "))
 333   (sax:comment *sink* data)
 334   data)
 335
 336 (defun nc-name-p (str)
 337   (and (and (not (zerop (length str)))
 338        (cxml::name-start-rune-p (elt str 0))
 339        (every #'cxml::name-rune-p str))
 340        (cxml::nc-name-p str)))
 341
 342 (defun/unparse write-processing-instruction (target data)
 343   (maybe-emit-start-tag)
 344   (setf data (cl-ppcre:regex-replace-all "[?]>" data "? >"))
 345   (cond
 346     ((nc-name-p target)
 347      (sax:processing-instruction *sink* target data))
 348     (t
 349      (xslt-cerror "PI target not an NCName: ~A" target)))
 350   data)
 351
 352 (defun/unparse write-unescaped (str)
 353   (maybe-emit-start-tag)
 354   (sax:unescaped *sink* str))