1 ;;; -*- show-trailing-whitespace: t; indent-tabs-mode: nil -*-
3 ;;; Copyright (c) 2007,2008 David Lichteblau, Ivan Shvedunov.
4 ;;; All rights reserved.
6 ;;; Redistribution and use in source and binary forms, with or without
7 ;;; modification, are permitted provided that the following conditions
10 ;;; * Redistributions of source code must retain the above copyright
11 ;;; notice, this list of conditions and the following disclaimer.
13 ;;; * Redistributions in binary form must reproduce the above
14 ;;; copyright notice, this list of conditions and the following
15 ;;; disclaimer in the documentation and/or other materials
16 ;;; provided with the distribution.
18 ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
19 ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
20 ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
21 ;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
22 ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
23 ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
24 ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
25 ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
26 ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
27 ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
28 ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
30 (in-package :xuriella
)
32 (defun map-namespace-declarations (fn element
&optional include-redeclared
)
33 (let ((parent (stp:parent element
)))
34 (maphash (lambda (prefix uri
)
35 (unless (and (not include-redeclared
)
36 (typep parent
'stp
:element
)
37 (equal (stp:find-namespace prefix parent
) uri
))
38 (funcall fn prefix uri
)))
39 (cxml-stp-impl::collect-local-namespaces element
))))
41 (defun maybe-wrap-namespaces (child exprs
)
42 (if (typep child
'stp
:element
)
45 (map-namespace-declarations (lambda (prefix uri
)
46 (push (list prefix uri
) bindings
))
48 (stp:with-attributes
((erp "exclude-result-prefixes" *xsl
*))
50 (dolist (prefix (words (or erp
"")))
51 (when (equal prefix
"#default")
53 (push (or (stp:find-namespace prefix child
)
54 (xslt-error "namespace not found: ~A" prefix
))
56 (if (or bindings excluded-uris
)
57 `((xsl:with-namespaces
,bindings
58 (xsl:with-excluded-namespaces
,excluded-uris
63 (defun parse-body (node &optional
(start 0) (param-names '()))
64 "@arg[node]{A node representing part of a stylesheet.}
65 @arg[start]{An optional integer, defaulting to 0.}
66 @arg[param-names]{Undocumented.}
67 @return{An list of XSLT instructions in sexp syntax}
69 @short{Parses the children of an XSLT instruction.}
71 This function is for use in XSLT extensions. When defining an
72 extension using @fun{define-extension-parser}, it can be used
73 to parse the children of the extension node using regular XSLT syntax
76 Specify @code{start} to skip the first @code{start} child nodes."
77 (let ((n (stp:count-children-if
#'identity node
)))
80 (let ((child (stp:nth-child i node
)))
81 (if (namep child
"variable")
82 (maybe-wrap-namespaces
84 (only-with-attributes (name select
) child
85 (when (and select
(stp:list-children child
))
86 (xslt-error "variable with select and body"))
87 `((let ((,name
,(or select
88 `(progn ,@(parse-body child
)))))
89 (xsl:with-duplicates-check
(,name
)
90 ,@(recurse (1+ i
)))))))
91 (append (maybe-wrap-namespaces
93 (list (parse-instruction child
)))
94 (recurse (1+ i
))))))))
95 (let ((result (recurse start
)))
97 `((xsl:with-duplicates-check
(,@param-names
)
101 (defun parse-param (node)
102 ;; FIXME: empty body?
103 (only-with-attributes (name select
) node
105 (xslt-error "name not specified for parameter"))
106 (when (and select
(stp:list-children node
))
107 (xslt-error "param with select and body"))
110 `(progn ,@(parse-body node
))))))
112 (defun parse-instruction (node)
117 ((equal (stp:namespace-uri node
) *xsl
*)
118 (let ((sym (find-symbol (stp:local-name node
) :xuriella
)))
121 (parse-instruction/xsl-element sym node
))
122 (*forwards-compatible-p
*
123 (parse-fallback-children node
))
125 (xslt-error "undefined instruction: ~A"
126 (stp:local-name node
))))))
127 ((find (stp:namespace-uri node
)
128 *extension-namespaces
*
130 (let ((extension (find-extension-element
131 (stp:local-name node
)
132 (stp:namespace-uri node
))))
134 (funcall (extension-element-parser extension
) node
)
135 (parse-fallback-children node
))))
137 (parse-instruction/literal-element node
))))
138 (parent (stp:parent node
)))
139 (if (and (equal (stp:base-uri node
) (stp:base-uri parent
))
140 (equal (stp:namespace-uri parent
) *xsl
*)
141 (find-symbol (stp:local-name parent
) :xuriella
))
143 `(xsl:with-base-uri
,(stp:base-uri node
)
146 `(xsl:text
,(stp:data node
)))))
148 (defun parse-instruction/literal-element
(node)
149 (let ((extensions '()))
150 (stp:with-attributes
((eep "extension-element-prefixes" *xsl
*))
152 (dolist (prefix (words (or eep
"")))
153 (when (equal prefix
"#default")
155 (push (or (stp:find-namespace prefix node
)
156 (xslt-error "namespace not found: ~A" prefix
))
158 (if (find (stp:namespace-uri node
) extensions
:test
#'equal
)
159 ;; oops, this isn't a literal result element after all
160 (parse-fallback-children node
)
162 `(xsl:literal-element
163 (,(stp:local-name node
)
164 ,(stp:namespace-uri node
)
165 ,(stp:namespace-prefix node
))
166 (xsl:use-attribute-sets
167 ,(stp:attribute-value node
"use-attribute-sets" *xsl
*))
169 for a in
(stp:list-attributes node
)
170 for xslp
= (equal (stp:namespace-uri a
) *xsl
*)
172 do
(unless (find (stp:local-name a
)
174 "extension-element-prefixes"
175 "exclude-result-prefixes"
176 "use-attribute-sets")
179 "unknown attribute on literal result element: ~A"
182 collect
`(xsl:literal-attribute
184 ,(stp:namespace-uri a
)
185 ,(stp:namespace-prefix a
))
187 ,@ (let ((*extension-namespaces
*
188 (append extensions
*extension-namespaces
*)))
190 (version (stp:attribute-value node
"version" *xsl
*)))
193 `(xsl:with-extension-namespaces
,extensions
194 (xsl:with-excluded-namespaces
,extensions
198 `(xsl:with-version
,version
202 (defun parse-fallback-children (node)
205 for fallback in
(stp:filter-children
(of-name "fallback") node
)
206 do
(only-with-attributes () fallback
)
207 append
(parse-body fallback
))))
212 ,(format nil
"no fallback children in unknown element ~A/~A using forwards compatible processing"
213 (stp:local-name node
)
214 (stp:namespace-uri node
)))))))
216 (defmacro define-instruction-parser
(name (node-var) &body body
)
218 (setf (gethash ,(symbol-name name
) *builtin-instructions
*) t
)
219 (defmethod parse-instruction/xsl-element
220 ((.name.
(eql ',name
)) ,node-var
)
221 (declare (ignore .name.
))
224 (define-instruction-parser |fallback|
(node)
225 (only-with-attributes () node
228 (define-instruction-parser |apply-templates|
(node)
229 (only-with-attributes (select mode
) node
230 (multiple-value-bind (decls rest
)
233 for cons on
(stp:filter-children
235 (or (typep node
'stp
:element
)
236 (xslt-error "non-element in apply-templates")))
238 for
(child . nil
) = cons
239 while
(namep child
"sort")
240 collect
(parse-sort child
) into decls
241 finally
(return (values decls cons
)))
242 `(xsl:apply-templates
243 (:select
,select
:mode
,mode
)
245 ,@(mapcar (lambda (clause)
246 (unless (namep clause
"with-param")
247 (xslt-error "undefined instruction: ~A"
248 (stp:local-name clause
)))
249 (parse-param clause
))
252 (define-instruction-parser |apply-imports|
(node)
253 (only-with-attributes () node
)
254 (assert-no-body node
)
255 `(xsl:apply-imports
))
257 (define-instruction-parser |call-template|
(node)
258 (only-with-attributes (name) node
260 ,name
,@(stp:map-children
'list
262 (if (namep clause
"with-param")
264 (xslt-error "undefined instruction: ~A"
265 (stp:local-name clause
))))
268 (define-instruction-parser |if|
(node)
269 (only-with-attributes (test) node
271 ,@(parse-body node
))))
273 (define-instruction-parser |choose|
(node)
276 (only-with-attributes () node
278 ,@(stp:map-children
'list
281 ((namep clause
"when")
283 (only-with-attributes (test) clause
285 ,@(parse-body clause
))))
286 ((namep clause
"otherwise")
287 `(t ,@(parse-body clause
)))
289 (xslt-error "invalid <choose> clause: ~A"
290 (stp:local-name clause
)))))
293 (xslt-error "<choose> without <when>")))))
295 (define-instruction-parser |element|
(node)
296 (only-with-attributes (name namespace use-attribute-sets
) node
297 `(xsl:element
(,name
:namespace
,namespace
)
298 (xsl:use-attribute-sets
,use-attribute-sets
)
299 ,@(parse-body node
))))
301 (define-instruction-parser |attribute|
(node)
302 (only-with-attributes (name namespace
) node
303 `(xsl:attribute
(,name
:namespace
,namespace
)
304 ,@(parse-body node
))))
306 (defun boolean-or-error (str)
310 ((or (null str
) (equal str
"no"))
313 (xslt-error "not a boolean: ~A" str
))))
315 (define-instruction-parser |text|
(node)
316 (only-with-attributes (select disable-output-escaping
) node
317 (when (xpath:evaluate
"boolean(*)" node
)
318 (xslt-error "non-text found in xsl:text"))
319 (if (boolean-or-error disable-output-escaping
)
320 `(xsl:unescaped-text
,(stp:string-value node
))
321 `(xsl:text
,(stp:string-value node
)))))
323 (define-instruction-parser |comment|
(node)
324 (only-with-attributes () node
325 `(xsl:comment
,@(parse-body node
))))
327 (define-instruction-parser |processing-instruction|
(node)
328 (only-with-attributes (name) node
329 `(xsl:processing-instruction
,name
330 ,@(parse-body node
))))
332 (defun assert-no-body (node)
333 (when (stp:list-children node
)
334 (xslt-error "no child nodes expected in ~A" (stp:local-name node
))))
336 (define-instruction-parser |value-of|
(node)
337 (only-with-attributes (select disable-output-escaping
) node
338 (assert-no-body node
)
339 (if (boolean-or-error disable-output-escaping
)
340 `(xsl:unescaped-value-of
,select
)
341 `(xsl:value-of
,select
))))
343 (define-instruction-parser |copy-of|
(node)
344 (only-with-attributes (select) node
345 (assert-no-body node
)
346 `(xsl:copy-of
,select
)))
348 (define-instruction-parser |copy|
(node)
349 (only-with-attributes (use-attribute-sets) node
351 (xsl:use-attribute-sets
,use-attribute-sets
)
352 ,@(parse-body node
))))
354 (define-instruction-parser |variable|
(node)
355 (xslt-error "unhandled xsl:variable"))
357 (define-instruction-parser |for-each|
(node)
358 (only-with-attributes (select) node
359 (multiple-value-bind (decls body-position
)
362 for child in
(stp:list-children node
)
363 while
(namep child
"sort")
364 collect
(parse-sort child
) into decls
365 finally
(return (values decls i
)))
366 `(xsl:for-each
,select
368 ,@(parse-body node body-position
)))))
370 (defun parse-sort (node)
371 (only-with-attributes (select lang data-type order case-order
) node
372 (assert-no-body node
)
373 `(sort :select
,select
375 :data-type
,data-type
377 :case-order
,case-order
)))
379 (define-instruction-parser |message|
(node)
380 (only-with-attributes (terminate) node
381 (if (boolean-or-error terminate
)
382 `(xsl:terminate
,@(parse-body node
))
383 `(xsl:message
,@(parse-body node
)))))
385 (define-instruction-parser |number|
(node)
386 (only-with-attributes (level count from value format lang letter-value
387 grouping-separator grouping-size
)
389 (assert-no-body node
)
390 `(xsl:number
:level
,level
396 :letter-value
,letter-value
397 :grouping-separator
,grouping-separator
398 :grouping-size
,grouping-size
)))