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 (setf (stp:base-uri new-template
) (stp:base-uri literal-result-element
))
528 new-document-element
))
530 (defun parse-stylesheet-to-stp (input uri-resolver
)
531 (let* ((d (cxml:parse input
(make-text-normalizer (cxml-stp:make-builder
))))
532 (<transform
> (stp:document-element d
)))
533 (unless (equal (stp:namespace-uri
<transform
>) *xsl
*)
534 (setf <transform
> (unwrap-2.3 d
)))
535 (strip-stylesheet <transform
>)
536 (unless (and (equal (stp:namespace-uri
<transform
>) *xsl
*)
537 (or (equal (stp:local-name
<transform
>) "transform")
538 (equal (stp:local-name
<transform
>) "stylesheet")))
539 (xslt-error "not a stylesheet"))
540 (check-for-invalid-attributes
542 ("exclude-result-prefixes" .
"")
543 ("extension-element-prefixes" .
"")
544 ("space" .
"http://www.w3.org/XML/1998/namespace")
548 (or (stp:find-child-if
(of-name "stylesheet") <transform
>)
549 (stp:find-child-if
(of-name "transform") <transform
>))))
551 (xslt-error "invalid top-level element ~A" (stp:local-name invalid
))))
552 (dolist (include (stp:filter-children
(of-name "include") <transform
>))
553 (let* ((uri (puri:merge-uris
(or (stp:attribute-value include
"href")
554 (xslt-error "include without href"))
555 (stp:base-uri include
)))
556 (uri (if uri-resolver
557 (funcall uri-resolver uri
)
559 (str (puri:render-uri uri nil
))
562 (uri-to-pathname uri
)
563 (cxml:xml-parse-error
(c)
564 (xslt-error "cannot find included stylesheet ~A: ~A"
568 :element-type
'(unsigned-byte 8)
569 :if-does-not-exist nil
)
571 (xslt-error "cannot find included stylesheet ~A at ~A"
573 (when (find str
*xsl-include-stack
* :test
#'equal
)
574 (xslt-error "recursive inclusion of ~A" uri
))
575 (let* ((*xsl-include-stack
* (cons str
*xsl-include-stack
*))
576 (<transform
>2 (parse-stylesheet-to-stp stream uri-resolver
)))
577 (stp:insert-child-after
<transform
>
578 (stp:copy
<transform
>2)
580 (stp:detach include
)))))
583 (defvar *instruction-base-uri
*) ;misnamed, is also used in other attributes
584 (defvar *apply-imports-limit
*)
585 (defvar *import-priority
*)
586 (defvar *extension-namespaces
*)
588 (defmacro do-toplevel
((var xpath
<transform
>) &body body
)
589 `(map-toplevel (lambda (,var
) ,@body
) ,xpath
,<transform
>))
591 (defun map-toplevel (fn xpath
<transform
>)
592 (dolist (node (list-toplevel xpath
<transform
>))
593 (let ((*namespaces
* *initial-namespaces
*))
594 (xpath:do-node-set
(ancestor (xpath:evaluate
"ancestor::node()" node
))
595 (xpath:with-namespaces
(("" #.
*xsl
*))
596 (when (xpattern:node-matches-p ancestor
"stylesheet|transform")
597 ;; discard namespaces from including stylesheets
598 (setf *namespaces
* *initial-namespaces
*)))
599 (when (xpath-protocol:node-type-p ancestor
:element
)
600 (setf *namespaces
* (acons-namespaces ancestor
*namespaces
* t
))))
603 (defun list-toplevel (xpath <transform
>)
604 (labels ((recurse (sub)
607 (xpath:evaluate
"transform|stylesheet" sub
))))
609 (xpath-sys:pipe-of
(xpath:evaluate xpath sub
))
610 (xpath::mappend-pipe
#'recurse subsubs
)))))
611 (xpath::sort-nodes
(recurse <transform
>))))
613 (defmacro with-import-magic
((node env
) &body body
)
614 `(invoke-with-import-magic (lambda () ,@body
) ,node
,env
))
616 (defun invoke-with-import-magic (fn node env
)
617 (unless (or (namep node
"stylesheet") (namep node
"transform"))
618 (setf node
(stp:parent node
)))
619 (let ((*excluded-namespaces
* (list *xsl
*))
620 (*extension-namespaces
* '())
621 (*forwards-compatible-p
*
622 (not (equal (stp:attribute-value node
"version") "1.0"))))
623 (parse-exclude-result-prefixes! node env
)
624 (parse-extension-element-prefixes! node env
)
627 (defun parse-1-stylesheet (env stylesheet designator uri-resolver
)
628 (let* ((<transform
> (parse-stylesheet-to-stp designator uri-resolver
))
629 (instruction-base-uri (stp:base-uri
<transform
>))
630 (namespaces (acons-namespaces <transform
>))
631 (apply-imports-limit (1+ *import-priority
*))
633 (let ((*namespaces
* namespaces
))
634 (invoke-with-import-magic (constantly t
) <transform
> env
))
635 (do-toplevel (elt "node()" <transform
>)
636 (let ((version (stp:attribute-value
(stp:parent elt
) "version")))
639 (xslt-error "stylesheet lacks version"))
640 ((equal version
"1.0")
641 (if (typep elt
'stp
:element
)
642 (when (or (equal (stp:namespace-uri elt
) "")
643 (and (equal (stp:namespace-uri elt
) *xsl
*)
644 (not (find (stp:local-name elt
)
645 '("key" "template" "output"
646 "strip-space" "preserve-space"
647 "attribute-set" "namespace-alias"
648 "decimal-format" "variable" "param"
650 ;; for include handling:
651 "stylesheet" "transform")
653 (xslt-error "unknown top-level element ~A" (stp:local-name elt
)))
654 (xslt-error "text at top-level"))))))
655 (macrolet ((with-specials ((&optional
) &body body
)
656 `(let ((*instruction-base-uri
* instruction-base-uri
)
657 (*namespaces
* namespaces
)
658 (*apply-imports-limit
* apply-imports-limit
))
661 (do-toplevel (import "import" <transform
>)
662 (when (let ((prev (xpath:first-node
663 (xpath:evaluate
"preceding-sibling::*"
666 (and prev
(not (namep prev
"import"))))
667 (xslt-error "import not at beginning of stylesheet"))
668 (let ((uri (puri:merge-uris
(or (stp:attribute-value import
"href")
669 (xslt-error "import without href"))
670 (stp:base-uri import
))))
671 (push (parse-imported-stylesheet env stylesheet uri uri-resolver
)
673 (let ((import-priority
674 (incf *import-priority
*))
675 (var-cont (prepare-global-variables stylesheet
<transform
>)))
676 (parse-namespace-aliases! stylesheet
<transform
> env
)
677 ;; delay the rest of compilation until we've seen all global
680 (mapc #'funcall
(nreverse continuations
))
682 (let ((*import-priority
* import-priority
))
684 (parse-keys! stylesheet
<transform
> env
)
685 (parse-templates! stylesheet
<transform
> env
)
686 (parse-output! stylesheet
<transform
> env
)
687 (parse-strip/preserve-space
! stylesheet
<transform
> env
)
688 (parse-attribute-sets! stylesheet
<transform
> env
)
689 (parse-decimal-formats! stylesheet
<transform
> env
))))))))
691 (defvar *xsl-import-stack
* nil
)
693 (defun parse-imported-stylesheet (env stylesheet uri uri-resolver
)
694 (let* ((uri (if uri-resolver
695 (funcall uri-resolver uri
)
697 (str (puri:render-uri uri nil
))
700 (uri-to-pathname uri
)
701 (cxml:xml-parse-error
(c)
702 (xslt-error "cannot find imported stylesheet ~A: ~A"
706 :element-type
'(unsigned-byte 8)
707 :if-does-not-exist nil
)
709 (xslt-error "cannot find imported stylesheet ~A at ~A"
711 (when (find str
*xsl-import-stack
* :test
#'equal
)
712 (xslt-error "recursive inclusion of ~A" uri
))
713 (let ((*xsl-import-stack
* (cons str
*xsl-import-stack
*)))
714 (parse-1-stylesheet env stylesheet stream uri-resolver
)))))
716 (defvar *included-attribute-sets
*)
718 (defvar *stylesheet
*)
720 (defun parse-stylesheet (designator &key uri-resolver
)
721 "@arg[designator]{an XML designator}
722 @arg[uri-resolver]{optional function of one argument}
723 @return{An instance of @class{stylesheet}.}
725 @short{Parse a stylesheet.}
727 This function parses and compiles an XSLT stylesheet.
728 The precompiled stylesheet object can then be passed to
729 @fun{apply-stylesheet}.
731 Also refer to @fun{apply-stylesheet} for details on XML designators."
732 (with-resignalled-errors ()
733 (xpath:with-namespaces
((nil #.
*xsl
*))
734 (let* ((*import-priority
* 0)
735 (xpattern:*allow-variables-in-patterns
* nil
)
736 (puri:*strict-parse
* nil
)
737 (stylesheet (make-stylesheet))
739 ;; zzz this is for remove-excluded-namespaces only
741 (env (make-instance 'lexical-xslt-environment
))
742 (*excluded-namespaces
* *excluded-namespaces
*)
743 (*global-variable-declarations
* (make-empty-declaration-array))
744 (*included-attribute-sets
* nil
))
745 (ensure-mode stylesheet nil
)
746 (funcall (parse-1-stylesheet env stylesheet designator uri-resolver
))
747 ;; reverse attribute sets:
748 (let ((table (stylesheet-attribute-sets stylesheet
)))
749 (maphash (lambda (k v
)
750 (setf (gethash k table
) (nreverse v
)))
753 (dolist (sets *included-attribute-sets
*)
754 (loop for
(local-name uri nil
) in sets do
755 (find-attribute-set local-name uri stylesheet
)))
757 (unless (find-decimal-format "" "" stylesheet nil
)
758 (setf (find-decimal-format "" "" stylesheet
)
759 (make-decimal-format)))
760 ;; compile a template matcher for each mode:
762 for mode being each hash-value in
(stylesheet-modes stylesheet
)
764 (setf (mode-match-thunk mode
)
765 (xpattern:make-pattern-matcher
766 (mapcar #'template-compiled-pattern
767 (mode-templates mode
)))))
768 ;; and for the strip tests
769 (setf (stylesheet-strip-thunk stylesheet
)
770 (let ((patterns (stylesheet-strip-tests stylesheet
)))
772 (xpattern:make-pattern-matcher
773 (mapcar #'strip-test-compiled-pattern patterns
)))))
776 (defun parse-attribute-sets! (stylesheet <transform
> env
)
777 (do-toplevel (elt "attribute-set" <transform
>)
778 (with-import-magic (elt env
)
780 (mapcar (lambda (qname)
781 (multiple-value-list (decode-qname qname env nil
)))
783 (stp:attribute-value elt
"use-attribute-sets"))))
789 (and (typep child
'stp
:element
)
790 (or (and (equal (stp:namespace-uri child
) *xsl
*)
791 (equal (stp:local-name child
)
793 (find (stp:namespace-uri child
)
794 *extension-namespaces
*
796 (xslt-error "non-attribute found in attribute set"))
797 (parse-instruction child
))
799 (*lexical-variable-declarations
*
800 (make-empty-declaration-array))
802 (compile-instruction `(progn ,@instructions
) env
))
803 (n-variables (length *lexical-variable-declarations
*)))
804 (push sets
*included-attribute-sets
*)
807 (loop for
(local-name uri nil
) in sets do
808 (dolist (thunk (find-attribute-set local-name uri
))
809 (funcall thunk ctx
)))
810 (let ((*lexical-variable-values
*
811 (make-variable-value-array n-variables
)))
812 (funcall thunk ctx
)))))
813 (gethash (multiple-value-bind (local-name uri
)
814 (decode-qname (or (stp:attribute-value elt
"name")
815 (xslt-error "missing name"))
818 (cons local-name uri
))
819 (stylesheet-attribute-sets stylesheet
))))))
821 (defun parse-namespace-aliases! (stylesheet <transform
> env
)
822 (do-toplevel (elt "namespace-alias" <transform
>)
823 (let ((*namespaces
* (acons-namespaces elt
)))
824 (only-with-attributes (stylesheet-prefix result-prefix
) elt
825 (unless stylesheet-prefix
826 (xslt-error "missing stylesheet-prefix in namespace-alias"))
827 (unless result-prefix
828 (xslt-error "missing result-prefix in namespace-alias"))
830 (if (equal stylesheet-prefix
"#default")
832 (or (xpath-sys:environment-find-namespace
835 (xslt-error "stylesheet namespace not found in alias: ~A"
837 (stylesheet-namespace-aliases stylesheet
))
838 (or (xpath-sys:environment-find-namespace
840 (if (equal result-prefix
"#default")
843 (xslt-error "result namespace not found in alias: ~A"
846 (defun parse-decimal-formats! (stylesheet <transform
> env
)
847 (do-toplevel (elt "decimal-format" <transform
>)
848 (stp:with-attributes
(name
862 (multiple-value-bind (local-name uri
)
864 (decode-qname name env nil
)
866 (let ((current (find-decimal-format local-name uri stylesheet nil
))
871 (unless (eql (length x
) 1)
872 (xslt-error "not a single character: ~A" x
))
873 (let ((chr (elt x
0)))
874 (when (find chr seen
)
876 "conflicting decimal format characters: ~A"
883 (apply #'make-decimal-format
884 (append (str :infinity infinity
)
886 (chr :decimal-separator decimal-separator
)
887 (chr :grouping-separator grouping-separator
)
888 (chr :zero-digit zero-digit
)
889 (chr :percent percent
)
890 (chr :per-mille per-mille
)
892 (chr :pattern-separator pattern-separator
)
893 (chr :minus-sign minus-sign
)))))))
895 (unless (decimal-format= current new
)
896 (xslt-error "decimal format mismatch for ~S" local-name
))
897 (setf (find-decimal-format local-name uri stylesheet
) new
)))))))
899 (defun parse-exclude-result-prefixes! (node env
)
900 (stp:with-attributes
(exclude-result-prefixes)
902 (dolist (prefix (words (or exclude-result-prefixes
"")))
903 (if (equal prefix
"#default")
905 (unless (cxml-stp-impl::nc-name-p prefix
)
906 (xslt-error "invalid prefix: ~A" prefix
)))
907 (push (or (xpath-sys:environment-find-namespace env prefix
)
908 (xslt-error "namespace not found: ~A" prefix
))
909 *excluded-namespaces
*))))
911 (defun parse-extension-element-prefixes! (node env
)
912 (stp:with-attributes
(extension-element-prefixes)
914 (dolist (prefix (words (or extension-element-prefixes
"")))
915 (if (equal prefix
"#default")
917 (unless (cxml-stp-impl::nc-name-p prefix
)
918 (xslt-error "invalid prefix: ~A" prefix
)))
920 (or (xpath-sys:environment-find-namespace env prefix
)
921 (xslt-error "namespace not found: ~A" prefix
))))
922 (unless (equal uri
*xsl
*)
923 (push uri
*extension-namespaces
*)
924 (push uri
*excluded-namespaces
*))))))
926 (defun parse-nametest-tokens (str)
927 (labels ((check (boolean)
929 (xslt-error "invalid nametest token")))
930 (check-null (boolean)
931 (check (not boolean
))))
934 (mapcar (lambda (name-test)
935 (destructuring-bind (&optional path
&rest junk
)
936 (cdr (xpattern:parse-pattern-expression name-test
))
938 (check (eq (car path
) :path
))
939 (destructuring-bind (&optional child
&rest junk
) (cdr path
)
941 (check (eq (car child
) :child
))
942 (destructuring-bind (nodetest &rest junk
) (cdr child
)
944 (check (or (stringp nodetest
)
946 (and (consp nodetest
)
947 (or (eq (car nodetest
) :namespace
)
948 (eq (car nodetest
) :qname
)))))))
952 (defstruct strip-test
958 (defun parse-strip/preserve-space
! (stylesheet <transform
> env
)
960 (do-toplevel (elt "strip-space|preserve-space" <transform
>)
961 (let ((*namespaces
* (acons-namespaces elt
))
963 (if (equal (stp:local-name elt
) "strip-space")
967 (cdr (parse-nametest-tokens
968 (stp:attribute-value elt
"elements"))))
969 (let* ((compiled-pattern
970 (car (without-xslt-current ()
971 (xpattern:compute-patterns
972 `(:patterns
,expression
)
977 (make-strip-test :compiled-pattern compiled-pattern
978 :priority
(expression-priority expression
)
981 (setf (xpattern:pattern-value compiled-pattern
) strip-test
)
982 (push strip-test
(stylesheet-strip-tests stylesheet
)))))
985 (defstruct (output-specification
986 (:conc-name
"OUTPUT-"))
993 cdata-section-matchers
997 (defun parse-output! (stylesheet <transform
> env
)
998 (dolist (<output
> (list-toplevel "output" <transform
>))
999 (let ((spec (stylesheet-output-specification stylesheet
)))
1000 (only-with-attributes (version
1007 omit-xml-declaration
1009 cdata-section-elements
)
1011 (declare (ignore version
))
1013 (multiple-value-bind (local-name uri
)
1014 (decode-qname method env t
)
1015 (setf (output-method spec
)
1016 (if (plusp (length uri
))
1019 ((equalp local-name
"HTML") :html
)
1020 ((equalp local-name
"TEXT") :text
)
1021 ((equalp local-name
"XML") :xml
)
1023 (xslt-error "invalid output method: ~A" method
)))))))
1025 (setf (output-indent spec
) indent
))
1027 (setf (output-encoding spec
) encoding
))
1028 (when doctype-system
1029 (setf (output-doctype-system spec
) doctype-system
))
1030 (when doctype-public
1031 (setf (output-doctype-public spec
) doctype-public
))
1032 (when omit-xml-declaration
1033 (setf (output-omit-xml-declaration spec
) omit-xml-declaration
))
1034 (when cdata-section-elements
1035 (dolist (qname (words cdata-section-elements
))
1036 (decode-qname qname env nil
) ;check the syntax
1037 (push (xpattern:make-pattern-matcher
* qname env
)
1038 (output-cdata-section-matchers spec
))))
1040 (setf (output-standalone-p spec
)
1041 (boolean-or-error standalone
)))
1043 (setf (output-media-type spec
) media-type
))))))
1045 (defun make-empty-declaration-array ()
1046 (make-array 1 :fill-pointer
0 :adjustable t
))
1048 (defun make-variable-value-array (n-lexical-variables)
1049 (make-array n-lexical-variables
:initial-element
'unbound
))
1051 (defun compile-global-variable (<variable
> env
) ;; also for <param>
1052 (stp:with-attributes
(name select
) <variable
>
1053 (when (and select
(stp:list-children
<variable
>))
1054 (xslt-error "variable with select and body"))
1055 (let* ((*lexical-variable-declarations
* (make-empty-declaration-array))
1058 (compile-xpath select env
))
1059 ((stp:list-children
<variable
>)
1060 (let* ((inner-sexpr `(progn ,@(parse-body <variable
>)))
1061 (inner-thunk (compile-instruction inner-sexpr env
)))
1063 (apply-to-result-tree-fragment ctx inner-thunk
))))
1066 (declare (ignore ctx
))
1068 (n-lexical-variables (length *lexical-variable-declarations
*)))
1071 (let* ((*lexical-variable-values
*
1072 (make-variable-value-array n-lexical-variables
)))
1073 (funcall inner ctx
)))
1074 "global ~s (~s) = ~s" name select
:result
))))
1076 (defstruct (variable-chain
1077 (:constructor make-variable-chain
)
1078 (:conc-name
"VARIABLE-CHAIN-"))
1085 (defstruct (import-variable
1086 (:constructor make-variable
)
1087 (:conc-name
"VARIABLE-"))
1092 (defun parse-global-variable! (stylesheet <variable
> global-env
)
1093 (let* ((*namespaces
* (acons-namespaces <variable
>))
1094 (instruction-base-uri (stp:base-uri
<variable
>))
1095 (*instruction-base-uri
* instruction-base-uri
)
1096 (*excluded-namespaces
* (list *xsl
*))
1097 (*extension-namespaces
* '())
1098 (qname (stp:attribute-value
<variable
> "name")))
1099 (with-import-magic (<variable
> global-env
)
1101 (xslt-error "name missing in ~A" (stp:local-name
<variable
>)))
1102 (multiple-value-bind (local-name uri
)
1103 (decode-qname qname global-env nil
)
1104 ;; For the normal compilation environment of templates, install it
1105 ;; into *GLOBAL-VARIABLE-DECLARATIONS*:
1106 (let ((index (intern-global-variable local-name uri
)))
1107 ;; For the evaluation of a global variable itself, build a thunk
1108 ;; that lazily resolves other variables, stored into
1109 ;; INITIAL-GLOBAL-VARIABLE-THUNKS:
1110 (let* ((value-thunk :unknown
)
1111 (sgv (stylesheet-global-variables stylesheet
))
1113 (if (< index
(length sgv
))
1115 (make-variable-chain
1117 :local-name local-name
1119 (next (car (variable-chain-definitions chain
)))
1120 (global-variable-thunk
1122 (let ((v (global-variable-value index nil
)))
1126 (xslt-error "no next definition for: ~A"
1128 (funcall (variable-value-thunk next
) ctx
))
1130 (setf (global-variable-value index
) 'seen
)
1131 (setf (global-variable-value index
)
1132 (funcall value-thunk ctx
)))
1135 (excluded-namespaces *excluded-namespaces
*)
1136 (extension-namespaces *extension-namespaces
*)
1138 (make-variable :param-p
(namep <variable
> "param")))
1139 (forwards-compatible-p *forwards-compatible-p
*)
1142 (let* ((*instruction-base-uri
* instruction-base-uri
)
1143 (*excluded-namespaces
* excluded-namespaces
)
1144 (*extension-namespaces
* extension-namespaces
)
1145 (*forwards-compatible-p
* forwards-compatible-p
)
1147 (compile-global-variable <variable
> global-env
)))
1148 (setf value-thunk fn
)
1149 (setf (variable-value-thunk variable
) fn
)))))
1150 (setf (variable-value-thunk-setter variable
)
1152 (setf (gethash (cons local-name uri
)
1153 (initial-global-variable-thunks global-env
))
1154 global-variable-thunk
)
1155 (setf (variable-chain-thunk chain
) global-variable-thunk
)
1156 (push variable
(variable-chain-definitions chain
))
1159 (defun parse-keys! (stylesheet <transform
> env
)
1160 (xpath:with-namespaces
((nil #.
*xsl
*))
1161 (do-toplevel (<key
> "key" <transform
>)
1162 (with-import-magic (<key
> env
)
1163 (let ((*instruction-base-uri
* (stp:base-uri
<key
>)))
1164 (only-with-attributes (name match use
) <key
>
1165 (unless name
(xslt-error "key name attribute not specified"))
1166 (unless match
(xslt-error "key match attribute not specified"))
1167 (unless use
(xslt-error "key use attribute not specified"))
1168 (multiple-value-bind (local-name uri
)
1169 (decode-qname name env nil
)
1171 (cons local-name uri
)
1172 (compile-xpath `(xpath:xpath
,(parse-key-pattern match
))
1175 (make-instance 'key-environment
))))))))))
1177 (defun prepare-global-variables (stylesheet <transform
>)
1178 (xpath:with-namespaces
((nil #.
*xsl
*))
1179 (let* ((igvt (stylesheet-initial-global-variable-thunks stylesheet
))
1180 (global-env (make-instance 'global-variable-environment
1181 :initial-global-variable-thunks igvt
))
1183 (do-toplevel (<variable
> "variable|param" <transform
>)
1185 (parse-global-variable! stylesheet
<variable
> global-env
)))
1186 (xslt-trace "parsing global variable ~s (uri ~s)"
1187 (variable-chain-local-name chain
)
1188 (variable-chain-uri chain
))
1192 (and (equal (variable-chain-local-name a
)
1193 (variable-chain-local-name b
))
1194 (equal (variable-chain-uri a
)
1195 (variable-chain-uri b
)))))
1196 (xslt-error "duplicate definition for global variable ~A"
1197 (variable-chain-local-name chain
)))
1198 (push chain chains
)))
1199 (setf chains
(nreverse chains
))
1200 (let ((table (stylesheet-global-variables stylesheet
))
1201 (newlen (length *global-variable-declarations
*)))
1202 (adjust-array table newlen
:fill-pointer newlen
)
1203 (dolist (chain chains
)
1204 (setf (elt table
(variable-chain-index chain
)) chain
)))
1206 ;; now that the global environment knows about all variables, run the
1207 ;; thunk setters to perform their compilation
1208 (mapc (lambda (chain)
1209 (dolist (var (variable-chain-definitions chain
))
1210 (funcall (variable-value-thunk-setter var
))))
1213 (defun parse-templates! (stylesheet <transform
> env
)
1215 (do-toplevel (<template
> "template" <transform
>)
1216 (let ((*namespaces
* (acons-namespaces <template
>))
1217 (*instruction-base-uri
* (stp:base-uri
<template
>)))
1218 (with-import-magic (<template
> env
)
1219 (dolist (template (compile-template <template
> env i
))
1220 (setf (template-stylesheet template
) stylesheet
)
1221 (setf (template-base-uri template
) (stp:base-uri
<template
>))
1222 (let ((name (template-name template
)))
1224 (let* ((table (stylesheet-named-templates stylesheet
))
1225 (head (car (gethash name table
))))
1226 (when (and head
(eql (template-import-priority head
)
1227 (template-import-priority template
)))
1228 ;; fixme: is this supposed to be a run-time error?
1229 (xslt-error "conflicting templates for ~A" name
))
1230 (push template
(gethash name table
)))
1231 (let ((mode (ensure-mode/qname stylesheet
1232 (template-mode-qname template
)
1234 (setf (template-mode template
) mode
)
1235 (push template
(mode-templates mode
))))))))
1239 ;;;; APPLY-STYLESHEET
1241 (deftype xml-designator
() '(or runes
:xstream runes
:rod array stream pathname
))
1243 (defun unalias-uri (uri)
1245 (gethash uri
(stylesheet-namespace-aliases *stylesheet
*)
1247 (check-type result string
)
1250 (defstruct (parameter
1251 (:constructor make-parameter
(value local-name
&optional uri
)))
1256 (setf (documentation 'parameter
'type
)
1257 "The class of top-level parameters to XSLT stylesheets.
1259 Parameters are identified by expanded names, i.e. a namespace URI
1262 Their value is string.
1264 @see-constructor{make-parameter}
1265 @see-slot{parameter-uri}
1266 @see-slot{parameter-local-name}
1267 @see-slot{parameter-value}")
1269 (setf (documentation 'make-parameter
'function
)
1270 "@arg[value]{The parameter's value, a string.}
1271 @arg[local-name]{The parameter's local name, a string.}
1272 @arg[local-name]{The parameter's namespace URI, a string.}
1273 @return{An instance of @class{parameter}.}
1275 @short{Creates a paramater.}
1278 @see{parameter-local-name}
1279 @see{parameter-value}")
1281 (setf (documentation 'parameter-uri
'function
)
1282 "@arg[instance]{An instance of @class{parameter}.}
1284 @return{Returns the parameter's namespace URI.}
1286 @see{parameter-local-name}
1287 @see{parameter-value}")
1289 (setf (documentation 'parameter-local-name
'function
)
1290 "@arg[instance]{An instance of @class{parameter}.}
1292 @return{Returns the parameter's local name.}
1295 @see{parameter-value}")
1297 (setf (documentation 'parameter-value
'function
)
1298 "@arg[instance]{An instance of @class{parameter}.}
1300 @return{Returns the parameter's value.}
1303 @see{parameter-local-name}")
1305 (defun find-parameter-value (local-name uri parameters
)
1306 (dolist (p parameters
)
1307 (when (and (equal (parameter-local-name p
) local-name
)
1308 (equal (parameter-uri p
) uri
))
1309 (return (parameter-value p
)))))
1311 (defvar *uri-resolver
*)
1313 (defun parse-allowing-microsoft-bom (pathname handler
)
1314 (with-open-file (s pathname
:element-type
'(unsigned-byte 8))
1315 (unless (and (eql (read-byte s nil
) #xef
)
1316 (eql (read-byte s nil
) #xbb
)
1317 (eql (read-byte s nil
) #xbf
))
1318 (file-position s
0))
1319 (cxml:parse s handler
)))
1321 (defstruct source-document
1324 (indices (make-hash-table)))
1326 (defvar *uri-to-document
*)
1327 (defvar *root-to-document
*)
1329 (defun %document
(uri-string base-uri
)
1330 (let* ((absolute-uri
1331 (puri:merge-uris uri-string
(or base-uri
"")))
1334 (funcall *uri-resolver
* absolute-uri
)
1338 (uri-to-pathname resolved-uri
)
1339 (cxml:xml-parse-error
(c)
1340 (xslt-error "cannot find referenced document ~A: ~A"
1342 (document (gethash pathname
*uri-to-document
*)))
1345 (make-whitespace-stripper
1347 (parse-allowing-microsoft-bom pathname
1349 ((or file-error cxml
:xml-parse-error
) (c)
1350 (xslt-error "cannot parse referenced document ~A: ~A"
1352 (stylesheet-strip-thunk *stylesheet
*)))
1353 (id (hash-table-count *root-to-document
*)))
1354 (setf document
(make-source-document :id id
:root-node root-node
))
1355 (setf (gethash pathname
*uri-to-document
*) document
)
1356 (setf (gethash root-node
*root-to-document
*) document
)))
1357 (when (puri:uri-fragment absolute-uri
)
1358 (xslt-error "use of fragment identifiers in document() not supported"))
1359 (source-document-root-node document
)))
1361 (xpath-sys:define-extension xslt
*xsl
*)
1363 (defun document-base-uri (node)
1364 (xpath-protocol:base-uri
1366 ((xpath-protocol:node-type-p node
:document
)
1367 (xpath::find-in-pipe-if
1369 (xpath-protocol:node-type-p x
:element
))
1370 (xpath-protocol:child-pipe node
)))
1371 ((xpath-protocol:node-type-p node
:element
)
1374 (xpath-protocol:parent-node node
)))))
1376 (xpath-sys:define-xpath-function
/lazy
1378 (object &optional node-set
)
1379 (let ((instruction-base-uri *instruction-base-uri
*))
1381 (with-profile-counter (*parse-xml-counter
*)
1382 (let* ((object (funcall object ctx
))
1383 (node-set (and node-set
(funcall node-set ctx
)))
1386 (document-base-uri (xpath::textually-first-node node-set
))
1387 instruction-base-uri
)))
1388 (xpath-sys:make-node-set
1389 (if (xpath:node-set-p object
)
1390 (xpath:map-node-set-
>list
1392 (%document
(xpath:string-value node
)
1395 (document-base-uri node
))))
1397 (list (%document
(xpath:string-value object
) base-uri
)))))))))
1400 (defun build-key-index (document key-conses
)
1401 (let ((index (make-hash-table :test
'equal
)))
1402 (dolist (key key-conses
)
1405 (xpath:evaluate-compiled
(key-match key
)
1407 (source-document-root-node document
))))
1408 (let* ((use-result (xpath:evaluate-compiled
(key-use key
) node
))
1409 (uses (if (xpath:node-set-p use-result
)
1410 (xpath:all-nodes use-result
)
1411 (list use-result
))))
1413 (push node
(gethash (xpath:string-value use
) index
))))))
1416 (defun %key
(document key-conses value
)
1417 (let* ((indices (source-document-indices document
))
1418 (index (or (gethash key-conses indices
)
1419 (setf (gethash key-conses indices
)
1420 (build-key-index document key-conses
)))))
1421 (gethash value index
)))
1423 (xpath-sys:define-xpath-function
/lazy xslt
:key
(name object
)
1424 (let ((namespaces *namespaces
*))
1426 (let* ((qname (xpath:string-value
(funcall name ctx
)))
1427 (object (funcall object ctx
))
1429 (multiple-value-bind (local-name uri
)
1430 (decode-qname/runtime qname namespaces nil
)
1431 (cons local-name uri
)))
1432 (key-conses (find-key expanded-name
*stylesheet
*)))
1433 (xpath-sys:make-node-set
1434 (labels ((get-by-key (value)
1435 (%key
(node-to-source-document (xpath:context-node ctx
))
1437 (xpath:string-value value
))))
1439 (if (xpath:node-set-p object
)
1440 (xpath::mappend-pipe
#'get-by-key
(xpath-sys:pipe-of object
))
1441 (get-by-key object
)))))))))
1443 ;; FIXME: add alias mechanism for XPath extensions in order to avoid duplication
1445 (xpath-sys:define-xpath-function
/lazy xslt
:current
()
1446 (when *without-xslt-current-p
*
1447 (xslt-error "current() not allowed here"))
1449 (xpath-sys:make-node-set
1450 (xpath-sys:make-pipe
1451 (xpath:context-starting-node ctx
)
1454 (xpath-sys:define-xpath-function
/lazy xslt
:unparsed-entity-uri
(name)
1456 (or (xpath-protocol:unparsed-entity-uri
(xpath:context-node ctx
)
1460 (defun node-to-source-document (node)
1461 (gethash (xpath:first-node
1462 (xpath:evaluate
(xpath:xpath
(:path
(:root
:node
))) node
))
1463 *root-to-document
*))
1465 (defun %get-node-id
(node)
1466 (when (xpath:node-set-p node
)
1467 (setf node
(xpath::textually-first-node node
)))
1470 (source-document-id (node-to-source-document node
))
1471 (xpath-sys:get-node-id node
))))
1473 (xpath-sys:define-xpath-function
/lazy xslt
:generate-id
(&optional node-set-thunk
)
1476 (%get-node-id
(xpath:node-set-value
(funcall node-set-thunk ctx
))))
1478 (%get-node-id
(xpath:context-node ctx
)))))
1480 (declaim (special *builtin-instructions
*))
1482 (xpath-sys:define-xpath-function
/lazy xslt
:element-available
(qname)
1483 (let ((namespaces *namespaces
*)
1484 (extensions *extension-namespaces
*))
1486 (let ((qname (funcall qname ctx
)))
1487 (multiple-value-bind (local-name uri
)
1488 (decode-qname/runtime qname namespaces nil
)
1491 (and (gethash local-name
*builtin-instructions
*) t
))
1492 ((find uri extensions
:test
#'equal
)
1493 (and (find-extension-element local-name uri
) t
))
1497 (xpath-sys:define-xpath-function
/lazy xslt
:function-available
(qname)
1498 (let ((namespaces *namespaces
*))
1500 (let ((qname (funcall qname ctx
)))
1501 (multiple-value-bind (local-name uri
)
1502 (decode-qname/runtime qname namespaces nil
)
1503 (and (zerop (length uri
))
1504 (or (xpath-sys:find-xpath-function local-name
*xsl
*)
1505 (xpath-sys:find-xpath-function local-name uri
))
1508 (xpath-sys:define-xpath-function
/lazy xslt
:system-property
(qname)
1509 (let ((namespaces *namespaces
*))
1511 (let ((qname (xpath:string-value
(funcall qname ctx
))))
1512 (multiple-value-bind (local-name uri
)
1513 (decode-qname/runtime qname namespaces nil
)
1514 (if (equal uri
*xsl
*)
1516 ((equal local-name
"version")
1518 ((equal local-name
"vendor")
1520 ((equal local-name
"vendor-url")
1521 "http://repo.or.cz/w/xuriella.git")
1526 ;; FIXME: should there be separate uri-resolver arguments for stylesheet
1528 (defun apply-stylesheet
1529 (stylesheet source-designator
1530 &key output parameters uri-resolver navigator
)
1531 "@arg[stylesheet]{a stylesheet designator (see below for details)}
1532 @arg[source-designator]{a source document designator (see below for details)}
1533 @arg[output]{optional output sink designator (see below for details)}
1534 @arg[parameters]{a list of @class{parameter} instances}
1535 @arg[uri-resolver]{optional function of one argument}
1536 @arg[navigator]{optional XPath navigator}
1537 @return{The value returned by sax:end-document when called on the
1538 designated output sink.}
1540 @short{Apply a stylesheet to a document.}
1542 This function takes @code{stylesheet} (either a parsed @class{stylesheet}
1543 or a designator for XML file to be parsed) and a source document, specified
1544 using the XML designator @code{source-designator}, and applies the
1545 stylesheet to the document.
1547 An XML designator is any value accepted by @code{cxml:parse}, in particular:
1549 @item{Pathnames -- The file referred to by the pathname will parsed
1551 @item{Stream -- The stream will be parsed using cxml.}
1552 @item{Xstream -- Similar to the stream case, but using cxml's internal
1553 representation of rune streams.}
1554 @item{String -- The string itself will be parsed as an XML document,
1555 and is assumed to have been decoded into characters already.}
1556 @item{Array of (unsigned-byte 8) -- The array itself will be parsed as
1557 an XML document (which has not been decoded yet).}
1560 Note: Since strings are interpreted as documents, namestrings are
1561 not acceptable. Use pathnames instead of namestrings.
1563 An output sink designator is has the following form:
1565 @item{Null -- Designates a string sink. I.e., the result document
1566 of the stylesheet will be returned as a string. This as the default.}
1567 @item{Pathnames -- The file referred to by the pathname will created
1569 @item{Stream -- The stream will be written to.}
1570 @item{SAX or HAX handler -- Events will be sent directly to this sink.}
1573 Note: Specificaton of a sink overrides the specification of XML or HTML
1574 output method in the styl.sheet.
1576 Parameters are identified by names, and have values that are strings.
1577 Top-level parameters of these names are bound accordingly. If a paramater
1578 is not specified, its default value is computed as implemented in the
1579 stylesheet. If parameters are specified that the stylesheet does not
1580 recognize, they will be ignored.
1582 A @code{uri-resolver} is a function taking a PURI object as an argument
1583 and returning a PURI object as a value. The URI resolver will be invoked
1584 for all references to external files, e.g. at compilation time using
1585 xsl:import and xsl:include, and at run-time using the document() function.
1587 The URI resolver can be used to rewrite URLs so that file http:// links
1588 are replaced by file:// links, for example. Another application are
1589 URI resolvers that signal an error instead of returning, for example
1590 so that file:// links forbidden.
1592 The specified @code{navigator} will be passed to XPath protocol functions.
1594 @see{parse-stylesheet}"
1595 (with-profile-counter (*apply-stylesheet-counter
*)
1596 (when (typep stylesheet
'xml-designator
)
1597 (with-profile-counter (*parse-stylesheet-counter
*)
1600 ((cxml:xml-parse-error
1602 (xslt-error "cannot parse stylesheet: ~A" c
))))
1603 (parse-stylesheet stylesheet
:uri-resolver uri-resolver
)))))
1604 (with-resignalled-errors ()
1605 (invoke-with-output-sink
1607 (let* ((*uri-to-document
* (make-hash-table :test
'equal
))
1609 ;; fixme? should be xpath-protocol:node-equal
1610 (make-hash-table :test
'equal
))
1611 (xpath:*navigator
* (or navigator
:default-navigator
))
1612 (puri:*strict-parse
* nil
)
1613 (*stylesheet
* stylesheet
)
1614 (*empty-mode
* (make-mode))
1615 (*default-mode
* (find-mode stylesheet nil
))
1616 (global-variable-chains
1617 (stylesheet-global-variables stylesheet
))
1618 (*global-variable-values
*
1619 (make-variable-value-array (length global-variable-chains
)))
1620 (*uri-resolver
* uri-resolver
)
1622 (if (typep source-designator
'xml-designator
)
1623 (with-profile-counter (*parse-xml-counter
*)
1624 (cxml:parse source-designator
(stp:make-builder
)))
1627 (make-whitespace-stripper
1629 (stylesheet-strip-thunk stylesheet
)))
1630 (ctx (xpath:make-context xpath-root-node
))
1631 (document (make-source-document
1633 :root-node xpath-root-node
)))
1634 (when (pathnamep source-designator
) ;fixme: else use base uri?
1635 (setf (gethash source-designator
*uri-to-document
*) document
))
1636 (setf (gethash xpath-root-node
*root-to-document
*) document
)
1639 (let ((head (car (variable-chain-definitions chain
))))
1640 (when (variable-param-p head
)
1642 (find-parameter-value
1643 (variable-chain-local-name chain
)
1644 (variable-chain-uri chain
)
1647 (setf (global-variable-value
1648 (variable-chain-index chain
))
1650 global-variable-chains
)
1653 (funcall (variable-chain-thunk chain
) ctx
))
1654 global-variable-chains
)
1655 ;; zzz we wouldn't have to mask float traps here if we used the
1656 ;; XPath API properly. Unfortunately I've been using FUNCALL
1657 ;; everywhere instead of EVALUATE, so let's paper over that
1658 ;; at a central place to be sure:
1659 (xpath::with-float-traps-masked
()
1660 (apply-templates ctx
:mode
*default-mode
*))))
1661 (stylesheet-output-specification stylesheet
)
1664 (defun find-attribute-set (local-name uri
&optional
(stylesheet *stylesheet
*))
1665 (or (gethash (cons local-name uri
) (stylesheet-attribute-sets stylesheet
))
1666 (xslt-error "no such attribute set: ~A/~A" local-name uri
)))
1668 (defun apply-templates/list
(list &key param-bindings sort-predicate mode
)
1669 (when sort-predicate
1671 (mapcar #'xpath
:context-node
1672 (stable-sort (contextify-node-list list
)
1674 (let* ((n (length list
))
1675 (s/d
(lambda () n
)))
1680 (apply-templates (xpath:make-context child s
/d i
)
1681 :param-bindings param-bindings
1684 (defvar *stack-limit
* 200)
1686 (defun invoke-with-stack-limit (fn)
1687 (let ((*stack-limit
* (1- *stack-limit
*)))
1688 (unless (plusp *stack-limit
*)
1689 (xslt-error "*stack-limit* reached; stack overflow"))
1692 (defun invoke-template (ctx template param-bindings
)
1693 (let ((*lexical-variable-values
*
1694 (make-variable-value-array (template-n-variables template
))))
1695 (with-stack-limit ()
1697 for
(name-cons value
) in param-bindings
1698 for
(nil index nil
) = (find name-cons
1699 (template-params template
)
1704 (setf (lexical-variable-value index
) value
)))
1705 (funcall (template-body template
) ctx
))))
1707 (defun apply-default-templates (ctx mode
)
1708 (let ((node (xpath:context-node ctx
)))
1710 ((or (xpath-protocol:node-type-p node
:processing-instruction
)
1711 (xpath-protocol:node-type-p node
:comment
)))
1712 ((or (xpath-protocol:node-type-p node
:text
)
1713 (xpath-protocol:node-type-p node
:attribute
))
1714 (write-text (xpath-protocol:node-text node
)))
1716 (apply-templates/list
1718 (xpath-protocol:child-pipe node
))
1721 (defvar *apply-imports
*)
1723 (defun apply-applicable-templates (ctx templates param-bindings finally
)
1724 (labels ((apply-imports (&optional actual-param-bindings
)
1726 (let* ((this (pop templates
))
1727 (low (template-apply-imports-limit this
))
1728 (high (template-import-priority this
)))
1732 (<= low
(template-import-priority x
) high
))
1734 (if *profiling-enabled-p
*
1735 (invoke-template/profile ctx this actual-param-bindings
)
1736 (invoke-template ctx this actual-param-bindings
)))
1737 (funcall finally
))))
1738 (let ((*apply-imports
* #'apply-imports
))
1739 (apply-imports param-bindings
))))
1741 (defun apply-templates (ctx &key param-bindings mode
)
1742 (apply-applicable-templates ctx
1743 (find-templates ctx
(or mode
*default-mode
*))
1746 (apply-default-templates ctx mode
))))
1748 (defun call-template (ctx name
&optional param-bindings
)
1749 (apply-applicable-templates ctx
1750 (find-named-templates name
)
1753 (xslt-error "cannot find named template: ~s"
1756 (defun find-templates (ctx mode
)
1757 (let* ((matching-candidates
1758 (xpattern:matching-values
(mode-match-thunk mode
)
1759 (xpath:context-node ctx
)))
1761 (if matching-candidates
1764 :key
#'template-import-priority
))
1766 (priority-groups (make-array npriorities
:initial-element nil
)))
1767 (dolist (template matching-candidates
)
1769 (elt priority-groups
(template-import-priority template
))))
1771 for i from
(1- npriorities
) downto
0
1772 for group
= (elt priority-groups i
)
1773 for template
= (maximize #'template
< group
)
1777 (defun find-named-templates (name)
1778 (gethash name
(stylesheet-named-templates *stylesheet
*)))
1780 (defun template< (a b
) ;assuming same import priority
1781 (let ((p (template-priority a
))
1782 (q (template-priority b
)))
1787 (xslt-cerror "conflicting templates:~_~A,~_~A"
1788 (template-match-expression a
)
1789 (template-match-expression b
))
1790 (< (template-position a
) (template-position b
))))))
1792 (defun maximize (< things
)
1794 (let ((max (car things
)))
1795 (dolist (other (cdr things
))
1796 (when (funcall < max other
)
1800 (defun invoke-with-output-sink (fn output-spec output
)
1803 (with-open-file (s output
1805 :element-type
'(unsigned-byte 8)
1806 :if-exists
:rename-and-delete
)
1807 (invoke-with-output-sink fn output-spec s
)))
1809 (invoke-with-output-sink fn
1811 (make-output-sink output-spec output
)))
1812 ((or hax
:abstract-handler sax
:abstract-handler
)
1813 (with-xml-output output
1814 (when (typep output
'(or combi-sink auto-detect-sink
))
1815 (sax:start-dtd output
1816 :autodetect-me-please
1817 (output-doctype-public output-spec
)
1818 (output-doctype-system output-spec
)))
1821 (defun make-output-sink (output-spec stream
)
1824 (let ((et (stream-element-type stream
)))
1826 ((or (null et
) (subtypep et
'(unsigned-byte 8)))
1827 (runes:make-octet-stream-ystream stream
))
1828 ((subtypep et
'character
)
1829 (runes:make-character-stream-ystream stream
))))
1830 (runes:make-rod-ystream
)))
1831 (omit-xml-declaration-p
1832 (boolean-or-error (output-omit-xml-declaration output-spec
)))
1833 (sink-encoding (or (output-encoding output-spec
) "UTF-8"))
1836 (setf (runes:ystream-encoding ystream
)
1837 (cxml::find-output-encoding sink-encoding
))
1838 (make-instance 'cxml
::sink
1840 :omit-xml-declaration-p omit-xml-declaration-p
1841 :encoding sink-encoding
))))
1842 (flet ((make-combi-sink ()
1843 (make-instance 'combi-sink
1844 :hax-target
(make-instance 'chtml
::sink
1846 :sax-target sax-target
1847 :media-type
(output-media-type output-spec
)
1848 :encoding sink-encoding
)))
1849 (let ((method-key (output-method output-spec
)))
1851 ((and (eq method-key
:html
)
1852 (null (output-doctype-system output-spec
))
1853 (null (output-doctype-public output-spec
)))
1855 ((eq method-key
:text
)
1856 (make-text-filter sax-target
))
1857 ((and (eq method-key
:xml
)
1858 (null (output-doctype-system output-spec
)))
1861 (make-auto-detect-sink (make-combi-sink) method-key
)))))))
1876 ;; for profiling output only:
1881 (defun expression-priority (form)
1882 (let ((step (second form
)))
1883 (if (and (null (cddr form
))
1885 (member (car step
) '(:child
:attribute
))
1887 (let ((name (second step
)))
1891 (or (eq (car name
) :qname
)
1892 (eq (car name
) :processing-instruction
))))
1895 (or (eq (car name
) :namespace
)
1896 (eq (car name
) '*)))
1902 (defun parse-key-pattern (str)
1903 (with-resignalled-errors ()
1904 (with-forward-compatible-errors
1905 (xpath:parse-xpath
"compile-time-error()") ;hack
1907 (mapcar #'(lambda (item)
1908 `(:path
(:root
:node
)
1909 (:descendant-or-self
:node
)
1911 (cdr (xpath::parse-pattern-expression str
)))))
1912 (if (null (rest parsed
))
1914 `(:union
,@parsed
))))))
1916 (defun compile-value-thunk (value env
)
1917 (if (and (listp value
) (eq (car value
) 'progn
))
1918 (let ((inner-thunk (compile-instruction value env
)))
1920 (apply-to-result-tree-fragment ctx inner-thunk
)))
1921 (compile-xpath value env
)))
1923 (defun compile-var-binding (name value env
)
1924 (multiple-value-bind (local-name uri
)
1925 (decode-qname name env nil
)
1926 (let ((thunk (xslt-trace-thunk
1927 (compile-value-thunk value env
)
1928 "local variable ~s = ~s" name
:result
)))
1929 (list (cons local-name uri
)
1930 (push-variable local-name
1932 *lexical-variable-declarations
*)
1935 (defun compile-var-bindings (forms env
)
1937 for
(name value
) in forms
1938 collect
(compile-var-binding name value env
)))
1940 (defmacro sometimes-with-attributes
((&rest attrs
) node
&body body
)
1943 (if *forwards-compatible-p
*
1944 (stp:with-attributes
(,@attrs
) ,x
,@body
)
1945 (only-with-attributes (,@attrs
) ,x
,@body
)))))
1947 (defun compile-template (<template
> env position
)
1948 (sometimes-with-attributes (match name priority mode
) <template
>
1949 (unless (or name match
)
1950 (xslt-error "missing match in template"))
1951 (multiple-value-bind (params body-pos
)
1954 for child in
(stp:list-children
<template
>)
1955 while
(namep child
"param")
1956 collect
(parse-param child
) into params
1957 finally
(return (values params i
)))
1958 (let* ((*lexical-variable-declarations
* (make-empty-declaration-array))
1959 (param-bindings (compile-var-bindings params env
))
1960 (body (parse-body <template
> body-pos
(mapcar #'car params
)))
1961 (body-thunk (compile-instruction `(progn ,@body
) env
))
1967 ;; set params that weren't initialized by apply-templates
1968 (loop for
(name index param-thunk
) in param-bindings
1969 when
(eq (lexical-variable-value index nil
) 'unbound
)
1970 do
(setf (lexical-variable-value index
)
1971 (funcall param-thunk ctx
)))
1972 (funcall body-thunk ctx
))))
1973 "template: match = ~s name = ~s" match name
))
1974 (n-variables (length *lexical-variable-declarations
*)))
1977 (multiple-value-bind (local-name uri
)
1978 (decode-qname name env nil
)
1980 (make-template :name
(cons local-name uri
)
1981 :import-priority
*import-priority
*
1982 :apply-imports-limit
*apply-imports-limit
*
1983 :params param-bindings
1984 :body outer-body-thunk
1985 :n-variables n-variables
1986 ;; record unparsed `name' for profiler output:
1987 :unparsed-qname name
))))
1989 (mapcar (lambda (expression)
1990 (let* ((compiled-pattern
1992 (car (without-xslt-current ()
1993 (xpattern:compute-patterns
1994 `(:patterns
,expression
)
1998 "match-thunk for template (match ~s): ~s --> ~s"
1999 match expression
:result
))
2001 (xpath::parse-xnum priority
)
2002 (expression-priority expression
)))
2005 (unless (and (numberp p
)
2006 (not (xpath::inf-p p
))
2007 (not (xpath::nan-p p
)))
2008 (xslt-error "failed to parse priority"))
2011 (make-template :match-expression expression
2012 :compiled-pattern compiled-pattern
2013 :import-priority
*import-priority
*
2014 :apply-imports-limit
*apply-imports-limit
*
2018 :params param-bindings
2019 :body outer-body-thunk
2020 :n-variables n-variables
)))
2021 (setf (xpattern:pattern-value compiled-pattern
)
2024 (cdr (xpattern:parse-pattern-expression match
)))))))))
2026 (xuriella::parse-stylesheet
#p
"/home/david/src/lisp/xuriella/test.xsl")