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
)
53 (error 'xslt-error
:format-control fmt
:format-arguments args
))
55 ;; Many errors in XSLT are "recoverable", with a specified action that must
56 ;; be taken if the error isn't raised. My original plan was to implement
57 ;; such issues as continuable conditions, so that users are alerted about
58 ;; portability issues with their stylesheet, but can contiue anyway.
60 ;; However, our current test suite driver compares against Saxon results,
61 ;; and Saxon recovers (nearly) always. So our coverage of these errors
62 ;; is very incomplete.
64 ;; Re-enable this code once we can check that it's actually being used
66 (defun xslt-cerror (fmt &rest args
)
67 (declare (ignore fmt args
))
69 (with-simple-restart (recover "recover")
70 (error 'recoverable-xslt-error
72 :format-arguments args
)))
76 (defmacro handler-case
* (form &rest clauses
)
77 ;; like HANDLER-CASE if *DEBUG* is off. If it's on, don't establish
78 ;; a handler at all so that we see the real stack traces. (We could use
79 ;; HANDLER-BIND here and check at signalling time, but doesn't seem
81 (let ((doit (gensym)))
82 `(flet ((,doit
() ,form
))
89 (defmacro with-resignalled-errors
((&optional
) &body body
)
90 `(invoke-with-resignalled-errors (lambda () ,@body
)))
92 (defun invoke-with-resignalled-errors (fn)
97 (babel-encodings:character-encoding-error
99 (xslt-error "~A" c
))))
102 (defmacro with-forward-compatible-errors
(error-form &body body
)
103 `(invoke-with-forward-compatible-errors (lambda () ,@body
)
104 (lambda () ,error-form
)))
106 (defun invoke-with-forward-compatible-errors (fn error-fn
)
113 (when *forwards-compatible-p
*
115 (setf result
(funcall fn
)))
118 (setf result
(funcall error-fn
))
122 (defun compile-xpath (xpath &optional env
)
123 (with-resignalled-errors ()
124 (with-forward-compatible-errors
126 (xslt-error "attempt to evaluate an XPath expression with compile-time errors, delayed due to forwards compatible processing: ~A"
128 (xpath:compile-xpath xpath env
))))
130 (defmacro with-stack-limit
((&optional
) &body body
)
131 `(invoke-with-stack-limit (lambda () ,@body
)))
133 (defparameter *without-xslt-current-p
* nil
)
135 (defmacro without-xslt-current
((&optional
) &body body
)
136 `(invoke-without-xslt-current (lambda () ,@body
)))
138 (defun invoke-without-xslt-current (fn)
139 (let ((*without-xslt-current-p
* t
))
142 ;;; (defun invoke-without-xslt-current (fn)
143 ;;; (let ((non-extensions (gethash "" xpath::*extensions*))
144 ;;; (xpath::*extensions*
145 ;;; ;; hide XSLT extensions
146 ;;; (make-hash-table :test #'equal)))
147 ;;; (setf (gethash "" xpath::*extensions*) non-extensions)
151 ;;;; Helper functions and macros
153 (defun check-for-invalid-attributes (valid-names node
)
154 (labels ((check-attribute (a)
156 (let ((uri (stp:namespace-uri a
)))
157 (or (and (plusp (length uri
)) (not (equal uri
*xsl
*)))
158 (find (cons (stp:local-name a
) uri
)
161 (xslt-error "attribute ~A not allowed on ~A"
163 (stp:local-name node
)))))
164 (stp:map-attributes nil
#'check-attribute node
)))
166 (defmacro only-with-attributes
((&rest specs
) node
&body body
)
168 (mapcar (lambda (entry)
169 (if (and (listp entry
) (cdr entry
))
170 (destructuring-bind (name &optional
(uri ""))
173 (cons (string-downcase
175 (symbol-name entry
)))
179 `(let ((,%NODE
,node
))
180 (check-for-invalid-attributes ',valid-names
,%NODE
)
181 (stp:with-attributes
,specs
,%NODE
184 (defun map-pipe-eagerly (fn pipe
)
185 (xpath::enumerate pipe
:key fn
:result nil
))
187 (defmacro do-pipe
((var pipe
&optional result
) &body body
)
189 (map-pipe-eagerly #'(lambda (,var
) ,@body
) ,pipe
)
193 ;;;; XSLT-ENVIRONMENT and XSLT-CONTEXT
195 (defparameter *initial-namespaces
*
197 ("xmlns" .
#"http://www.w3.org/2000/xmlns/")
198 ("xml" .
#"http://www.w3.org/XML/1998/namespace")))
200 (defparameter *namespaces
*
201 *initial-namespaces
*)
203 (defvar *global-variable-declarations
*)
204 (defvar *lexical-variable-declarations
*)
206 (defvar *global-variable-values
*)
207 (defvar *lexical-variable-values
*)
209 (defclass xslt-environment
() ())
211 (defun split-qname (str)
213 (multiple-value-bind (prefix local-name
)
214 (cxml::split-qname str
)
216 ;; FIXME: cxml should really offer a function that does
217 ;; checks for NCName and QName in a sensible way for user code.
218 ;; cxml::split-qname is tailored to the needs of the parser.
220 ;; For now, let's just check the syntax explicitly.
221 (and (or (null prefix
) (xpath::nc-name-p prefix
))
222 (xpath::nc-name-p local-name
))
223 (xslt-error "not a qname: ~A" str
))
224 (values prefix local-name
))
225 (cxml:well-formedness-violation
()
226 (xslt-error "not a qname: ~A" str
))))
228 (defun decode-qname (qname env attributep
&key allow-unknown-namespace
)
230 (xslt-error "missing name"))
231 (multiple-value-bind (prefix local-name
)
234 (if (or prefix
(not attributep
))
235 (or (xpath-sys:environment-find-namespace env
(or prefix
""))
236 (if allow-unknown-namespace
238 (xslt-error "namespace not found: ~A" prefix
)))
242 (defmethod xpath-sys:environment-find-namespace
((env xslt-environment
) prefix
)
243 (or (cdr (assoc prefix
*namespaces
* :test
'equal
))
245 ;; Change the entire code base to represent "no prefix" as the
246 ;; empty string consistently. unparse.lisp has already been changed.
247 (and (equal prefix
"")
248 (cdr (assoc nil
*namespaces
* :test
'equal
)))
249 (and (eql prefix nil
)
250 (cdr (assoc "" *namespaces
* :test
'equal
)))))
252 (defun find-variable-index (local-name uri table
)
253 (position (cons local-name uri
) table
:test
'equal
))
255 (defun intern-global-variable (local-name uri
)
256 (or (find-variable-index local-name uri
*global-variable-declarations
*)
257 (push-variable local-name uri
*global-variable-declarations
*)))
259 (defun push-variable (local-name uri table
)
262 (vector-push-extend (cons local-name uri
) table
)))
264 (defun lexical-variable-value (index &optional
(errorp t
))
265 (let ((result (svref *lexical-variable-values
* index
)))
267 (assert (not (eq result
'unbound
))))
270 (defun (setf lexical-variable-value
) (newval index
)
271 (assert (not (eq newval
'unbound
)))
272 (setf (svref *lexical-variable-values
* index
) newval
))
274 (defun global-variable-value (index &optional
(errorp t
))
275 (let ((result (svref *global-variable-values
* index
)))
277 (assert (not (eq result
'unbound
))))
280 (defun (setf global-variable-value
) (newval index
)
281 (assert (not (eq newval
'unbound
)))
282 (setf (svref *global-variable-values
* index
) newval
))
284 (defmethod xpath-sys:environment-find-function
285 ((env xslt-environment
) lname uri
)
286 (or (if (string= uri
"")
287 (or (xpath-sys:find-xpath-function lname
*xsl
*)
288 (xpath-sys:find-xpath-function lname uri
))
289 (xpath-sys:find-xpath-function lname uri
))
290 (when *forwards-compatible-p
*
291 (lambda (&rest ignore
)
292 (declare (ignore ignore
))
293 (xslt-error "attempt to call an unknown XPath function (~A); error delayed until run-time due to forwards compatible processing"
296 (defmethod xpath-sys:environment-find-variable
297 ((env xslt-environment
) lname uri
)
299 (find-variable-index lname uri
*lexical-variable-declarations
*)))
302 (declare (ignore ctx
))
303 (svref *lexical-variable-values
* index
)))))
305 (defclass lexical-xslt-environment
(xslt-environment) ())
307 (defmethod xpath-sys:environment-find-variable
308 ((env lexical-xslt-environment
) lname uri
)
309 (or (call-next-method)
311 (find-variable-index lname uri
*global-variable-declarations
*)))
315 (declare (ignore ctx
))
316 (svref *global-variable-values
* index
))
317 "global ~s (uri ~s) = ~s" lname uri
:result
)))))
319 (defclass key-environment
(xslt-environment) ())
321 (defmethod xpath-sys:environment-find-variable
322 ((env key-environment
) lname uri
)
323 (declare (ignore lname uri
))
324 (xslt-error "disallowed variable reference"))
326 (defclass global-variable-environment
(xslt-environment)
327 ((initial-global-variable-thunks
328 :initarg
:initial-global-variable-thunks
329 :accessor initial-global-variable-thunks
)))
331 (defmethod xpath-sys:environment-find-variable
332 ((env global-variable-environment
) lname uri
)
333 (or (call-next-method)
334 (gethash (cons lname uri
) (initial-global-variable-thunks env
))))
337 ;;;; TOPLEVEL-TEXT-OUTPUT-SINK
339 ;;;; A sink that serializes only text not contained in any element.
341 (defmacro with-toplevel-text-output-sink
((var) &body body
)
342 `(invoke-with-toplevel-text-output-sink (lambda (,var
) ,@body
)))
344 (defclass toplevel-text-output-sink
(sax:default-handler
)
345 ((target :initarg
:target
:accessor text-output-sink-target
)
346 (depth :initform
0 :accessor textoutput-sink-depth
)))
348 (defmethod sax:start-element
((sink toplevel-text-output-sink
)
349 namespace-uri local-name qname attributes
)
350 (declare (ignore namespace-uri local-name qname attributes
))
351 (incf (textoutput-sink-depth sink
)))
353 (defmethod sax:characters
((sink toplevel-text-output-sink
) data
)
354 (when (zerop (textoutput-sink-depth sink
))
355 (write-string data
(text-output-sink-target sink
))))
357 (defmethod sax:unescaped
((sink toplevel-text-output-sink
) data
)
358 (sax:characters sink data
))
360 (defmethod sax:end-element
((sink toplevel-text-output-sink
)
361 namespace-uri local-name qname
)
362 (declare (ignore namespace-uri local-name qname
))
363 (decf (textoutput-sink-depth sink
)))
365 (defun invoke-with-toplevel-text-output-sink (fn)
366 (with-output-to-string (s)
367 (funcall fn
(make-instance 'toplevel-text-output-sink
:target s
))))
372 ;;;; A sink that passes through only text (at any level) and turns to
373 ;;;; into unescaped characters.
375 (defclass text-filter
(sax:default-handler
)
376 ((target :initarg
:target
:accessor text-filter-target
)))
378 (defmethod sax:characters
((sink text-filter
) data
)
379 (sax:unescaped
(text-filter-target sink
) data
))
381 (defmethod sax:unescaped
((sink text-filter
) data
)
382 (sax:unescaped
(text-filter-target sink
) data
))
384 (defmethod sax:end-document
((sink text-filter
))
385 (sax:end-document
(text-filter-target sink
)))
387 (defun make-text-filter (target)
388 (make-instance 'text-filter
:target target
))
393 ;;;; A sink that recovers from sax:unescaped using sax:characters, as per
396 (defclass escaper
(cxml:broadcast-handler
)
399 (defmethod sax:unescaped
((sink escaper
) data
)
400 (sax:characters sink data
))
402 (defun make-escaper (target)
403 (make-instance 'escaper
:handlers
(list target
)))
408 (defun of-name (local-name)
409 (stp:of-name local-name
*xsl
*))
411 (defun namep (node local-name
)
412 (and (typep node
'(or stp
:element stp
:attribute
))
413 (equal (stp:namespace-uri node
) *xsl
*)
414 (equal (stp:local-name node
) local-name
)))
417 ;;;; PARSE-STYLESHEET
419 (defstruct stylesheet
420 (modes (make-hash-table :test
'equal
))
421 (global-variables (make-empty-declaration-array))
422 (output-specification (make-output-specification))
425 (named-templates (make-hash-table :test
'equal
))
426 (attribute-sets (make-hash-table :test
'equal
))
427 (keys (make-hash-table :test
'equal
))
428 (namespace-aliases (make-hash-table :test
'equal
))
429 (decimal-formats (make-hash-table :test
'equal
))
430 (initial-global-variable-thunks (make-hash-table :test
'equal
)))
434 (match-thunk (lambda (ignore) (declare (ignore ignore
)) nil
)))
436 (defun find-mode (stylesheet local-name
&optional uri
)
437 (gethash (cons local-name uri
) (stylesheet-modes stylesheet
)))
439 (defun ensure-mode (stylesheet &optional local-name uri
)
440 (or (find-mode stylesheet local-name uri
)
441 (setf (gethash (cons local-name uri
) (stylesheet-modes stylesheet
))
444 (defun ensure-mode/qname
(stylesheet qname env
)
446 (multiple-value-bind (local-name uri
)
447 (decode-qname qname env nil
)
448 (ensure-mode stylesheet local-name uri
))
449 (find-mode stylesheet nil
)))
451 (defun acons-namespaces
452 (element &optional
(bindings *namespaces
*) include-redeclared
)
453 (map-namespace-declarations (lambda (prefix uri
)
454 (push (cons prefix uri
) bindings
))
459 (defun find-key (name stylesheet
)
460 (or (gethash name
(stylesheet-keys stylesheet
))
461 (xslt-error "unknown key: ~a" name
)))
463 (defun make-key (match use
) (cons match use
))
465 (defun key-match (key) (car key
))
467 (defun key-use (key) (cdr key
))
469 (defun add-key (stylesheet name match use
)
470 (push (make-key match use
)
471 (gethash name
(stylesheet-keys stylesheet
))))
473 (defvar *excluded-namespaces
* (list *xsl
*))
474 (defvar *empty-mode
*)
475 (defvar *default-mode
*)
477 (defvar *xsl-include-stack
* nil
)
479 (defun uri-to-pathname (uri)
480 (cxml::uri-to-pathname
(puri:parse-uri uri
)))
482 ;; Why this extra check for literal result element used as stylesheets,
483 ;; instead of a general check for every literal result element? Because
484 ;; Stylesheet__91804 says so.
485 (defun check-Errors_err035 (literal-result-element)
486 (let ((*namespaces
* (acons-namespaces literal-result-element
))
487 (env (make-instance 'lexical-xslt-environment
)))
488 (stp:with-attributes
((extension-element-prefixes
489 "extension-element-prefixes"
491 literal-result-element
492 (dolist (prefix (words (or extension-element-prefixes
"")))
493 (if (equal prefix
"#default")
495 (unless (cxml-stp-impl::nc-name-p prefix
)
496 (xslt-error "invalid prefix: ~A" prefix
)))
498 (or (xpath-sys:environment-find-namespace env prefix
)
499 (xslt-error "namespace not found: ~A" prefix
))))
500 (when (equal uri
(stp:namespace-uri literal-result-element
))
501 (xslt-error "literal result element used as stylesheet, but is ~
502 declared as an extension element")))))))
504 (defun unwrap-2.3
(document)
505 (let ((literal-result-element (stp:document-element document
))
506 (new-template (stp:make-element
"template" *xsl
*))
507 (new-document-element (stp:make-element
"stylesheet" *xsl
*)))
508 (check-Errors_err035 literal-result-element
)
509 (setf (stp:attribute-value new-document-element
"version")
510 (or (stp:attribute-value literal-result-element
"version" *xsl
*)
511 (xslt-error "not a stylesheet: root element lacks xsl:version")))
512 (setf (stp:attribute-value new-template
"match") "/")
513 (setf (stp:document-element document
) new-document-element
)
514 (stp:append-child new-document-element new-template
)
515 (stp:append-child new-template literal-result-element
)
516 new-document-element
))
518 (defun parse-stylesheet-to-stp (input uri-resolver
)
519 (let* ((d (cxml:parse input
(make-text-normalizer (cxml-stp:make-builder
))))
520 (<transform
> (stp:document-element d
)))
521 (unless (equal (stp:namespace-uri
<transform
>) *xsl
*)
522 (setf <transform
> (unwrap-2.3 d
)))
523 (strip-stylesheet <transform
>)
524 (unless (and (equal (stp:namespace-uri
<transform
>) *xsl
*)
525 (or (equal (stp:local-name
<transform
>) "transform")
526 (equal (stp:local-name
<transform
>) "stylesheet")))
527 (xslt-error "not a stylesheet"))
528 (check-for-invalid-attributes
530 ("exclude-result-prefixes" .
"")
531 ("extension-element-prefixes" .
"")
532 ("space" .
"http://www.w3.org/XML/1998/namespace")
536 (or (stp:find-child-if
(of-name "stylesheet") <transform
>)
537 (stp:find-child-if
(of-name "transform") <transform
>))))
539 (xslt-error "invalid top-level element ~A" (stp:local-name invalid
))))
540 (dolist (include (stp:filter-children
(of-name "include") <transform
>))
541 (let* ((uri (puri:merge-uris
(or (stp:attribute-value include
"href")
542 (xslt-error "include without href"))
543 (stp:base-uri include
)))
544 (uri (if uri-resolver
545 (funcall uri-resolver uri
)
547 (str (puri:render-uri uri nil
))
550 (uri-to-pathname uri
)
551 (cxml:xml-parse-error
(c)
552 (xslt-error "cannot find included stylesheet ~A: ~A"
556 :element-type
'(unsigned-byte 8)
557 :if-does-not-exist nil
)
559 (xslt-error "cannot find included stylesheet ~A at ~A"
561 (when (find str
*xsl-include-stack
* :test
#'equal
)
562 (xslt-error "recursive inclusion of ~A" uri
))
563 (let* ((*xsl-include-stack
* (cons str
*xsl-include-stack
*))
564 (<transform
>2 (parse-stylesheet-to-stp stream uri-resolver
)))
565 (stp:insert-child-after
<transform
>
566 (stp:copy
<transform
>2)
568 (stp:detach include
)))))
571 (defvar *instruction-base-uri
*) ;misnamed, is also used in other attributes
572 (defvar *apply-imports-limit
*)
573 (defvar *import-priority
*)
574 (defvar *extension-namespaces
*)
575 (defvar *forwards-compatible-p
*)
577 (defmacro do-toplevel
((var xpath
<transform
>) &body body
)
578 `(map-toplevel (lambda (,var
) ,@body
) ,xpath
,<transform
>))
580 (defun map-toplevel (fn xpath
<transform
>)
581 (dolist (node (list-toplevel xpath
<transform
>))
582 (let ((*namespaces
* *initial-namespaces
*))
583 (xpath:do-node-set
(ancestor (xpath:evaluate
"ancestor::node()" node
))
584 (xpath:with-namespaces
(("" #.
*xsl
*))
585 (when (xpath:node-matches-p ancestor
"stylesheet|transform")
586 ;; discard namespaces from including stylesheets
587 (setf *namespaces
* *initial-namespaces
*)))
588 (when (xpath-protocol:node-type-p ancestor
:element
)
589 (setf *namespaces
* (acons-namespaces ancestor
*namespaces
* t
))))
592 (defun list-toplevel (xpath <transform
>)
593 (labels ((recurse (sub)
596 (xpath:evaluate
"transform|stylesheet" sub
))))
598 (xpath-sys:pipe-of
(xpath:evaluate xpath sub
))
599 (xpath::mappend-pipe
#'recurse subsubs
)))))
600 (xpath::sort-nodes
(recurse <transform
>))))
602 (defmacro with-import-magic
((node env
) &body body
)
603 `(invoke-with-import-magic (lambda () ,@body
) ,node
,env
))
605 (defun invoke-with-import-magic (fn node env
)
606 (unless (or (namep node
"stylesheet") (namep node
"transform"))
607 (setf node
(stp:parent node
)))
608 (let ((*excluded-namespaces
* (list *xsl
*))
609 (*extension-namespaces
* '())
610 (*forwards-compatible-p
*
611 (not (equal (stp:attribute-value node
"version") "1.0"))))
612 (parse-exclude-result-prefixes! node env
)
613 (parse-extension-element-prefixes! node env
)
616 (defun parse-1-stylesheet (env stylesheet designator uri-resolver
)
617 (let* ((<transform
> (parse-stylesheet-to-stp designator uri-resolver
))
618 (instruction-base-uri (stp:base-uri
<transform
>))
619 (namespaces (acons-namespaces <transform
>))
620 (apply-imports-limit (1+ *import-priority
*))
622 (let ((*namespaces
* namespaces
))
623 (invoke-with-import-magic (constantly t
) <transform
> env
))
624 (do-toplevel (elt "node()" <transform
>)
625 (let ((version (stp:attribute-value
(stp:parent elt
) "version")))
628 (xslt-error "stylesheet lacks version"))
629 ((equal version
"1.0")
630 (if (typep elt
'stp
:element
)
631 (when (or (equal (stp:namespace-uri elt
) "")
632 (and (equal (stp:namespace-uri elt
) *xsl
*)
633 (not (find (stp:local-name elt
)
634 '("key" "template" "output"
635 "strip-space" "preserve-space"
636 "attribute-set" "namespace-alias"
637 "decimal-format" "variable" "param"
639 ;; for include handling:
640 "stylesheet" "transform")
642 (xslt-error "unknown top-level element ~A" (stp:local-name elt
)))
643 (xslt-error "text at top-level"))))))
644 (macrolet ((with-specials ((&optional
) &body body
)
645 `(let ((*instruction-base-uri
* instruction-base-uri
)
646 (*namespaces
* namespaces
)
647 (*apply-imports-limit
* apply-imports-limit
))
650 (do-toplevel (import "import" <transform
>)
651 (when (let ((prev (xpath:first-node
652 (xpath:evaluate
"preceding-sibling::*"
655 (and prev
(not (namep prev
"import"))))
656 (xslt-error "import not at beginning of stylesheet"))
657 (let ((uri (puri:merge-uris
(or (stp:attribute-value import
"href")
658 (xslt-error "import without href"))
659 (stp:base-uri import
))))
660 (push (parse-imported-stylesheet env stylesheet uri uri-resolver
)
662 (let ((import-priority
663 (incf *import-priority
*))
664 (var-cont (prepare-global-variables stylesheet
<transform
>)))
665 (parse-namespace-aliases! stylesheet
<transform
> env
)
666 ;; delay the rest of compilation until we've seen all global
669 (mapc #'funcall
(nreverse continuations
))
671 (let ((*import-priority
* import-priority
))
673 (parse-keys! stylesheet
<transform
> env
)
674 (parse-templates! stylesheet
<transform
> env
)
675 (parse-output! stylesheet
<transform
> env
)
676 (parse-strip/preserve-space
! stylesheet
<transform
> env
)
677 (parse-attribute-sets! stylesheet
<transform
> env
)
678 (parse-decimal-formats! stylesheet
<transform
> env
))))))))
680 (defvar *xsl-import-stack
* nil
)
682 (defun parse-imported-stylesheet (env stylesheet uri uri-resolver
)
683 (let* ((uri (if uri-resolver
684 (funcall uri-resolver uri
)
686 (str (puri:render-uri uri nil
))
689 (uri-to-pathname uri
)
690 (cxml:xml-parse-error
(c)
691 (xslt-error "cannot find imported stylesheet ~A: ~A"
695 :element-type
'(unsigned-byte 8)
696 :if-does-not-exist nil
)
698 (xslt-error "cannot find imported stylesheet ~A at ~A"
700 (when (find str
*xsl-import-stack
* :test
#'equal
)
701 (xslt-error "recursive inclusion of ~A" uri
))
702 (let ((*xsl-import-stack
* (cons str
*xsl-import-stack
*)))
703 (parse-1-stylesheet env stylesheet stream uri-resolver
)))))
705 (defvar *included-attribute-sets
*)
707 (defun parse-stylesheet (designator &key uri-resolver
)
708 (with-resignalled-errors ()
709 (xpath:with-namespaces
((nil #.
*xsl
*))
710 (let* ((*import-priority
* 0)
711 (xpath:*allow-variables-in-patterns
* nil
)
712 (puri:*strict-parse
* nil
)
713 (stylesheet (make-stylesheet))
715 ;; zzz this is for remove-excluded-namespaces only
717 (env (make-instance 'lexical-xslt-environment
))
718 (*excluded-namespaces
* *excluded-namespaces
*)
719 (*global-variable-declarations
* (make-empty-declaration-array))
720 (*included-attribute-sets
* nil
))
721 (ensure-mode stylesheet nil
)
722 (funcall (parse-1-stylesheet env stylesheet designator uri-resolver
))
723 ;; reverse attribute sets:
724 (let ((table (stylesheet-attribute-sets stylesheet
)))
725 (maphash (lambda (k v
)
726 (setf (gethash k table
) (nreverse v
)))
729 (dolist (sets *included-attribute-sets
*)
730 (loop for
(local-name uri nil
) in sets do
731 (find-attribute-set local-name uri stylesheet
)))
733 (unless (find-decimal-format "" "" stylesheet nil
)
734 (setf (find-decimal-format "" "" stylesheet
)
735 (make-decimal-format)))
736 ;; compile a template matcher for each mode:
738 for mode being each hash-value in
(stylesheet-modes stylesheet
)
740 (setf (mode-match-thunk mode
)
741 (xpath:make-pattern-matcher
742 (mapcar #'template-compiled-pattern
743 (mode-templates mode
)))))
744 ;; and for the strip tests
745 (setf (stylesheet-strip-thunk stylesheet
)
746 (let ((patterns (stylesheet-strip-tests stylesheet
)))
748 (xpath:make-pattern-matcher
749 (mapcar #'strip-test-compiled-pattern patterns
)))))
752 (defun parse-attribute-sets! (stylesheet <transform
> env
)
753 (do-toplevel (elt "attribute-set" <transform
>)
754 (with-import-magic (elt env
)
756 (mapcar (lambda (qname)
757 (multiple-value-list (decode-qname qname env nil
)))
759 (stp:attribute-value elt
"use-attribute-sets"))))
765 (and (typep child
'stp
:element
)
766 (or (and (equal (stp:namespace-uri child
) *xsl
*)
767 (equal (stp:local-name child
)
769 (find (stp:namespace-uri child
)
770 *extension-namespaces
*
772 (xslt-error "non-attribute found in attribute set"))
773 (parse-instruction child
))
775 (*lexical-variable-declarations
*
776 (make-empty-declaration-array))
778 (compile-instruction `(progn ,@instructions
) env
))
779 (n-variables (length *lexical-variable-declarations
*)))
780 (push sets
*included-attribute-sets
*)
783 (loop for
(local-name uri nil
) in sets do
784 (dolist (thunk (find-attribute-set local-name uri
))
785 (funcall thunk ctx
)))
786 (let ((*lexical-variable-values
*
787 (make-variable-value-array n-variables
)))
788 (funcall thunk ctx
)))))
789 (gethash (multiple-value-bind (local-name uri
)
790 (decode-qname (or (stp:attribute-value elt
"name")
791 (xslt-error "missing name"))
794 (cons local-name uri
))
795 (stylesheet-attribute-sets stylesheet
))))))
797 (defun parse-namespace-aliases! (stylesheet <transform
> env
)
798 (do-toplevel (elt "namespace-alias" <transform
>)
799 (let ((*namespaces
* (acons-namespaces elt
)))
800 (only-with-attributes (stylesheet-prefix result-prefix
) elt
801 (unless stylesheet-prefix
802 (xslt-error "missing stylesheet-prefix in namespace-alias"))
803 (unless result-prefix
804 (xslt-error "missing result-prefix in namespace-alias"))
806 (if (equal stylesheet-prefix
"#default")
808 (or (xpath-sys:environment-find-namespace
811 (xslt-error "stylesheet namespace not found in alias: ~A"
813 (stylesheet-namespace-aliases stylesheet
))
814 (or (xpath-sys:environment-find-namespace
816 (if (equal result-prefix
"#default")
819 (xslt-error "result namespace not found in alias: ~A"
822 (defun parse-decimal-formats! (stylesheet <transform
> env
)
823 (do-toplevel (elt "decimal-format" <transform
>)
824 (stp:with-attributes
(name
838 (multiple-value-bind (local-name uri
)
840 (decode-qname name env nil
)
842 (let ((current (find-decimal-format local-name uri stylesheet nil
))
847 (unless (eql (length x
) 1)
848 (xslt-error "not a single character: ~A" x
))
849 (let ((chr (elt x
0)))
850 (when (find chr seen
)
852 "conflicting decimal format characters: ~A"
859 (apply #'make-decimal-format
860 (append (str :infinity infinity
)
862 (chr :decimal-separator decimal-separator
)
863 (chr :grouping-separator grouping-separator
)
864 (chr :zero-digit zero-digit
)
865 (chr :percent percent
)
866 (chr :per-mille per-mille
)
868 (chr :pattern-separator pattern-separator
)
869 (chr :minus-sign minus-sign
)))))))
871 (unless (decimal-format= current new
)
872 (xslt-error "decimal format mismatch for ~S" local-name
))
873 (setf (find-decimal-format local-name uri stylesheet
) new
)))))))
875 (defun parse-exclude-result-prefixes! (node env
)
876 (stp:with-attributes
(exclude-result-prefixes)
878 (dolist (prefix (words (or exclude-result-prefixes
"")))
879 (if (equal prefix
"#default")
881 (unless (cxml-stp-impl::nc-name-p prefix
)
882 (xslt-error "invalid prefix: ~A" prefix
)))
883 (push (or (xpath-sys:environment-find-namespace env prefix
)
884 (xslt-error "namespace not found: ~A" prefix
))
885 *excluded-namespaces
*))))
887 (defun parse-extension-element-prefixes! (node env
)
888 (stp:with-attributes
(extension-element-prefixes)
890 (dolist (prefix (words (or extension-element-prefixes
"")))
891 (if (equal prefix
"#default")
893 (unless (cxml-stp-impl::nc-name-p prefix
)
894 (xslt-error "invalid prefix: ~A" prefix
)))
896 (or (xpath-sys:environment-find-namespace env prefix
)
897 (xslt-error "namespace not found: ~A" prefix
))))
898 (unless (equal uri
*xsl
*)
899 (push uri
*extension-namespaces
*)
900 (push uri
*excluded-namespaces
*))))))
902 (defun parse-nametest-tokens (str)
903 (labels ((check (boolean)
905 (xslt-error "invalid nametest token")))
906 (check-null (boolean)
907 (check (not boolean
))))
910 (mapcar (lambda (name-test)
911 (destructuring-bind (&optional path
&rest junk
)
912 (cdr (xpath:parse-pattern-expression name-test
))
914 (check (eq (car path
) :path
))
915 (destructuring-bind (&optional child
&rest junk
) (cdr path
)
917 (check (eq (car child
) :child
))
918 (destructuring-bind (nodetest &rest junk
) (cdr child
)
920 (check (or (stringp nodetest
)
922 (and (consp nodetest
)
923 (or (eq (car nodetest
) :namespace
)
924 (eq (car nodetest
) :qname
)))))))
928 (defstruct strip-test
934 (defun parse-strip/preserve-space
! (stylesheet <transform
> env
)
936 (do-toplevel (elt "strip-space|preserve-space" <transform
>)
937 (let ((*namespaces
* (acons-namespaces elt
))
939 (if (equal (stp:local-name elt
) "strip-space")
943 (cdr (parse-nametest-tokens
944 (stp:attribute-value elt
"elements"))))
945 (let* ((compiled-pattern
946 (car (without-xslt-current ()
947 (xpath:compute-patterns
948 `(:patterns
,expression
)
953 (make-strip-test :compiled-pattern compiled-pattern
954 :priority
(expression-priority expression
)
957 (setf (xpath:pattern-value compiled-pattern
) strip-test
)
958 (push strip-test
(stylesheet-strip-tests stylesheet
)))))
961 (defstruct (output-specification
962 (:conc-name
"OUTPUT-"))
969 cdata-section-matchers
972 (defun parse-output! (stylesheet <transform
> env
)
973 (dolist (<output
> (list-toplevel "output" <transform
>))
974 (let ((spec (stylesheet-output-specification stylesheet
)))
975 (only-with-attributes (version
984 cdata-section-elements
)
986 (declare (ignore version
990 (multiple-value-bind (local-name uri
)
991 (decode-qname method env t
)
992 (setf (output-method spec
)
993 (if (plusp (length uri
))
996 ((equalp method
"HTML") :html
)
997 ((equalp method
"TEXT") :text
)
998 ((equalp method
"XML") :xml
)
1000 (xslt-error "invalid output method: ~A" method
)))))))
1002 (setf (output-indent spec
) indent
))
1004 (setf (output-encoding spec
) encoding
))
1005 (when doctype-system
1006 (setf (output-doctype-system spec
) doctype-system
))
1007 (when doctype-public
1008 (setf (output-doctype-public spec
) doctype-public
))
1009 (when omit-xml-declaration
1010 (setf (output-omit-xml-declaration spec
) omit-xml-declaration
))
1011 (when cdata-section-elements
1012 (dolist (qname (words cdata-section-elements
))
1013 (decode-qname qname env nil
) ;check the syntax
1014 (push (xpath:make-pattern-matcher
* qname env
)
1015 (output-cdata-section-matchers spec
))))
1017 (setf (output-standalone-p spec
)
1018 (boolean-or-error standalone
)))))))
1020 (defun make-empty-declaration-array ()
1021 (make-array 1 :fill-pointer
0 :adjustable t
))
1023 (defun make-variable-value-array (n-lexical-variables)
1024 (make-array n-lexical-variables
:initial-element
'unbound
))
1026 (defun compile-global-variable (<variable
> env
) ;; also for <param>
1027 (stp:with-attributes
(name select
) <variable
>
1028 (when (and select
(stp:list-children
<variable
>))
1029 (xslt-error "variable with select and body"))
1030 (let* ((*lexical-variable-declarations
* (make-empty-declaration-array))
1033 (compile-xpath select env
))
1034 ((stp:list-children
<variable
>)
1035 (let* ((inner-sexpr `(progn ,@(parse-body <variable
>)))
1036 (inner-thunk (compile-instruction inner-sexpr env
)))
1038 (apply-to-result-tree-fragment ctx inner-thunk
))))
1041 (declare (ignore ctx
))
1043 (n-lexical-variables (length *lexical-variable-declarations
*)))
1046 (let* ((*lexical-variable-values
*
1047 (make-variable-value-array n-lexical-variables
)))
1048 (funcall inner ctx
)))
1049 "global ~s (~s) = ~s" name select
:result
))))
1051 (defstruct (variable-chain
1052 (:constructor make-variable-chain
)
1053 (:conc-name
"VARIABLE-CHAIN-"))
1060 (defstruct (import-variable
1061 (:constructor make-variable
)
1062 (:conc-name
"VARIABLE-"))
1067 (defun parse-global-variable! (stylesheet <variable
> global-env
)
1068 (let* ((*namespaces
* (acons-namespaces <variable
>))
1069 (instruction-base-uri (stp:base-uri
<variable
>))
1070 (*instruction-base-uri
* instruction-base-uri
)
1071 (*excluded-namespaces
* (list *xsl
*))
1072 (*extension-namespaces
* '())
1073 (qname (stp:attribute-value
<variable
> "name")))
1074 (with-import-magic (<variable
> global-env
)
1076 (xslt-error "name missing in ~A" (stp:local-name
<variable
>)))
1077 (multiple-value-bind (local-name uri
)
1078 (decode-qname qname global-env nil
)
1079 ;; For the normal compilation environment of templates, install it
1080 ;; into *GLOBAL-VARIABLE-DECLARATIONS*:
1081 (let ((index (intern-global-variable local-name uri
)))
1082 ;; For the evaluation of a global variable itself, build a thunk
1083 ;; that lazily resolves other variables, stored into
1084 ;; INITIAL-GLOBAL-VARIABLE-THUNKS:
1085 (let* ((value-thunk :unknown
)
1086 (sgv (stylesheet-global-variables stylesheet
))
1088 (if (< index
(length sgv
))
1090 (make-variable-chain
1092 :local-name local-name
1094 (next (car (variable-chain-definitions chain
)))
1095 (global-variable-thunk
1097 (let ((v (global-variable-value index nil
)))
1101 (xslt-error "no next definition for: ~A"
1103 (funcall (variable-value-thunk next
) ctx
))
1105 (setf (global-variable-value index
) 'seen
)
1106 (setf (global-variable-value index
)
1107 (funcall value-thunk ctx
)))
1110 (excluded-namespaces *excluded-namespaces
*)
1111 (extension-namespaces *extension-namespaces
*)
1113 (make-variable :param-p
(namep <variable
> "param")))
1114 (forwards-compatible-p *forwards-compatible-p
*)
1117 (let* ((*instruction-base-uri
* instruction-base-uri
)
1118 (*excluded-namespaces
* excluded-namespaces
)
1119 (*extension-namespaces
* extension-namespaces
)
1120 (*forwards-compatible-p
* forwards-compatible-p
)
1122 (compile-global-variable <variable
> global-env
)))
1123 (setf value-thunk fn
)
1124 (setf (variable-value-thunk variable
) fn
)))))
1125 (setf (variable-value-thunk-setter variable
)
1127 (setf (gethash (cons local-name uri
)
1128 (initial-global-variable-thunks global-env
))
1129 global-variable-thunk
)
1130 (setf (variable-chain-thunk chain
) global-variable-thunk
)
1131 (push variable
(variable-chain-definitions chain
))
1134 (defun parse-keys! (stylesheet <transform
> env
)
1135 (xpath:with-namespaces
((nil #.
*xsl
*))
1136 (do-toplevel (<key
> "key" <transform
>)
1137 (with-import-magic (<key
> env
)
1138 (let ((*instruction-base-uri
* (stp:base-uri
<key
>)))
1139 (only-with-attributes (name match use
) <key
>
1140 (unless name
(xslt-error "key name attribute not specified"))
1141 (unless match
(xslt-error "key match attribute not specified"))
1142 (unless use
(xslt-error "key use attribute not specified"))
1143 (multiple-value-bind (local-name uri
)
1144 (decode-qname name env nil
)
1146 (cons local-name uri
)
1147 (compile-xpath `(xpath:xpath
,(parse-key-pattern match
))
1150 (make-instance 'key-environment
))))))))))
1152 (defun prepare-global-variables (stylesheet <transform
>)
1153 (xpath:with-namespaces
((nil #.
*xsl
*))
1154 (let* ((igvt (stylesheet-initial-global-variable-thunks stylesheet
))
1155 (global-env (make-instance 'global-variable-environment
1156 :initial-global-variable-thunks igvt
))
1158 (do-toplevel (<variable
> "variable|param" <transform
>)
1160 (parse-global-variable! stylesheet
<variable
> global-env
)))
1161 (xslt-trace "parsing global variable ~s (uri ~s)"
1162 (variable-chain-local-name chain
)
1163 (variable-chain-uri chain
))
1167 (and (equal (variable-chain-local-name a
)
1168 (variable-chain-local-name b
))
1169 (equal (variable-chain-uri a
)
1170 (variable-chain-uri b
)))))
1171 (xslt-error "duplicate definition for global variable ~A"
1172 (variable-chain-local-name chain
)))
1173 (push chain chains
)))
1174 (setf chains
(nreverse chains
))
1175 (let ((table (stylesheet-global-variables stylesheet
))
1176 (newlen (length *global-variable-declarations
*)))
1177 (adjust-array table newlen
:fill-pointer newlen
)
1178 (dolist (chain chains
)
1179 (setf (elt table
(variable-chain-index chain
)) chain
)))
1181 ;; now that the global environment knows about all variables, run the
1182 ;; thunk setters to perform their compilation
1183 (mapc (lambda (chain)
1184 (dolist (var (variable-chain-definitions chain
))
1185 (funcall (variable-value-thunk-setter var
))))
1188 (defun parse-templates! (stylesheet <transform
> env
)
1190 (do-toplevel (<template
> "template" <transform
>)
1191 (let ((*namespaces
* (acons-namespaces <template
>))
1192 (*instruction-base-uri
* (stp:base-uri
<template
>)))
1193 (with-import-magic (<template
> env
)
1194 (dolist (template (compile-template <template
> env i
))
1195 (let ((name (template-name template
)))
1197 (let* ((table (stylesheet-named-templates stylesheet
))
1198 (head (car (gethash name table
))))
1199 (when (and head
(eql (template-import-priority head
)
1200 (template-import-priority template
)))
1201 ;; fixme: is this supposed to be a run-time error?
1202 (xslt-error "conflicting templates for ~A" name
))
1203 (push template
(gethash name table
)))
1204 (let ((mode (ensure-mode/qname stylesheet
1205 (template-mode-qname template
)
1207 (setf (template-mode template
) mode
)
1208 (push template
(mode-templates mode
))))))))
1212 ;;;; APPLY-STYLESHEET
1214 (defvar *stylesheet
*)
1216 (deftype xml-designator
() '(or runes
:xstream runes
:rod array stream pathname
))
1218 (defun unalias-uri (uri)
1220 (gethash uri
(stylesheet-namespace-aliases *stylesheet
*)
1222 (check-type result string
)
1225 (defstruct (parameter
1226 (:constructor make-parameter
(value local-name
&optional uri
)))
1231 (defun find-parameter-value (local-name uri parameters
)
1232 (dolist (p parameters
)
1233 (when (and (equal (parameter-local-name p
) local-name
)
1234 (equal (parameter-uri p
) uri
))
1235 (return (parameter-value p
)))))
1237 (defvar *uri-resolver
*)
1239 (defun parse-allowing-microsoft-bom (pathname handler
)
1240 (with-open-file (s pathname
:element-type
'(unsigned-byte 8))
1241 (unless (and (eql (read-byte s nil
) #xef
)
1242 (eql (read-byte s nil
) #xbb
)
1243 (eql (read-byte s nil
) #xbf
))
1244 (file-position s
0))
1245 (cxml:parse s handler
)))
1247 (defvar *documents
*)
1249 (defun %document
(uri-string base-uri
)
1250 (let* ((absolute-uri
1251 (puri:merge-uris uri-string
(or base-uri
"")))
1254 (funcall *uri-resolver
* absolute-uri
)
1258 (uri-to-pathname resolved-uri
)
1259 (cxml:xml-parse-error
(c)
1260 (xslt-error "cannot find referenced document ~A: ~A"
1263 (or (gethash pathname
*documents
*)
1264 (setf (gethash pathname
*documents
*)
1265 (make-whitespace-stripper
1267 (parse-allowing-microsoft-bom pathname
1269 ((or file-error cxml
:xml-parse-error
) (c)
1270 (xslt-error "cannot parse referenced document ~A: ~A"
1272 (stylesheet-strip-thunk *stylesheet
*))))))
1273 (when (puri:uri-fragment absolute-uri
)
1274 (xslt-error "use of fragment identifiers in document() not supported"))
1277 (xpath-sys:define-extension xslt
*xsl
*)
1279 (defun document-base-uri (node)
1280 (xpath-protocol:base-uri
1282 ((xpath-protocol:node-type-p node
:document
)
1283 (xpath::find-in-pipe-if
1285 (xpath-protocol:node-type-p x
:element
))
1286 (xpath-protocol:child-pipe node
)))
1287 ((xpath-protocol:node-type-p node
:element
)
1290 (xpath-protocol:parent-node node
)))))
1292 (xpath-sys:define-xpath-function
/lazy
1294 (object &optional node-set
)
1295 (let ((instruction-base-uri *instruction-base-uri
*))
1297 (let* ((object (funcall object ctx
))
1298 (node-set (and node-set
(funcall node-set ctx
)))
1301 (document-base-uri (xpath::textually-first-node node-set
))
1302 instruction-base-uri
)))
1303 (xpath-sys:make-node-set
1304 (if (xpath:node-set-p object
)
1305 (xpath:map-node-set-
>list
1307 (%document
(xpath:string-value node
)
1310 (document-base-uri node
))))
1312 (list (%document
(xpath:string-value object
) base-uri
))))))))
1314 ;; FIXME: the point of keys is that we are meant to optimize this
1315 ;; by building a table mapping nodes to values for each key.
1316 ;; We should run over all matching nodes and store them in such a table
1317 ;; when seeing their document for the first time.
1318 (xpath-sys:define-xpath-function
/lazy xslt
:key
(name object
)
1319 (let ((namespaces *namespaces
*))
1321 (let* ((qname (xpath:string-value
(funcall name ctx
)))
1322 (object (funcall object ctx
))
1324 (multiple-value-bind (local-name uri
)
1325 (decode-qname/runtime qname namespaces nil
)
1326 (cons local-name uri
)))
1327 (key-conses (find-key expanded-name
*stylesheet
*)))
1328 (xpath-sys:make-node-set
1329 (xpath::mappend-pipe
1331 (labels ((get-by-key (value)
1332 (let ((value (xpath:string-value value
)))
1336 (xpath:evaluate-compiled
(key-use key
)
1338 (if (xpath:node-set-p uses
)
1339 (xpath::find-in-pipe
1341 (xpath-sys:pipe-of uses
)
1342 :key
#'xpath
:string-value
1344 (equal value
(xpath:string-value uses
)))))
1346 (xpath:node-set-value
1347 (xpath:evaluate-compiled
(key-match key
) ctx
)))))))
1349 (if (xpath:node-set-p object
)
1350 (xpath::mappend-pipe
#'get-by-key
1351 (xpath-sys:pipe-of object
))
1352 (get-by-key object
)))))
1355 ;; FIXME: add alias mechanism for XPath extensions in order to avoid duplication
1357 (xpath-sys:define-xpath-function
/lazy xslt
:current
()
1358 (when *without-xslt-current-p
*
1359 (xslt-error "current() not allowed here"))
1361 (xpath-sys:make-node-set
1362 (xpath-sys:make-pipe
1363 (xpath:context-starting-node ctx
)
1366 (xpath-sys:define-xpath-function
/lazy xslt
:unparsed-entity-uri
(name)
1368 (or (xpath-protocol:unparsed-entity-uri
(xpath:context-node ctx
)
1372 (defun %get-node-id
(node)
1373 (when (xpath:node-set-p node
)
1374 (setf node
(xpath::textually-first-node node
)))
1376 (let ((id (xpath-sys:get-node-id node
))
1379 for parent
= node then next
1380 for next
= (xpath-protocol:parent-node parent
)
1381 for this-base-uri
= (xpath-protocol:base-uri parent
)
1382 for highest-base-uri
= (if (plusp (length this-base-uri
))
1386 finally
(return highest-base-uri
))))
1387 ;; FIXME: Now that we intern documents, we could use a short ID for
1388 ;; the document instead of the base URI.
1389 (nreverse (concatenate 'string highest-base-uri
"//" id
)))))
1391 (xpath-sys:define-xpath-function
/lazy xslt
:generate-id
(&optional node-set-thunk
)
1394 (%get-node-id
(xpath:node-set-value
(funcall node-set-thunk ctx
))))
1396 (%get-node-id
(xpath:context-node ctx
)))))
1398 (declaim (special *available-instructions
*))
1400 (xpath-sys:define-xpath-function
/lazy xslt
:element-available
(qname)
1401 (let ((namespaces *namespaces
*))
1403 (let ((qname (funcall qname ctx
)))
1404 (multiple-value-bind (local-name uri
)
1405 (decode-qname/runtime qname namespaces nil
)
1406 (and (equal uri
*xsl
*)
1407 (gethash local-name
*available-instructions
*)
1410 (xpath-sys:define-xpath-function
/lazy xslt
:function-available
(qname)
1411 (let ((namespaces *namespaces
*))
1413 (let ((qname (funcall qname ctx
)))
1414 (multiple-value-bind (local-name uri
)
1415 (decode-qname/runtime qname namespaces nil
)
1416 (and (zerop (length uri
))
1417 (or (xpath-sys:find-xpath-function local-name
*xsl
*)
1418 (xpath-sys:find-xpath-function local-name uri
))
1421 (xpath-sys:define-xpath-function
/lazy xslt
:system-property
(qname)
1422 (let ((namespaces *namespaces
*))
1424 (let ((qname (xpath:string-value
(funcall qname ctx
))))
1425 (multiple-value-bind (local-name uri
)
1426 (decode-qname/runtime qname namespaces nil
)
1427 (if (equal uri
*xsl
*)
1429 ((equal local-name
"version")
1431 ((equal local-name
"vendor")
1433 ((equal local-name
"vendor-uri")
1434 "http://repo.or.cz/w/xuriella.git")
1439 ;; FIXME: should there be separate uri-resolver arguments for stylesheet
1441 (defun apply-stylesheet
1442 (stylesheet source-designator
1443 &key output parameters uri-resolver navigator
)
1444 (when (typep stylesheet
'xml-designator
)
1447 ((cxml:xml-parse-error
1449 (xslt-error "cannot parse stylesheet: ~A" c
))))
1450 (parse-stylesheet stylesheet
:uri-resolver uri-resolver
))))
1451 (with-resignalled-errors ()
1452 (invoke-with-output-sink
1454 (let* ((*documents
* (make-hash-table :test
'equal
))
1455 (xpath:*navigator
* (or navigator
:default-navigator
))
1456 (puri:*strict-parse
* nil
)
1457 (*stylesheet
* stylesheet
)
1458 (*empty-mode
* (make-mode))
1459 (*default-mode
* (find-mode stylesheet nil
))
1460 (global-variable-chains
1461 (stylesheet-global-variables stylesheet
))
1462 (*global-variable-values
*
1463 (make-variable-value-array (length global-variable-chains
)))
1464 (*uri-resolver
* uri-resolver
)
1466 (if (typep source-designator
'xml-designator
)
1467 (cxml:parse source-designator
(stp:make-builder
))
1470 (make-whitespace-stripper
1472 (stylesheet-strip-thunk stylesheet
)))
1473 (ctx (xpath:make-context xpath-root-node
)))
1474 (when (pathnamep source-designator
)
1475 (setf (gethash source-designator
*documents
*) xpath-root-node
))
1478 (let ((head (car (variable-chain-definitions chain
))))
1479 (when (variable-param-p head
)
1481 (find-parameter-value
1482 (variable-chain-local-name chain
)
1483 (variable-chain-uri chain
)
1486 (setf (global-variable-value
1487 (variable-chain-index chain
))
1489 global-variable-chains
)
1492 (funcall (variable-chain-thunk chain
) ctx
))
1493 global-variable-chains
)
1494 ;; zzz we wouldn't have to mask float traps here if we used the
1495 ;; XPath API properly. Unfortunately I've been using FUNCALL
1496 ;; everywhere instead of EVALUATE, so let's paper over that
1497 ;; at a central place to be sure:
1498 (xpath::with-float-traps-masked
()
1499 (apply-templates ctx
:mode
*default-mode
*))))
1500 (stylesheet-output-specification stylesheet
)
1503 (defun find-attribute-set (local-name uri
&optional
(stylesheet *stylesheet
*))
1504 (or (gethash (cons local-name uri
) (stylesheet-attribute-sets stylesheet
))
1505 (xslt-error "no such attribute set: ~A/~A" local-name uri
)))
1507 (defun apply-templates/list
(list &key param-bindings sort-predicate mode
)
1508 (when sort-predicate
1510 (mapcar #'xpath
:context-node
1511 (stable-sort (contextify-node-list list
)
1513 (let* ((n (length list
))
1514 (s/d
(lambda () n
)))
1519 (apply-templates (xpath:make-context child s
/d i
)
1520 :param-bindings param-bindings
1523 (defvar *stack-limit
* 200)
1525 (defun invoke-with-stack-limit (fn)
1526 (let ((*stack-limit
* (1- *stack-limit
*)))
1527 (unless (plusp *stack-limit
*)
1528 (xslt-error "*stack-limit* reached; stack overflow"))
1531 (defun invoke-template (ctx template param-bindings
)
1532 (let ((*lexical-variable-values
*
1533 (make-variable-value-array (template-n-variables template
))))
1534 (with-stack-limit ()
1536 for
(name-cons value
) in param-bindings
1537 for
(nil index nil
) = (find name-cons
1538 (template-params template
)
1543 (setf (lexical-variable-value index
) value
)))
1544 (funcall (template-body template
) ctx
))))
1546 (defun apply-default-templates (ctx mode
)
1547 (let ((node (xpath:context-node ctx
)))
1549 ((or (xpath-protocol:node-type-p node
:processing-instruction
)
1550 (xpath-protocol:node-type-p node
:comment
)))
1551 ((or (xpath-protocol:node-type-p node
:text
)
1552 (xpath-protocol:node-type-p node
:attribute
))
1553 (write-text (xpath-protocol:node-text node
)))
1555 (apply-templates/list
1557 (xpath-protocol:child-pipe node
))
1560 (defvar *apply-imports
*)
1562 (defun apply-applicable-templates (ctx templates param-bindings finally
)
1563 (labels ((apply-imports (&optional actual-param-bindings
)
1565 (let* ((this (pop templates
))
1566 (low (template-apply-imports-limit this
))
1567 (high (template-import-priority this
)))
1571 (<= low
(template-import-priority x
) high
))
1573 (invoke-template ctx this actual-param-bindings
))
1574 (funcall finally
))))
1575 (let ((*apply-imports
* #'apply-imports
))
1576 (apply-imports param-bindings
))))
1578 (defun apply-templates (ctx &key param-bindings mode
)
1579 (apply-applicable-templates ctx
1580 (find-templates ctx
(or mode
*default-mode
*))
1583 (apply-default-templates ctx mode
))))
1585 (defun call-template (ctx name
&optional param-bindings
)
1586 (apply-applicable-templates ctx
1587 (find-named-templates name
)
1590 (xslt-error "cannot find named template: ~s"
1593 (defun find-templates (ctx mode
)
1594 (let* ((matching-candidates
1595 (xpath:matching-values
(mode-match-thunk mode
)
1596 (xpath:context-node ctx
)))
1598 (if matching-candidates
1601 :key
#'template-import-priority
))
1603 (priority-groups (make-array npriorities
:initial-element nil
)))
1604 (dolist (template matching-candidates
)
1606 (elt priority-groups
(template-import-priority template
))))
1608 for i from
(1- npriorities
) downto
0
1609 for group
= (elt priority-groups i
)
1610 for template
= (maximize #'template
< group
)
1614 (defun find-named-templates (name)
1615 (gethash name
(stylesheet-named-templates *stylesheet
*)))
1617 (defun template< (a b
) ;assuming same import priority
1618 (let ((p (template-priority a
))
1619 (q (template-priority b
)))
1624 (xslt-cerror "conflicting templates:~_~A,~_~A"
1625 (template-match-expression a
)
1626 (template-match-expression b
))
1627 (< (template-position a
) (template-position b
))))))
1629 (defun maximize (< things
)
1631 (let ((max (car things
)))
1632 (dolist (other (cdr things
))
1633 (when (funcall < max other
)
1637 (defun invoke-with-output-sink (fn output-spec output
)
1640 (with-open-file (s output
1642 :element-type
'(unsigned-byte 8)
1643 :if-exists
:rename-and-delete
)
1644 (invoke-with-output-sink fn output-spec s
)))
1646 (invoke-with-output-sink fn
1648 (make-output-sink output-spec output
)))
1649 ((or hax
:abstract-handler sax
:abstract-handler
)
1650 (with-xml-output output
1651 (when (typep output
'(or combi-sink auto-detect-sink
))
1652 (sax:start-dtd output
1653 :autodetect-me-please
1654 (output-doctype-public output-spec
)
1655 (output-doctype-system output-spec
)))
1658 (defun make-output-sink (output-spec stream
)
1661 (let ((et (stream-element-type stream
)))
1663 ((or (null et
) (subtypep et
'(unsigned-byte 8)))
1664 (runes:make-octet-stream-ystream stream
))
1665 ((subtypep et
'character
)
1666 (runes:make-character-stream-ystream stream
))))
1667 (runes:make-rod-ystream
)))
1668 (omit-xml-declaration-p
1669 (boolean-or-error (output-omit-xml-declaration output-spec
)))
1670 (sink-encoding (or (output-encoding output-spec
) "UTF-8"))
1673 (setf (runes:ystream-encoding ystream
)
1674 (cxml::find-output-encoding sink-encoding
))
1675 (make-instance 'cxml
::sink
1677 :omit-xml-declaration-p omit-xml-declaration-p
1678 :encoding sink-encoding
))))
1679 (flet ((make-combi-sink ()
1680 (make-instance 'combi-sink
1681 :hax-target
(make-instance 'chtml
::sink
1683 :sax-target sax-target
1684 :encoding sink-encoding
)))
1685 (let ((method-key (output-method output-spec
)))
1687 ((and (eq method-key
:html
)
1688 (null (output-doctype-system output-spec
))
1689 (null (output-doctype-public output-spec
)))
1691 ((eq method-key
:text
)
1692 (make-text-filter sax-target
))
1693 ((and (eq method-key
:xml
)
1694 (null (output-doctype-system output-spec
)))
1697 (make-auto-detect-sink (make-combi-sink) method-key
)))))))
1713 (defun expression-priority (form)
1714 (let ((step (second form
)))
1715 (if (and (null (cddr form
))
1717 (member (car step
) '(:child
:attribute
))
1719 (let ((name (second step
)))
1723 (or (eq (car name
) :qname
)
1724 (eq (car name
) :processing-instruction
))))
1727 (or (eq (car name
) :namespace
)
1728 (eq (car name
) '*)))
1734 (defun parse-key-pattern (str)
1735 (with-resignalled-errors ()
1736 (with-forward-compatible-errors
1737 (xpath:parse-xpath
"compile-time-error()") ;hack
1739 (mapcar #'(lambda (item)
1740 `(:path
(:root
:node
)
1741 (:descendant-or-self
*)
1743 (cdr (xpath::parse-pattern-expression str
)))))
1744 (if (null (rest parsed
))
1746 `(:union
,@parsed
))))))
1748 (defun compile-value-thunk (value env
)
1749 (if (and (listp value
) (eq (car value
) 'progn
))
1750 (let ((inner-thunk (compile-instruction value env
)))
1752 (apply-to-result-tree-fragment ctx inner-thunk
)))
1753 (compile-xpath value env
)))
1755 (defun compile-var-binding (name value env
)
1756 (multiple-value-bind (local-name uri
)
1757 (decode-qname name env nil
)
1758 (let ((thunk (xslt-trace-thunk
1759 (compile-value-thunk value env
)
1760 "local variable ~s = ~s" name
:result
)))
1761 (list (cons local-name uri
)
1762 (push-variable local-name
1764 *lexical-variable-declarations
*)
1767 (defun compile-var-bindings (forms env
)
1769 for
(name value
) in forms
1770 collect
(compile-var-binding name value env
)))
1772 (defun compile-template (<template
> env position
)
1773 (stp:with-attributes
(match name priority mode
) <template
>
1774 (unless (or name match
)
1775 (xslt-error "missing match in template"))
1776 (multiple-value-bind (params body-pos
)
1779 for child in
(stp:list-children
<template
>)
1780 while
(namep child
"param")
1781 collect
(parse-param child
) into params
1782 finally
(return (values params i
)))
1783 (let* ((*lexical-variable-declarations
* (make-empty-declaration-array))
1784 (param-bindings (compile-var-bindings params env
))
1785 (body (parse-body <template
> body-pos
(mapcar #'car params
)))
1786 (body-thunk (compile-instruction `(progn ,@body
) env
))
1792 ;; set params that weren't initialized by apply-templates
1793 (loop for
(name index param-thunk
) in param-bindings
1794 when
(eq (lexical-variable-value index nil
) 'unbound
)
1795 do
(setf (lexical-variable-value index
)
1796 (funcall param-thunk ctx
)))
1797 (funcall body-thunk ctx
))))
1798 "template: match = ~s name = ~s" match name
))
1799 (n-variables (length *lexical-variable-declarations
*)))
1802 (multiple-value-bind (local-name uri
)
1803 (decode-qname name env nil
)
1805 (make-template :name
(cons local-name uri
)
1806 :import-priority
*import-priority
*
1807 :apply-imports-limit
*apply-imports-limit
*
1808 :params param-bindings
1809 :body outer-body-thunk
1810 :n-variables n-variables
))))
1812 (mapcar (lambda (expression)
1813 (let* ((compiled-pattern
1815 (car (without-xslt-current ()
1816 (xpath:compute-patterns
1817 `(:patterns
,expression
)
1821 "match-thunk for template (match ~s): ~s --> ~s"
1822 match expression
:result
))
1824 (xpath::parse-xnum priority
)
1825 (expression-priority expression
)))
1828 (unless (and (numberp p
)
1829 (not (xpath::inf-p p
))
1830 (not (xpath::nan-p p
)))
1831 (xslt-error "failed to parse priority"))
1834 (make-template :match-expression expression
1835 :compiled-pattern compiled-pattern
1836 :import-priority
*import-priority
*
1837 :apply-imports-limit
*apply-imports-limit
*
1841 :params param-bindings
1842 :body outer-body-thunk
1843 :n-variables n-variables
)))
1844 (setf (xpath:pattern-value compiled-pattern
)
1847 (cdr (xpath:parse-pattern-expression match
)))))))))
1849 (xuriella::parse-stylesheet
#p
"/home/david/src/lisp/xuriella/test.xsl")