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
11 ;;; * Redistributions of source code must retain the above copyright
12 ;;; notice, this list of conditions and the following disclaimer.
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.
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
*)
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
)
49 (*current-element
* nil
)
50 (*start-tag-written-p
* t
))
51 (sax:start-document
*sink
*)
53 (sax:end-document
*sink
*)))
55 (defun invoke-with-output-sink-bound (fn)
56 (maybe-emit-start-tag)
59 (defun unalias-uri (uri)
60 (gethash uri
(stylesheet-namespace-aliases *stylesheet
*)
63 (defmacro with-element
((local-name uri
&key suggested-prefix extra-namespaces
)
65 `(invoke-with-element (lambda () ,@body
)
68 :suggested-prefix
,suggested-prefix
69 :extra-namespaces
,extra-namespaces
))
71 (defun doctype (name public-id system-id
&optional internal-subset
)
72 (sax:start-dtd
*sink
* name public-id system-id
)
74 (sax:unparsed-internal-subset
*sink
* internal-subset
))
77 (defun maybe-emit-start-tag ()
78 (let ((elt *current-element
*))
79 (when (and elt
(not *start-tag-written-p
*))
80 (setf *start-tag-written-p
* t
)
81 (let* ((local-name (sink-element-local-name elt
))
82 (uri (sink-element-uri elt
))
83 (suggested-prefix (sink-element-suggested-prefix elt
))
84 (prefix (ensure-prefix-for-uri elt uri suggested-prefix
))
85 (qname (if (plusp (length prefix
))
86 (concatenate 'string prefix
":" local-name
)
89 (setf (sink-element-actual-qname elt
) qname
)
90 (dolist (attr (sink-element-attributes elt
))
91 (push (convert-attribute elt attr
) attrs
))
93 for
(prefix . uri
) in
(sink-element-new-namespaces elt
) do
94 (sax:start-prefix-mapping
*sink
* prefix uri
)
95 (push (make-xmlns-attribute prefix uri
) attrs
))
96 (sax:start-element
*sink
* uri local-name qname attrs
)))))
98 (defun convert-attribute (elt attr
)
99 (let* ((local-name (sink-attribute-local-name attr
))
100 (uri (sink-attribute-uri attr
))
101 (suggested-prefix (sink-attribute-suggested-prefix attr
))
102 (prefix (ensure-prefix-for-uri elt uri suggested-prefix
))
103 (qname (if (plusp (length prefix
))
104 (concatenate 'string prefix
":" local-name
)
106 (sax:make-attribute
:namespace-uri uri
107 :local-name local-name
109 :value
(sink-attribute-value attr
))))
111 (defun sink-element-find-uri (prefix elt
)
114 (sink-element-all-namespaces elt
)
118 (defun ensure-prefix-for-uri (elt uri
&optional suggested-prefix
)
121 (sink-element-all-namespaces elt
)
124 (prefix (car prefix-cons
))
127 (sink-element-find-uri prefix elt
))))
128 (if (and prefix-cons
(equal cross-check uri
))
132 for prefix
= suggested-prefix then
(format nil
"ns-~D" i
)
134 (sink-element-find-uri prefix elt
)
136 (push-sink-element-namespace elt prefix uri
)
139 (defun make-xmlns-attribute (prefix uri
)
141 :namespace-uri
#"http://www.w3.org/2000/xmlns/"
143 :qname
(if (zerop (length prefix
))
145 (concatenate 'string
"xmlns:" prefix
))
148 (defstruct sink-element
157 (defstruct sink-attribute
163 (defun invoke-with-element
164 (fn local-name uri
&key suggested-prefix extra-namespaces
)
165 (check-type local-name string
)
166 (check-type uri string
)
167 (check-type suggested-prefix
(or null string
))
168 (maybe-emit-start-tag)
169 (setf uri
(unalias-uri uri
))
170 (let* ((parent *current-element
*)
171 (elt (make-sink-element
172 :local-name local-name
174 :suggested-prefix suggested-prefix
175 :all-namespaces
(if parent
176 (sink-element-all-namespaces parent
)
177 *initial-namespaces
*)
180 (*current-element
* elt
)
181 (*start-tag-written-p
* nil
))
182 (process-extra-namespaces elt extra-namespaces
)
183 (multiple-value-prog1
185 (maybe-emit-start-tag)
186 (sax:end-element
*sink
* uri local-name
(sink-element-actual-qname elt
))
188 for
(prefix . uri
) in
(sink-element-new-namespaces elt
) do
189 (sax:end-prefix-mapping
*sink
* prefix
)))))
191 (defun process-extra-namespaces (elt extra-namespaces
)
193 for
(prefix . auri
) in extra-namespaces
194 for uri
= (unalias-uri auri
)
197 ;; allow earlier conses in extra-namespaces to hide later ones.
199 (sink-element-new-namespaces elt
)
202 (let ((previous (sink-element-find-uri prefix elt
)))
204 ;; no need to declare what has already been done
206 (push-sink-element-namespace elt prefix uri
))))))
208 (defun push-sink-element-namespace (elt prefix uri
)
210 ((equal prefix
"xml")
211 (assert (equal uri
"http://www.w3.org/XML/1998/namespace")))
212 ((equal prefix
"xmlns")
213 (assert (equal uri
"http://www.w3.org/2000/xmlns/")))
215 (let ((cons (cons prefix uri
)))
216 (push cons
(sink-element-all-namespaces elt
))
217 (push cons
(sink-element-new-namespaces elt
))))))
219 (defun write-attribute (local-name uri value
&key suggested-prefix
)
220 (check-type local-name string
)
221 (check-type uri string
)
222 (check-type value string
)
223 (check-type suggested-prefix
(or null string
))
224 (setf uri
(unalias-uri uri
))
226 ((null *current-element
*)
227 (xslt-error "attribute outside of element"))
228 (*start-tag-written-p
*
229 (xslt-cerror "attribute after start tag"))
230 ((equal local-name
"xmlns")
231 (xslt-error "attribute named xmlns"))
233 (setf (sink-element-attributes *current-element
*)
234 (cons (make-sink-attribute :local-name local-name
236 :suggested-prefix suggested-prefix
238 (delete-if (lambda (x)
239 (and (equal (sink-attribute-local-name x
)
241 (equal (sink-attribute-uri x
) uri
)))
242 (sink-element-attributes *current-element
*)))))))
244 (defun write-text (data)
245 (maybe-emit-start-tag)
246 (sax:characters
*sink
* data
)
249 (defun write-comment (data)
250 (maybe-emit-start-tag)
251 (sax:comment
*sink
* data
)
254 (defun write-processing-instruction (target data
)
255 (maybe-emit-start-tag)
256 (sax:processing-instruction
*sink
* target data
)
259 (defun write-unescaped (str)
260 (maybe-emit-start-tag)
261 (sax:unescaped
*sink
* str
))