Check included attribute sets at compile time like saxon
[xuriella.git] / unparse.lisp
blob67e826907ccc860638f2ae3b8683a6c1be0042bf
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 ""))
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 unalias-attribute-uri (uri)
195 (if (zerop (length uri))
197 (unalias-uri uri)))
199 (defun invoke-with-element
200 (fn local-name uri &key suggested-prefix extra-namespaces process-aliases)
201 (check-type local-name string)
202 (check-type uri string)
203 (check-type suggested-prefix (or null string))
204 (maybe-emit-start-tag)
205 (when process-aliases
206 (setf uri (unalias-uri uri)))
207 (let* ((parent *current-element*)
208 (elt (make-sink-element
209 :local-name local-name
210 :uri uri
211 :suggested-prefix suggested-prefix
212 :all-namespaces (if parent
213 (sink-element-all-namespaces parent)
214 *initial-namespaces*)
215 :new-namespaces nil
216 :attributes nil))
217 (*current-element* elt)
218 (*start-tag-written-p* nil))
219 ;; always establish explicitly copied namespaces first
220 ;; (not including declarations of the default namespace)
221 (process-extra-namespaces elt extra-namespaces process-aliases)
222 ;; establish the element's prefix (which might have to be the default
223 ;; namespace if it's the empty URI)
224 (ensure-prefix-for-uri elt uri suggested-prefix)
225 ;; we'll do attributes incrementally
226 (multiple-value-prog1
227 (funcall fn)
228 (maybe-emit-start-tag)
229 (sax:end-element *sink* uri local-name (sink-element-actual-qname elt))
230 (loop
231 for (prefix . uri) in (sink-element-new-namespaces elt) do
232 (sax:end-prefix-mapping *sink* prefix)))))
234 (defun process-extra-namespace (elt prefix uri process-aliases)
235 (when process-aliases
236 (setf uri (unalias-uri uri)))
237 (unless
239 ;; don't touch the empty prefix, since we might need it for the empty
240 ;; URI
241 (zerop (length prefix))
242 ;; don't touch the empty URI
243 (zerop (length uri))
244 ;; allow earlier conses in extra-namespaces to hide later ones.
245 ;; FIXME: add a good explanation here why we need to do this both
246 ;; here and in remove-extra-namespaces.
247 (find prefix
248 (sink-element-new-namespaces elt)
249 :key #'car
250 :test #'equal))
251 (let ((previous (sink-element-find-uri prefix elt)))
252 (if (equal uri previous) ;no need to declare what has already been done
253 (pushnew prefix (sink-element-used-prefixes elt) :test #'equal)
254 (push-sink-element-namespace elt prefix uri)))))
256 (defun process-extra-namespaces (elt extra-namespaces process-aliases)
257 (loop for (prefix . uri) in extra-namespaces do
258 (process-extra-namespace elt prefix uri process-aliases)))
260 (defun push-sink-element-namespace (elt prefix uri)
261 (assert prefix)
262 (cond
263 ((equal prefix "xml")
264 (assert (equal uri "http://www.w3.org/XML/1998/namespace")))
265 ((equal prefix "xmlns")
266 (assert (equal uri "http://www.w3.org/2000/xmlns/")))
268 (let ((cons (cons prefix uri)))
269 (push cons (sink-element-all-namespaces elt))
270 (push cons (sink-element-new-namespaces elt))))))
272 (defun write-attribute
273 (local-name uri value &key suggested-prefix process-aliases)
274 (check-type local-name string)
275 (check-type uri string)
276 (check-type value string)
277 (check-type suggested-prefix (or null string))
278 (when process-aliases
279 (setf uri (unalias-attribute-uri uri)))
280 (cond
281 ((null *current-element*)
282 (xslt-cerror "attribute outside of element"))
283 (*start-tag-written-p*
284 (xslt-cerror "attribute after start tag"))
285 ((and (equal local-name "xmlns") (equal uri ""))
286 (xslt-error "attribute named xmlns"))
288 (setf (sink-element-attributes *current-element*)
289 (cons (make-sink-attribute :local-name local-name
290 :uri uri
291 :suggested-prefix suggested-prefix
292 :value value)
293 (delete-if (lambda (x)
294 (and (equal (sink-attribute-local-name x)
295 local-name)
296 (equal (sink-attribute-uri x) uri)))
297 (sink-element-attributes *current-element*)))))))
299 (defun write-extra-namespace (prefix uri process-aliases)
300 (check-type prefix string)
301 (check-type uri string)
302 (cond
303 ((null *current-element*)
304 (xslt-error "attribute outside of element"))
305 (*start-tag-written-p*
306 (xslt-cerror "namespace after start tag"))
307 ((zerop (length prefix))
308 (xslt-cerror "refusing to copy declaration for default namespace"))
310 (process-extra-namespace *current-element* prefix uri process-aliases))))
312 (defun write-text (data)
313 (maybe-emit-start-tag)
314 (sax:characters *sink* data)
315 data)
317 (defun write-comment (data)
318 (maybe-emit-start-tag)
319 (setf data (cl-ppcre:regex-replace-all "--" data "- -"))
320 (setf data (cl-ppcre:regex-replace "-$" data "- "))
321 (sax:comment *sink* data)
322 data)
324 (defun nc-name-p (str)
325 (and (and (not (zerop (length str)))
326 (cxml::name-start-rune-p (elt str 0))
327 (every #'cxml::name-rune-p str))
328 (cxml::nc-name-p str)))
330 (defun write-processing-instruction (target data)
331 (maybe-emit-start-tag)
332 (setf data (cl-ppcre:regex-replace-all "[?]>" data "? >"))
333 (unless (nc-name-p target)
334 (xslt-error "PI target not an NCName: ~A" target))
335 (sax:processing-instruction *sink* target data)
336 data)
338 (defun write-unescaped (str)
339 (maybe-emit-start-tag)
340 (sax:unescaped *sink* str))