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)
153 (defstruct profile-counter calls run real
)
155 (defvar *apply-stylesheet-counter
* (make-profile-counter))
156 (defvar *parse-stylesheet-counter
* (make-profile-counter))
157 (defvar *parse-xml-counter
* (make-profile-counter))
158 (defvar *unparse-xml-counter
* (make-profile-counter))
160 (defmacro with-profile-counter
((var) &body body
)
162 (if (and *profiling-enabled-p
* ,var
)
163 (invoke-with-profile-counter fn
,var
)
168 ;;;; Helper functions and macros
170 (defun check-for-invalid-attributes (valid-names node
)
171 (labels ((check-attribute (a)
173 (let ((uri (stp:namespace-uri a
)))
174 (or (and (plusp (length uri
)) (not (equal uri
*xsl
*)))
175 (find (cons (stp:local-name a
) uri
)
178 (xslt-error "attribute ~A not allowed on ~A"
180 (stp:local-name node
)))))
181 (stp:map-attributes nil
#'check-attribute node
)))
183 (defmacro only-with-attributes
((&rest specs
) node
&body body
)
185 (mapcar (lambda (entry)
186 (if (and (listp entry
) (cdr entry
))
187 (destructuring-bind (name &optional
(uri ""))
190 (cons (string-downcase
192 (symbol-name entry
)))
196 `(let ((,%NODE
,node
))
197 (check-for-invalid-attributes ',valid-names
,%NODE
)
198 (stp:with-attributes
,specs
,%NODE
201 (defun map-pipe-eagerly (fn pipe
)
202 (xpath::enumerate pipe
:key fn
:result nil
))
204 (defmacro do-pipe
((var pipe
&optional result
) &body body
)
206 (map-pipe-eagerly #'(lambda (,var
) ,@body
) ,pipe
)
210 ;;;; XSLT-ENVIRONMENT and XSLT-CONTEXT
212 (defparameter *initial-namespaces
*
214 ("xmlns" .
#"http://www.w3.org/2000/xmlns/")
215 ("xml" .
#"http://www.w3.org/XML/1998/namespace")))
217 (defparameter *namespaces
*
218 *initial-namespaces
*)
220 (defvar *global-variable-declarations
*)
221 (defvar *lexical-variable-declarations
*)
223 (defvar *global-variable-values
*)
224 (defvar *lexical-variable-values
*)
226 (defclass xslt-environment
() ())
228 (defun split-qname (str)
230 (multiple-value-bind (prefix local-name
)
231 (cxml::split-qname str
)
233 ;; FIXME: cxml should really offer a function that does
234 ;; checks for NCName and QName in a sensible way for user code.
235 ;; cxml::split-qname is tailored to the needs of the parser.
237 ;; For now, let's just check the syntax explicitly.
238 (and (or (null prefix
) (xpath::nc-name-p prefix
))
239 (xpath::nc-name-p local-name
))
240 (xslt-error "not a qname: ~A" str
))
241 (values prefix local-name
))
242 (cxml:well-formedness-violation
()
243 (xslt-error "not a qname: ~A" str
))))
245 (defun decode-qname (qname env attributep
&key allow-unknown-namespace
)
247 (xslt-error "missing name"))
248 (multiple-value-bind (prefix local-name
)
251 (if (or prefix
(not attributep
))
252 (or (xpath-sys:environment-find-namespace env
(or prefix
""))
253 (if allow-unknown-namespace
255 (xslt-error "namespace not found: ~A" prefix
)))
259 (defmethod xpath-sys:environment-find-namespace
((env xslt-environment
) prefix
)
260 (or (cdr (assoc prefix
*namespaces
* :test
'equal
))
262 ;; Change the entire code base to represent "no prefix" as the
263 ;; empty string consistently. unparse.lisp has already been changed.
264 (and (equal prefix
"")
265 (cdr (assoc nil
*namespaces
* :test
'equal
)))
266 (and (eql prefix nil
)
267 (cdr (assoc "" *namespaces
* :test
'equal
)))))
269 (defun find-variable-index (local-name uri table
)
270 (position (cons local-name uri
) table
:test
'equal
))
272 (defun intern-global-variable (local-name uri
)
273 (or (find-variable-index local-name uri
*global-variable-declarations
*)
274 (push-variable local-name uri
*global-variable-declarations
*)))
276 (defun push-variable (local-name uri table
)
279 (vector-push-extend (cons local-name uri
) table
)))
281 (defun lexical-variable-value (index &optional
(errorp t
))
282 (let ((result (svref *lexical-variable-values
* index
)))
284 (assert (not (eq result
'unbound
))))
287 (defun (setf lexical-variable-value
) (newval index
)
288 (assert (not (eq newval
'unbound
)))
289 (setf (svref *lexical-variable-values
* index
) newval
))
291 (defun global-variable-value (index &optional
(errorp t
))
292 (let ((result (svref *global-variable-values
* index
)))
294 (assert (not (eq result
'unbound
))))
297 (defun (setf global-variable-value
) (newval index
)
298 (assert (not (eq newval
'unbound
)))
299 (setf (svref *global-variable-values
* index
) newval
))
301 (defmethod xpath-sys:environment-find-function
302 ((env xslt-environment
) lname uri
)
303 (or (if (string= uri
"")
304 (or (xpath-sys:find-xpath-function lname
*xsl
*)
305 (xpath-sys:find-xpath-function lname uri
))
306 (xpath-sys:find-xpath-function lname uri
))
307 (when *forwards-compatible-p
*
308 (lambda (&rest ignore
)
309 (declare (ignore ignore
))
310 (xslt-error "attempt to call an unknown XPath function (~A); error delayed until run-time due to forwards compatible processing"
313 (defmethod xpath-sys:environment-find-variable
314 ((env xslt-environment
) lname uri
)
316 (find-variable-index lname uri
*lexical-variable-declarations
*)))
319 (declare (ignore ctx
))
320 (svref *lexical-variable-values
* index
)))))
322 (defclass lexical-xslt-environment
(xslt-environment) ())
324 (defmethod xpath-sys:environment-find-variable
325 ((env lexical-xslt-environment
) lname uri
)
326 (or (call-next-method)
328 (find-variable-index lname uri
*global-variable-declarations
*)))
332 (declare (ignore ctx
))
333 (svref *global-variable-values
* index
))
334 "global ~s (uri ~s) = ~s" lname uri
:result
)))))
336 (defclass key-environment
(xslt-environment) ())
338 (defmethod xpath-sys:environment-find-variable
339 ((env key-environment
) lname uri
)
340 (declare (ignore lname uri
))
341 (xslt-error "disallowed variable reference"))
343 (defclass global-variable-environment
(xslt-environment)
344 ((initial-global-variable-thunks
345 :initarg
:initial-global-variable-thunks
346 :accessor initial-global-variable-thunks
)))
348 (defmethod xpath-sys:environment-find-variable
349 ((env global-variable-environment
) lname uri
)
350 (or (call-next-method)
351 (gethash (cons lname uri
) (initial-global-variable-thunks env
))))
354 ;;;; TOPLEVEL-TEXT-OUTPUT-SINK
356 ;;;; A sink that serializes only text not contained in any element.
358 (defmacro with-toplevel-text-output-sink
((var) &body body
)
359 `(invoke-with-toplevel-text-output-sink (lambda (,var
) ,@body
)))
361 (defclass toplevel-text-output-sink
(sax:default-handler
)
362 ((target :initarg
:target
:accessor text-output-sink-target
)
363 (depth :initform
0 :accessor textoutput-sink-depth
)))
365 (defmethod sax:start-element
((sink toplevel-text-output-sink
)
366 namespace-uri local-name qname attributes
)
367 (declare (ignore namespace-uri local-name qname attributes
))
368 (incf (textoutput-sink-depth sink
)))
370 (defmethod sax:characters
((sink toplevel-text-output-sink
) data
)
371 (when (zerop (textoutput-sink-depth sink
))
372 (write-string data
(text-output-sink-target sink
))))
374 (defmethod sax:unescaped
((sink toplevel-text-output-sink
) data
)
375 (sax:characters sink data
))
377 (defmethod sax:end-element
((sink toplevel-text-output-sink
)
378 namespace-uri local-name qname
)
379 (declare (ignore namespace-uri local-name qname
))
380 (decf (textoutput-sink-depth sink
)))
382 (defun invoke-with-toplevel-text-output-sink (fn)
383 (with-output-to-string (s)
384 (funcall fn
(make-instance 'toplevel-text-output-sink
:target s
))))
389 ;;;; A sink that passes through only text (at any level) and turns to
390 ;;;; into unescaped characters.
392 (defclass text-filter
(sax:default-handler
)
393 ((target :initarg
:target
:accessor text-filter-target
)))
395 (defmethod sax:characters
((sink text-filter
) data
)
396 (sax:unescaped
(text-filter-target sink
) data
))
398 (defmethod sax:unescaped
((sink text-filter
) data
)
399 (sax:unescaped
(text-filter-target sink
) data
))
401 (defmethod sax:end-document
((sink text-filter
))
402 (sax:end-document
(text-filter-target sink
)))
404 (defun make-text-filter (target)
405 (make-instance 'text-filter
:target target
))
410 ;;;; A sink that recovers from sax:unescaped using sax:characters, as per
413 (defclass escaper
(cxml:broadcast-handler
)
416 (defmethod sax:unescaped
((sink escaper
) data
)
417 (sax:characters sink data
))
419 (defun make-escaper (target)
420 (make-instance 'escaper
:handlers
(list target
)))
425 (defun of-name (local-name)
426 (stp:of-name local-name
*xsl
*))
428 (defun namep (node local-name
)
429 (and (typep node
'(or stp
:element stp
:attribute
))
430 (equal (stp:namespace-uri node
) *xsl
*)
431 (equal (stp:local-name node
) local-name
)))
434 ;;;; PARSE-STYLESHEET
436 (defstruct stylesheet
437 (modes (make-hash-table :test
'equal
))
438 (global-variables (make-empty-declaration-array))
439 (output-specification (make-output-specification))
442 (named-templates (make-hash-table :test
'equal
))
443 (attribute-sets (make-hash-table :test
'equal
))
444 (keys (make-hash-table :test
'equal
))
445 (namespace-aliases (make-hash-table :test
'equal
))
446 (decimal-formats (make-hash-table :test
'equal
))
447 (initial-global-variable-thunks (make-hash-table :test
'equal
)))
449 (setf (documentation 'stylesheet
'type
)
450 "The class of stylesheets that have been parsed and compiled.
452 Pass instances of this class to @fun{apply-stylesheet} to invoke
455 @see-constructor{parse-stylesheet}")
459 (match-thunk (lambda (ignore) (declare (ignore ignore
)) nil
)))
461 (defun find-mode (stylesheet local-name
&optional uri
)
462 (gethash (cons local-name uri
) (stylesheet-modes stylesheet
)))
464 (defun ensure-mode (stylesheet &optional local-name uri
)
465 (or (find-mode stylesheet local-name uri
)
466 (setf (gethash (cons local-name uri
) (stylesheet-modes stylesheet
))
469 (defun ensure-mode/qname
(stylesheet qname env
)
471 (multiple-value-bind (local-name uri
)
472 (decode-qname qname env nil
)
473 (ensure-mode stylesheet local-name uri
))
474 (find-mode stylesheet nil
)))
476 (defun acons-namespaces
477 (element &optional
(bindings *namespaces
*) include-redeclared
)
478 (map-namespace-declarations (lambda (prefix uri
)
479 (push (cons prefix uri
) bindings
))
484 (defun find-key (name stylesheet
)
485 (or (gethash name
(stylesheet-keys stylesheet
))
486 (xslt-error "unknown key: ~a" name
)))
488 (defun make-key (match use
) (cons match use
))
490 (defun key-match (key) (car key
))
492 (defun key-use (key) (cdr key
))
494 (defun add-key (stylesheet name match use
)
495 (push (make-key match use
)
496 (gethash name
(stylesheet-keys stylesheet
))))
498 (defvar *excluded-namespaces
* (list *xsl
*))
499 (defvar *empty-mode
*)
500 (defvar *default-mode
*)
502 (defvar *xsl-include-stack
* nil
)
504 (defun uri-to-pathname (uri)
505 (cxml::uri-to-pathname
(puri:parse-uri uri
)))
507 ;; Why this extra check for literal result element used as stylesheets,
508 ;; instead of a general check for every literal result element? Because
509 ;; Stylesheet__91804 says so.
510 (defun check-Errors_err035 (literal-result-element)
511 (let ((*namespaces
* (acons-namespaces literal-result-element
))
512 (env (make-instance 'lexical-xslt-environment
)))
513 (stp:with-attributes
((extension-element-prefixes
514 "extension-element-prefixes"
516 literal-result-element
517 (dolist (prefix (words (or extension-element-prefixes
"")))
518 (if (equal prefix
"#default")
520 (unless (cxml-stp-impl::nc-name-p prefix
)
521 (xslt-error "invalid prefix: ~A" prefix
)))
523 (or (xpath-sys:environment-find-namespace env prefix
)
524 (xslt-error "namespace not found: ~A" prefix
))))
525 (when (equal uri
(stp:namespace-uri literal-result-element
))
526 (xslt-error "literal result element used as stylesheet, but is ~
527 declared as an extension element")))))))
529 (defun unwrap-2.3
(document)
530 (let ((literal-result-element (stp:document-element document
))
531 (new-template (stp:make-element
"template" *xsl
*))
532 (new-document-element (stp:make-element
"stylesheet" *xsl
*)))
533 (check-Errors_err035 literal-result-element
)
534 (setf (stp:attribute-value new-document-element
"version")
535 (or (stp:attribute-value literal-result-element
"version" *xsl
*)
536 (xslt-error "not a stylesheet: root element lacks xsl:version")))
537 (setf (stp:attribute-value new-template
"match") "/")
538 (setf (stp:document-element document
) new-document-element
)
539 (stp:append-child new-document-element new-template
)
540 (stp:append-child new-template literal-result-element
)
541 (setf (stp:base-uri new-template
) (stp:base-uri literal-result-element
))
542 new-document-element
))
544 (defun parse-stylesheet-to-stp (input uri-resolver
)
545 (let* ((d (cxml:parse input
(make-text-normalizer (cxml-stp:make-builder
))))
546 (<transform
> (stp:document-element d
)))
547 (unless (equal (stp:namespace-uri
<transform
>) *xsl
*)
548 (setf <transform
> (unwrap-2.3 d
)))
549 (strip-stylesheet <transform
>)
550 (unless (and (equal (stp:namespace-uri
<transform
>) *xsl
*)
551 (or (equal (stp:local-name
<transform
>) "transform")
552 (equal (stp:local-name
<transform
>) "stylesheet")))
553 (xslt-error "not a stylesheet"))
554 (check-for-invalid-attributes
556 ("exclude-result-prefixes" .
"")
557 ("extension-element-prefixes" .
"")
558 ("space" .
"http://www.w3.org/XML/1998/namespace")
562 (or (stp:find-child-if
(of-name "stylesheet") <transform
>)
563 (stp:find-child-if
(of-name "transform") <transform
>))))
565 (xslt-error "invalid top-level element ~A" (stp:local-name invalid
))))
566 (dolist (include (stp:filter-children
(of-name "include") <transform
>))
567 (let* ((uri (puri:merge-uris
(or (stp:attribute-value include
"href")
568 (xslt-error "include without href"))
569 (stp:base-uri include
)))
570 (uri (if uri-resolver
571 (funcall uri-resolver uri
)
573 (str (puri:render-uri uri nil
))
576 (uri-to-pathname uri
)
577 (cxml:xml-parse-error
(c)
578 (xslt-error "cannot find included stylesheet ~A: ~A"
582 :element-type
'(unsigned-byte 8)
583 :if-does-not-exist nil
)
585 (xslt-error "cannot find included stylesheet ~A at ~A"
587 (when (find str
*xsl-include-stack
* :test
#'equal
)
588 (xslt-error "recursive inclusion of ~A" uri
))
589 (let* ((*xsl-include-stack
* (cons str
*xsl-include-stack
*))
590 (<transform
>2 (parse-stylesheet-to-stp stream uri-resolver
)))
591 (stp:insert-child-after
<transform
>
592 (stp:copy
<transform
>2)
594 (stp:detach include
)))))
597 (defvar *instruction-base-uri
*) ;misnamed, is also used in other attributes
598 (defvar *apply-imports-limit
*)
599 (defvar *import-priority
*)
600 (defvar *extension-namespaces
*)
602 (defmacro do-toplevel
((var xpath
<transform
>) &body body
)
603 `(map-toplevel (lambda (,var
) ,@body
) ,xpath
,<transform
>))
605 (defun map-toplevel (fn xpath
<transform
>)
606 (dolist (node (list-toplevel xpath
<transform
>))
607 (let ((*namespaces
* *initial-namespaces
*))
608 (xpath:do-node-set
(ancestor (xpath:evaluate
"ancestor::node()" node
))
609 (xpath:with-namespaces
(("" #.
*xsl
*))
610 (when (xpattern:node-matches-p ancestor
"stylesheet|transform")
611 ;; discard namespaces from including stylesheets
612 (setf *namespaces
* *initial-namespaces
*)))
613 (when (xpath-protocol:node-type-p ancestor
:element
)
614 (setf *namespaces
* (acons-namespaces ancestor
*namespaces
* t
))))
617 (defun list-toplevel (xpath <transform
>)
618 (labels ((recurse (sub)
621 (xpath:evaluate
"transform|stylesheet" sub
))))
623 (xpath-sys:pipe-of
(xpath:evaluate xpath sub
))
624 (xpath::mappend-pipe
#'recurse subsubs
)))))
625 (xpath::sort-nodes
(recurse <transform
>))))
627 (defmacro with-import-magic
((node env
) &body body
)
628 `(invoke-with-import-magic (lambda () ,@body
) ,node
,env
))
630 (defun invoke-with-import-magic (fn node env
)
631 (unless (or (namep node
"stylesheet") (namep node
"transform"))
632 (setf node
(stp:parent node
)))
633 (let ((*excluded-namespaces
* (list *xsl
*))
634 (*extension-namespaces
* '())
635 (*forwards-compatible-p
*
636 (not (equal (stp:attribute-value node
"version") "1.0"))))
637 (parse-exclude-result-prefixes! node env
)
638 (parse-extension-element-prefixes! node env
)
641 (defun parse-1-stylesheet (env stylesheet designator uri-resolver
)
642 (let* ((<transform
> (parse-stylesheet-to-stp designator uri-resolver
))
643 (instruction-base-uri (stp:base-uri
<transform
>))
644 (namespaces (acons-namespaces <transform
>))
645 (apply-imports-limit (1+ *import-priority
*))
647 (let ((*namespaces
* namespaces
))
648 (invoke-with-import-magic (constantly t
) <transform
> env
))
649 (do-toplevel (elt "node()" <transform
>)
650 (let ((version (stp:attribute-value
(stp:parent elt
) "version")))
653 (xslt-error "stylesheet lacks version"))
654 ((equal version
"1.0")
655 (if (typep elt
'stp
:element
)
656 (when (or (equal (stp:namespace-uri elt
) "")
657 (and (equal (stp:namespace-uri elt
) *xsl
*)
658 (not (find (stp:local-name elt
)
659 '("key" "template" "output"
660 "strip-space" "preserve-space"
661 "attribute-set" "namespace-alias"
662 "decimal-format" "variable" "param"
664 ;; for include handling:
665 "stylesheet" "transform")
667 (xslt-error "unknown top-level element ~A" (stp:local-name elt
)))
668 (xslt-error "text at top-level"))))))
669 (macrolet ((with-specials ((&optional
) &body body
)
670 `(let ((*instruction-base-uri
* instruction-base-uri
)
671 (*namespaces
* namespaces
)
672 (*apply-imports-limit
* apply-imports-limit
))
675 (do-toplevel (import "import" <transform
>)
676 (when (let ((prev (xpath:first-node
677 (xpath:evaluate
"preceding-sibling::*"
680 (and prev
(not (namep prev
"import"))))
681 (xslt-error "import not at beginning of stylesheet"))
682 (let ((uri (puri:merge-uris
(or (stp:attribute-value import
"href")
683 (xslt-error "import without href"))
684 (stp:base-uri import
))))
685 (push (parse-imported-stylesheet env stylesheet uri uri-resolver
)
687 (let ((import-priority
688 (incf *import-priority
*))
689 (var-cont (prepare-global-variables stylesheet
<transform
>)))
690 (parse-namespace-aliases! stylesheet
<transform
> env
)
691 ;; delay the rest of compilation until we've seen all global
694 (mapc #'funcall
(nreverse continuations
))
696 (let ((*import-priority
* import-priority
))
698 (parse-keys! stylesheet
<transform
> env
)
699 (parse-templates! stylesheet
<transform
> env
)
700 (parse-output! stylesheet
<transform
> env
)
701 (parse-strip/preserve-space
! stylesheet
<transform
> env
)
702 (parse-attribute-sets! stylesheet
<transform
> env
)
703 (parse-decimal-formats! stylesheet
<transform
> env
))))))))
705 (defvar *xsl-import-stack
* nil
)
707 (defun parse-imported-stylesheet (env stylesheet uri uri-resolver
)
708 (let* ((uri (if uri-resolver
709 (funcall uri-resolver uri
)
711 (str (puri:render-uri uri nil
))
714 (uri-to-pathname uri
)
715 (cxml:xml-parse-error
(c)
716 (xslt-error "cannot find imported stylesheet ~A: ~A"
720 :element-type
'(unsigned-byte 8)
721 :if-does-not-exist nil
)
723 (xslt-error "cannot find imported stylesheet ~A at ~A"
725 (when (find str
*xsl-import-stack
* :test
#'equal
)
726 (xslt-error "recursive inclusion of ~A" uri
))
727 (let ((*xsl-import-stack
* (cons str
*xsl-import-stack
*)))
728 (parse-1-stylesheet env stylesheet stream uri-resolver
)))))
730 (defvar *included-attribute-sets
*)
732 (defvar *stylesheet
*)
734 (defun parse-stylesheet (designator &key uri-resolver
)
735 "@arg[designator]{an XML designator}
736 @arg[uri-resolver]{optional function of one argument}
737 @return{An instance of @class{stylesheet}.}
739 @short{Parse a stylesheet.}
741 This function parses and compiles an XSLT stylesheet.
742 The precompiled stylesheet object can then be passed to
743 @fun{apply-stylesheet}.
745 Also refer to @fun{apply-stylesheet} for details on XML designators."
746 (with-resignalled-errors ()
747 (xpath:with-namespaces
((nil #.
*xsl
*))
748 (let* ((*import-priority
* 0)
749 (xpattern:*allow-variables-in-patterns
* nil
)
750 (puri:*strict-parse
* nil
)
751 (stylesheet (make-stylesheet))
753 ;; zzz this is for remove-excluded-namespaces only
755 (env (make-instance 'lexical-xslt-environment
))
756 (*excluded-namespaces
* *excluded-namespaces
*)
757 (*global-variable-declarations
* (make-empty-declaration-array))
758 (*included-attribute-sets
* nil
))
759 (ensure-mode stylesheet nil
)
760 (funcall (parse-1-stylesheet env stylesheet designator uri-resolver
))
761 ;; reverse attribute sets:
762 (let ((table (stylesheet-attribute-sets stylesheet
)))
763 (maphash (lambda (k v
)
764 (setf (gethash k table
) (nreverse v
)))
767 (dolist (sets *included-attribute-sets
*)
768 (loop for
(local-name uri nil
) in sets do
769 (find-attribute-set local-name uri stylesheet
)))
771 (unless (find-decimal-format "" "" stylesheet nil
)
772 (setf (find-decimal-format "" "" stylesheet
)
773 (make-decimal-format)))
774 ;; compile a template matcher for each mode:
776 for mode being each hash-value in
(stylesheet-modes stylesheet
)
778 (setf (mode-match-thunk mode
)
779 (xpattern:make-pattern-matcher
780 (mapcar #'template-compiled-pattern
781 (mode-templates mode
)))))
782 ;; and for the strip tests
783 (setf (stylesheet-strip-thunk stylesheet
)
784 (let ((patterns (stylesheet-strip-tests stylesheet
)))
786 (xpattern:make-pattern-matcher
787 (mapcar #'strip-test-compiled-pattern patterns
)))))
790 (defun parse-attribute-sets! (stylesheet <transform
> env
)
791 (do-toplevel (elt "attribute-set" <transform
>)
792 (with-import-magic (elt env
)
794 (mapcar (lambda (qname)
795 (multiple-value-list (decode-qname qname env nil
)))
797 (stp:attribute-value elt
"use-attribute-sets"))))
803 (and (typep child
'stp
:element
)
804 (or (and (equal (stp:namespace-uri child
) *xsl
*)
805 (equal (stp:local-name child
)
807 (find (stp:namespace-uri child
)
808 *extension-namespaces
*
810 (xslt-error "non-attribute found in attribute set"))
811 (parse-instruction child
))
813 (*lexical-variable-declarations
*
814 (make-empty-declaration-array))
816 (compile-instruction `(progn ,@instructions
) env
))
817 (n-variables (length *lexical-variable-declarations
*)))
818 (push sets
*included-attribute-sets
*)
821 (loop for
(local-name uri nil
) in sets do
822 (dolist (thunk (find-attribute-set local-name uri
))
823 (funcall thunk ctx
)))
824 (let ((*lexical-variable-values
*
825 (make-variable-value-array n-variables
)))
826 (funcall thunk ctx
)))))
827 (gethash (multiple-value-bind (local-name uri
)
828 (decode-qname (or (stp:attribute-value elt
"name")
829 (xslt-error "missing name"))
832 (cons local-name uri
))
833 (stylesheet-attribute-sets stylesheet
))))))
835 (defun parse-namespace-aliases! (stylesheet <transform
> env
)
836 (do-toplevel (elt "namespace-alias" <transform
>)
837 (let ((*namespaces
* (acons-namespaces elt
)))
838 (only-with-attributes (stylesheet-prefix result-prefix
) elt
839 (unless stylesheet-prefix
840 (xslt-error "missing stylesheet-prefix in namespace-alias"))
841 (unless result-prefix
842 (xslt-error "missing result-prefix in namespace-alias"))
844 (if (equal stylesheet-prefix
"#default")
846 (or (xpath-sys:environment-find-namespace
849 (xslt-error "stylesheet namespace not found in alias: ~A"
851 (stylesheet-namespace-aliases stylesheet
))
852 (or (xpath-sys:environment-find-namespace
854 (if (equal result-prefix
"#default")
857 (xslt-error "result namespace not found in alias: ~A"
860 (defun parse-decimal-formats! (stylesheet <transform
> env
)
861 (do-toplevel (elt "decimal-format" <transform
>)
862 (stp:with-attributes
(name
876 (multiple-value-bind (local-name uri
)
878 (decode-qname name env nil
)
880 (let ((current (find-decimal-format local-name uri stylesheet nil
))
885 (unless (eql (length x
) 1)
886 (xslt-error "not a single character: ~A" x
))
887 (let ((chr (elt x
0)))
888 (when (find chr seen
)
890 "conflicting decimal format characters: ~A"
897 (apply #'make-decimal-format
898 (append (str :infinity infinity
)
900 (chr :decimal-separator decimal-separator
)
901 (chr :grouping-separator grouping-separator
)
902 (chr :zero-digit zero-digit
)
903 (chr :percent percent
)
904 (chr :per-mille per-mille
)
906 (chr :pattern-separator pattern-separator
)
907 (chr :minus-sign minus-sign
)))))))
909 (unless (decimal-format= current new
)
910 (xslt-error "decimal format mismatch for ~S" local-name
))
911 (setf (find-decimal-format local-name uri stylesheet
) new
)))))))
913 (defun parse-exclude-result-prefixes! (node env
)
914 (stp:with-attributes
(exclude-result-prefixes)
916 (dolist (prefix (words (or exclude-result-prefixes
"")))
917 (if (equal prefix
"#default")
919 (unless (cxml-stp-impl::nc-name-p prefix
)
920 (xslt-error "invalid prefix: ~A" prefix
)))
921 (push (or (xpath-sys:environment-find-namespace env prefix
)
922 (xslt-error "namespace not found: ~A" prefix
))
923 *excluded-namespaces
*))))
925 (defun parse-extension-element-prefixes! (node env
)
926 (stp:with-attributes
(extension-element-prefixes)
928 (dolist (prefix (words (or extension-element-prefixes
"")))
929 (if (equal prefix
"#default")
931 (unless (cxml-stp-impl::nc-name-p prefix
)
932 (xslt-error "invalid prefix: ~A" prefix
)))
934 (or (xpath-sys:environment-find-namespace env prefix
)
935 (xslt-error "namespace not found: ~A" prefix
))))
936 (unless (equal uri
*xsl
*)
937 (push uri
*extension-namespaces
*)
938 (push uri
*excluded-namespaces
*))))))
940 (defun parse-nametest-tokens (str)
941 (labels ((check (boolean)
943 (xslt-error "invalid nametest token")))
944 (check-null (boolean)
945 (check (not boolean
))))
948 (mapcar (lambda (name-test)
949 (destructuring-bind (&optional path
&rest junk
)
950 (cdr (xpattern:parse-pattern-expression name-test
))
952 (check (eq (car path
) :path
))
953 (destructuring-bind (&optional child
&rest junk
) (cdr path
)
955 (check (eq (car child
) :child
))
956 (destructuring-bind (nodetest &rest junk
) (cdr child
)
958 (check (or (stringp nodetest
)
960 (and (consp nodetest
)
961 (or (eq (car nodetest
) :namespace
)
962 (eq (car nodetest
) :qname
)))))))
966 (defstruct strip-test
972 (defun parse-strip/preserve-space
! (stylesheet <transform
> env
)
974 (do-toplevel (elt "strip-space|preserve-space" <transform
>)
975 (let ((*namespaces
* (acons-namespaces elt
))
977 (if (equal (stp:local-name elt
) "strip-space")
981 (cdr (parse-nametest-tokens
982 (stp:attribute-value elt
"elements"))))
983 (let* ((compiled-pattern
984 (car (without-xslt-current ()
985 (xpattern:compute-patterns
986 `(:patterns
,expression
)
991 (make-strip-test :compiled-pattern compiled-pattern
992 :priority
(expression-priority expression
)
995 (setf (xpattern:pattern-value compiled-pattern
) strip-test
)
996 (push strip-test
(stylesheet-strip-tests stylesheet
)))))
999 (defstruct (output-specification
1000 (:conc-name
"OUTPUT-"))
1003 omit-xml-declaration
1007 cdata-section-matchers
1011 (defun parse-output! (stylesheet <transform
> env
)
1012 (dolist (<output
> (list-toplevel "output" <transform
>))
1013 (let ((spec (stylesheet-output-specification stylesheet
)))
1014 (only-with-attributes (version
1021 omit-xml-declaration
1023 cdata-section-elements
)
1025 (declare (ignore version
))
1027 (multiple-value-bind (local-name uri
)
1028 (decode-qname method env t
)
1029 (setf (output-method spec
)
1030 (if (plusp (length uri
))
1033 ((equalp local-name
"HTML") :html
)
1034 ((equalp local-name
"TEXT") :text
)
1035 ((equalp local-name
"XML") :xml
)
1037 (xslt-error "invalid output method: ~A" method
)))))))
1039 (setf (output-indent spec
) indent
))
1041 (setf (output-encoding spec
) encoding
))
1042 (when doctype-system
1043 (setf (output-doctype-system spec
) doctype-system
))
1044 (when doctype-public
1045 (setf (output-doctype-public spec
) doctype-public
))
1046 (when omit-xml-declaration
1047 (setf (output-omit-xml-declaration spec
) omit-xml-declaration
))
1048 (when cdata-section-elements
1049 (dolist (qname (words cdata-section-elements
))
1050 (decode-qname qname env nil
) ;check the syntax
1051 (push (xpattern:make-pattern-matcher
* qname env
)
1052 (output-cdata-section-matchers spec
))))
1054 (setf (output-standalone-p spec
)
1055 (boolean-or-error standalone
)))
1057 (setf (output-media-type spec
) media-type
))))))
1059 (defun make-empty-declaration-array ()
1060 (make-array 1 :fill-pointer
0 :adjustable t
))
1062 (defun make-variable-value-array (n-lexical-variables)
1063 (make-array n-lexical-variables
:initial-element
'unbound
))
1065 (defun compile-global-variable (<variable
> env
) ;; also for <param>
1066 (stp:with-attributes
(name select
) <variable
>
1067 (when (and select
(stp:list-children
<variable
>))
1068 (xslt-error "variable with select and body"))
1069 (let* ((*lexical-variable-declarations
* (make-empty-declaration-array))
1072 (compile-xpath select env
))
1073 ((stp:list-children
<variable
>)
1074 (let* ((inner-sexpr `(progn ,@(parse-body <variable
>)))
1075 (inner-thunk (compile-instruction inner-sexpr env
)))
1077 (apply-to-result-tree-fragment ctx inner-thunk
))))
1080 (declare (ignore ctx
))
1082 (n-lexical-variables (length *lexical-variable-declarations
*)))
1085 (let* ((*lexical-variable-values
*
1086 (make-variable-value-array n-lexical-variables
)))
1087 (funcall inner ctx
)))
1088 "global ~s (~s) = ~s" name select
:result
))))
1090 (defstruct (variable-chain
1091 (:constructor make-variable-chain
)
1092 (:conc-name
"VARIABLE-CHAIN-"))
1099 (defstruct (import-variable
1100 (:constructor make-variable
)
1101 (:conc-name
"VARIABLE-"))
1106 (defun parse-global-variable! (stylesheet <variable
> global-env
)
1107 (let* ((*namespaces
* (acons-namespaces <variable
>))
1108 (instruction-base-uri (stp:base-uri
<variable
>))
1109 (*instruction-base-uri
* instruction-base-uri
)
1110 (*excluded-namespaces
* (list *xsl
*))
1111 (*extension-namespaces
* '())
1112 (qname (stp:attribute-value
<variable
> "name")))
1113 (with-import-magic (<variable
> global-env
)
1115 (xslt-error "name missing in ~A" (stp:local-name
<variable
>)))
1116 (multiple-value-bind (local-name uri
)
1117 (decode-qname qname global-env nil
)
1118 ;; For the normal compilation environment of templates, install it
1119 ;; into *GLOBAL-VARIABLE-DECLARATIONS*:
1120 (let ((index (intern-global-variable local-name uri
)))
1121 ;; For the evaluation of a global variable itself, build a thunk
1122 ;; that lazily resolves other variables, stored into
1123 ;; INITIAL-GLOBAL-VARIABLE-THUNKS:
1124 (let* ((value-thunk :unknown
)
1125 (sgv (stylesheet-global-variables stylesheet
))
1127 (if (< index
(length sgv
))
1129 (make-variable-chain
1131 :local-name local-name
1133 (next (car (variable-chain-definitions chain
)))
1134 (global-variable-thunk
1136 (let ((v (global-variable-value index nil
)))
1140 (xslt-error "no next definition for: ~A"
1142 (funcall (variable-value-thunk next
) ctx
))
1144 (setf (global-variable-value index
) 'seen
)
1145 (setf (global-variable-value index
)
1146 (funcall value-thunk ctx
)))
1149 (excluded-namespaces *excluded-namespaces
*)
1150 (extension-namespaces *extension-namespaces
*)
1152 (make-variable :param-p
(namep <variable
> "param")))
1153 (forwards-compatible-p *forwards-compatible-p
*)
1156 (let* ((*instruction-base-uri
* instruction-base-uri
)
1157 (*excluded-namespaces
* excluded-namespaces
)
1158 (*extension-namespaces
* extension-namespaces
)
1159 (*forwards-compatible-p
* forwards-compatible-p
)
1161 (compile-global-variable <variable
> global-env
)))
1162 (setf value-thunk fn
)
1163 (setf (variable-value-thunk variable
) fn
)))))
1164 (setf (variable-value-thunk-setter variable
)
1166 (setf (gethash (cons local-name uri
)
1167 (initial-global-variable-thunks global-env
))
1168 global-variable-thunk
)
1169 (setf (variable-chain-thunk chain
) global-variable-thunk
)
1170 (push variable
(variable-chain-definitions chain
))
1173 (defun parse-keys! (stylesheet <transform
> env
)
1174 (xpath:with-namespaces
((nil #.
*xsl
*))
1175 (do-toplevel (<key
> "key" <transform
>)
1176 (with-import-magic (<key
> env
)
1177 (let ((*instruction-base-uri
* (stp:base-uri
<key
>)))
1178 (only-with-attributes (name match use
) <key
>
1179 (unless name
(xslt-error "key name attribute not specified"))
1180 (unless match
(xslt-error "key match attribute not specified"))
1181 (unless use
(xslt-error "key use attribute not specified"))
1182 (multiple-value-bind (local-name uri
)
1183 (decode-qname name env nil
)
1185 (cons local-name uri
)
1186 (compile-xpath `(xpath:xpath
,(parse-key-pattern match
))
1189 (make-instance 'key-environment
))))))))))
1191 (defun prepare-global-variables (stylesheet <transform
>)
1192 (xpath:with-namespaces
((nil #.
*xsl
*))
1193 (let* ((igvt (stylesheet-initial-global-variable-thunks stylesheet
))
1194 (global-env (make-instance 'global-variable-environment
1195 :initial-global-variable-thunks igvt
))
1197 (do-toplevel (<variable
> "variable|param" <transform
>)
1199 (parse-global-variable! stylesheet
<variable
> global-env
)))
1200 (xslt-trace "parsing global variable ~s (uri ~s)"
1201 (variable-chain-local-name chain
)
1202 (variable-chain-uri chain
))
1206 (and (equal (variable-chain-local-name a
)
1207 (variable-chain-local-name b
))
1208 (equal (variable-chain-uri a
)
1209 (variable-chain-uri b
)))))
1210 (xslt-error "duplicate definition for global variable ~A"
1211 (variable-chain-local-name chain
)))
1212 (push chain chains
)))
1213 (setf chains
(nreverse chains
))
1214 (let ((table (stylesheet-global-variables stylesheet
))
1215 (newlen (length *global-variable-declarations
*)))
1216 (adjust-array table newlen
:fill-pointer newlen
)
1217 (dolist (chain chains
)
1218 (setf (elt table
(variable-chain-index chain
)) chain
)))
1220 ;; now that the global environment knows about all variables, run the
1221 ;; thunk setters to perform their compilation
1222 (mapc (lambda (chain)
1223 (dolist (var (variable-chain-definitions chain
))
1224 (funcall (variable-value-thunk-setter var
))))
1227 (defun parse-templates! (stylesheet <transform
> env
)
1229 (do-toplevel (<template
> "template" <transform
>)
1230 (let ((*namespaces
* (acons-namespaces <template
>))
1231 (*instruction-base-uri
* (stp:base-uri
<template
>)))
1232 (with-import-magic (<template
> env
)
1233 (dolist (template (compile-template <template
> env i
))
1234 (setf (template-stylesheet template
) stylesheet
)
1235 (setf (template-base-uri template
) (stp:base-uri
<template
>))
1236 (let ((name (template-name template
)))
1238 (let* ((table (stylesheet-named-templates stylesheet
))
1239 (head (car (gethash name table
))))
1240 (when (and head
(eql (template-import-priority head
)
1241 (template-import-priority template
)))
1242 ;; fixme: is this supposed to be a run-time error?
1243 (xslt-error "conflicting templates for ~A" name
))
1244 (push template
(gethash name table
)))
1245 (let ((mode (ensure-mode/qname stylesheet
1246 (template-mode-qname template
)
1248 (setf (template-mode template
) mode
)
1249 (push template
(mode-templates mode
))))))))
1253 ;;;; APPLY-STYLESHEET
1255 (deftype xml-designator
() '(or runes
:xstream runes
:rod array stream pathname
))
1257 (defun unalias-uri (uri)
1259 (gethash uri
(stylesheet-namespace-aliases *stylesheet
*)
1261 (check-type result string
)
1264 (defstruct (parameter
1265 (:constructor make-parameter
(value local-name
&optional uri
)))
1270 (setf (documentation 'parameter
'type
)
1271 "The class of top-level parameters to XSLT stylesheets.
1273 Parameters are identified by expanded names, i.e. a namespace URI
1276 Their value is string.
1278 @see-constructor{make-parameter}
1279 @see-slot{parameter-uri}
1280 @see-slot{parameter-local-name}
1281 @see-slot{parameter-value}")
1283 (setf (documentation 'make-parameter
'function
)
1284 "@arg[value]{The parameter's value, a string.}
1285 @arg[local-name]{The parameter's local name, a string.}
1286 @arg[local-name]{The parameter's namespace URI, a string.}
1287 @return{An instance of @class{parameter}.}
1289 @short{Creates a paramater.}
1292 @see{parameter-local-name}
1293 @see{parameter-value}")
1295 (setf (documentation 'parameter-uri
'function
)
1296 "@arg[instance]{An instance of @class{parameter}.}
1298 @return{Returns the parameter's namespace URI.}
1300 @see{parameter-local-name}
1301 @see{parameter-value}")
1303 (setf (documentation 'parameter-local-name
'function
)
1304 "@arg[instance]{An instance of @class{parameter}.}
1306 @return{Returns the parameter's local name.}
1309 @see{parameter-value}")
1311 (setf (documentation 'parameter-value
'function
)
1312 "@arg[instance]{An instance of @class{parameter}.}
1314 @return{Returns the parameter's value.}
1317 @see{parameter-local-name}")
1319 (defun find-parameter-value (local-name uri parameters
)
1320 (dolist (p parameters
)
1321 (when (and (equal (parameter-local-name p
) local-name
)
1322 (equal (parameter-uri p
) uri
))
1323 (return (parameter-value p
)))))
1325 (defvar *uri-resolver
*)
1327 (defun parse-allowing-microsoft-bom (pathname handler
)
1328 (with-open-file (s pathname
:element-type
'(unsigned-byte 8))
1329 (unless (and (eql (read-byte s nil
) #xef
)
1330 (eql (read-byte s nil
) #xbb
)
1331 (eql (read-byte s nil
) #xbf
))
1332 (file-position s
0))
1333 (cxml:parse s handler
)))
1335 (defstruct source-document
1338 (indices (make-hash-table)))
1340 (defvar *uri-to-document
*)
1341 (defvar *root-to-document
*)
1343 (defun %document
(uri-string base-uri
)
1344 (let* ((absolute-uri
1345 (puri:merge-uris uri-string
(or base-uri
"")))
1348 (funcall *uri-resolver
* absolute-uri
)
1352 (uri-to-pathname resolved-uri
)
1353 (cxml:xml-parse-error
(c)
1354 (xslt-error "cannot find referenced document ~A: ~A"
1356 (document (gethash pathname
*uri-to-document
*)))
1359 (make-whitespace-stripper
1361 (parse-allowing-microsoft-bom pathname
1363 ((or file-error cxml
:xml-parse-error
) (c)
1364 (xslt-error "cannot parse referenced document ~A: ~A"
1366 (stylesheet-strip-thunk *stylesheet
*)))
1367 (id (hash-table-count *root-to-document
*)))
1368 (setf document
(make-source-document :id id
:root-node root-node
))
1369 (setf (gethash pathname
*uri-to-document
*) document
)
1370 (setf (gethash root-node
*root-to-document
*) document
)))
1371 (when (puri:uri-fragment absolute-uri
)
1372 (xslt-error "use of fragment identifiers in document() not supported"))
1373 (source-document-root-node document
)))
1375 (xpath-sys:define-extension xslt
*xsl
*)
1377 (defun document-base-uri (node)
1378 (xpath-protocol:base-uri
1380 ((xpath-protocol:node-type-p node
:document
)
1381 (xpath::find-in-pipe-if
1383 (xpath-protocol:node-type-p x
:element
))
1384 (xpath-protocol:child-pipe node
)))
1385 ((xpath-protocol:node-type-p node
:element
)
1388 (xpath-protocol:parent-node node
)))))
1390 (xpath-sys:define-xpath-function
/lazy
1392 (object &optional node-set
)
1393 (let ((instruction-base-uri *instruction-base-uri
*))
1395 (with-profile-counter (*parse-xml-counter
*)
1396 (let* ((object (funcall object ctx
))
1397 (node-set (and node-set
(funcall node-set ctx
)))
1400 (document-base-uri (xpath::textually-first-node node-set
))
1401 instruction-base-uri
)))
1402 (xpath-sys:make-node-set
1403 (if (xpath:node-set-p object
)
1404 (xpath:map-node-set-
>list
1406 (%document
(xpath:string-value node
)
1409 (document-base-uri node
))))
1411 (list (%document
(xpath:string-value object
) base-uri
)))))))))
1414 (defun build-key-index (document key-conses
)
1415 (let ((index (make-hash-table :test
'equal
)))
1416 (dolist (key key-conses
)
1419 (xpath:evaluate-compiled
(key-match key
)
1421 (source-document-root-node document
))))
1422 (let* ((use-result (xpath:evaluate-compiled
(key-use key
) node
))
1423 (uses (if (xpath:node-set-p use-result
)
1424 (xpath:all-nodes use-result
)
1425 (list use-result
))))
1427 (push node
(gethash (xpath:string-value use
) index
))))))
1430 (defun %key
(document key-conses value
)
1431 (let* ((indices (source-document-indices document
))
1432 (index (or (gethash key-conses indices
)
1433 (setf (gethash key-conses indices
)
1434 (build-key-index document key-conses
)))))
1435 (gethash value index
)))
1437 (xpath-sys:define-xpath-function
/lazy xslt
:key
(name object
)
1438 (let ((namespaces *namespaces
*))
1440 (let* ((qname (xpath:string-value
(funcall name ctx
)))
1441 (object (funcall object ctx
))
1443 (multiple-value-bind (local-name uri
)
1444 (decode-qname/runtime qname namespaces nil
)
1445 (cons local-name uri
)))
1446 (key-conses (find-key expanded-name
*stylesheet
*)))
1447 (xpath-sys:make-node-set
1448 (labels ((get-by-key (value)
1449 (%key
(node-to-source-document (xpath:context-node ctx
))
1451 (xpath:string-value value
))))
1453 (if (xpath:node-set-p object
)
1454 (xpath::mappend-pipe
#'get-by-key
(xpath-sys:pipe-of object
))
1455 (get-by-key object
)))))))))
1457 ;; FIXME: add alias mechanism for XPath extensions in order to avoid duplication
1459 (xpath-sys:define-xpath-function
/lazy xslt
:current
()
1460 (when *without-xslt-current-p
*
1461 (xslt-error "current() not allowed here"))
1463 (xpath-sys:make-node-set
1464 (xpath-sys:make-pipe
1465 (xpath:context-starting-node ctx
)
1468 (xpath-sys:define-xpath-function
/lazy xslt
:unparsed-entity-uri
(name)
1470 (or (xpath-protocol:unparsed-entity-uri
(xpath:context-node ctx
)
1474 (defun node-to-source-document (node)
1475 (gethash (xpath:first-node
1476 (xpath:evaluate
(xpath:xpath
(:path
(:root
:node
))) node
))
1477 *root-to-document
*))
1479 (defun %get-node-id
(node)
1480 (when (xpath:node-set-p node
)
1481 (setf node
(xpath::textually-first-node node
)))
1484 (source-document-id (node-to-source-document node
))
1485 (xpath-sys:get-node-id node
))))
1487 (xpath-sys:define-xpath-function
/lazy xslt
:generate-id
(&optional node-set-thunk
)
1490 (%get-node-id
(xpath:node-set-value
(funcall node-set-thunk ctx
))))
1492 (%get-node-id
(xpath:context-node ctx
)))))
1494 (declaim (special *builtin-instructions
*))
1496 (xpath-sys:define-xpath-function
/lazy xslt
:element-available
(qname)
1497 (let ((namespaces *namespaces
*)
1498 (extensions *extension-namespaces
*))
1500 (let ((qname (funcall qname ctx
)))
1501 (multiple-value-bind (local-name uri
)
1502 (decode-qname/runtime qname namespaces nil
)
1505 (and (gethash local-name
*builtin-instructions
*) t
))
1506 ((find uri extensions
:test
#'equal
)
1507 (and (find-extension-element local-name uri
) t
))
1511 (xpath-sys:define-xpath-function
/lazy xslt
:function-available
(qname)
1512 (let ((namespaces *namespaces
*))
1514 (let ((qname (funcall qname ctx
)))
1515 (multiple-value-bind (local-name uri
)
1516 (decode-qname/runtime qname namespaces nil
)
1517 (and (zerop (length uri
))
1518 (or (xpath-sys:find-xpath-function local-name
*xsl
*)
1519 (xpath-sys:find-xpath-function local-name uri
))
1522 (xpath-sys:define-xpath-function
/lazy xslt
:system-property
(qname)
1523 (let ((namespaces *namespaces
*))
1525 (let ((qname (xpath:string-value
(funcall qname ctx
))))
1526 (multiple-value-bind (local-name uri
)
1527 (decode-qname/runtime qname namespaces nil
)
1528 (if (equal uri
*xsl
*)
1530 ((equal local-name
"version")
1532 ((equal local-name
"vendor")
1534 ((equal local-name
"vendor-url")
1535 "http://repo.or.cz/w/xuriella.git")
1540 ;; FIXME: should there be separate uri-resolver arguments for stylesheet
1542 (defun apply-stylesheet
1543 (stylesheet source-designator
1544 &key output parameters uri-resolver navigator
)
1545 "@arg[stylesheet]{a stylesheet designator (see below for details)}
1546 @arg[source-designator]{a source document designator (see below for details)}
1547 @arg[output]{optional output sink designator (see below for details)}
1548 @arg[parameters]{a list of @class{parameter} instances}
1549 @arg[uri-resolver]{optional function of one argument}
1550 @arg[navigator]{optional XPath navigator}
1551 @return{The value returned by sax:end-document when called on the
1552 designated output sink.}
1554 @short{Apply a stylesheet to a document.}
1556 This function takes @code{stylesheet} (either a parsed @class{stylesheet}
1557 or a designator for XML file to be parsed) and a source document, specified
1558 using the XML designator @code{source-designator}, and applies the
1559 stylesheet to the document.
1561 An XML designator is any value accepted by @code{cxml:parse}, in particular:
1563 @item{Pathnames -- The file referred to by the pathname will parsed
1565 @item{Stream -- The stream will be parsed using cxml.}
1566 @item{Xstream -- Similar to the stream case, but using cxml's internal
1567 representation of rune streams.}
1568 @item{String -- The string itself will be parsed as an XML document,
1569 and is assumed to have been decoded into characters already.}
1570 @item{Array of (unsigned-byte 8) -- The array itself will be parsed as
1571 an XML document (which has not been decoded yet).}
1574 Note: Since strings are interpreted as documents, namestrings are
1575 not acceptable. Use pathnames instead of namestrings.
1577 An output sink designator is has the following form:
1579 @item{Null -- Designates a string sink. I.e., the result document
1580 of the stylesheet will be returned as a string. This as the default.}
1581 @item{Pathnames -- The file referred to by the pathname will created
1583 @item{Stream -- The stream will be written to.}
1584 @item{SAX or HAX handler -- Events will be sent directly to this sink.}
1587 Note: Specificaton of a sink overrides the specification of XML or HTML
1588 output method in the styl.sheet.
1590 Parameters are identified by names, and have values that are strings.
1591 Top-level parameters of these names are bound accordingly. If a paramater
1592 is not specified, its default value is computed as implemented in the
1593 stylesheet. If parameters are specified that the stylesheet does not
1594 recognize, they will be ignored.
1596 A @code{uri-resolver} is a function taking a PURI object as an argument
1597 and returning a PURI object as a value. The URI resolver will be invoked
1598 for all references to external files, e.g. at compilation time using
1599 xsl:import and xsl:include, and at run-time using the document() function.
1601 The URI resolver can be used to rewrite URLs so that file http:// links
1602 are replaced by file:// links, for example. Another application are
1603 URI resolvers that signal an error instead of returning, for example
1604 so that file:// links forbidden.
1606 The specified @code{navigator} will be passed to XPath protocol functions.
1608 @see{parse-stylesheet}"
1609 (with-profile-counter (*apply-stylesheet-counter
*)
1610 (when (typep stylesheet
'xml-designator
)
1611 (with-profile-counter (*parse-stylesheet-counter
*)
1614 ((cxml:xml-parse-error
1616 (xslt-error "cannot parse stylesheet: ~A" c
))))
1617 (parse-stylesheet stylesheet
:uri-resolver uri-resolver
)))))
1618 (with-resignalled-errors ()
1619 (invoke-with-output-sink
1621 (let* ((*uri-to-document
* (make-hash-table :test
'equal
))
1623 ;; fixme? should be xpath-protocol:node-equal
1624 (make-hash-table :test
'equal
))
1625 (xpath:*navigator
* (or navigator
:default-navigator
))
1626 (puri:*strict-parse
* nil
)
1627 (*stylesheet
* stylesheet
)
1628 (*empty-mode
* (make-mode))
1629 (*default-mode
* (find-mode stylesheet nil
))
1630 (global-variable-chains
1631 (stylesheet-global-variables stylesheet
))
1632 (*global-variable-values
*
1633 (make-variable-value-array (length global-variable-chains
)))
1634 (*uri-resolver
* uri-resolver
)
1636 (if (typep source-designator
'xml-designator
)
1637 (with-profile-counter (*parse-xml-counter
*)
1638 (cxml:parse source-designator
(stp:make-builder
)))
1641 (make-whitespace-stripper
1643 (stylesheet-strip-thunk stylesheet
)))
1644 (ctx (xpath:make-context xpath-root-node
))
1645 (document (make-source-document
1647 :root-node xpath-root-node
)))
1648 (when (pathnamep source-designator
) ;fixme: else use base uri?
1649 (setf (gethash source-designator
*uri-to-document
*) document
))
1650 (setf (gethash xpath-root-node
*root-to-document
*) document
)
1653 (let ((head (car (variable-chain-definitions chain
))))
1654 (when (variable-param-p head
)
1656 (find-parameter-value
1657 (variable-chain-local-name chain
)
1658 (variable-chain-uri chain
)
1661 (setf (global-variable-value
1662 (variable-chain-index chain
))
1664 global-variable-chains
)
1667 (funcall (variable-chain-thunk chain
) ctx
))
1668 global-variable-chains
)
1669 ;; zzz we wouldn't have to mask float traps here if we used the
1670 ;; XPath API properly. Unfortunately I've been using FUNCALL
1671 ;; everywhere instead of EVALUATE, so let's paper over that
1672 ;; at a central place to be sure:
1673 (xpath::with-float-traps-masked
()
1674 (apply-templates ctx
:mode
*default-mode
*))))
1675 (stylesheet-output-specification stylesheet
)
1678 (defun find-attribute-set (local-name uri
&optional
(stylesheet *stylesheet
*))
1679 (or (gethash (cons local-name uri
) (stylesheet-attribute-sets stylesheet
))
1680 (xslt-error "no such attribute set: ~A/~A" local-name uri
)))
1682 (defun apply-templates/list
(list &key param-bindings sort-predicate mode
)
1683 (when sort-predicate
1685 (mapcar #'xpath
:context-node
1686 (stable-sort (contextify-node-list list
)
1688 (let* ((n (length list
))
1689 (s/d
(lambda () n
)))
1694 (apply-templates (xpath:make-context child s
/d i
)
1695 :param-bindings param-bindings
1698 (defvar *stack-limit
* 200)
1700 (defun invoke-with-stack-limit (fn)
1701 (let ((*stack-limit
* (1- *stack-limit
*)))
1702 (unless (plusp *stack-limit
*)
1703 (xslt-error "*stack-limit* reached; stack overflow"))
1706 (defun invoke-template (ctx template param-bindings
)
1707 (let ((*lexical-variable-values
*
1708 (make-variable-value-array (template-n-variables template
))))
1709 (with-stack-limit ()
1711 for
(name-cons value
) in param-bindings
1712 for
(nil index nil
) = (find name-cons
1713 (template-params template
)
1718 (setf (lexical-variable-value index
) value
)))
1719 (funcall (template-body template
) ctx
))))
1721 (defun apply-default-templates (ctx mode
)
1722 (let ((node (xpath:context-node ctx
)))
1724 ((or (xpath-protocol:node-type-p node
:processing-instruction
)
1725 (xpath-protocol:node-type-p node
:comment
)))
1726 ((or (xpath-protocol:node-type-p node
:text
)
1727 (xpath-protocol:node-type-p node
:attribute
))
1728 (write-text (xpath-protocol:node-text node
)))
1730 (apply-templates/list
1732 (xpath-protocol:child-pipe node
))
1735 (defvar *apply-imports
*)
1736 (defvar *profiling-enabled-p
* nil
)
1738 (defun apply-applicable-templates (ctx templates param-bindings finally
)
1739 (labels ((apply-imports (&optional actual-param-bindings
)
1741 (let* ((this (pop templates
))
1742 (low (template-apply-imports-limit this
))
1743 (high (template-import-priority this
)))
1747 (<= low
(template-import-priority x
) high
))
1749 (if *profiling-enabled-p
*
1750 (invoke-template/profile ctx this actual-param-bindings
)
1751 (invoke-template ctx this actual-param-bindings
)))
1752 (funcall finally
))))
1753 (let ((*apply-imports
* #'apply-imports
))
1754 (apply-imports param-bindings
))))
1756 (defun apply-templates (ctx &key param-bindings mode
)
1757 (apply-applicable-templates ctx
1758 (find-templates ctx
(or mode
*default-mode
*))
1761 (apply-default-templates ctx mode
))))
1763 (defun call-template (ctx name
&optional param-bindings
)
1764 (apply-applicable-templates ctx
1765 (find-named-templates name
)
1768 (xslt-error "cannot find named template: ~s"
1771 (defun find-templates (ctx mode
)
1772 (let* ((matching-candidates
1773 (xpattern:matching-values
(mode-match-thunk mode
)
1774 (xpath:context-node ctx
)))
1776 (if matching-candidates
1779 :key
#'template-import-priority
))
1781 (priority-groups (make-array npriorities
:initial-element nil
)))
1782 (dolist (template matching-candidates
)
1784 (elt priority-groups
(template-import-priority template
))))
1786 for i from
(1- npriorities
) downto
0
1787 for group
= (elt priority-groups i
)
1788 for template
= (maximize #'template
< group
)
1792 (defun find-named-templates (name)
1793 (gethash name
(stylesheet-named-templates *stylesheet
*)))
1795 (defun template< (a b
) ;assuming same import priority
1796 (let ((p (template-priority a
))
1797 (q (template-priority b
)))
1802 (xslt-cerror "conflicting templates:~_~A,~_~A"
1803 (template-match-expression a
)
1804 (template-match-expression b
))
1805 (< (template-position a
) (template-position b
))))))
1807 (defun maximize (< things
)
1809 (let ((max (car things
)))
1810 (dolist (other (cdr things
))
1811 (when (funcall < max other
)
1815 (defun invoke-with-output-sink (fn output-spec output
)
1818 (with-open-file (s output
1820 :element-type
'(unsigned-byte 8)
1821 :if-exists
:rename-and-delete
)
1822 (invoke-with-output-sink fn output-spec s
)))
1824 (invoke-with-output-sink fn
1826 (make-output-sink output-spec output
)))
1827 ((or hax
:abstract-handler sax
:abstract-handler
)
1828 (with-xml-output output
1829 (when (typep output
'(or combi-sink auto-detect-sink
))
1830 (sax:start-dtd output
1831 :autodetect-me-please
1832 (output-doctype-public output-spec
)
1833 (output-doctype-system output-spec
)))
1836 (defun make-output-sink (output-spec stream
)
1839 (let ((et (stream-element-type stream
)))
1841 ((or (null et
) (subtypep et
'(unsigned-byte 8)))
1842 (runes:make-octet-stream-ystream stream
))
1843 ((subtypep et
'character
)
1844 (runes:make-character-stream-ystream stream
))))
1845 (runes:make-rod-ystream
)))
1846 (omit-xml-declaration-p
1847 (boolean-or-error (output-omit-xml-declaration output-spec
)))
1848 (sink-encoding (or (output-encoding output-spec
) "UTF-8"))
1851 (setf (runes:ystream-encoding ystream
)
1852 (cxml::find-output-encoding sink-encoding
))
1853 (make-instance 'cxml
::sink
1855 :omit-xml-declaration-p omit-xml-declaration-p
1856 :encoding sink-encoding
))))
1857 (flet ((make-combi-sink ()
1858 (make-instance 'combi-sink
1859 :hax-target
(make-instance 'chtml
::sink
1861 :sax-target sax-target
1862 :media-type
(output-media-type output-spec
)
1863 :encoding sink-encoding
)))
1864 (let ((method-key (output-method output-spec
)))
1866 ((and (eq method-key
:html
)
1867 (null (output-doctype-system output-spec
))
1868 (null (output-doctype-public output-spec
)))
1870 ((eq method-key
:text
)
1871 (make-text-filter sax-target
))
1872 ((and (eq method-key
:xml
)
1873 (null (output-doctype-system output-spec
)))
1876 (make-auto-detect-sink (make-combi-sink) method-key
)))))))
1891 ;; for profiling output only:
1896 (defun expression-priority (form)
1897 (let ((step (second form
)))
1898 (if (and (null (cddr form
))
1900 (member (car step
) '(:child
:attribute
))
1902 (let ((name (second step
)))
1906 (or (eq (car name
) :qname
)
1907 (eq (car name
) :processing-instruction
))))
1910 (or (eq (car name
) :namespace
)
1911 (eq (car name
) '*)))
1917 (defun parse-key-pattern (str)
1918 (with-resignalled-errors ()
1919 (with-forward-compatible-errors
1920 (xpath:parse-xpath
"compile-time-error()") ;hack
1922 (mapcar #'(lambda (item)
1923 `(:path
(:root
:node
)
1924 (:descendant-or-self
:node
)
1926 (cdr (xpath::parse-pattern-expression str
)))))
1927 (if (null (rest parsed
))
1929 `(:union
,@parsed
))))))
1931 (defun compile-value-thunk (value env
)
1932 (if (and (listp value
) (eq (car value
) 'progn
))
1933 (let ((inner-thunk (compile-instruction value env
)))
1935 (apply-to-result-tree-fragment ctx inner-thunk
)))
1936 (compile-xpath value env
)))
1938 (defun compile-var-binding (name value env
)
1939 (multiple-value-bind (local-name uri
)
1940 (decode-qname name env nil
)
1941 (let ((thunk (xslt-trace-thunk
1942 (compile-value-thunk value env
)
1943 "local variable ~s = ~s" name
:result
)))
1944 (list (cons local-name uri
)
1945 (push-variable local-name
1947 *lexical-variable-declarations
*)
1950 (defun compile-var-bindings (forms env
)
1952 for
(name value
) in forms
1953 collect
(compile-var-binding name value env
)))
1955 (defmacro sometimes-with-attributes
((&rest attrs
) node
&body body
)
1958 (if *forwards-compatible-p
*
1959 (stp:with-attributes
(,@attrs
) ,x
,@body
)
1960 (only-with-attributes (,@attrs
) ,x
,@body
)))))
1962 (defun compile-template (<template
> env position
)
1963 (sometimes-with-attributes (match name priority mode
) <template
>
1964 (unless (or name match
)
1965 (xslt-error "missing match in template"))
1966 (multiple-value-bind (params body-pos
)
1969 for child in
(stp:list-children
<template
>)
1970 while
(namep child
"param")
1971 collect
(parse-param child
) into params
1972 finally
(return (values params i
)))
1973 (let* ((*lexical-variable-declarations
* (make-empty-declaration-array))
1974 (param-bindings (compile-var-bindings params env
))
1975 (body (parse-body <template
> body-pos
(mapcar #'car params
)))
1976 (body-thunk (compile-instruction `(progn ,@body
) env
))
1982 ;; set params that weren't initialized by apply-templates
1983 (loop for
(name index param-thunk
) in param-bindings
1984 when
(eq (lexical-variable-value index nil
) 'unbound
)
1985 do
(setf (lexical-variable-value index
)
1986 (funcall param-thunk ctx
)))
1987 (funcall body-thunk ctx
))))
1988 "template: match = ~s name = ~s" match name
))
1989 (n-variables (length *lexical-variable-declarations
*)))
1992 (multiple-value-bind (local-name uri
)
1993 (decode-qname name env nil
)
1995 (make-template :name
(cons local-name uri
)
1996 :import-priority
*import-priority
*
1997 :apply-imports-limit
*apply-imports-limit
*
1998 :params param-bindings
1999 :body outer-body-thunk
2000 :n-variables n-variables
2001 ;; record unparsed `name' for profiler output:
2002 :unparsed-qname name
))))
2004 (mapcar (lambda (expression)
2005 (let* ((compiled-pattern
2007 (car (without-xslt-current ()
2008 (xpattern:compute-patterns
2009 `(:patterns
,expression
)
2013 "match-thunk for template (match ~s): ~s --> ~s"
2014 match expression
:result
))
2016 (xpath::parse-xnum priority
)
2017 (expression-priority expression
)))
2020 (unless (and (numberp p
)
2021 (not (xpath::inf-p p
))
2022 (not (xpath::nan-p p
)))
2023 (xslt-error "failed to parse priority"))
2026 (make-template :match-expression expression
2027 :compiled-pattern compiled-pattern
2028 :import-priority
*import-priority
*
2029 :apply-imports-limit
*apply-imports-limit
*
2033 :params param-bindings
2034 :body outer-body-thunk
2035 :n-variables n-variables
)))
2036 (setf (xpattern:pattern-value compiled-pattern
)
2039 (cdr (xpattern:parse-pattern-expression match
)))))))))
2041 (xuriella::parse-stylesheet
#p
"/home/david/src/lisp/xuriella/test.xsl")