Forwards compatible processing: Unknown instruction elements
[xuriella.git] / unparse.lisp
blob0fa324257c427abde98e688318b32b359ab11acf
1 ;;; -*- show-trailing-whitespace: t; indent-tabs-mode: nil -*-
3 ;;; Copyright (c) 2007,2008 David Lichteblau, Ivan Shvedunov.
4 ;;; Copyright (c) 2004 David Lichteblau (for headcraft.de)
5 ;;; All rights reserved.
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.
31 (in-package :xuriella)
34 ;;; Convenience functions for serialization to SAX, similar in syntax
35 ;;; to what cxml offers, but with namespace handling as required for XSLT.
37 (defvar *current-element*)
38 (defvar *sink*)
39 (defvar *start-tag-written-p*)
41 (defmacro with-xml-output (sink &body body)
42 `(invoke-with-xml-output (lambda () ,@body) ,sink))
44 (defmacro with-output-sink-bound ((var) &body body)
45 `(invoke-with-output-sink-bound (lambda (,var) ,@body)))
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*)))
55 (defun invoke-with-output-sink-bound (fn)
56 (maybe-emit-start-tag)
57 (funcall fn *sink*))
59 (defmacro with-element
60 ((local-name uri &key suggested-prefix extra-namespaces process-aliases)
61 &body body)
62 `(invoke-with-element (lambda () ,@body)
63 ,local-name
64 ,uri
65 :suggested-prefix ,suggested-prefix
66 :extra-namespaces ,extra-namespaces
67 :process-aliases ,process-aliases))
69 (defun doctype (name public-id system-id &optional internal-subset)
70 (sax:start-dtd *sink* name public-id system-id)
71 (when internal-subset
72 (sax:unparsed-internal-subset *sink* internal-subset))
73 (sax:end-dtd *sink*))
75 (defun maybe-emit-start-tag ()
76 (let ((elt *current-element*))
77 (when (and elt (not *start-tag-written-p*))
78 (setf *start-tag-written-p* t)
79 (let* ((local-name (sink-element-local-name elt))
80 (uri (sink-element-uri elt))
81 (suggested-prefix (sink-element-suggested-prefix elt))
82 (prefix (ensure-prefix-for-uri elt uri suggested-prefix))
83 (qname (if (plusp (length prefix))
84 (concatenate 'string prefix ":" local-name)
85 local-name))
86 (attrs '()))
87 (setf (sink-element-actual-qname elt) qname)
88 (dolist (attr (sink-element-attributes elt))
89 (push (convert-attribute elt attr) attrs))
90 (loop
91 for (prefix . uri) in (sink-element-new-namespaces elt) do
92 (sax:start-prefix-mapping *sink* prefix uri)
93 (push (make-xmlns-attribute prefix uri) attrs))
94 (sax:start-element *sink* uri local-name qname attrs)))))
96 (defun convert-attribute (elt attr)
97 (let* ((local-name (sink-attribute-local-name attr))
98 (uri (sink-attribute-uri attr))
99 (suggested-prefix (sink-attribute-suggested-prefix attr))
100 (prefix (ensure-prefix-for-uri elt uri suggested-prefix t))
101 (qname (if (plusp (length prefix))
102 (concatenate 'string prefix ":" local-name)
103 local-name)))
104 (sax:make-attribute :namespace-uri uri
105 :local-name local-name
106 :qname qname
107 :value (sink-attribute-value attr))))
109 (defun sink-element-find-uri (prefix elt)
110 (assert prefix)
111 (cdr
112 (find prefix
113 (sink-element-all-namespaces elt)
114 :key #'car
115 :test #'equal)))
117 (defun ensure-prefix-for-uri (elt uri suggested-prefix &optional attributep)
118 (check-type uri string)
119 (setf suggested-prefix (or suggested-prefix "")) ;zzz
120 (when (or (equal suggested-prefix "xmlns")
121 (equal suggested-prefix "xml"))
122 (setf suggested-prefix nil))
123 (let* ((prefix-cons
124 (find uri
125 (sink-element-all-namespaces elt)
126 :key #'cdr
127 :test #'equal))
128 (prefix (car prefix-cons))
129 (cross-check
130 (when prefix-cons
131 (sink-element-find-uri prefix elt))))
132 (cond
133 ((equal uri "")
134 (unless (or attributep
135 (equal (sink-element-find-uri "" elt) ""))
136 (push-sink-element-namespace elt "" ""))
138 ((and (or (plusp (length suggested-prefix))
139 (not attributep))
140 (not (find suggested-prefix
141 (sink-element-new-namespaces elt)
142 :key #'car
143 :test #'equal))
144 (not (find suggested-prefix
145 (sink-element-used-prefixes elt)
146 :test #'equal)))
147 (push-sink-element-namespace elt suggested-prefix uri)
148 suggested-prefix)
149 ((and prefix-cons
150 (equal cross-check uri)
151 (or (plusp (length prefix))
152 (not attributep)))
153 (pushnew prefix (sink-element-used-prefixes elt) :test #'equal)
154 prefix)
156 (loop
157 for i from 0
158 for prefix = (format nil "ns-~D" i)
159 while (sink-element-find-uri prefix elt)
160 finally
161 (push-sink-element-namespace elt prefix uri)
162 (return prefix))))))
164 (defun make-xmlns-attribute (prefix uri)
165 (sax:make-attribute
166 :namespace-uri #"http://www.w3.org/2000/xmlns/"
167 :local-name prefix
168 :qname (if (zerop (length prefix))
169 "xmlns"
170 (concatenate 'string "xmlns:" prefix))
171 :value uri))
173 (defstruct sink-element
174 local-name
176 suggested-prefix
177 all-namespaces
178 new-namespaces
179 used-prefixes
180 attributes
181 actual-qname)
183 (defstruct sink-attribute
184 local-name
186 suggested-prefix
187 value)
189 (defparameter *initial-namespaces*
190 '(("" . "")
191 ("xmlns" . #"http://www.w3.org/2000/xmlns/")
192 ("xml" . #"http://www.w3.org/XML/1998/namespace")))
194 (defun invoke-with-element
195 (fn local-name uri &key suggested-prefix extra-namespaces process-aliases)
196 (check-type local-name string)
197 (check-type uri string)
198 (check-type suggested-prefix (or null string))
199 (maybe-emit-start-tag)
200 (when process-aliases
201 (setf uri (unalias-uri uri)))
202 (let* ((parent *current-element*)
203 (elt (make-sink-element
204 :local-name local-name
205 :uri uri
206 :suggested-prefix suggested-prefix
207 :all-namespaces (if parent
208 (sink-element-all-namespaces parent)
209 *initial-namespaces*)
210 :new-namespaces nil
211 :attributes nil))
212 (*current-element* elt)
213 (*start-tag-written-p* nil))
214 ;; always establish explicitly copied namespaces first
215 ;; (not including declarations of the default namespace)
216 (process-extra-namespaces elt extra-namespaces process-aliases)
217 ;; establish the element's prefix (which might have to be the default
218 ;; namespace if it's the empty URI)
219 (ensure-prefix-for-uri elt uri suggested-prefix)
220 ;; we'll do attributes incrementally
221 (multiple-value-prog1
222 (funcall fn)
223 (maybe-emit-start-tag)
224 (sax:end-element *sink* uri local-name (sink-element-actual-qname elt))
225 (loop
226 for (prefix . uri) in (sink-element-new-namespaces elt) do
227 (sax:end-prefix-mapping *sink* prefix)))))
229 (defun process-extra-namespace (elt prefix uri process-aliases)
230 (when process-aliases
231 (setf uri (unalias-uri uri)))
232 (unless
234 ;; don't touch the empty prefix, since we might need it for the empty
235 ;; URI
236 (zerop (length prefix))
237 ;; don't touch the empty URI
238 (zerop (length uri))
239 ;; allow earlier conses in extra-namespaces to hide later ones.
240 ;; FIXME: add a good explanation here why we need to do this both
241 ;; here and in remove-extra-namespaces.
242 (find prefix
243 (sink-element-new-namespaces elt)
244 :key #'car
245 :test #'equal))
246 (let ((previous (sink-element-find-uri prefix elt)))
247 (if (equal uri previous) ;no need to declare what has already been done
248 (pushnew prefix (sink-element-used-prefixes elt) :test #'equal)
249 (push-sink-element-namespace elt prefix uri)))))
251 (defun process-extra-namespaces (elt extra-namespaces process-aliases)
252 (loop for (prefix . uri) in extra-namespaces do
253 (process-extra-namespace elt prefix uri process-aliases)))
255 (defun push-sink-element-namespace (elt prefix uri)
256 (assert prefix)
257 (cond
258 ((equal prefix "xml")
259 (assert (equal uri "http://www.w3.org/XML/1998/namespace")))
260 ((equal prefix "xmlns")
261 (assert (equal uri "http://www.w3.org/2000/xmlns/")))
263 (let ((cons (cons prefix uri)))
264 (push cons (sink-element-all-namespaces elt))
265 (push cons (sink-element-new-namespaces elt))))))
267 (defun write-attribute
268 (local-name uri value &key suggested-prefix process-aliases)
269 (check-type local-name string)
270 (check-type uri string)
271 (check-type value string)
272 (check-type suggested-prefix (or null string))
273 (when process-aliases
274 (setf uri (unalias-uri uri)))
275 (cond
276 ((null *current-element*)
277 (xslt-cerror "attribute outside of element"))
278 (*start-tag-written-p*
279 (xslt-cerror "attribute after start tag"))
280 ((equal local-name "xmlns")
281 (xslt-error "attribute named xmlns"))
283 (setf (sink-element-attributes *current-element*)
284 (cons (make-sink-attribute :local-name local-name
285 :uri uri
286 :suggested-prefix suggested-prefix
287 :value value)
288 (delete-if (lambda (x)
289 (and (equal (sink-attribute-local-name x)
290 local-name)
291 (equal (sink-attribute-uri x) uri)))
292 (sink-element-attributes *current-element*)))))))
294 (defun write-extra-namespace (prefix uri process-aliases)
295 (check-type prefix string)
296 (check-type uri string)
297 (cond
298 ((null *current-element*)
299 (xslt-error "attribute outside of element"))
300 (*start-tag-written-p*
301 (xslt-cerror "namespace after start tag"))
302 ((zerop (length prefix))
303 (xslt-cerror "refusing to copy declaration for default namespace"))
305 (process-extra-namespace *current-element* prefix uri process-aliases))))
307 (defun write-text (data)
308 (maybe-emit-start-tag)
309 (sax:characters *sink* data)
310 data)
312 (defun write-comment (data)
313 (maybe-emit-start-tag)
314 (setf data (cl-ppcre:regex-replace-all "--" data "- -"))
315 (setf data (cl-ppcre:regex-replace "-$" data "- "))
316 (sax:comment *sink* data)
317 data)
319 (defun write-processing-instruction (target data)
320 (maybe-emit-start-tag)
321 (setf data (cl-ppcre:regex-replace-all "[?]>" data "? >"))
322 (sax:processing-instruction *sink* target data)
323 data)
325 (defun write-unescaped (str)
326 (maybe-emit-start-tag)
327 (sax:unescaped *sink* str))