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
)
33 (declaim (optimize (debug 2)))
36 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
37 (defvar *xsl
* "http://www.w3.org/1999/XSL/Transform")
38 (defvar *xml
* "http://www.w3.org/XML/1998/namespace")
39 (defvar *html
* "http://www.w3.org/1999/xhtml"))
44 (define-condition xslt-error
(simple-error)
46 (:documentation
"The class of all XSLT errors."))
48 (define-condition recoverable-xslt-error
(xslt-error)
50 (:documentation
"The class of recoverable XSLT errors."))
52 (defun xslt-error (fmt &rest args
)
54 (error 'xslt-error
:format-control fmt
:format-arguments args
))
56 ;; Many errors in XSLT are "recoverable", with a specified action that must
57 ;; be taken if the error isn't raised. My original plan was to implement
58 ;; such issues as continuable conditions, so that users are alerted about
59 ;; portability issues with their stylesheet, but can contiue anyway.
61 ;; However, our current test suite driver compares against Saxon results,
62 ;; and Saxon recovers (nearly) always. So our coverage of these errors
63 ;; is very incomplete.
65 ;; Re-enable this code once we can check that it's actually being used
67 (defun xslt-cerror (fmt &rest args
)
68 (declare (ignore fmt args
))
70 (with-simple-restart (recover "recover")
71 (error 'recoverable-xslt-error
73 :format-arguments args
)))
77 (defmacro handler-case
* (form &rest clauses
)
78 ;; like HANDLER-CASE if *DEBUG* is off. If it's on, don't establish
79 ;; a handler at all so that we see the real stack traces. (We could use
80 ;; HANDLER-BIND here and check at signalling time, but doesn't seem
82 (let ((doit (gensym)))
83 `(flet ((,doit
() ,form
))
90 (defmacro with-resignalled-errors
((&optional
) &body body
)
91 `(invoke-with-resignalled-errors (lambda () ,@body
)))
93 (defun invoke-with-resignalled-errors (fn)
98 (babel-encodings:character-encoding-error
100 (xslt-error "~A" c
))))
103 (defmacro with-forward-compatible-errors
(error-form &body body
)
104 `(invoke-with-forward-compatible-errors (lambda () ,@body
)
105 (lambda () ,error-form
)))
107 (defvar *forwards-compatible-p
*)
109 (defun invoke-with-forward-compatible-errors (fn error-fn
)
116 (when *forwards-compatible-p
*
118 (setf result
(funcall fn
)))
121 (setf result
(funcall error-fn
))
125 (defun compile-xpath (xpath &optional env
)
126 (with-resignalled-errors ()
127 (with-forward-compatible-errors
129 (xslt-error "attempt to evaluate an XPath expression with compile-time errors, delayed due to forwards compatible processing: ~A"
131 (xpath:compile-xpath xpath env
))))
133 (defmacro with-stack-limit
((&optional
) &body body
)
134 `(invoke-with-stack-limit (lambda () ,@body
)))
136 (defparameter *without-xslt-current-p
* nil
)
138 (defmacro without-xslt-current
((&optional
) &body body
)
139 `(invoke-without-xslt-current (lambda () ,@body
)))
141 (defun invoke-without-xslt-current (fn)
142 (let ((*without-xslt-current-p
* t
))
145 ;;; (defun invoke-without-xslt-current (fn)
146 ;;; (let ((non-extensions (gethash "" xpath::*extensions*))
147 ;;; (xpath::*extensions*
148 ;;; ;; hide XSLT extensions
149 ;;; (make-hash-table :test #'equal)))
150 ;;; (setf (gethash "" xpath::*extensions*) non-extensions)
154 ;;;; Helper functions and macros
156 (defun check-for-invalid-attributes (valid-names node
)
157 (labels ((check-attribute (a)
159 (let ((uri (stp:namespace-uri a
)))
160 (or (and (plusp (length uri
)) (not (equal uri
*xsl
*)))
161 (find (cons (stp:local-name a
) uri
)
164 (xslt-error "attribute ~A not allowed on ~A"
166 (stp:local-name node
)))))
167 (stp:map-attributes nil
#'check-attribute node
)))
169 (defmacro only-with-attributes
((&rest specs
) node
&body body
)
171 (mapcar (lambda (entry)
172 (if (and (listp entry
) (cdr entry
))
173 (destructuring-bind (name &optional
(uri ""))
176 (cons (string-downcase
178 (symbol-name entry
)))
182 `(let ((,%NODE
,node
))
183 (check-for-invalid-attributes ',valid-names
,%NODE
)
184 (stp:with-attributes
,specs
,%NODE
187 (defun map-pipe-eagerly (fn pipe
)
188 (xpath::enumerate pipe
:key fn
:result nil
))
190 (defmacro do-pipe
((var pipe
&optional result
) &body body
)
192 (map-pipe-eagerly #'(lambda (,var
) ,@body
) ,pipe
)
196 ;;;; XSLT-ENVIRONMENT and XSLT-CONTEXT
198 (defparameter *initial-namespaces
*
200 ("xmlns" .
#"http://www.w3.org/2000/xmlns/")
201 ("xml" .
#"http://www.w3.org/XML/1998/namespace")))
203 (defparameter *namespaces
*
204 *initial-namespaces
*)
206 (defvar *global-variable-declarations
*)
207 (defvar *lexical-variable-declarations
*)
209 (defvar *global-variable-values
*)
210 (defvar *lexical-variable-values
*)
212 (defclass xslt-environment
() ())
214 (defun split-qname (str)
216 (multiple-value-bind (prefix local-name
)
217 (cxml::split-qname str
)
219 ;; FIXME: cxml should really offer a function that does
220 ;; checks for NCName and QName in a sensible way for user code.
221 ;; cxml::split-qname is tailored to the needs of the parser.
223 ;; For now, let's just check the syntax explicitly.
224 (and (or (null prefix
) (xpath::nc-name-p prefix
))
225 (xpath::nc-name-p local-name
))
226 (xslt-error "not a qname: ~A" str
))
227 (values prefix local-name
))
228 (cxml:well-formedness-violation
()
229 (xslt-error "not a qname: ~A" str
))))
231 (defun decode-qname (qname env attributep
&key allow-unknown-namespace
)
233 (xslt-error "missing name"))
234 (multiple-value-bind (prefix local-name
)
237 (if (or prefix
(not attributep
))
238 (or (xpath-sys:environment-find-namespace env
(or prefix
""))
239 (if allow-unknown-namespace
241 (xslt-error "namespace not found: ~A" prefix
)))
245 (defmethod xpath-sys:environment-find-namespace
((env xslt-environment
) prefix
)
246 (or (cdr (assoc prefix
*namespaces
* :test
'equal
))
248 ;; Change the entire code base to represent "no prefix" as the
249 ;; empty string consistently. unparse.lisp has already been changed.
250 (and (equal prefix
"")
251 (cdr (assoc nil
*namespaces
* :test
'equal
)))
252 (and (eql prefix nil
)
253 (cdr (assoc "" *namespaces
* :test
'equal
)))))
255 (defun find-variable-index (local-name uri table
)
256 (position (cons local-name uri
) table
:test
'equal
))
258 (defun intern-global-variable (local-name uri
)
259 (or (find-variable-index local-name uri
*global-variable-declarations
*)
260 (push-variable local-name uri
*global-variable-declarations
*)))
262 (defun push-variable (local-name uri table
)
265 (vector-push-extend (cons local-name uri
) table
)))
267 (defun lexical-variable-value (index &optional
(errorp t
))
268 (let ((result (svref *lexical-variable-values
* index
)))
270 (assert (not (eq result
'unbound
))))
273 (defun (setf lexical-variable-value
) (newval index
)
274 (assert (not (eq newval
'unbound
)))
275 (setf (svref *lexical-variable-values
* index
) newval
))
277 (defun global-variable-value (index &optional
(errorp t
))
278 (let ((result (svref *global-variable-values
* index
)))
280 (assert (not (eq result
'unbound
))))
283 (defun (setf global-variable-value
) (newval index
)
284 (assert (not (eq newval
'unbound
)))
285 (setf (svref *global-variable-values
* index
) newval
))
287 (defmethod xpath-sys:environment-find-function
288 ((env xslt-environment
) lname uri
)
289 (or (if (string= uri
"")
290 (or (xpath-sys:find-xpath-function lname
*xsl
*)
291 (xpath-sys:find-xpath-function lname uri
))
292 (xpath-sys:find-xpath-function lname uri
))
293 (when *forwards-compatible-p
*
294 (lambda (&rest ignore
)
295 (declare (ignore ignore
))
296 (xslt-error "attempt to call an unknown XPath function (~A); error delayed until run-time due to forwards compatible processing"
299 (defmethod xpath-sys:environment-find-variable
300 ((env xslt-environment
) lname uri
)
302 (find-variable-index lname uri
*lexical-variable-declarations
*)))
305 (declare (ignore ctx
))
306 (svref *lexical-variable-values
* index
)))))
308 (defclass lexical-xslt-environment
(xslt-environment) ())
310 (defmethod xpath-sys:environment-find-variable
311 ((env lexical-xslt-environment
) lname uri
)
312 (or (call-next-method)
314 (find-variable-index lname uri
*global-variable-declarations
*)))
318 (declare (ignore ctx
))
319 (svref *global-variable-values
* index
))
320 "global ~s (uri ~s) = ~s" lname uri
:result
)))))
322 (defclass key-environment
(xslt-environment) ())
324 (defmethod xpath-sys:environment-find-variable
325 ((env key-environment
) lname uri
)
326 (declare (ignore lname uri
))
327 (xslt-error "disallowed variable reference"))
329 (defclass global-variable-environment
(xslt-environment)
330 ((initial-global-variable-thunks
331 :initarg
:initial-global-variable-thunks
332 :accessor initial-global-variable-thunks
)))
334 (defmethod xpath-sys:environment-find-variable
335 ((env global-variable-environment
) lname uri
)
336 (or (call-next-method)
337 (gethash (cons lname uri
) (initial-global-variable-thunks env
))))
340 ;;;; TOPLEVEL-TEXT-OUTPUT-SINK
342 ;;;; A sink that serializes only text not contained in any element.
344 (defmacro with-toplevel-text-output-sink
((var) &body body
)
345 `(invoke-with-toplevel-text-output-sink (lambda (,var
) ,@body
)))
347 (defclass toplevel-text-output-sink
(sax:default-handler
)
348 ((target :initarg
:target
:accessor text-output-sink-target
)
349 (depth :initform
0 :accessor textoutput-sink-depth
)))
351 (defmethod sax:start-element
((sink toplevel-text-output-sink
)
352 namespace-uri local-name qname attributes
)
353 (declare (ignore namespace-uri local-name qname attributes
))
354 (incf (textoutput-sink-depth sink
)))
356 (defmethod sax:characters
((sink toplevel-text-output-sink
) data
)
357 (when (zerop (textoutput-sink-depth sink
))
358 (write-string data
(text-output-sink-target sink
))))
360 (defmethod sax:unescaped
((sink toplevel-text-output-sink
) data
)
361 (sax:characters sink data
))
363 (defmethod sax:end-element
((sink toplevel-text-output-sink
)
364 namespace-uri local-name qname
)
365 (declare (ignore namespace-uri local-name qname
))
366 (decf (textoutput-sink-depth sink
)))
368 (defun invoke-with-toplevel-text-output-sink (fn)
369 (with-output-to-string (s)
370 (funcall fn
(make-instance 'toplevel-text-output-sink
:target s
))))
375 ;;;; A sink that passes through only text (at any level) and turns to
376 ;;;; into unescaped characters.
378 (defclass text-filter
(sax:default-handler
)
379 ((target :initarg
:target
:accessor text-filter-target
)))
381 (defmethod sax:characters
((sink text-filter
) data
)
382 (sax:unescaped
(text-filter-target sink
) data
))
384 (defmethod sax:unescaped
((sink text-filter
) data
)
385 (sax:unescaped
(text-filter-target sink
) data
))
387 (defmethod sax:end-document
((sink text-filter
))
388 (sax:end-document
(text-filter-target sink
)))
390 (defun make-text-filter (target)
391 (make-instance 'text-filter
:target target
))
396 ;;;; A sink that recovers from sax:unescaped using sax:characters, as per
399 (defclass escaper
(cxml:broadcast-handler
)
402 (defmethod sax:unescaped
((sink escaper
) data
)
403 (sax:characters sink data
))
405 (defun make-escaper (target)
406 (make-instance 'escaper
:handlers
(list target
)))
411 (defun of-name (local-name)
412 (stp:of-name local-name
*xsl
*))
414 (defun namep (node local-name
)
415 (and (typep node
'(or stp
:element stp
:attribute
))
416 (equal (stp:namespace-uri node
) *xsl
*)
417 (equal (stp:local-name node
) local-name
)))
420 ;;;; PARSE-STYLESHEET
422 (defstruct stylesheet
423 (modes (make-hash-table :test
'equal
))
424 (global-variables (make-empty-declaration-array))
425 (output-specification (make-output-specification))
428 (named-templates (make-hash-table :test
'equal
))
429 (attribute-sets (make-hash-table :test
'equal
))
430 (keys (make-hash-table :test
'equal
))
431 (namespace-aliases (make-hash-table :test
'equal
))
432 (decimal-formats (make-hash-table :test
'equal
))
433 (initial-global-variable-thunks (make-hash-table :test
'equal
)))
435 (setf (documentation 'stylesheet
'type
)
436 "The class of stylesheets that have been parsed and compiled.
438 Pass instances of this class to @fun{apply-stylesheet} to invoke
441 @see-constructor{parse-stylesheet}")
445 (match-thunk (lambda (ignore) (declare (ignore ignore
)) nil
)))
447 (defun find-mode (stylesheet local-name
&optional uri
)
448 (gethash (cons local-name uri
) (stylesheet-modes stylesheet
)))
450 (defun ensure-mode (stylesheet &optional local-name uri
)
451 (or (find-mode stylesheet local-name uri
)
452 (setf (gethash (cons local-name uri
) (stylesheet-modes stylesheet
))
455 (defun ensure-mode/qname
(stylesheet qname env
)
457 (multiple-value-bind (local-name uri
)
458 (decode-qname qname env nil
)
459 (ensure-mode stylesheet local-name uri
))
460 (find-mode stylesheet nil
)))
462 (defun acons-namespaces
463 (element &optional
(bindings *namespaces
*) include-redeclared
)
464 (map-namespace-declarations (lambda (prefix uri
)
465 (push (cons prefix uri
) bindings
))
470 (defun find-key (name stylesheet
)
471 (or (gethash name
(stylesheet-keys stylesheet
))
472 (xslt-error "unknown key: ~a" name
)))
474 (defun make-key (match use
) (cons match use
))
476 (defun key-match (key) (car key
))
478 (defun key-use (key) (cdr key
))
480 (defun add-key (stylesheet name match use
)
481 (push (make-key match use
)
482 (gethash name
(stylesheet-keys stylesheet
))))
484 (defvar *excluded-namespaces
* (list *xsl
*))
485 (defvar *empty-mode
*)
486 (defvar *default-mode
*)
488 (defvar *xsl-include-stack
* nil
)
490 (defun uri-to-pathname (uri)
491 (cxml::uri-to-pathname
(puri:parse-uri uri
)))
493 ;; Why this extra check for literal result element used as stylesheets,
494 ;; instead of a general check for every literal result element? Because
495 ;; Stylesheet__91804 says so.
496 (defun check-Errors_err035 (literal-result-element)
497 (let ((*namespaces
* (acons-namespaces literal-result-element
))
498 (env (make-instance 'lexical-xslt-environment
)))
499 (stp:with-attributes
((extension-element-prefixes
500 "extension-element-prefixes"
502 literal-result-element
503 (dolist (prefix (words (or extension-element-prefixes
"")))
504 (if (equal prefix
"#default")
506 (unless (cxml-stp-impl::nc-name-p prefix
)
507 (xslt-error "invalid prefix: ~A" prefix
)))
509 (or (xpath-sys:environment-find-namespace env prefix
)
510 (xslt-error "namespace not found: ~A" prefix
))))
511 (when (equal uri
(stp:namespace-uri literal-result-element
))
512 (xslt-error "literal result element used as stylesheet, but is ~
513 declared as an extension element")))))))
515 (defun unwrap-2.3
(document)
516 (let ((literal-result-element (stp:document-element document
))
517 (new-template (stp:make-element
"template" *xsl
*))
518 (new-document-element (stp:make-element
"stylesheet" *xsl
*)))
519 (check-Errors_err035 literal-result-element
)
520 (setf (stp:attribute-value new-document-element
"version")
521 (or (stp:attribute-value literal-result-element
"version" *xsl
*)
522 (xslt-error "not a stylesheet: root element lacks xsl:version")))
523 (setf (stp:attribute-value new-template
"match") "/")
524 (setf (stp:document-element document
) new-document-element
)
525 (stp:append-child new-document-element new-template
)
526 (stp:append-child new-template literal-result-element
)
527 new-document-element
))
529 (defun parse-stylesheet-to-stp (input uri-resolver
)
530 (let* ((d (cxml:parse input
(make-text-normalizer (cxml-stp:make-builder
))))
531 (<transform
> (stp:document-element d
)))
532 (unless (equal (stp:namespace-uri
<transform
>) *xsl
*)
533 (setf <transform
> (unwrap-2.3 d
)))
534 (strip-stylesheet <transform
>)
535 (unless (and (equal (stp:namespace-uri
<transform
>) *xsl
*)
536 (or (equal (stp:local-name
<transform
>) "transform")
537 (equal (stp:local-name
<transform
>) "stylesheet")))
538 (xslt-error "not a stylesheet"))
539 (check-for-invalid-attributes
541 ("exclude-result-prefixes" .
"")
542 ("extension-element-prefixes" .
"")
543 ("space" .
"http://www.w3.org/XML/1998/namespace")
547 (or (stp:find-child-if
(of-name "stylesheet") <transform
>)
548 (stp:find-child-if
(of-name "transform") <transform
>))))
550 (xslt-error "invalid top-level element ~A" (stp:local-name invalid
))))
551 (dolist (include (stp:filter-children
(of-name "include") <transform
>))
552 (let* ((uri (puri:merge-uris
(or (stp:attribute-value include
"href")
553 (xslt-error "include without href"))
554 (stp:base-uri include
)))
555 (uri (if uri-resolver
556 (funcall uri-resolver uri
)
558 (str (puri:render-uri uri nil
))
561 (uri-to-pathname uri
)
562 (cxml:xml-parse-error
(c)
563 (xslt-error "cannot find included stylesheet ~A: ~A"
567 :element-type
'(unsigned-byte 8)
568 :if-does-not-exist nil
)
570 (xslt-error "cannot find included stylesheet ~A at ~A"
572 (when (find str
*xsl-include-stack
* :test
#'equal
)
573 (xslt-error "recursive inclusion of ~A" uri
))
574 (let* ((*xsl-include-stack
* (cons str
*xsl-include-stack
*))
575 (<transform
>2 (parse-stylesheet-to-stp stream uri-resolver
)))
576 (stp:insert-child-after
<transform
>
577 (stp:copy
<transform
>2)
579 (stp:detach include
)))))
582 (defvar *instruction-base-uri
*) ;misnamed, is also used in other attributes
583 (defvar *apply-imports-limit
*)
584 (defvar *import-priority
*)
585 (defvar *extension-namespaces
*)
587 (defmacro do-toplevel
((var xpath
<transform
>) &body body
)
588 `(map-toplevel (lambda (,var
) ,@body
) ,xpath
,<transform
>))
590 (defun map-toplevel (fn xpath
<transform
>)
591 (dolist (node (list-toplevel xpath
<transform
>))
592 (let ((*namespaces
* *initial-namespaces
*))
593 (xpath:do-node-set
(ancestor (xpath:evaluate
"ancestor::node()" node
))
594 (xpath:with-namespaces
(("" #.
*xsl
*))
595 (when (xpattern:node-matches-p ancestor
"stylesheet|transform")
596 ;; discard namespaces from including stylesheets
597 (setf *namespaces
* *initial-namespaces
*)))
598 (when (xpath-protocol:node-type-p ancestor
:element
)
599 (setf *namespaces
* (acons-namespaces ancestor
*namespaces
* t
))))
602 (defun list-toplevel (xpath <transform
>)
603 (labels ((recurse (sub)
606 (xpath:evaluate
"transform|stylesheet" sub
))))
608 (xpath-sys:pipe-of
(xpath:evaluate xpath sub
))
609 (xpath::mappend-pipe
#'recurse subsubs
)))))
610 (xpath::sort-nodes
(recurse <transform
>))))
612 (defmacro with-import-magic
((node env
) &body body
)
613 `(invoke-with-import-magic (lambda () ,@body
) ,node
,env
))
615 (defun invoke-with-import-magic (fn node env
)
616 (unless (or (namep node
"stylesheet") (namep node
"transform"))
617 (setf node
(stp:parent node
)))
618 (let ((*excluded-namespaces
* (list *xsl
*))
619 (*extension-namespaces
* '())
620 (*forwards-compatible-p
*
621 (not (equal (stp:attribute-value node
"version") "1.0"))))
622 (parse-exclude-result-prefixes! node env
)
623 (parse-extension-element-prefixes! node env
)
626 (defun parse-1-stylesheet (env stylesheet designator uri-resolver
)
627 (let* ((<transform
> (parse-stylesheet-to-stp designator uri-resolver
))
628 (instruction-base-uri (stp:base-uri
<transform
>))
629 (namespaces (acons-namespaces <transform
>))
630 (apply-imports-limit (1+ *import-priority
*))
632 (let ((*namespaces
* namespaces
))
633 (invoke-with-import-magic (constantly t
) <transform
> env
))
634 (do-toplevel (elt "node()" <transform
>)
635 (let ((version (stp:attribute-value
(stp:parent elt
) "version")))
638 (xslt-error "stylesheet lacks version"))
639 ((equal version
"1.0")
640 (if (typep elt
'stp
:element
)
641 (when (or (equal (stp:namespace-uri elt
) "")
642 (and (equal (stp:namespace-uri elt
) *xsl
*)
643 (not (find (stp:local-name elt
)
644 '("key" "template" "output"
645 "strip-space" "preserve-space"
646 "attribute-set" "namespace-alias"
647 "decimal-format" "variable" "param"
649 ;; for include handling:
650 "stylesheet" "transform")
652 (xslt-error "unknown top-level element ~A" (stp:local-name elt
)))
653 (xslt-error "text at top-level"))))))
654 (macrolet ((with-specials ((&optional
) &body body
)
655 `(let ((*instruction-base-uri
* instruction-base-uri
)
656 (*namespaces
* namespaces
)
657 (*apply-imports-limit
* apply-imports-limit
))
660 (do-toplevel (import "import" <transform
>)
661 (when (let ((prev (xpath:first-node
662 (xpath:evaluate
"preceding-sibling::*"
665 (and prev
(not (namep prev
"import"))))
666 (xslt-error "import not at beginning of stylesheet"))
667 (let ((uri (puri:merge-uris
(or (stp:attribute-value import
"href")
668 (xslt-error "import without href"))
669 (stp:base-uri import
))))
670 (push (parse-imported-stylesheet env stylesheet uri uri-resolver
)
672 (let ((import-priority
673 (incf *import-priority
*))
674 (var-cont (prepare-global-variables stylesheet
<transform
>)))
675 (parse-namespace-aliases! stylesheet
<transform
> env
)
676 ;; delay the rest of compilation until we've seen all global
679 (mapc #'funcall
(nreverse continuations
))
681 (let ((*import-priority
* import-priority
))
683 (parse-keys! stylesheet
<transform
> env
)
684 (parse-templates! stylesheet
<transform
> env
)
685 (parse-output! stylesheet
<transform
> env
)
686 (parse-strip/preserve-space
! stylesheet
<transform
> env
)
687 (parse-attribute-sets! stylesheet
<transform
> env
)
688 (parse-decimal-formats! stylesheet
<transform
> env
))))))))
690 (defvar *xsl-import-stack
* nil
)
692 (defun parse-imported-stylesheet (env stylesheet uri uri-resolver
)
693 (let* ((uri (if uri-resolver
694 (funcall uri-resolver uri
)
696 (str (puri:render-uri uri nil
))
699 (uri-to-pathname uri
)
700 (cxml:xml-parse-error
(c)
701 (xslt-error "cannot find imported stylesheet ~A: ~A"
705 :element-type
'(unsigned-byte 8)
706 :if-does-not-exist nil
)
708 (xslt-error "cannot find imported stylesheet ~A at ~A"
710 (when (find str
*xsl-import-stack
* :test
#'equal
)
711 (xslt-error "recursive inclusion of ~A" uri
))
712 (let ((*xsl-import-stack
* (cons str
*xsl-import-stack
*)))
713 (parse-1-stylesheet env stylesheet stream uri-resolver
)))))
715 (defvar *included-attribute-sets
*)
717 (defvar *stylesheet
*)
719 (defun parse-stylesheet (designator &key uri-resolver
)
720 "@arg[designator]{an XML designator}
721 @arg[uri-resolver]{optional function of one argument}
722 @return{An instance of @class{stylesheet}.}
724 @short{Parse a stylesheet.}
726 This function parses and compiles an XSLT stylesheet.
727 The precompiled stylesheet object can then be passed to
728 @fun{apply-stylesheet}.
730 Also refer to @fun{apply-stylesheet} for details on XML designators."
731 (with-resignalled-errors ()
732 (xpath:with-namespaces
((nil #.
*xsl
*))
733 (let* ((*import-priority
* 0)
734 (xpattern:*allow-variables-in-patterns
* nil
)
735 (puri:*strict-parse
* nil
)
736 (stylesheet (make-stylesheet))
738 ;; zzz this is for remove-excluded-namespaces only
740 (env (make-instance 'lexical-xslt-environment
))
741 (*excluded-namespaces
* *excluded-namespaces
*)
742 (*global-variable-declarations
* (make-empty-declaration-array))
743 (*included-attribute-sets
* nil
))
744 (ensure-mode stylesheet nil
)
745 (funcall (parse-1-stylesheet env stylesheet designator uri-resolver
))
746 ;; reverse attribute sets:
747 (let ((table (stylesheet-attribute-sets stylesheet
)))
748 (maphash (lambda (k v
)
749 (setf (gethash k table
) (nreverse v
)))
752 (dolist (sets *included-attribute-sets
*)
753 (loop for
(local-name uri nil
) in sets do
754 (find-attribute-set local-name uri stylesheet
)))
756 (unless (find-decimal-format "" "" stylesheet nil
)
757 (setf (find-decimal-format "" "" stylesheet
)
758 (make-decimal-format)))
759 ;; compile a template matcher for each mode:
761 for mode being each hash-value in
(stylesheet-modes stylesheet
)
763 (setf (mode-match-thunk mode
)
764 (xpattern:make-pattern-matcher
765 (mapcar #'template-compiled-pattern
766 (mode-templates mode
)))))
767 ;; and for the strip tests
768 (setf (stylesheet-strip-thunk stylesheet
)
769 (let ((patterns (stylesheet-strip-tests stylesheet
)))
771 (xpattern:make-pattern-matcher
772 (mapcar #'strip-test-compiled-pattern patterns
)))))
775 (defun parse-attribute-sets! (stylesheet <transform
> env
)
776 (do-toplevel (elt "attribute-set" <transform
>)
777 (with-import-magic (elt env
)
779 (mapcar (lambda (qname)
780 (multiple-value-list (decode-qname qname env nil
)))
782 (stp:attribute-value elt
"use-attribute-sets"))))
788 (and (typep child
'stp
:element
)
789 (or (and (equal (stp:namespace-uri child
) *xsl
*)
790 (equal (stp:local-name child
)
792 (find (stp:namespace-uri child
)
793 *extension-namespaces
*
795 (xslt-error "non-attribute found in attribute set"))
796 (parse-instruction child
))
798 (*lexical-variable-declarations
*
799 (make-empty-declaration-array))
801 (compile-instruction `(progn ,@instructions
) env
))
802 (n-variables (length *lexical-variable-declarations
*)))
803 (push sets
*included-attribute-sets
*)
806 (loop for
(local-name uri nil
) in sets do
807 (dolist (thunk (find-attribute-set local-name uri
))
808 (funcall thunk ctx
)))
809 (let ((*lexical-variable-values
*
810 (make-variable-value-array n-variables
)))
811 (funcall thunk ctx
)))))
812 (gethash (multiple-value-bind (local-name uri
)
813 (decode-qname (or (stp:attribute-value elt
"name")
814 (xslt-error "missing name"))
817 (cons local-name uri
))
818 (stylesheet-attribute-sets stylesheet
))))))
820 (defun parse-namespace-aliases! (stylesheet <transform
> env
)
821 (do-toplevel (elt "namespace-alias" <transform
>)
822 (let ((*namespaces
* (acons-namespaces elt
)))
823 (only-with-attributes (stylesheet-prefix result-prefix
) elt
824 (unless stylesheet-prefix
825 (xslt-error "missing stylesheet-prefix in namespace-alias"))
826 (unless result-prefix
827 (xslt-error "missing result-prefix in namespace-alias"))
829 (if (equal stylesheet-prefix
"#default")
831 (or (xpath-sys:environment-find-namespace
834 (xslt-error "stylesheet namespace not found in alias: ~A"
836 (stylesheet-namespace-aliases stylesheet
))
837 (or (xpath-sys:environment-find-namespace
839 (if (equal result-prefix
"#default")
842 (xslt-error "result namespace not found in alias: ~A"
845 (defun parse-decimal-formats! (stylesheet <transform
> env
)
846 (do-toplevel (elt "decimal-format" <transform
>)
847 (stp:with-attributes
(name
861 (multiple-value-bind (local-name uri
)
863 (decode-qname name env nil
)
865 (let ((current (find-decimal-format local-name uri stylesheet nil
))
870 (unless (eql (length x
) 1)
871 (xslt-error "not a single character: ~A" x
))
872 (let ((chr (elt x
0)))
873 (when (find chr seen
)
875 "conflicting decimal format characters: ~A"
882 (apply #'make-decimal-format
883 (append (str :infinity infinity
)
885 (chr :decimal-separator decimal-separator
)
886 (chr :grouping-separator grouping-separator
)
887 (chr :zero-digit zero-digit
)
888 (chr :percent percent
)
889 (chr :per-mille per-mille
)
891 (chr :pattern-separator pattern-separator
)
892 (chr :minus-sign minus-sign
)))))))
894 (unless (decimal-format= current new
)
895 (xslt-error "decimal format mismatch for ~S" local-name
))
896 (setf (find-decimal-format local-name uri stylesheet
) new
)))))))
898 (defun parse-exclude-result-prefixes! (node env
)
899 (stp:with-attributes
(exclude-result-prefixes)
901 (dolist (prefix (words (or exclude-result-prefixes
"")))
902 (if (equal prefix
"#default")
904 (unless (cxml-stp-impl::nc-name-p prefix
)
905 (xslt-error "invalid prefix: ~A" prefix
)))
906 (push (or (xpath-sys:environment-find-namespace env prefix
)
907 (xslt-error "namespace not found: ~A" prefix
))
908 *excluded-namespaces
*))))
910 (defun parse-extension-element-prefixes! (node env
)
911 (stp:with-attributes
(extension-element-prefixes)
913 (dolist (prefix (words (or extension-element-prefixes
"")))
914 (if (equal prefix
"#default")
916 (unless (cxml-stp-impl::nc-name-p prefix
)
917 (xslt-error "invalid prefix: ~A" prefix
)))
919 (or (xpath-sys:environment-find-namespace env prefix
)
920 (xslt-error "namespace not found: ~A" prefix
))))
921 (unless (equal uri
*xsl
*)
922 (push uri
*extension-namespaces
*)
923 (push uri
*excluded-namespaces
*))))))
925 (defun parse-nametest-tokens (str)
926 (labels ((check (boolean)
928 (xslt-error "invalid nametest token")))
929 (check-null (boolean)
930 (check (not boolean
))))
933 (mapcar (lambda (name-test)
934 (destructuring-bind (&optional path
&rest junk
)
935 (cdr (xpattern:parse-pattern-expression name-test
))
937 (check (eq (car path
) :path
))
938 (destructuring-bind (&optional child
&rest junk
) (cdr path
)
940 (check (eq (car child
) :child
))
941 (destructuring-bind (nodetest &rest junk
) (cdr child
)
943 (check (or (stringp nodetest
)
945 (and (consp nodetest
)
946 (or (eq (car nodetest
) :namespace
)
947 (eq (car nodetest
) :qname
)))))))
951 (defstruct strip-test
957 (defun parse-strip/preserve-space
! (stylesheet <transform
> env
)
959 (do-toplevel (elt "strip-space|preserve-space" <transform
>)
960 (let ((*namespaces
* (acons-namespaces elt
))
962 (if (equal (stp:local-name elt
) "strip-space")
966 (cdr (parse-nametest-tokens
967 (stp:attribute-value elt
"elements"))))
968 (let* ((compiled-pattern
969 (car (without-xslt-current ()
970 (xpattern:compute-patterns
971 `(:patterns
,expression
)
976 (make-strip-test :compiled-pattern compiled-pattern
977 :priority
(expression-priority expression
)
980 (setf (xpattern:pattern-value compiled-pattern
) strip-test
)
981 (push strip-test
(stylesheet-strip-tests stylesheet
)))))
984 (defstruct (output-specification
985 (:conc-name
"OUTPUT-"))
992 cdata-section-matchers
996 (defun parse-output! (stylesheet <transform
> env
)
997 (dolist (<output
> (list-toplevel "output" <transform
>))
998 (let ((spec (stylesheet-output-specification stylesheet
)))
999 (only-with-attributes (version
1006 omit-xml-declaration
1008 cdata-section-elements
)
1010 (declare (ignore version
))
1012 (multiple-value-bind (local-name uri
)
1013 (decode-qname method env t
)
1014 (setf (output-method spec
)
1015 (if (plusp (length uri
))
1018 ((equalp local-name
"HTML") :html
)
1019 ((equalp local-name
"TEXT") :text
)
1020 ((equalp local-name
"XML") :xml
)
1022 (xslt-error "invalid output method: ~A" method
)))))))
1024 (setf (output-indent spec
) indent
))
1026 (setf (output-encoding spec
) encoding
))
1027 (when doctype-system
1028 (setf (output-doctype-system spec
) doctype-system
))
1029 (when doctype-public
1030 (setf (output-doctype-public spec
) doctype-public
))
1031 (when omit-xml-declaration
1032 (setf (output-omit-xml-declaration spec
) omit-xml-declaration
))
1033 (when cdata-section-elements
1034 (dolist (qname (words cdata-section-elements
))
1035 (decode-qname qname env nil
) ;check the syntax
1036 (push (xpattern:make-pattern-matcher
* qname env
)
1037 (output-cdata-section-matchers spec
))))
1039 (setf (output-standalone-p spec
)
1040 (boolean-or-error standalone
)))
1042 (setf (output-media-type spec
) media-type
))))))
1044 (defun make-empty-declaration-array ()
1045 (make-array 1 :fill-pointer
0 :adjustable t
))
1047 (defun make-variable-value-array (n-lexical-variables)
1048 (make-array n-lexical-variables
:initial-element
'unbound
))
1050 (defun compile-global-variable (<variable
> env
) ;; also for <param>
1051 (stp:with-attributes
(name select
) <variable
>
1052 (when (and select
(stp:list-children
<variable
>))
1053 (xslt-error "variable with select and body"))
1054 (let* ((*lexical-variable-declarations
* (make-empty-declaration-array))
1057 (compile-xpath select env
))
1058 ((stp:list-children
<variable
>)
1059 (let* ((inner-sexpr `(progn ,@(parse-body <variable
>)))
1060 (inner-thunk (compile-instruction inner-sexpr env
)))
1062 (apply-to-result-tree-fragment ctx inner-thunk
))))
1065 (declare (ignore ctx
))
1067 (n-lexical-variables (length *lexical-variable-declarations
*)))
1070 (let* ((*lexical-variable-values
*
1071 (make-variable-value-array n-lexical-variables
)))
1072 (funcall inner ctx
)))
1073 "global ~s (~s) = ~s" name select
:result
))))
1075 (defstruct (variable-chain
1076 (:constructor make-variable-chain
)
1077 (:conc-name
"VARIABLE-CHAIN-"))
1084 (defstruct (import-variable
1085 (:constructor make-variable
)
1086 (:conc-name
"VARIABLE-"))
1091 (defun parse-global-variable! (stylesheet <variable
> global-env
)
1092 (let* ((*namespaces
* (acons-namespaces <variable
>))
1093 (instruction-base-uri (stp:base-uri
<variable
>))
1094 (*instruction-base-uri
* instruction-base-uri
)
1095 (*excluded-namespaces
* (list *xsl
*))
1096 (*extension-namespaces
* '())
1097 (qname (stp:attribute-value
<variable
> "name")))
1098 (with-import-magic (<variable
> global-env
)
1100 (xslt-error "name missing in ~A" (stp:local-name
<variable
>)))
1101 (multiple-value-bind (local-name uri
)
1102 (decode-qname qname global-env nil
)
1103 ;; For the normal compilation environment of templates, install it
1104 ;; into *GLOBAL-VARIABLE-DECLARATIONS*:
1105 (let ((index (intern-global-variable local-name uri
)))
1106 ;; For the evaluation of a global variable itself, build a thunk
1107 ;; that lazily resolves other variables, stored into
1108 ;; INITIAL-GLOBAL-VARIABLE-THUNKS:
1109 (let* ((value-thunk :unknown
)
1110 (sgv (stylesheet-global-variables stylesheet
))
1112 (if (< index
(length sgv
))
1114 (make-variable-chain
1116 :local-name local-name
1118 (next (car (variable-chain-definitions chain
)))
1119 (global-variable-thunk
1121 (let ((v (global-variable-value index nil
)))
1125 (xslt-error "no next definition for: ~A"
1127 (funcall (variable-value-thunk next
) ctx
))
1129 (setf (global-variable-value index
) 'seen
)
1130 (setf (global-variable-value index
)
1131 (funcall value-thunk ctx
)))
1134 (excluded-namespaces *excluded-namespaces
*)
1135 (extension-namespaces *extension-namespaces
*)
1137 (make-variable :param-p
(namep <variable
> "param")))
1138 (forwards-compatible-p *forwards-compatible-p
*)
1141 (let* ((*instruction-base-uri
* instruction-base-uri
)
1142 (*excluded-namespaces
* excluded-namespaces
)
1143 (*extension-namespaces
* extension-namespaces
)
1144 (*forwards-compatible-p
* forwards-compatible-p
)
1146 (compile-global-variable <variable
> global-env
)))
1147 (setf value-thunk fn
)
1148 (setf (variable-value-thunk variable
) fn
)))))
1149 (setf (variable-value-thunk-setter variable
)
1151 (setf (gethash (cons local-name uri
)
1152 (initial-global-variable-thunks global-env
))
1153 global-variable-thunk
)
1154 (setf (variable-chain-thunk chain
) global-variable-thunk
)
1155 (push variable
(variable-chain-definitions chain
))
1158 (defun parse-keys! (stylesheet <transform
> env
)
1159 (xpath:with-namespaces
((nil #.
*xsl
*))
1160 (do-toplevel (<key
> "key" <transform
>)
1161 (with-import-magic (<key
> env
)
1162 (let ((*instruction-base-uri
* (stp:base-uri
<key
>)))
1163 (only-with-attributes (name match use
) <key
>
1164 (unless name
(xslt-error "key name attribute not specified"))
1165 (unless match
(xslt-error "key match attribute not specified"))
1166 (unless use
(xslt-error "key use attribute not specified"))
1167 (multiple-value-bind (local-name uri
)
1168 (decode-qname name env nil
)
1170 (cons local-name uri
)
1171 (compile-xpath `(xpath:xpath
,(parse-key-pattern match
))
1174 (make-instance 'key-environment
))))))))))
1176 (defun prepare-global-variables (stylesheet <transform
>)
1177 (xpath:with-namespaces
((nil #.
*xsl
*))
1178 (let* ((igvt (stylesheet-initial-global-variable-thunks stylesheet
))
1179 (global-env (make-instance 'global-variable-environment
1180 :initial-global-variable-thunks igvt
))
1182 (do-toplevel (<variable
> "variable|param" <transform
>)
1184 (parse-global-variable! stylesheet
<variable
> global-env
)))
1185 (xslt-trace "parsing global variable ~s (uri ~s)"
1186 (variable-chain-local-name chain
)
1187 (variable-chain-uri chain
))
1191 (and (equal (variable-chain-local-name a
)
1192 (variable-chain-local-name b
))
1193 (equal (variable-chain-uri a
)
1194 (variable-chain-uri b
)))))
1195 (xslt-error "duplicate definition for global variable ~A"
1196 (variable-chain-local-name chain
)))
1197 (push chain chains
)))
1198 (setf chains
(nreverse chains
))
1199 (let ((table (stylesheet-global-variables stylesheet
))
1200 (newlen (length *global-variable-declarations
*)))
1201 (adjust-array table newlen
:fill-pointer newlen
)
1202 (dolist (chain chains
)
1203 (setf (elt table
(variable-chain-index chain
)) chain
)))
1205 ;; now that the global environment knows about all variables, run the
1206 ;; thunk setters to perform their compilation
1207 (mapc (lambda (chain)
1208 (dolist (var (variable-chain-definitions chain
))
1209 (funcall (variable-value-thunk-setter var
))))
1212 (defun parse-templates! (stylesheet <transform
> env
)
1214 (do-toplevel (<template
> "template" <transform
>)
1215 (let ((*namespaces
* (acons-namespaces <template
>))
1216 (*instruction-base-uri
* (stp:base-uri
<template
>)))
1217 (with-import-magic (<template
> env
)
1218 (dolist (template (compile-template <template
> env i
))
1219 (let ((name (template-name template
)))
1221 (let* ((table (stylesheet-named-templates stylesheet
))
1222 (head (car (gethash name table
))))
1223 (when (and head
(eql (template-import-priority head
)
1224 (template-import-priority template
)))
1225 ;; fixme: is this supposed to be a run-time error?
1226 (xslt-error "conflicting templates for ~A" name
))
1227 (push template
(gethash name table
)))
1228 (let ((mode (ensure-mode/qname stylesheet
1229 (template-mode-qname template
)
1231 (setf (template-mode template
) mode
)
1232 (push template
(mode-templates mode
))))))))
1236 ;;;; APPLY-STYLESHEET
1238 (deftype xml-designator
() '(or runes
:xstream runes
:rod array stream pathname
))
1240 (defun unalias-uri (uri)
1242 (gethash uri
(stylesheet-namespace-aliases *stylesheet
*)
1244 (check-type result string
)
1247 (defstruct (parameter
1248 (:constructor make-parameter
(value local-name
&optional uri
)))
1253 (setf (documentation 'parameter
'type
)
1254 "The class of top-level parameters to XSLT stylesheets.
1256 Parameters are identified by expanded names, i.e. a namespace URI
1259 Their value is string.
1261 @see-constructor{make-parameter}
1262 @see-slot{parameter-uri}
1263 @see-slot{parameter-local-name}
1264 @see-slot{parameter-value}")
1266 (setf (documentation 'make-parameter
'function
)
1267 "@arg[value]{The parameter's value, a string.}
1268 @arg[local-name]{The parameter's local name, a string.}
1269 @arg[local-name]{The parameter's namespace URI, a string.}
1270 @return{An instance of @class{parameter}.}
1272 @short{Creates a paramater.}
1275 @see{parameter-local-name}
1276 @see{parameter-value}")
1278 (setf (documentation 'parameter-uri
'function
)
1279 "@arg[instance]{An instance of @class{parameter}.}
1281 @return{Returns the parameter's namespace URI.}
1283 @see{parameter-local-name}
1284 @see{parameter-value}")
1286 (setf (documentation 'parameter-local-name
'function
)
1287 "@arg[instance]{An instance of @class{parameter}.}
1289 @return{Returns the parameter's local name.}
1292 @see{parameter-value}")
1294 (setf (documentation 'parameter-value
'function
)
1295 "@arg[instance]{An instance of @class{parameter}.}
1297 @return{Returns the parameter's value.}
1300 @see{parameter-local-name}")
1302 (defun find-parameter-value (local-name uri parameters
)
1303 (dolist (p parameters
)
1304 (when (and (equal (parameter-local-name p
) local-name
)
1305 (equal (parameter-uri p
) uri
))
1306 (return (parameter-value p
)))))
1308 (defvar *uri-resolver
*)
1310 (defun parse-allowing-microsoft-bom (pathname handler
)
1311 (with-open-file (s pathname
:element-type
'(unsigned-byte 8))
1312 (unless (and (eql (read-byte s nil
) #xef
)
1313 (eql (read-byte s nil
) #xbb
)
1314 (eql (read-byte s nil
) #xbf
))
1315 (file-position s
0))
1316 (cxml:parse s handler
)))
1318 (defstruct source-document
1321 (indices (make-hash-table)))
1323 (defvar *uri-to-document
*)
1324 (defvar *root-to-document
*)
1326 (defun %document
(uri-string base-uri
)
1327 (let* ((absolute-uri
1328 (puri:merge-uris uri-string
(or base-uri
"")))
1331 (funcall *uri-resolver
* absolute-uri
)
1335 (uri-to-pathname resolved-uri
)
1336 (cxml:xml-parse-error
(c)
1337 (xslt-error "cannot find referenced document ~A: ~A"
1339 (document (gethash pathname
*uri-to-document
*)))
1342 (make-whitespace-stripper
1344 (parse-allowing-microsoft-bom pathname
1346 ((or file-error cxml
:xml-parse-error
) (c)
1347 (xslt-error "cannot parse referenced document ~A: ~A"
1349 (stylesheet-strip-thunk *stylesheet
*)))
1350 (id (hash-table-count *root-to-document
*)))
1351 (setf document
(make-source-document :id id
:root-node root-node
))
1352 (setf (gethash pathname
*uri-to-document
*) document
)
1353 (setf (gethash root-node
*root-to-document
*) document
)))
1354 (when (puri:uri-fragment absolute-uri
)
1355 (xslt-error "use of fragment identifiers in document() not supported"))
1356 (source-document-root-node document
)))
1358 (xpath-sys:define-extension xslt
*xsl
*)
1360 (defun document-base-uri (node)
1361 (xpath-protocol:base-uri
1363 ((xpath-protocol:node-type-p node
:document
)
1364 (xpath::find-in-pipe-if
1366 (xpath-protocol:node-type-p x
:element
))
1367 (xpath-protocol:child-pipe node
)))
1368 ((xpath-protocol:node-type-p node
:element
)
1371 (xpath-protocol:parent-node node
)))))
1373 (xpath-sys:define-xpath-function
/lazy
1375 (object &optional node-set
)
1376 (let ((instruction-base-uri *instruction-base-uri
*))
1378 (let* ((object (funcall object ctx
))
1379 (node-set (and node-set
(funcall node-set ctx
)))
1382 (document-base-uri (xpath::textually-first-node node-set
))
1383 instruction-base-uri
)))
1384 (xpath-sys:make-node-set
1385 (if (xpath:node-set-p object
)
1386 (xpath:map-node-set-
>list
1388 (%document
(xpath:string-value node
)
1391 (document-base-uri node
))))
1393 (list (%document
(xpath:string-value object
) base-uri
))))))))
1396 (defun build-key-index (document key-conses
)
1397 (let ((index (make-hash-table :test
'equal
)))
1398 (dolist (key key-conses
)
1401 (xpath:evaluate-compiled
(key-match key
)
1403 (source-document-root-node document
))))
1404 (let* ((use-result (xpath:evaluate-compiled
(key-use key
) node
))
1405 (uses (if (xpath:node-set-p use-result
)
1406 (xpath:all-nodes use-result
)
1407 (list use-result
))))
1409 (push node
(gethash (xpath:string-value use
) index
))))))
1412 (defun %key
(document key-conses value
)
1413 (let* ((indices (source-document-indices document
))
1414 (index (or (gethash key-conses indices
)
1415 (setf (gethash key-conses indices
)
1416 (build-key-index document key-conses
)))))
1417 (gethash value index
)))
1419 (xpath-sys:define-xpath-function
/lazy xslt
:key
(name object
)
1420 (let ((namespaces *namespaces
*))
1422 (let* ((qname (xpath:string-value
(funcall name ctx
)))
1423 (object (funcall object ctx
))
1425 (multiple-value-bind (local-name uri
)
1426 (decode-qname/runtime qname namespaces nil
)
1427 (cons local-name uri
)))
1428 (key-conses (find-key expanded-name
*stylesheet
*)))
1429 (xpath-sys:make-node-set
1430 (labels ((get-by-key (value)
1431 (%key
(node-to-source-document (xpath:context-node ctx
))
1433 (xpath:string-value value
))))
1435 (if (xpath:node-set-p object
)
1436 (xpath::mappend-pipe
#'get-by-key
(xpath-sys:pipe-of object
))
1437 (get-by-key object
)))))))))
1439 ;; FIXME: add alias mechanism for XPath extensions in order to avoid duplication
1441 (xpath-sys:define-xpath-function
/lazy xslt
:current
()
1442 (when *without-xslt-current-p
*
1443 (xslt-error "current() not allowed here"))
1445 (xpath-sys:make-node-set
1446 (xpath-sys:make-pipe
1447 (xpath:context-starting-node ctx
)
1450 (xpath-sys:define-xpath-function
/lazy xslt
:unparsed-entity-uri
(name)
1452 (or (xpath-protocol:unparsed-entity-uri
(xpath:context-node ctx
)
1456 (defun node-to-source-document (node)
1457 (gethash (xpath:first-node
1458 (xpath:evaluate
(xpath:xpath
(:path
(:root
:node
))) node
))
1459 *root-to-document
*))
1461 (defun %get-node-id
(node)
1462 (when (xpath:node-set-p node
)
1463 (setf node
(xpath::textually-first-node node
)))
1466 (source-document-id (node-to-source-document node
))
1467 (xpath-sys:get-node-id node
))))
1469 (xpath-sys:define-xpath-function
/lazy xslt
:generate-id
(&optional node-set-thunk
)
1472 (%get-node-id
(xpath:node-set-value
(funcall node-set-thunk ctx
))))
1474 (%get-node-id
(xpath:context-node ctx
)))))
1476 (declaim (special *builtin-instructions
*))
1478 (xpath-sys:define-xpath-function
/lazy xslt
:element-available
(qname)
1479 (let ((namespaces *namespaces
*)
1480 (extensions *extension-namespaces
*))
1482 (let ((qname (funcall qname ctx
)))
1483 (multiple-value-bind (local-name uri
)
1484 (decode-qname/runtime qname namespaces nil
)
1487 (and (gethash local-name
*builtin-instructions
*) t
))
1488 ((find uri extensions
:test
#'equal
)
1489 (and (find-extension-element local-name uri
) t
))
1493 (xpath-sys:define-xpath-function
/lazy xslt
:function-available
(qname)
1494 (let ((namespaces *namespaces
*))
1496 (let ((qname (funcall qname ctx
)))
1497 (multiple-value-bind (local-name uri
)
1498 (decode-qname/runtime qname namespaces nil
)
1499 (and (zerop (length uri
))
1500 (or (xpath-sys:find-xpath-function local-name
*xsl
*)
1501 (xpath-sys:find-xpath-function local-name uri
))
1504 (xpath-sys:define-xpath-function
/lazy xslt
:system-property
(qname)
1505 (let ((namespaces *namespaces
*))
1507 (let ((qname (xpath:string-value
(funcall qname ctx
))))
1508 (multiple-value-bind (local-name uri
)
1509 (decode-qname/runtime qname namespaces nil
)
1510 (if (equal uri
*xsl
*)
1512 ((equal local-name
"version")
1514 ((equal local-name
"vendor")
1516 ((equal local-name
"vendor-url")
1517 "http://repo.or.cz/w/xuriella.git")
1522 ;; FIXME: should there be separate uri-resolver arguments for stylesheet
1524 (defun apply-stylesheet
1525 (stylesheet source-designator
1526 &key output parameters uri-resolver navigator
)
1527 "@arg[stylesheet]{a stylesheet designator (see below for details)}
1528 @arg[source-designator]{a source document designator (see below for details)}
1529 @arg[output]{optional output sink designator (see below for details)}
1530 @arg[parameters]{a list of @class{parameter} instances}
1531 @arg[uri-resolver]{optional function of one argument}
1532 @arg[navigator]{optional XPath navigator}
1533 @return{The value returned by sax:end-document when called on the
1534 designated output sink.}
1536 @short{Apply a stylesheet to a document.}
1538 This function takes @code{stylesheet} (either a parsed @class{stylesheet}
1539 or a designator for XML file to be parsed) and a source document, specified
1540 using the XML designator @code{source-designator}, and applies the
1541 stylesheet to the document.
1543 An XML designator is any value accepted by @code{cxml:parse}, in particular:
1545 @item{Pathnames -- The file referred to by the pathname will parsed
1547 @item{Stream -- The stream will be parsed using cxml.}
1548 @item{Xstream -- Similar to the stream case, but using cxml's internal
1549 representation of rune streams.}
1550 @item{String -- The string itself will be parsed as an XML document,
1551 and is assumed to have been decoded into characters already.}
1552 @item{Array of (unsigned-byte 8) -- The array itself will be parsed as
1553 an XML document (which has not been decoded yet).}
1556 Note: Since strings are interpreted as documents, namestrings are
1557 not acceptable. Use pathnames instead of namestrings.
1559 An output sink designator is has the following form:
1561 @item{Null -- Designates a string sink. I.e., the result document
1562 of the stylesheet will be returned as a string. This as the default.}
1563 @item{Pathnames -- The file referred to by the pathname will created
1565 @item{Stream -- The stream will be written to.}
1566 @item{SAX or HAX handler -- Events will be sent directly to this sink.}
1569 Note: Specificaton of a sink overrides the specification of XML or HTML
1570 output method in the styl.sheet.
1572 Parameters are identified by names, and have values that are strings.
1573 Top-level parameters of these names are bound accordingly. If a paramater
1574 is not specified, its default value is computed as implemented in the
1575 stylesheet. If parameters are specified that the stylesheet does not
1576 recognize, they will be ignored.
1578 A @code{uri-resolver} is a function taking a PURI object as an argument
1579 and returning a PURI object as a value. The URI resolver will be invoked
1580 for all references to external files, e.g. at compilation time using
1581 xsl:import and xsl:include, and at run-time using the document() function.
1583 The URI resolver can be used to rewrite URLs so that file http:// links
1584 are replaced by file:// links, for example. Another application are
1585 URI resolvers that signal an error instead of returning, for example
1586 so that file:// links forbidden.
1588 The specified @code{navigator} will be passed to XPath protocol functions.
1590 @see{parse-stylesheet}"
1591 (when (typep stylesheet
'xml-designator
)
1594 ((cxml:xml-parse-error
1596 (xslt-error "cannot parse stylesheet: ~A" c
))))
1597 (parse-stylesheet stylesheet
:uri-resolver uri-resolver
))))
1598 (with-resignalled-errors ()
1599 (invoke-with-output-sink
1601 (let* ((*uri-to-document
* (make-hash-table :test
'equal
))
1603 ;; fixme? should be xpath-protocol:node-equal
1604 (make-hash-table :test
'equal
))
1605 (xpath:*navigator
* (or navigator
:default-navigator
))
1606 (puri:*strict-parse
* nil
)
1607 (*stylesheet
* stylesheet
)
1608 (*empty-mode
* (make-mode))
1609 (*default-mode
* (find-mode stylesheet nil
))
1610 (global-variable-chains
1611 (stylesheet-global-variables stylesheet
))
1612 (*global-variable-values
*
1613 (make-variable-value-array (length global-variable-chains
)))
1614 (*uri-resolver
* uri-resolver
)
1616 (if (typep source-designator
'xml-designator
)
1617 (cxml:parse source-designator
(stp:make-builder
))
1620 (make-whitespace-stripper
1622 (stylesheet-strip-thunk stylesheet
)))
1623 (ctx (xpath:make-context xpath-root-node
))
1624 (document (make-source-document
1626 :root-node xpath-root-node
)))
1627 (when (pathnamep source-designator
) ;fixme: else use base uri?
1628 (setf (gethash source-designator
*uri-to-document
*) document
))
1629 (setf (gethash xpath-root-node
*root-to-document
*) document
)
1632 (let ((head (car (variable-chain-definitions chain
))))
1633 (when (variable-param-p head
)
1635 (find-parameter-value
1636 (variable-chain-local-name chain
)
1637 (variable-chain-uri chain
)
1640 (setf (global-variable-value
1641 (variable-chain-index chain
))
1643 global-variable-chains
)
1646 (funcall (variable-chain-thunk chain
) ctx
))
1647 global-variable-chains
)
1648 ;; zzz we wouldn't have to mask float traps here if we used the
1649 ;; XPath API properly. Unfortunately I've been using FUNCALL
1650 ;; everywhere instead of EVALUATE, so let's paper over that
1651 ;; at a central place to be sure:
1652 (xpath::with-float-traps-masked
()
1653 (apply-templates ctx
:mode
*default-mode
*))))
1654 (stylesheet-output-specification stylesheet
)
1657 (defun find-attribute-set (local-name uri
&optional
(stylesheet *stylesheet
*))
1658 (or (gethash (cons local-name uri
) (stylesheet-attribute-sets stylesheet
))
1659 (xslt-error "no such attribute set: ~A/~A" local-name uri
)))
1661 (defun apply-templates/list
(list &key param-bindings sort-predicate mode
)
1662 (when sort-predicate
1664 (mapcar #'xpath
:context-node
1665 (stable-sort (contextify-node-list list
)
1667 (let* ((n (length list
))
1668 (s/d
(lambda () n
)))
1673 (apply-templates (xpath:make-context child s
/d i
)
1674 :param-bindings param-bindings
1677 (defvar *stack-limit
* 200)
1679 (defun invoke-with-stack-limit (fn)
1680 (let ((*stack-limit
* (1- *stack-limit
*)))
1681 (unless (plusp *stack-limit
*)
1682 (xslt-error "*stack-limit* reached; stack overflow"))
1685 (defun invoke-template (ctx template param-bindings
)
1686 (let ((*lexical-variable-values
*
1687 (make-variable-value-array (template-n-variables template
))))
1688 (with-stack-limit ()
1690 for
(name-cons value
) in param-bindings
1691 for
(nil index nil
) = (find name-cons
1692 (template-params template
)
1697 (setf (lexical-variable-value index
) value
)))
1698 (funcall (template-body template
) ctx
))))
1700 (defun apply-default-templates (ctx mode
)
1701 (let ((node (xpath:context-node ctx
)))
1703 ((or (xpath-protocol:node-type-p node
:processing-instruction
)
1704 (xpath-protocol:node-type-p node
:comment
)))
1705 ((or (xpath-protocol:node-type-p node
:text
)
1706 (xpath-protocol:node-type-p node
:attribute
))
1707 (write-text (xpath-protocol:node-text node
)))
1709 (apply-templates/list
1711 (xpath-protocol:child-pipe node
))
1714 (defvar *apply-imports
*)
1716 (defun apply-applicable-templates (ctx templates param-bindings finally
)
1717 (labels ((apply-imports (&optional actual-param-bindings
)
1719 (let* ((this (pop templates
))
1720 (low (template-apply-imports-limit this
))
1721 (high (template-import-priority this
)))
1725 (<= low
(template-import-priority x
) high
))
1727 (invoke-template ctx this actual-param-bindings
))
1728 (funcall finally
))))
1729 (let ((*apply-imports
* #'apply-imports
))
1730 (apply-imports param-bindings
))))
1732 (defun apply-templates (ctx &key param-bindings mode
)
1733 (apply-applicable-templates ctx
1734 (find-templates ctx
(or mode
*default-mode
*))
1737 (apply-default-templates ctx mode
))))
1739 (defun call-template (ctx name
&optional param-bindings
)
1740 (apply-applicable-templates ctx
1741 (find-named-templates name
)
1744 (xslt-error "cannot find named template: ~s"
1747 (defun find-templates (ctx mode
)
1748 (let* ((matching-candidates
1749 (xpattern:matching-values
(mode-match-thunk mode
)
1750 (xpath:context-node ctx
)))
1752 (if matching-candidates
1755 :key
#'template-import-priority
))
1757 (priority-groups (make-array npriorities
:initial-element nil
)))
1758 (dolist (template matching-candidates
)
1760 (elt priority-groups
(template-import-priority template
))))
1762 for i from
(1- npriorities
) downto
0
1763 for group
= (elt priority-groups i
)
1764 for template
= (maximize #'template
< group
)
1768 (defun find-named-templates (name)
1769 (gethash name
(stylesheet-named-templates *stylesheet
*)))
1771 (defun template< (a b
) ;assuming same import priority
1772 (let ((p (template-priority a
))
1773 (q (template-priority b
)))
1778 (xslt-cerror "conflicting templates:~_~A,~_~A"
1779 (template-match-expression a
)
1780 (template-match-expression b
))
1781 (< (template-position a
) (template-position b
))))))
1783 (defun maximize (< things
)
1785 (let ((max (car things
)))
1786 (dolist (other (cdr things
))
1787 (when (funcall < max other
)
1791 (defun invoke-with-output-sink (fn output-spec output
)
1794 (with-open-file (s output
1796 :element-type
'(unsigned-byte 8)
1797 :if-exists
:rename-and-delete
)
1798 (invoke-with-output-sink fn output-spec s
)))
1800 (invoke-with-output-sink fn
1802 (make-output-sink output-spec output
)))
1803 ((or hax
:abstract-handler sax
:abstract-handler
)
1804 (with-xml-output output
1805 (when (typep output
'(or combi-sink auto-detect-sink
))
1806 (sax:start-dtd output
1807 :autodetect-me-please
1808 (output-doctype-public output-spec
)
1809 (output-doctype-system output-spec
)))
1812 (defun make-output-sink (output-spec stream
)
1815 (let ((et (stream-element-type stream
)))
1817 ((or (null et
) (subtypep et
'(unsigned-byte 8)))
1818 (runes:make-octet-stream-ystream stream
))
1819 ((subtypep et
'character
)
1820 (runes:make-character-stream-ystream stream
))))
1821 (runes:make-rod-ystream
)))
1822 (omit-xml-declaration-p
1823 (boolean-or-error (output-omit-xml-declaration output-spec
)))
1824 (sink-encoding (or (output-encoding output-spec
) "UTF-8"))
1827 (setf (runes:ystream-encoding ystream
)
1828 (cxml::find-output-encoding sink-encoding
))
1829 (make-instance 'cxml
::sink
1831 :omit-xml-declaration-p omit-xml-declaration-p
1832 :encoding sink-encoding
))))
1833 (flet ((make-combi-sink ()
1834 (make-instance 'combi-sink
1835 :hax-target
(make-instance 'chtml
::sink
1837 :sax-target sax-target
1838 :media-type
(output-media-type output-spec
)
1839 :encoding sink-encoding
)))
1840 (let ((method-key (output-method output-spec
)))
1842 ((and (eq method-key
:html
)
1843 (null (output-doctype-system output-spec
))
1844 (null (output-doctype-public output-spec
)))
1846 ((eq method-key
:text
)
1847 (make-text-filter sax-target
))
1848 ((and (eq method-key
:xml
)
1849 (null (output-doctype-system output-spec
)))
1852 (make-auto-detect-sink (make-combi-sink) method-key
)))))))
1868 (defun expression-priority (form)
1869 (let ((step (second form
)))
1870 (if (and (null (cddr form
))
1872 (member (car step
) '(:child
:attribute
))
1874 (let ((name (second step
)))
1878 (or (eq (car name
) :qname
)
1879 (eq (car name
) :processing-instruction
))))
1882 (or (eq (car name
) :namespace
)
1883 (eq (car name
) '*)))
1889 (defun parse-key-pattern (str)
1890 (with-resignalled-errors ()
1891 (with-forward-compatible-errors
1892 (xpath:parse-xpath
"compile-time-error()") ;hack
1894 (mapcar #'(lambda (item)
1895 `(:path
(:root
:node
)
1896 (:descendant-or-self
:node
)
1898 (cdr (xpath::parse-pattern-expression str
)))))
1899 (if (null (rest parsed
))
1901 `(:union
,@parsed
))))))
1903 (defun compile-value-thunk (value env
)
1904 (if (and (listp value
) (eq (car value
) 'progn
))
1905 (let ((inner-thunk (compile-instruction value env
)))
1907 (apply-to-result-tree-fragment ctx inner-thunk
)))
1908 (compile-xpath value env
)))
1910 (defun compile-var-binding (name value env
)
1911 (multiple-value-bind (local-name uri
)
1912 (decode-qname name env nil
)
1913 (let ((thunk (xslt-trace-thunk
1914 (compile-value-thunk value env
)
1915 "local variable ~s = ~s" name
:result
)))
1916 (list (cons local-name uri
)
1917 (push-variable local-name
1919 *lexical-variable-declarations
*)
1922 (defun compile-var-bindings (forms env
)
1924 for
(name value
) in forms
1925 collect
(compile-var-binding name value env
)))
1927 (defmacro sometimes-with-attributes
((&rest attrs
) node
&body body
)
1930 (if *forwards-compatible-p
*
1931 (stp:with-attributes
(,@attrs
) ,x
,@body
)
1932 (only-with-attributes (,@attrs
) ,x
,@body
)))))
1934 (defun compile-template (<template
> env position
)
1935 (sometimes-with-attributes (match name priority mode
) <template
>
1936 (unless (or name match
)
1937 (xslt-error "missing match in template"))
1938 (multiple-value-bind (params body-pos
)
1941 for child in
(stp:list-children
<template
>)
1942 while
(namep child
"param")
1943 collect
(parse-param child
) into params
1944 finally
(return (values params i
)))
1945 (let* ((*lexical-variable-declarations
* (make-empty-declaration-array))
1946 (param-bindings (compile-var-bindings params env
))
1947 (body (parse-body <template
> body-pos
(mapcar #'car params
)))
1948 (body-thunk (compile-instruction `(progn ,@body
) env
))
1954 ;; set params that weren't initialized by apply-templates
1955 (loop for
(name index param-thunk
) in param-bindings
1956 when
(eq (lexical-variable-value index nil
) 'unbound
)
1957 do
(setf (lexical-variable-value index
)
1958 (funcall param-thunk ctx
)))
1959 (funcall body-thunk ctx
))))
1960 "template: match = ~s name = ~s" match name
))
1961 (n-variables (length *lexical-variable-declarations
*)))
1964 (multiple-value-bind (local-name uri
)
1965 (decode-qname name env nil
)
1967 (make-template :name
(cons local-name uri
)
1968 :import-priority
*import-priority
*
1969 :apply-imports-limit
*apply-imports-limit
*
1970 :params param-bindings
1971 :body outer-body-thunk
1972 :n-variables n-variables
))))
1974 (mapcar (lambda (expression)
1975 (let* ((compiled-pattern
1977 (car (without-xslt-current ()
1978 (xpattern:compute-patterns
1979 `(:patterns
,expression
)
1983 "match-thunk for template (match ~s): ~s --> ~s"
1984 match expression
:result
))
1986 (xpath::parse-xnum priority
)
1987 (expression-priority expression
)))
1990 (unless (and (numberp p
)
1991 (not (xpath::inf-p p
))
1992 (not (xpath::nan-p p
)))
1993 (xslt-error "failed to parse priority"))
1996 (make-template :match-expression expression
1997 :compiled-pattern compiled-pattern
1998 :import-priority
*import-priority
*
1999 :apply-imports-limit
*apply-imports-limit
*
2003 :params param-bindings
2004 :body outer-body-thunk
2005 :n-variables n-variables
)))
2006 (setf (xpattern:pattern-value compiled-pattern
)
2009 (cdr (xpattern:parse-pattern-expression match
)))))))))
2011 (xuriella::parse-stylesheet
#p
"/home/david/src/lisp/xuriella/test.xsl")