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)))
38 (define-condition xslt-error
(simple-error)
40 (:documentation
"The class of all XSLT errors."))
42 (define-condition recoverable-xslt-error
(xslt-error)
44 (:documentation
"The class of recoverable XSLT errors."))
46 (defun xslt-error (fmt &rest args
)
47 (error 'xslt-error
:format-control fmt
:format-arguments args
))
49 (defun xslt-cerror (fmt &rest args
)
50 (with-simple-restart (recover "recover")
51 (error 'recoverable-xslt-error
53 :format-arguments args
)))
57 (defmacro handler-case
* (form &rest clauses
)
58 ;; like HANDLER-CASE if *DEBUG* is off. If it's on, don't establish
59 ;; a handler at all so that we see the real stack traces. (We could use
60 ;; HANDLER-BIND here and check at signalling time, but doesn't seem
62 (let ((doit (gensym)))
63 `(flet ((,doit
() ,form
))
70 (defun compile-xpath (xpath &optional env
)
72 (xpath:compile-xpath xpath env
)
73 (xpath:xpath-error
(c)
74 (xslt-error "~A" c
))))
76 (defmacro with-stack-limit
((&optional
) &body body
)
77 `(invoke-with-stack-limit (lambda () ,@body
)))
80 ;;;; Helper function and macro
82 (defun map-pipe-eagerly (fn pipe
)
83 (xpath::enumerate pipe
:key fn
:result nil
))
85 (defmacro do-pipe
((var pipe
&optional result
) &body body
)
87 (map-pipe-eagerly #'(lambda (,var
) ,@body
) ,pipe
)
91 ;;;; XSLT-ENVIRONMENT and XSLT-CONTEXT
93 (defparameter *initial-namespaces
*
95 ("xmlns" .
#"http://www.w3.org/2000/xmlns/")
96 ("xml" .
#"http://www.w3.org/XML/1998/namespace")))
98 (defparameter *namespaces
* *initial-namespaces
*)
100 (defvar *global-variable-declarations
*)
101 (defvar *lexical-variable-declarations
*)
103 (defvar *global-variable-values
*)
104 (defvar *lexical-variable-values
*)
106 (defclass xslt-environment
() ())
108 (defun split-qname (str)
110 (multiple-value-bind (prefix local-name
)
111 (cxml::split-qname str
)
113 ;; FIXME: cxml should really offer a function that does
114 ;; checks for NCName and QName in a sensible way for user code.
115 ;; cxml::split-qname is tailored to the needs of the parser.
117 ;; For now, let's just check the syntax explicitly.
118 (and (or (null prefix
) (xpath::nc-name-p prefix
))
119 (xpath::nc-name-p local-name
))
120 (xslt-error "not a qname: ~A" str
))
121 (values prefix local-name
))
122 (cxml:well-formedness-violation
()
123 (xslt-error "not a qname: ~A" str
))))
125 (defun decode-qname (qname env attributep
)
126 (multiple-value-bind (prefix local-name
)
129 (if (or prefix
(not attributep
))
130 (xpath-sys:environment-find-namespace env prefix
)
134 (defmethod xpath-sys:environment-find-namespace
((env xslt-environment
) prefix
)
135 (cdr (assoc prefix
*namespaces
* :test
'equal
)))
137 (defun find-variable-index (local-name uri table
)
138 (position (cons local-name uri
) table
:test
'equal
))
140 (defun intern-global-variable (local-name uri
)
141 (or (find-variable-index local-name uri
*global-variable-declarations
*)
142 (push-variable local-name uri
*global-variable-declarations
*)))
144 (defun push-variable (local-name uri table
)
147 (vector-push-extend (cons local-name uri
) table
)))
149 (defun lexical-variable-value (index &optional
(errorp t
))
150 (let ((result (svref *lexical-variable-values
* index
)))
152 (assert (not (eq result
'unbound
))))
155 (defun (setf lexical-variable-value
) (newval index
)
156 (assert (not (eq newval
'unbound
)))
157 (setf (svref *lexical-variable-values
* index
) newval
))
159 (defun global-variable-value (index &optional
(errorp t
))
160 (let ((result (svref *global-variable-values
* index
)))
162 (assert (not (eq result
'unbound
))))
165 (defun (setf global-variable-value
) (newval index
)
166 (assert (not (eq newval
'unbound
)))
167 (setf (svref *global-variable-values
* index
) newval
))
169 (defmethod xpath-sys:environment-find-function
170 ((env xslt-environment
) lname uri
)
172 (or (xpath-sys:find-xpath-function lname
*xsl
*)
173 (xpath-sys:find-xpath-function lname uri
))
174 (xpath-sys:find-xpath-function lname uri
)))
176 (defmethod xpath-sys:environment-find-variable
177 ((env xslt-environment
) lname uri
)
179 (find-variable-index lname uri
*lexical-variable-declarations
*)))
182 (declare (ignore ctx
))
183 (svref *lexical-variable-values
* index
)))))
185 (defclass lexical-xslt-environment
(xslt-environment) ())
187 (defmethod xpath-sys:environment-find-variable
188 ((env lexical-xslt-environment
) lname uri
)
189 (or (call-next-method)
191 (find-variable-index lname uri
*global-variable-declarations
*)))
195 (declare (ignore ctx
))
196 (svref *global-variable-values
* index
))
197 "global ~s (uri ~s) = ~s" lname uri
:result
)))))
199 (defclass global-variable-environment
(xslt-environment)
200 ((initial-global-variable-thunks
201 :initarg
:initial-global-variable-thunks
202 :accessor initial-global-variable-thunks
)))
204 (defmethod xpath-sys:environment-find-variable
205 ((env global-variable-environment
) lname uri
)
206 (or (call-next-method)
207 (gethash (cons lname uri
) (initial-global-variable-thunks env
))))
210 ;;;; TEXT-OUTPUT-SINK
212 ;;;; A sink that serializes only text and will error out on any other
215 (defmacro with-text-output-sink
((var) &body body
)
216 `(invoke-with-text-output-sink (lambda (,var
) ,@body
)))
218 (defclass text-output-sink
(sax:default-handler
)
219 ((target :initarg
:target
:accessor text-output-sink-target
)
220 (depth :initform
0 :accessor textoutput-sink-depth
)))
222 (defmethod sax:start-element
((sink text-output-sink
)
223 namespace-uri local-name qname attributes
)
224 (declare (ignore namespace-uri local-name qname attributes
))
225 (incf (textoutput-sink-depth sink
)))
227 (defmethod sax:characters
((sink text-output-sink
) data
)
228 (when (zerop (textoutput-sink-depth sink
))
229 (write-string data
(text-output-sink-target sink
))))
231 (defmethod sax:end-element
((sink text-output-sink
)
232 namespace-uri local-name qname
)
233 (declare (ignore namespace-uri local-name qname
))
234 (decf (textoutput-sink-depth sink
)))
236 (defun invoke-with-text-output-sink (fn)
237 (with-output-to-string (s)
238 (funcall fn
(make-instance 'text-output-sink
:target s
))))
242 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
243 (defvar *xsl
* "http://www.w3.org/1999/XSL/Transform")
244 (defvar *xml
* "http://www.w3.org/XML/1998/namespace")
245 (defvar *html
* "http://www.w3.org/1999/xhtml"))
247 (defun of-name (local-name)
248 (stp:of-name local-name
*xsl
*))
250 (defun namep (node local-name
)
251 (and (typep node
'(or stp
:element stp
:attribute
))
252 (equal (stp:namespace-uri node
) *xsl
*)
253 (equal (stp:local-name node
) local-name
)))
256 ;;;; PARSE-STYLESHEET
258 (defstruct stylesheet
259 (modes (make-hash-table :test
'equal
))
260 (global-variables ())
261 (output-specification (make-output-specification))
263 (named-templates (make-hash-table :test
'equal
))
264 (attribute-sets (make-hash-table :test
'equal
))
265 (keys (make-hash-table :test
'equal
))
266 (namespace-aliases (make-hash-table :test
'equal
)))
268 (defstruct mode
(templates nil
))
270 (defun find-mode (stylesheet local-name
&optional uri
)
271 (gethash (cons local-name uri
) (stylesheet-modes stylesheet
)))
273 (defun ensure-mode (stylesheet &optional local-name uri
)
274 (or (find-mode stylesheet local-name uri
)
275 (setf (gethash (cons local-name uri
) (stylesheet-modes stylesheet
))
278 (defun ensure-mode/qname
(stylesheet qname env
)
280 (multiple-value-bind (local-name uri
)
281 (decode-qname qname env nil
)
282 (ensure-mode stylesheet local-name uri
))
283 (find-mode stylesheet nil
)))
285 (defun acons-namespaces (element &optional
(bindings *namespaces
*))
286 (map-namespace-declarations (lambda (prefix uri
)
287 (push (cons prefix uri
) bindings
))
291 (defun find-key (name stylesheet
)
292 (or (gethash name
(stylesheet-keys stylesheet
))
293 (xslt-error "unknown key: ~a" name
)))
295 (defun make-key (match use
) (cons match use
))
297 (defun key-match (key) (car key
))
299 (defun key-use (key) (cdr key
))
301 (defun add-key (stylesheet name match use
)
302 (if (gethash name
(stylesheet-keys stylesheet
))
303 (xslt-error "duplicate key: ~a" name
)
304 (setf (gethash name
(stylesheet-keys stylesheet
))
305 (make-key match use
))))
307 (defvar *excluded-namespaces
* (list *xsl
*))
308 (defvar *empty-mode
*)
310 (defvar *xsl-include-stack
* nil
)
312 (defun uri-to-pathname (uri)
313 (cxml::uri-to-pathname
(puri:parse-uri uri
)))
315 (defun parse-stylesheet-to-stp (input uri-resolver
)
316 (let* ((d (cxml:parse input
(make-text-normalizer (cxml-stp:make-builder
))))
317 (<transform
> (stp:document-element d
)))
318 (strip-stylesheet <transform
>)
319 ;; FIXME: handle embedded stylesheets
320 (unless (and (equal (stp:namespace-uri
<transform
>) *xsl
*)
321 (or (equal (stp:local-name
<transform
>) "transform")
322 (equal (stp:local-name
<transform
>) "stylesheet")))
323 (xslt-error "not a stylesheet"))
324 (dolist (include (stp:filter-children
(of-name "include") <transform
>))
325 (let* ((uri (puri:merge-uris
(stp:attribute-value include
"href")
326 (stp:base-uri include
)))
327 (uri (if uri-resolver
328 (funcall uri-resolver
(puri:render-uri uri nil
))
330 (str (puri:render-uri uri nil
))
333 (uri-to-pathname uri
)
334 (cxml:xml-parse-error
(c)
335 (xslt-error "cannot find included stylesheet ~A: ~A"
339 :element-type
'(unsigned-byte 8)
340 :if-does-not-exist nil
)
342 (xslt-error "cannot find included stylesheet ~A at ~A"
344 (when (find str
*xsl-include-stack
* :test
#'equal
)
345 (xslt-error "recursive inclusion of ~A" uri
))
346 (let* ((*xsl-include-stack
* (cons str
*xsl-include-stack
*))
347 (<transform
>2 (parse-stylesheet-to-stp stream uri-resolver
)))
348 (stp:do-children
(child <transform
>2)
349 (stp:insert-child-after
<transform
>
352 (stp:detach include
)))))
355 (defvar *instruction-base-uri
*)
356 (defvar *apply-imports-limit
*)
357 (defvar *import-priority
*)
359 (defun parse-1-stylesheet (env stylesheet designator uri-resolver
)
360 (let* ((<transform
> (parse-stylesheet-to-stp designator uri-resolver
))
361 (*instruction-base-uri
* (stp:base-uri
<transform
>))
362 (*namespaces
* (acons-namespaces <transform
>))
363 (*apply-imports-limit
* (1+ *import-priority
*)))
364 (dolist (import (stp:filter-children
(of-name "import") <transform
>))
365 (let ((uri (puri:merge-uris
(stp:attribute-value import
"href")
366 (stp:base-uri import
))))
367 (parse-imported-stylesheet env stylesheet uri uri-resolver
)))
368 (incf *import-priority
*)
369 (parse-exclude-result-prefixes! <transform
> env
)
370 (parse-global-variables! stylesheet
<transform
>)
371 (parse-keys! stylesheet
<transform
> env
)
372 (parse-templates! stylesheet
<transform
> env
)
373 (parse-output! stylesheet
<transform
>)
374 (parse-strip/preserve-space
! stylesheet
<transform
> env
)
375 (parse-attribute-sets! stylesheet
<transform
> env
)
376 (parse-namespace-aliases! stylesheet
<transform
> env
)))
378 (defvar *xsl-import-stack
* nil
)
380 (defun parse-imported-stylesheet (env stylesheet uri uri-resolver
)
381 (let* ((uri (if uri-resolver
382 (funcall uri-resolver
(puri:render-uri uri nil
))
384 (str (puri:render-uri uri nil
))
387 (uri-to-pathname uri
)
388 (cxml:xml-parse-error
(c)
389 (xslt-error "cannot find imported stylesheet ~A: ~A"
393 :element-type
'(unsigned-byte 8)
394 :if-does-not-exist nil
)
396 (xslt-error "cannot find imported stylesheet ~A at ~A"
398 (when (find str
*xsl-import-stack
* :test
#'equal
)
399 (xslt-error "recursive inclusion of ~A" uri
))
400 (let ((*xsl-import-stack
* (cons str
*xsl-import-stack
*)))
401 (parse-1-stylesheet env stylesheet stream uri-resolver
)))))
403 (defun parse-stylesheet (designator &key uri-resolver
)
404 (let* ((*import-priority
* 0)
405 (puri:*strict-parse
* nil
)
406 (stylesheet (make-stylesheet))
407 (env (make-instance 'lexical-xslt-environment
))
408 (*excluded-namespaces
* *excluded-namespaces
*)
409 (*global-variable-declarations
* (make-empty-declaration-array)))
410 (ensure-mode stylesheet nil
)
411 (parse-1-stylesheet env stylesheet designator uri-resolver
)
412 ;; reverse attribute sets:
413 (let ((table (stylesheet-attribute-sets stylesheet
)))
414 (maphash (lambda (k v
)
415 (setf (gethash k table
) (nreverse v
)))
419 (defun parse-attribute-sets! (stylesheet <transform
> env
)
420 (dolist (elt (stp:filter-children
(of-name "attribute-set") <transform
>))
422 (mapcar (lambda (qname)
423 (multiple-value-list (decode-qname qname env nil
)))
425 (stp:attribute-value elt
"use-attribute-sets"))))
427 (stp:map-children
'list
#'parse-instruction elt
))
428 (*lexical-variable-declarations
*
429 (make-empty-declaration-array))
431 (compile-instruction `(progn ,@instructions
) env
))
432 (n-variables (length *lexical-variable-declarations
*)))
435 (loop for
(local-name uri nil
) in sets do
436 (dolist (thunk (find-attribute-set local-name uri
))
437 (funcall thunk ctx
)))
438 (let ((*lexical-variable-values
*
439 (make-variable-value-array n-variables
)))
440 (funcall thunk ctx
)))))
441 (gethash (multiple-value-bind (local-name uri
)
442 (decode-qname (stp:attribute-value elt
"name") env nil
)
443 (cons local-name uri
))
444 (stylesheet-attribute-sets stylesheet
)))))
446 (defun parse-namespace-aliases! (stylesheet <transform
> env
)
447 (dolist (elt (stp:filter-children
(of-name "namespace-alias") <transform
>))
448 (stp:with-attributes
(stylesheet-prefix result-prefix
) elt
450 (xpath-sys:environment-find-namespace env stylesheet-prefix
)
451 (stylesheet-namespace-aliases stylesheet
))
452 (xpath-sys:environment-find-namespace env result-prefix
)))))
454 (defun parse-exclude-result-prefixes! (<transform
> env
)
455 (stp:with-attributes
(exclude-result-prefixes) <transform
>
456 (dolist (prefix (words (or exclude-result-prefixes
"")))
457 (when (equal prefix
"#default")
459 (push (or (xpath-sys:environment-find-namespace env prefix
)
460 (xslt-error "namespace not found: ~A" prefix
))
461 *excluded-namespaces
*))))
463 (defun parse-strip/preserve-space
! (stylesheet <transform
> env
)
464 (xpath:with-namespaces
((nil #.
*xsl
*))
465 (dolist (elt (stp:filter-children
(lambda (x)
466 (or (namep x
"strip-space")
467 (namep x
"preserve-space")))
469 (let ((*namespaces
* (acons-namespaces elt
))
471 (if (equal (stp:local-name elt
) "strip-space")
474 (dolist (name-test (words (stp:attribute-value elt
"elements")))
475 (let* ((pos (search ":*" name-test
))
478 ((eql pos
(- (length name-test
) 2))
479 (let* ((prefix (subseq name-test
0 pos
))
481 (xpath-sys:environment-find-namespace env prefix
)))
482 (unless (xpath::nc-name-p prefix
)
483 (xslt-error "not an NCName: ~A" prefix
))
484 (lambda (local-name uri
)
485 (declare (ignore local-name
))
486 (if (equal uri name-test-uri
)
489 ((equal name-test
"*")
490 (lambda (local-name uri
)
491 (declare (ignore local-name uri
))
494 (multiple-value-bind (name-test-local-name name-test-uri
)
495 (decode-qname name-test env nil
)
496 (lambda (local-name uri
)
497 (if (and (equal local-name name-test-local-name
)
498 (equal uri name-test-uri
))
501 (push test-function
(stylesheet-strip-tests stylesheet
))))))))
503 (defstruct (output-specification
504 (:conc-name
"OUTPUT-"))
510 (defun parse-output! (stylesheet <transform
>)
511 (let ((outputs (stp:filter-children
(of-name "output") <transform
>)))
515 ;; - concatenate cdata-section-elements
516 ;; - the others must not conflict
517 (error "oops, merging of output elements not supported yet"))
518 (let ((<output
> (car outputs
))
519 (spec (stylesheet-output-specification stylesheet
)))
520 (stp:with-attributes
(;; version
529 ;;; cdata-section-elements
532 (setf (output-method spec
) method
)
533 (setf (output-indent spec
) indent
)
534 (setf (output-encoding spec
) encoding
)
535 (setf (output-omit-xml-declaration spec
) omit-xml-declaration
))))))
537 (defun make-empty-declaration-array ()
538 (make-array 1 :fill-pointer
0 :adjustable t
))
540 (defun make-variable-value-array (n-lexical-variables)
541 (make-array n-lexical-variables
:initial-element
'unbound
))
543 (defun compile-global-variable (<variable
> env
) ;; also for <param>
544 (stp:with-attributes
(name select
) <variable
>
545 (when (and select
(stp:list-children
<variable
>))
546 (xslt-error "variable with select and body"))
547 (let* ((*lexical-variable-declarations
* (make-empty-declaration-array))
550 (compile-xpath select env
))
551 ((stp:list-children
<variable
>)
552 (let* ((inner-sexpr `(progn ,@(parse-body <variable
>)))
553 (inner-thunk (compile-instruction inner-sexpr env
)))
555 (apply-to-result-tree-fragment ctx inner-thunk
))))
558 (declare (ignore ctx
))
560 (n-lexical-variables (length *lexical-variable-declarations
*)))
563 (let* ((*lexical-variable-values
*
564 (make-variable-value-array n-lexical-variables
)))
565 (funcall inner ctx
)))
566 "global ~s (~s) = ~s" name select
:result
))))
568 (defstruct (variable-information
569 (:constructor make-variable
)
570 (:conc-name
"VARIABLE-"))
578 (defun parse-global-variable! (<variable
> global-env
) ;; also for <param>
579 (let ((*namespaces
* (acons-namespaces <variable
>))
580 (qname (stp:attribute-value
<variable
> "name")))
582 (xslt-error "name missing in ~A" (stp:local-name
<variable
>)))
583 (multiple-value-bind (local-name uri
)
584 (decode-qname qname global-env nil
)
585 ;; For the normal compilation environment of templates, install it
586 ;; into *GLOBAL-VARIABLE-DECLARATIONS*:
587 (let ((index (intern-global-variable local-name uri
)))
588 ;; For the evaluation of a global variable itself, build a thunk
589 ;; that lazily resolves other variables, stored into
590 ;; INITIAL-GLOBAL-VARIABLE-THUNKS:
591 (let* ((value-thunk :unknown
)
592 (global-variable-thunk
594 (let ((v (global-variable-value index nil
)))
596 (xslt-error "recursive variable definition"))
599 ;; (print (list :computing index))
600 (setf (global-variable-value index
) 'seen
)
601 (setf (global-variable-value index
)
602 (funcall value-thunk ctx
))
603 #+nil
(print (list :done-computing index
604 (global-variable-value index
)))
605 #+nil
(global-variable-value index
))
607 #+nil
(print (list :have
613 (compile-global-variable <variable
> global-env
)))))
614 (setf (gethash (cons local-name uri
)
615 (initial-global-variable-thunks global-env
))
616 global-variable-thunk
)
617 (make-variable :index index
618 :local-name local-name
620 :thunk global-variable-thunk
621 :param-p
(namep <variable
> "param")
622 :thunk-setter thunk-setter
))))))
624 (defun parse-keys! (stylesheet <transform
> env
)
625 (xpath:with-namespaces
((nil #.
*xsl
*))
627 (<key
> (xpath:evaluate
"key" <transform
>))
628 (stp:with-attributes
(name match use
) <key
>
629 (unless name
(xslt-error "key name attribute not specified"))
630 (unless match
(xslt-error "key match attribute not specified"))
631 (unless use
(xslt-error "key use attribute not specified"))
632 (add-key stylesheet name
633 (compile-xpath `(xpath:xpath
,(parse-key-pattern match
)) env
)
634 (compile-xpath use env
))))))
636 (defun parse-global-variables! (stylesheet <transform
>)
637 (xpath:with-namespaces
((nil #.
*xsl
*))
638 (let* ((table (make-hash-table :test
'equal
))
639 (global-env (make-instance 'global-variable-environment
640 :initial-global-variable-thunks table
))
643 (<variable
> (xpath:evaluate
"variable|param" <transform
>))
644 (let ((var (parse-global-variable! <variable
> global-env
)))
645 (xslt-trace "parsing global variable ~s (uri ~s)"
646 (variable-local-name var
)
651 (and (equal (variable-local-name a
)
652 (variable-local-name b
))
653 (equal (variable-uri a
)
655 (xslt-error "duplicate definition for global variable ~A"
656 (variable-local-name var
)))
658 ;; now that the global environment knows about all variables, run the
659 ;; thunk setters to perform their compilation
660 (setf specs
(nreverse specs
))
661 (mapc (lambda (spec) (funcall (variable-thunk-setter spec
))) specs
)
662 (setf (stylesheet-global-variables stylesheet
) specs
))))
664 (defun parse-templates! (stylesheet <transform
> env
)
666 (dolist (<template
> (stp:filter-children
(of-name "template") <transform
>))
667 (let ((*namespaces
* (acons-namespaces <template
>)))
668 (dolist (template (compile-template <template
> env i
))
669 (let ((name (template-name template
)))
671 (let* ((table (stylesheet-named-templates stylesheet
))
672 (head (car (gethash name table
))))
673 (when (and head
(eql (template-import-priority head
)
674 (template-import-priority template
)))
675 ;; fixme: is this supposed to be a run-time error?
676 (xslt-error "conflicting templates for ~A" name
))
677 (push template
(gethash name table
)))
678 (let ((mode (ensure-mode/qname stylesheet
679 (template-mode-qname template
)
681 (setf (template-mode template
) mode
)
682 (push template
(mode-templates mode
)))))))
686 ;;;; APPLY-STYLESHEET
688 (defvar *stylesheet
*)
691 (deftype xml-designator
() '(or runes
:xstream runes
:rod array stream pathname
))
693 (defstruct (parameter
694 (:constructor make-parameter
(value local-name
&optional uri
)))
699 (defun find-parameter-value (local-name uri parameters
)
700 (dolist (p parameters
)
701 (when (and (equal (parameter-local-name p
) local-name
)
702 (equal (parameter-uri p
) uri
))
703 (return (parameter-value p
)))))
705 (defvar *uri-resolver
*)
707 (defun parse-allowing-microsoft-bom (pathname handler
)
708 (with-open-file (s pathname
:element-type
'(unsigned-byte 8))
709 (unless (and (eql (read-byte s nil
) #xef
)
710 (eql (read-byte s nil
) #xbb
)
711 (eql (read-byte s nil
) #xbf
))
713 (cxml:parse s handler
)))
715 (defun %document
(uri-string base-uri
)
717 (puri:merge-uris uri-string base-uri
))
720 (funcall *uri-resolver
* (puri:render-uri absolute-uri nil
))
724 (uri-to-pathname resolved-uri
)
725 (cxml:xml-parse-error
(c)
726 (xslt-error "cannot find referenced document ~A: ~A"
730 (parse-allowing-microsoft-bom pathname
(stp:make-builder
))
731 ((or file-error cxml
:xml-parse-error
) (c)
732 (xslt-error "cannot parse referenced document ~A: ~A"
735 (make-whitespace-stripper document
736 (stylesheet-strip-tests *stylesheet
*))))
737 (when (puri:uri-fragment absolute-uri
)
738 (xslt-error "use of fragment identifiers in document() not supported"))
741 (xpath-sys:define-extension xslt
*xsl
*)
743 (xpath-sys:define-xpath-function
/lazy
745 (object &optional node-set
)
746 (let ((instruction-base-uri *instruction-base-uri
*))
748 (let* ((object (funcall object ctx
))
749 (node-set (and node-set
(funcall node-set ctx
)))
752 ;; FIXME: should use first node of the node set
753 ;; _in document order_
754 (xpath-protocol:base-uri
(xpath:first-node node-set
)))))
755 (xpath-sys:make-node-set
756 (if (xpath:node-set-p object
)
757 (xpath:map-node-set-
>list
759 (%document
(xpath:string-value node
)
760 (or uri
(xpath-protocol:base-uri node
))))
762 (list (%document
(xpath:string-value object
)
763 (or uri instruction-base-uri
)))))))))
765 (xpath-sys:define-xpath-function
/eager xslt
:key
(name object
)
766 (let ((key (find-key (xpath:string-value name
) *stylesheet
*)))
767 (labels ((get-by-key (value)
768 (let ((value (xpath:string-value value
)))
771 (equal value
(xpath:string-value
772 (xpath:evaluate-compiled
773 (key-use key
) node
))))
775 (xpath:node-set-value
776 (xpath:evaluate-compiled
777 (key-match key
) xpath
:context
)))))))
778 (xpath-sys:make-node-set
780 (if (xpath:node-set-p object
)
781 (xpath::mappend-pipe
#'get-by-key
(xpath-sys:pipe-of object
))
782 (get-by-key object
)))))))
784 ;; FIXME: add alias mechanism for XPath extensions in order to avoid duplication
786 (xpath-sys:define-xpath-function
/lazy xslt
:current
()
788 (xpath-sys:make-node-set
790 (xpath:context-starting-node ctx
)
793 (xpath-sys:define-xpath-function
/lazy xslt
:generate-id
(&optional node-set-thunk
)
796 (xpath-sys:get-node-id
(xpath:node-set-value
(funcall node-set-thunk ctx
))))
798 (xpath-sys:get-node-id
(xpath:context-node ctx
)))))
800 (defun apply-stylesheet
801 (stylesheet source-document
802 &key output parameters uri-resolver navigator
)
803 (when (typep stylesheet
'xml-designator
)
804 (setf stylesheet
(parse-stylesheet stylesheet
)))
805 (when (typep source-document
'xml-designator
)
806 (setf source-document
(cxml:parse source-document
(stp:make-builder
))))
807 (invoke-with-output-sink
810 (let* ((xpath:*navigator
* (or navigator
:default-navigator
))
811 (puri:*strict-parse
* nil
)
812 (*stylesheet
* stylesheet
)
813 (*mode
* (find-mode stylesheet nil
))
814 (*empty-mode
* (make-mode))
815 (global-variable-specs
816 (stylesheet-global-variables stylesheet
))
817 (*global-variable-values
*
818 (make-variable-value-array (length global-variable-specs
)))
819 (*uri-resolver
* uri-resolver
)
821 (make-whitespace-stripper
823 (stylesheet-strip-tests stylesheet
)))
824 (ctx (xpath:make-context xpath-root-node
)))
826 (when (variable-param-p spec
)
828 (find-parameter-value (variable-local-name spec
)
832 (setf (global-variable-value (variable-index spec
))
834 global-variable-specs
)
836 (funcall (variable-thunk spec
) ctx
))
837 global-variable-specs
)
838 #+nil
(print global-variable-specs
)
839 #+nil
(print *global-variable-values
*)
840 ;; zzz we wouldn't have to mask float traps here if we used the
841 ;; XPath API properly. Unfortunately I've been using FUNCALL
842 ;; everywhere instead of EVALUATE, so let's paper over that
843 ;; at a central place to be sure:
844 (xpath::with-float-traps-masked
()
845 (apply-templates ctx
)))
846 (xpath:xpath-error
(c)
847 (xslt-error "~A" c
))))
848 (stylesheet-output-specification stylesheet
)
851 (defun find-attribute-set (local-name uri
)
852 (or (gethash (cons local-name uri
) (stylesheet-attribute-sets *stylesheet
*))
853 (xslt-error "no such attribute set: ~A/~A" local-name uri
)))
855 (defun apply-templates/list
(list &optional param-bindings sort-predicate
)
857 (setf list
(sort list sort-predicate
)))
858 (let* ((n (length list
))
864 (apply-templates (xpath:make-context child s
/d i
)
867 (defvar *stack-limit
* 200)
869 (defun invoke-with-stack-limit (fn)
870 (let ((*stack-limit
* (1- *stack-limit
*)))
871 (unless (plusp *stack-limit
*)
872 (xslt-error "*stack-limit* reached; stack overflow"))
875 (defun invoke-template (ctx template param-bindings
)
876 (let ((*lexical-variable-values
*
877 (make-variable-value-array (template-n-variables template
))))
880 for
(name-cons value
) in param-bindings
881 for
(nil index nil
) = (find name-cons
882 (template-params template
)
887 (xslt-error "invalid template parameter ~A" name-cons
))
888 (setf (lexical-variable-value index
) value
))
889 (funcall (template-body template
) ctx
))))
891 (defun apply-default-templates (ctx)
892 (let ((node (xpath:context-node ctx
)))
894 ((or (xpath-protocol:node-type-p node
:processing-instruction
)
895 (xpath-protocol:node-type-p node
:comment
)))
896 ((or (xpath-protocol:node-type-p node
:text
)
897 (xpath-protocol:node-type-p node
:attribute
))
898 (write-text (xpath-protocol:node-text node
)))
900 (apply-templates/list
902 (xpath-protocol:child-pipe node
)))))))
904 (defvar *apply-imports
*)
906 (defun apply-applicable-templates (ctx templates param-bindings finally
)
907 (labels ((apply-imports ()
909 (let* ((this (pop templates
))
910 (low (template-apply-imports-limit this
))
911 (high (template-import-priority this
)))
915 (<= low
(template-import-priority x
) high
))
917 (invoke-template ctx this param-bindings
))
919 (let ((*apply-imports
* #'apply-imports
))
922 (defun apply-templates (ctx &optional param-bindings
)
923 (apply-applicable-templates ctx
927 (apply-default-templates ctx
))))
929 (defun call-template (ctx name
&optional param-bindings
)
930 (apply-applicable-templates ctx
931 (find-named-templates name
)
934 (error "cannot find named template: ~s"
937 (defun find-templates (ctx)
938 (let* ((matching-candidates
939 (remove-if-not (lambda (template)
940 (template-matches-p template ctx
))
941 (mode-templates *mode
*)))
943 (if matching-candidates
946 :key
#'template-import-priority
))
948 (priority-groups (make-array npriorities
:initial-element nil
)))
949 (dolist (template matching-candidates
)
951 (elt priority-groups
(template-import-priority template
))))
952 ;;; (print (map 'list #'length priority-groups))
955 for i from
(1- npriorities
) downto
0
956 for group
= (elt priority-groups i
)
957 for template
= (maximize #'template
< group
)
961 (defun find-named-templates (name)
962 (gethash name
(stylesheet-named-templates *stylesheet
*)))
964 (defun template< (a b
) ;assuming same import priority
965 (let ((p (template-priority a
))
966 (q (template-priority b
)))
971 (xslt-cerror "conflicting templates:~_~A,~_~A"
972 (template-match-expression a
)
973 (template-match-expression b
))
974 (< (template-position a
) (template-position b
))))))
976 (defun maximize (< things
)
978 (let ((max (car things
)))
979 (dolist (other (cdr things
))
980 (when (funcall < max other
)
984 (defun template-matches-p (template ctx
)
985 (find (xpath:context-node ctx
)
986 (xpath:all-nodes
(funcall (template-match-thunk template
) ctx
))))
988 (defun invoke-with-output-sink (fn output-spec output
)
991 (with-open-file (s output
993 :element-type
'(unsigned-byte 8)
994 :if-exists
:rename-and-delete
)
995 (invoke-with-output-sink fn output-spec s
)))
997 (invoke-with-output-sink fn
999 (make-output-sink output-spec output
)))
1000 ((or hax
:abstract-handler sax
:abstract-handler
)
1001 (with-xml-output output
1004 (defun make-output-sink (output-spec stream
)
1007 (let ((et (stream-element-type stream
)))
1009 ((or (null et
) (subtypep et
'(unsigned-byte 8)))
1010 (runes:make-octet-stream-ystream stream
))
1011 ((subtypep et
'character
)
1012 (runes:make-character-stream-ystream stream
))))
1013 (runes:make-rod-ystream
)))
1014 (omit-xml-declaration-p
1015 (equal (output-omit-xml-declaration output-spec
) "yes"))
1017 (make-instance 'cxml
::sink
1019 :omit-xml-declaration-p omit-xml-declaration-p
)))
1020 (if (equalp (output-method output-spec
) "HTML")
1021 (make-instance 'combi-sink
1022 :hax-target
(make-instance 'chtml
::sink
1024 :sax-target sax-target
1025 :encoding
(output-encoding output-spec
))
1042 (defun expression-priority (form)
1043 (let ((step (second form
)))
1044 (if (and (null (cddr form
))
1046 (member (car step
) '(:child
:attribute
))
1048 (let ((name (second step
)))
1052 (or (eq (car name
) :qname
)
1053 (eq (car name
) :processing-instruction
))))
1056 (or (eq (car name
) :namespace
)
1057 (eq (car name
) '*)))
1063 (defun valid-expression-p (expr)
1066 ((eq (first expr
) :path
)
1068 (let ((filter (third x
)))
1069 (or (null filter
) (valid-expression-p filter
))))
1071 ((eq (first expr
) :variable
) ;(!)
1074 (every #'valid-expression-p
(cdr expr
)))))
1076 (defun parse-xpath (str)
1078 (xpath:parse-xpath str
)
1079 (xpath:xpath-error
(c)
1080 (xslt-error "~A" c
))))
1082 (defun parse-key-pattern (str)
1084 (mapcar #'(lambda (item)
1085 `(:path
(:root
:node
)
1086 (:descendant-or-self
*)
1088 (parse-pattern str
))))
1089 (if (null (rest parsed
))
1091 `(:union
,@parsed
))))
1093 (defun parse-pattern (str)
1094 ;; zzz check here for anything not allowed as an XSLT pattern
1095 ;; zzz can we hack id() and key() here?
1096 (let ((form (parse-xpath str
)))
1097 (unless (consp form
)
1098 (xslt-error "not a valid pattern: ~A" str
))
1099 (labels ((process-form (form)
1100 (cond ((eq (car form
) :union
)
1101 (alexandria:mappend
#'process-form
(rest form
)))
1102 ((not (eq (car form
) :path
)) ;zzz: filter statt path
1103 (xslt-error "not a valid pattern: ~A" str
))
1104 ((not (valid-expression-p form
))
1105 (xslt-error "invalid filter"))
1107 (process-form form
))))
1109 (defun compile-value-thunk (value env
)
1110 (if (and (listp value
) (eq (car value
) 'progn
))
1111 (let ((inner-thunk (compile-instruction value env
)))
1113 (apply-to-result-tree-fragment ctx inner-thunk
)))
1114 (compile-xpath value env
)))
1116 (defun compile-var-bindings/nointern
(forms env
)
1118 for
(name value
) in forms
1119 collect
(multiple-value-bind (local-name uri
)
1120 (decode-qname name env nil
)
1121 (list (cons local-name uri
)
1123 (compile-value-thunk value env
)
1124 "local variable ~s = ~s" name
:result
)))))
1126 (defun compile-var-bindings (forms env
)
1128 for
(cons thunk
) in
(compile-var-bindings/nointern forms env
)
1129 for
(local-name . uri
) = cons
1131 (push-variable local-name
1133 *lexical-variable-declarations
*)
1136 (defun compile-template (<template
> env position
)
1137 (stp:with-attributes
(match name priority mode
) <template
>
1138 (unless (or name match
)
1139 (xslt-error "missing match in template"))
1140 (multiple-value-bind (params body-pos
)
1143 for child in
(stp:list-children
<template
>)
1144 while
(namep child
"param")
1145 collect
(parse-param child
) into params
1146 finally
(return (values params i
)))
1147 (let* ((*lexical-variable-declarations
* (make-empty-declaration-array))
1148 (param-bindings (compile-var-bindings params env
))
1149 (body (parse-body <template
> body-pos
(mapcar #'car params
)))
1150 (body-thunk (compile-instruction `(progn ,@body
) env
))
1156 ;; set params that weren't initialized by apply-templates
1157 (loop for
(name index param-thunk
) in param-bindings
1158 when
(eq (lexical-variable-value index nil
) 'unbound
)
1159 do
(setf (lexical-variable-value index
)
1160 (funcall param-thunk ctx
)))
1161 (funcall body-thunk ctx
))))
1162 "template: match = ~s name = ~s" match name
))
1163 (n-variables (length *lexical-variable-declarations
*)))
1166 (multiple-value-bind (local-name uri
)
1167 (decode-qname name env nil
)
1169 (make-template :name
(cons local-name uri
)
1170 :import-priority
*import-priority
*
1171 :apply-imports-limit
*apply-imports-limit
*
1172 :params param-bindings
1173 :body outer-body-thunk
1174 :n-variables n-variables
))))
1176 (mapcar (lambda (expression)
1181 (:path
(:ancestor-or-self
:node
)
1182 ,@(cdr expression
)))
1184 "match-thunk for template (match ~s): ~s --> ~s"
1185 match expression
:result
))
1187 (parse-number:parse-number priority
)
1188 (expression-priority expression
))))
1189 (make-template :match-expression expression
1190 :match-thunk match-thunk
1191 :import-priority
*import-priority
*
1192 :apply-imports-limit
*apply-imports-limit
*
1196 :params param-bindings
1197 :body outer-body-thunk
1198 :n-variables n-variables
)))
1199 (parse-pattern match
))))))))
1201 (xuriella::parse-stylesheet
#p
"/home/david/src/lisp/xuriella/test.xsl")