Check boolean attributes
[xuriella.git] / xslt.lisp
blob037fc6c56785441653479918a909a9af62dbb85a
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
8 ;;; are met:
9 ;;;
10 ;;; * Redistributions of source code must retain the above copyright
11 ;;; notice, this list of conditions and the following disclaimer.
12 ;;;
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.
17 ;;;
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)
32 #+sbcl
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"))
42 ;;;; XSLT-ERROR
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
65 ;; everywhere.
66 (defun xslt-cerror (fmt &rest args)
67 (declare (ignore fmt args))
68 #+(or)
69 (with-simple-restart (recover "recover")
70 (error 'recoverable-xslt-error
71 :format-control fmt
72 :format-arguments args)))
74 (defvar *debug* nil)
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
80 ;; important.)
81 (let ((doit (gensym)))
82 `(flet ((,doit () ,form))
83 (if *debug*
84 (,doit)
85 (handler-case
86 (,doit)
87 ,@clauses)))))
89 (defmacro with-resignalled-errors ((&optional) &body body)
90 `(invoke-with-resignalled-errors (lambda () ,@body)))
92 (defun invoke-with-resignalled-errors (fn)
93 (handler-bind
94 ((xpath:xpath-error
95 (lambda (c)
96 (xslt-error "~A" c)))
97 (babel-encodings:character-encoding-error
98 (lambda (c)
99 (xslt-error "~A" c))))
100 (funcall fn)))
102 (defun compile-xpath (xpath &optional env)
103 (with-resignalled-errors ()
104 (xpath:compile-xpath xpath env)))
106 (defmacro with-stack-limit ((&optional) &body body)
107 `(invoke-with-stack-limit (lambda () ,@body)))
109 (defparameter *without-xslt-current-p* nil)
111 (defmacro without-xslt-current ((&optional) &body body)
112 `(invoke-without-xslt-current (lambda () ,@body)))
114 (defun invoke-without-xslt-current (fn)
115 (let ((*without-xslt-current-p* t))
116 (funcall fn)))
118 ;;; (defun invoke-without-xslt-current (fn)
119 ;;; (let ((non-extensions (gethash "" xpath::*extensions*))
120 ;;; (xpath::*extensions*
121 ;;; ;; hide XSLT extensions
122 ;;; (make-hash-table :test #'equal)))
123 ;;; (setf (gethash "" xpath::*extensions*) non-extensions)
124 ;;; (funcall fn)))
127 ;;;; Helper functions and macros
129 (defun check-for-invalid-attributes (valid-names node)
130 (labels ((check-attribute (a)
131 (unless
132 (let ((uri (stp:namespace-uri a)))
133 (or (and (plusp (length uri)) (not (equal uri *xsl*)))
134 (find (cons (stp:local-name a) uri)
135 valid-names
136 :test #'equal)))
137 (xslt-error "attribute ~A not allowed on ~A"
138 (stp:local-name a)
139 (stp:local-name node)))))
140 (stp:map-attributes nil #'check-attribute node)))
142 (defmacro only-with-attributes ((&rest specs) node &body body)
143 (let ((valid-names
144 (mapcar (lambda (entry)
145 (if (and (listp entry) (cdr entry))
146 (destructuring-bind (name &optional (uri ""))
147 (cdr entry)
148 (cons name uri))
149 (cons (string-downcase
150 (princ-to-string
151 (symbol-name entry)))
152 "")))
153 specs))
154 (%node (gensym)))
155 `(let ((,%NODE ,node))
156 (check-for-invalid-attributes ',valid-names ,%NODE)
157 (stp:with-attributes ,specs ,%NODE
158 ,@body))))
160 (defun map-pipe-eagerly (fn pipe)
161 (xpath::enumerate pipe :key fn :result nil))
163 (defmacro do-pipe ((var pipe &optional result) &body body)
164 `(block nil
165 (map-pipe-eagerly #'(lambda (,var) ,@body) ,pipe)
166 ,result))
169 ;;;; XSLT-ENVIRONMENT and XSLT-CONTEXT
171 (defparameter *namespaces*
172 '((nil . "")
173 ("xmlns" . #"http://www.w3.org/2000/xmlns/")
174 ("xml" . #"http://www.w3.org/XML/1998/namespace")))
176 (defvar *global-variable-declarations*)
177 (defvar *lexical-variable-declarations*)
179 (defvar *global-variable-values*)
180 (defvar *lexical-variable-values*)
182 (defclass xslt-environment () ())
184 (defun split-qname (str)
185 (handler-case
186 (multiple-value-bind (prefix local-name)
187 (cxml::split-qname str)
188 (unless
189 ;; FIXME: cxml should really offer a function that does
190 ;; checks for NCName and QName in a sensible way for user code.
191 ;; cxml::split-qname is tailored to the needs of the parser.
193 ;; For now, let's just check the syntax explicitly.
194 (and (or (null prefix) (xpath::nc-name-p prefix))
195 (xpath::nc-name-p local-name))
196 (xslt-error "not a qname: ~A" str))
197 (values prefix local-name))
198 (cxml:well-formedness-violation ()
199 (xslt-error "not a qname: ~A" str))))
201 (defun decode-qname (qname env attributep)
202 (unless qname
203 (xslt-error "missing name"))
204 (multiple-value-bind (prefix local-name)
205 (split-qname qname)
206 (values local-name
207 (if (or prefix (not attributep))
208 (xpath-sys:environment-find-namespace env (or prefix ""))
210 prefix)))
212 (defmethod xpath-sys:environment-find-namespace ((env xslt-environment) prefix)
213 (or (cdr (assoc prefix *namespaces* :test 'equal))
214 ;; zzz gross hack.
215 ;; Change the entire code base to represent "no prefix" as the
216 ;; empty string consistently. unparse.lisp has already been changed.
217 (and (equal prefix "")
218 (cdr (assoc nil *namespaces* :test 'equal)))
219 (and (eql prefix nil)
220 (cdr (assoc "" *namespaces* :test 'equal)))))
222 (defun find-variable-index (local-name uri table)
223 (position (cons local-name uri) table :test 'equal))
225 (defun intern-global-variable (local-name uri)
226 (or (find-variable-index local-name uri *global-variable-declarations*)
227 (push-variable local-name uri *global-variable-declarations*)))
229 (defun push-variable (local-name uri table)
230 (prog1
231 (length table)
232 (vector-push-extend (cons local-name uri) table)))
234 (defun lexical-variable-value (index &optional (errorp t))
235 (let ((result (svref *lexical-variable-values* index)))
236 (when errorp
237 (assert (not (eq result 'unbound))))
238 result))
240 (defun (setf lexical-variable-value) (newval index)
241 (assert (not (eq newval 'unbound)))
242 (setf (svref *lexical-variable-values* index) newval))
244 (defun global-variable-value (index &optional (errorp t))
245 (let ((result (svref *global-variable-values* index)))
246 (when errorp
247 (assert (not (eq result 'unbound))))
248 result))
250 (defun (setf global-variable-value) (newval index)
251 (assert (not (eq newval 'unbound)))
252 (setf (svref *global-variable-values* index) newval))
254 (defmethod xpath-sys:environment-find-function
255 ((env xslt-environment) lname uri)
256 (if (string= uri "")
257 (or (xpath-sys:find-xpath-function lname *xsl*)
258 (xpath-sys:find-xpath-function lname uri))
259 (xpath-sys:find-xpath-function lname uri)))
261 (defmethod xpath-sys:environment-find-variable
262 ((env xslt-environment) lname uri)
263 (let ((index
264 (find-variable-index lname uri *lexical-variable-declarations*)))
265 (when index
266 (lambda (ctx)
267 (declare (ignore ctx))
268 (svref *lexical-variable-values* index)))))
270 (defclass lexical-xslt-environment (xslt-environment) ())
272 (defmethod xpath-sys:environment-find-variable
273 ((env lexical-xslt-environment) lname uri)
274 (or (call-next-method)
275 (let ((index
276 (find-variable-index lname uri *global-variable-declarations*)))
277 (when index
278 (xslt-trace-thunk
279 (lambda (ctx)
280 (declare (ignore ctx))
281 (svref *global-variable-values* index))
282 "global ~s (uri ~s) = ~s" lname uri :result)))))
284 (defclass key-environment (xslt-environment) ())
286 (defmethod xpath-sys:environment-find-variable
287 ((env key-environment) lname uri)
288 (declare (ignore lname uri))
289 (xslt-error "disallowed variable reference"))
291 (defclass global-variable-environment (xslt-environment)
292 ((initial-global-variable-thunks
293 :initarg :initial-global-variable-thunks
294 :accessor initial-global-variable-thunks)))
296 (defmethod xpath-sys:environment-find-variable
297 ((env global-variable-environment) lname uri)
298 (or (call-next-method)
299 (gethash (cons lname uri) (initial-global-variable-thunks env))))
302 ;;;; TOPLEVEL-TEXT-OUTPUT-SINK
303 ;;;;
304 ;;;; A sink that serializes only text not contained in any element.
306 (defmacro with-toplevel-text-output-sink ((var) &body body)
307 `(invoke-with-toplevel-text-output-sink (lambda (,var) ,@body)))
309 (defclass toplevel-text-output-sink (sax:default-handler)
310 ((target :initarg :target :accessor text-output-sink-target)
311 (depth :initform 0 :accessor textoutput-sink-depth)))
313 (defmethod sax:start-element ((sink toplevel-text-output-sink)
314 namespace-uri local-name qname attributes)
315 (declare (ignore namespace-uri local-name qname attributes))
316 (incf (textoutput-sink-depth sink)))
318 (defmethod sax:characters ((sink toplevel-text-output-sink) data)
319 (when (zerop (textoutput-sink-depth sink))
320 (write-string data (text-output-sink-target sink))))
322 (defmethod sax:unescaped ((sink toplevel-text-output-sink) data)
323 (sax:characters sink data))
325 (defmethod sax:end-element ((sink toplevel-text-output-sink)
326 namespace-uri local-name qname)
327 (declare (ignore namespace-uri local-name qname))
328 (decf (textoutput-sink-depth sink)))
330 (defun invoke-with-toplevel-text-output-sink (fn)
331 (with-output-to-string (s)
332 (funcall fn (make-instance 'toplevel-text-output-sink :target s))))
335 ;;;; TEXT-FILTER
336 ;;;;
337 ;;;; A sink that passes through only text (at any level) and turns to
338 ;;;; into unescaped characters.
340 (defclass text-filter (sax:default-handler)
341 ((target :initarg :target :accessor text-filter-target)))
343 (defmethod sax:characters ((sink text-filter) data)
344 (sax:unescaped (text-filter-target sink) data))
346 (defmethod sax:unescaped ((sink text-filter) data)
347 (sax:unescaped (text-filter-target sink) data))
349 (defmethod sax:end-document ((sink text-filter))
350 (sax:end-document (text-filter-target sink)))
352 (defun make-text-filter (target)
353 (make-instance 'text-filter :target target))
356 ;;;; ESCAPER
357 ;;;;
358 ;;;; A sink that recovers from sax:unescaped using sax:characters, as per
359 ;;;; XSLT 16.4.
361 (defclass escaper (cxml:broadcast-handler)
364 (defmethod sax:unescaped ((sink escaper) data)
365 (sax:characters sink data))
367 (defun make-escaper (target)
368 (make-instance 'escaper :handlers (list target)))
371 ;;;; Names
373 (defun of-name (local-name)
374 (stp:of-name local-name *xsl*))
376 (defun namep (node local-name)
377 (and (typep node '(or stp:element stp:attribute))
378 (equal (stp:namespace-uri node) *xsl*)
379 (equal (stp:local-name node) local-name)))
382 ;;;; PARSE-STYLESHEET
384 (defstruct stylesheet
385 (modes (make-hash-table :test 'equal))
386 (global-variables (make-empty-declaration-array))
387 (output-specification (make-output-specification))
388 (strip-tests nil)
389 (strip-thunk nil)
390 (named-templates (make-hash-table :test 'equal))
391 (attribute-sets (make-hash-table :test 'equal))
392 (keys (make-hash-table :test 'equal))
393 (namespace-aliases (make-hash-table :test 'equal))
394 (decimal-formats (make-hash-table :test 'equal))
395 (initial-global-variable-thunks (make-hash-table :test 'equal)))
397 (defstruct mode
398 (templates nil)
399 (match-thunk (lambda (ignore) (declare (ignore ignore)) nil)))
401 (defun find-mode (stylesheet local-name &optional uri)
402 (gethash (cons local-name uri) (stylesheet-modes stylesheet)))
404 (defun ensure-mode (stylesheet &optional local-name uri)
405 (or (find-mode stylesheet local-name uri)
406 (setf (gethash (cons local-name uri) (stylesheet-modes stylesheet))
407 (make-mode))))
409 (defun ensure-mode/qname (stylesheet qname env)
410 (if qname
411 (multiple-value-bind (local-name uri)
412 (decode-qname qname env nil)
413 (ensure-mode stylesheet local-name uri))
414 (find-mode stylesheet nil)))
416 (defun acons-namespaces (element &optional (bindings *namespaces*))
417 (map-namespace-declarations (lambda (prefix uri)
418 (push (cons prefix uri) bindings))
419 element)
420 bindings)
422 (defun find-key (name stylesheet)
423 (or (gethash name (stylesheet-keys stylesheet))
424 (xslt-error "unknown key: ~a" name)))
426 (defun make-key (match use) (cons match use))
428 (defun key-match (key) (car key))
430 (defun key-use (key) (cdr key))
432 (defun add-key (stylesheet name match use)
433 (if (gethash name (stylesheet-keys stylesheet))
434 (xslt-error "duplicate key: ~a" name)
435 (setf (gethash name (stylesheet-keys stylesheet))
436 (make-key match use))))
438 (defvar *excluded-namespaces* (list *xsl*))
439 (defvar *empty-mode*)
440 (defvar *default-mode*)
442 (defvar *xsl-include-stack* nil)
444 (defun uri-to-pathname (uri)
445 (cxml::uri-to-pathname (puri:parse-uri uri)))
447 ;; Why this extra check for literal result element used as stylesheets,
448 ;; instead of a general check for every literal result element? Because
449 ;; Stylesheet__91804 says so.
450 (defun check-Errors_err035 (literal-result-element)
451 (let ((*namespaces* (acons-namespaces literal-result-element))
452 (env (make-instance 'lexical-xslt-environment)))
453 (stp:with-attributes ((extension-element-prefixes
454 "extension-element-prefixes"
455 *xsl*))
456 literal-result-element
457 (dolist (prefix (words (or extension-element-prefixes "")))
458 (if (equal prefix "#default")
459 (setf prefix nil)
460 (unless (cxml-stp-impl::nc-name-p prefix)
461 (xslt-error "invalid prefix: ~A" prefix)))
462 (let ((uri
463 (or (xpath-sys:environment-find-namespace env prefix)
464 (xslt-error "namespace not found: ~A" prefix))))
465 (when (equal uri (stp:namespace-uri literal-result-element))
466 (xslt-error "literal result element used as stylesheet, but is ~
467 declared as an extension element")))))))
469 (defun unwrap-2.3 (document)
470 (let ((literal-result-element (stp:document-element document))
471 (new-template (stp:make-element "template" *xsl*))
472 (new-document-element (stp:make-element "stylesheet" *xsl*)))
473 (check-Errors_err035 literal-result-element)
474 (setf (stp:attribute-value new-document-element "version")
475 (or (stp:attribute-value literal-result-element "version" *xsl*)
476 (xslt-error "not a stylesheet: root element lacks xsl:version")))
477 (setf (stp:attribute-value new-template "match") "/")
478 (setf (stp:document-element document) new-document-element)
479 (stp:append-child new-document-element new-template)
480 (stp:append-child new-template literal-result-element)
481 new-document-element))
483 (defun parse-stylesheet-to-stp (input uri-resolver)
484 (let* ((d (cxml:parse input (make-text-normalizer (cxml-stp:make-builder))))
485 (<transform> (stp:document-element d)))
486 (unless (equal (stp:namespace-uri <transform>) *xsl*)
487 (setf <transform> (unwrap-2.3 d)))
488 (strip-stylesheet <transform>)
489 (unless (and (equal (stp:namespace-uri <transform>) *xsl*)
490 (or (equal (stp:local-name <transform>) "transform")
491 (equal (stp:local-name <transform>) "stylesheet")))
492 (xslt-error "not a stylesheet"))
493 (check-for-invalid-attributes '(("version" . "")
494 ("exclude-result-prefixes" . "")
495 ("extension-element-prefixes" . ""))
496 <transform>)
497 (let ((invalid
498 (or (stp:find-child-if (of-name "stylesheet") <transform>)
499 (stp:find-child-if (of-name "transform") <transform>))))
500 (when invalid
501 (xslt-error "invalid top-level element ~A" (stp:local-name invalid))))
502 (dolist (include (stp:filter-children (of-name "include") <transform>))
503 (let* ((uri (puri:merge-uris (or (stp:attribute-value include "href")
504 (xslt-error "include without href"))
505 (stp:base-uri include)))
506 (uri (if uri-resolver
507 (funcall uri-resolver (puri:render-uri uri nil))
508 uri))
509 (str (puri:render-uri uri nil))
510 (pathname
511 (handler-case
512 (uri-to-pathname uri)
513 (cxml:xml-parse-error (c)
514 (xslt-error "cannot find included stylesheet ~A: ~A"
515 uri c)))))
516 (with-open-file
517 (stream pathname
518 :element-type '(unsigned-byte 8)
519 :if-does-not-exist nil)
520 (unless stream
521 (xslt-error "cannot find included stylesheet ~A at ~A"
522 uri pathname))
523 (when (find str *xsl-include-stack* :test #'equal)
524 (xslt-error "recursive inclusion of ~A" uri))
525 (let* ((*xsl-include-stack* (cons str *xsl-include-stack*))
526 (<transform>2 (parse-stylesheet-to-stp stream uri-resolver)))
527 (stp:insert-child-after <transform>
528 (stp:copy <transform>2)
529 include)
530 (stp:detach include)))))
531 <transform>))
533 (defvar *instruction-base-uri*) ;misnamed, is also used in other attributes
534 (defvar *apply-imports-limit*)
535 (defvar *import-priority*)
536 (defvar *extension-namespaces*)
537 (defvar *forwards-compatible-p*)
539 (defmacro do-toplevel ((var xpath <transform>) &body body)
540 `(map-toplevel (lambda (,var) ,@body) ,xpath ,<transform>))
542 (defun map-toplevel (fn xpath <transform>)
543 (dolist (node (list-toplevel xpath <transform>))
544 (let ((*namespaces* *namespaces*))
545 (xpath:do-node-set (ancestor (xpath:evaluate "ancestor::node()" node))
546 (when (xpath-protocol:node-type-p ancestor :element)
547 (setf *namespaces* (acons-namespaces ancestor))))
548 (funcall fn node))))
550 (defun list-toplevel (xpath <transform>)
551 (labels ((recurse (sub)
552 (let ((subsubs
553 (xpath-sys:pipe-of
554 (xpath:evaluate "transform|stylesheet" sub))))
555 (xpath::append-pipes
556 (xpath-sys:pipe-of (xpath:evaluate xpath sub))
557 (xpath::mappend-pipe #'recurse subsubs)))))
558 (xpath::sort-nodes (recurse <transform>))))
560 (defmacro with-import-magic ((node env) &body body)
561 `(invoke-with-import-magic (lambda () ,@body) ,node ,env))
563 (defun invoke-with-import-magic (fn node env)
564 (unless (or (namep node "stylesheet") (namep node "transform"))
565 (setf node (stp:parent node)))
566 (let ((*excluded-namespaces* (list *xsl*))
567 (*extension-namespaces* '())
568 (*forwards-compatible-p*
569 (not (equal (stp:attribute-value node "version") "1.0"))))
570 (parse-exclude-result-prefixes! node env)
571 (parse-extension-element-prefixes! node env)
572 (funcall fn)))
574 (defun parse-1-stylesheet (env stylesheet designator uri-resolver)
575 (let* ((<transform> (parse-stylesheet-to-stp designator uri-resolver))
576 (instruction-base-uri (stp:base-uri <transform>))
577 (namespaces (acons-namespaces <transform>))
578 (apply-imports-limit (1+ *import-priority*))
579 (continuations '()))
580 (let ((*namespaces* namespaces))
581 (invoke-with-import-magic (constantly t) <transform> env))
582 (do-toplevel (elt "node()" <transform>)
583 (let ((version (stp:attribute-value (stp:parent elt) "version")))
584 (cond
585 ((null version)
586 (xslt-error "stylesheet lacks version"))
587 ((equal version "1.0")
588 (if (typep elt 'stp:element)
589 (when (or (equal (stp:namespace-uri elt) "")
590 (and (equal (stp:namespace-uri elt) *xsl*)
591 (not (find (stp:local-name elt)
592 '("key" "template" "output"
593 "strip-space" "preserve-space"
594 "attribute-set" "namespace-alias"
595 "decimal-format" "variable" "param"
596 "import" "include"
597 ;; for include handling:
598 "stylesheet" "transform")
599 :test #'equal))))
600 (xslt-error "unknown top-level element ~A" (stp:local-name elt)))
601 (xslt-error "text at top-level"))))))
602 (macrolet ((with-specials ((&optional) &body body)
603 `(let ((*instruction-base-uri* instruction-base-uri)
604 (*namespaces* namespaces)
605 (*apply-imports-limit* apply-imports-limit))
606 ,@body)))
607 (with-specials ()
608 (do-toplevel (import "import" <transform>)
609 (let ((uri (puri:merge-uris (or (stp:attribute-value import "href")
610 (xslt-error "import without href"))
611 (stp:base-uri import))))
612 (push (parse-imported-stylesheet env stylesheet uri uri-resolver)
613 continuations))))
614 (let ((import-priority
615 (incf *import-priority*))
616 (var-cont (prepare-global-variables stylesheet <transform>)))
617 ;; delay the rest of compilation until we've seen all global
618 ;; variables:
619 (lambda ()
620 (mapc #'funcall (nreverse continuations))
621 (with-specials ()
622 (let ((*import-priority* import-priority))
623 (funcall var-cont)
624 (parse-keys! stylesheet <transform> env)
625 (parse-templates! stylesheet <transform> env)
626 (parse-output! stylesheet <transform> env)
627 (parse-strip/preserve-space! stylesheet <transform> env)
628 (parse-attribute-sets! stylesheet <transform> env)
629 (parse-namespace-aliases! stylesheet <transform> env)
630 (parse-decimal-formats! stylesheet <transform> env))))))))
632 (defvar *xsl-import-stack* nil)
634 (defun parse-imported-stylesheet (env stylesheet uri uri-resolver)
635 (let* ((uri (if uri-resolver
636 (funcall uri-resolver (puri:render-uri uri nil))
637 uri))
638 (str (puri:render-uri uri nil))
639 (pathname
640 (handler-case
641 (uri-to-pathname uri)
642 (cxml:xml-parse-error (c)
643 (xslt-error "cannot find imported stylesheet ~A: ~A"
644 uri c)))))
645 (with-open-file
646 (stream pathname
647 :element-type '(unsigned-byte 8)
648 :if-does-not-exist nil)
649 (unless stream
650 (xslt-error "cannot find imported stylesheet ~A at ~A"
651 uri pathname))
652 (when (find str *xsl-import-stack* :test #'equal)
653 (xslt-error "recursive inclusion of ~A" uri))
654 (let ((*xsl-import-stack* (cons str *xsl-import-stack*)))
655 (parse-1-stylesheet env stylesheet stream uri-resolver)))))
657 (defvar *included-attribute-sets*)
659 (defun parse-stylesheet (designator &key uri-resolver)
660 (with-resignalled-errors ()
661 (xpath:with-namespaces ((nil #.*xsl*))
662 (let* ((*import-priority* 0)
663 (xpath:*allow-variables-in-patterns* nil)
664 (puri:*strict-parse* nil)
665 (stylesheet (make-stylesheet))
666 (env (make-instance 'lexical-xslt-environment))
667 (*excluded-namespaces* *excluded-namespaces*)
668 (*global-variable-declarations* (make-empty-declaration-array))
669 (*included-attribute-sets* nil))
670 (ensure-mode stylesheet nil)
671 (funcall (parse-1-stylesheet env stylesheet designator uri-resolver))
672 ;; reverse attribute sets:
673 (let ((table (stylesheet-attribute-sets stylesheet)))
674 (maphash (lambda (k v)
675 (setf (gethash k table) (nreverse v)))
676 table))
677 ;; for Errors_err011
678 (dolist (sets *included-attribute-sets*)
679 (loop for (local-name uri nil) in sets do
680 (find-attribute-set local-name uri stylesheet)))
681 ;; add default df
682 (unless (find-decimal-format "" "" stylesheet nil)
683 (setf (find-decimal-format "" "" stylesheet)
684 (make-decimal-format)))
685 ;; compile a template matcher for each mode:
686 (loop
687 for mode being each hash-value in (stylesheet-modes stylesheet)
689 (setf (mode-match-thunk mode)
690 (xpath:make-pattern-matcher
691 (mapcar #'template-compiled-pattern
692 (mode-templates mode)))))
693 ;; and for the strip tests
694 (setf (stylesheet-strip-thunk stylesheet)
695 (let ((patterns (stylesheet-strip-tests stylesheet)))
696 (and patterns
697 (xpath:make-pattern-matcher
698 (mapcar #'strip-test-compiled-pattern patterns)))))
699 stylesheet))))
701 (defun parse-attribute-sets! (stylesheet <transform> env)
702 (do-toplevel (elt "attribute-set" <transform>)
703 (with-import-magic (elt env)
704 (push (let* ((sets
705 (mapcar (lambda (qname)
706 (multiple-value-list (decode-qname qname env nil)))
707 (words
708 (stp:attribute-value elt "use-attribute-sets"))))
709 (instructions
710 (stp:map-children
711 'list
712 (lambda (child)
713 (unless
714 (and (typep child 'stp:element)
715 (or (and (equal (stp:namespace-uri child) *xsl*)
716 (equal (stp:local-name child)
717 "attribute"))
718 (find (stp:namespace-uri child)
719 *extension-namespaces*
720 :test 'equal)))
721 (xslt-error "non-attribute found in attribute set"))
722 (parse-instruction child))
723 elt))
724 (*lexical-variable-declarations*
725 (make-empty-declaration-array))
726 (thunk
727 (compile-instruction `(progn ,@instructions) env))
728 (n-variables (length *lexical-variable-declarations*)))
729 (push sets *included-attribute-sets*)
730 (lambda (ctx)
731 (with-stack-limit ()
732 (loop for (local-name uri nil) in sets do
733 (dolist (thunk (find-attribute-set local-name uri))
734 (funcall thunk ctx)))
735 (let ((*lexical-variable-values*
736 (make-variable-value-array n-variables)))
737 (funcall thunk ctx)))))
738 (gethash (multiple-value-bind (local-name uri)
739 (decode-qname (or (stp:attribute-value elt "name")
740 (xslt-error "missing name"))
742 nil)
743 (cons local-name uri))
744 (stylesheet-attribute-sets stylesheet))))))
746 (defun parse-namespace-aliases! (stylesheet <transform> env)
747 (do-toplevel (elt "namespace-alias" <transform>)
748 (only-with-attributes (stylesheet-prefix result-prefix) elt
749 (unless stylesheet-prefix
750 (xslt-error "missing stylesheet-prefix in namespace-alias"))
751 (unless result-prefix
752 (xslt-error "missing result-prefix in namespace-alias"))
753 (setf (gethash
754 (if (equal stylesheet-prefix "#default")
756 (xpath-sys:environment-find-namespace env stylesheet-prefix))
757 (stylesheet-namespace-aliases stylesheet))
758 (xpath-sys:environment-find-namespace
760 (if (equal result-prefix "#default")
762 result-prefix))))))
764 (defun parse-decimal-formats! (stylesheet <transform> env)
765 (do-toplevel (elt "decimal-format" <transform>)
766 (stp:with-attributes (name
767 ;; strings
768 infinity
769 (nan "NaN")
770 ;; characters:
771 decimal-separator
772 grouping-separator
773 zero-digit
774 percent
775 per-mille
776 digit
777 pattern-separator
778 minus-sign)
780 (multiple-value-bind (local-name uri)
781 (if name
782 (decode-qname name env nil)
783 (values "" ""))
784 (let ((current (find-decimal-format local-name uri stylesheet nil))
785 (new
786 (let ((seen '()))
787 (flet ((chr (key x)
788 (when x
789 (unless (eql (length x) 1)
790 (xslt-error "not a single character: ~A" x))
791 (let ((chr (elt x 0)))
792 (when (find chr seen)
793 (xslt-error
794 "conflicting decimal format characters: ~A"
795 chr))
796 (push chr seen)
797 (list key chr))))
798 (str (key x)
799 (when x
800 (list key x))))
801 (apply #'make-decimal-format
802 (append (str :infinity infinity)
803 (str :nan nan)
804 (chr :decimal-separator decimal-separator)
805 (chr :grouping-separator grouping-separator)
806 (chr :zero-digit zero-digit)
807 (chr :percent percent)
808 (chr :per-mille per-mille)
809 (chr :digit digit)
810 (chr :pattern-separator pattern-separator)
811 (chr :minus-sign minus-sign)))))))
812 (if current
813 (unless (decimal-format= current new)
814 (xslt-error "decimal format mismatch for ~S" local-name))
815 (setf (find-decimal-format local-name uri stylesheet) new)))))))
817 (defun parse-exclude-result-prefixes! (node env)
818 (stp:with-attributes (exclude-result-prefixes)
819 node
820 (dolist (prefix (words (or exclude-result-prefixes "")))
821 (if (equal prefix "#default")
822 (setf prefix nil)
823 (unless (cxml-stp-impl::nc-name-p prefix)
824 (xslt-error "invalid prefix: ~A" prefix)))
825 (push (or (xpath-sys:environment-find-namespace env prefix)
826 (xslt-error "namespace not found: ~A" prefix))
827 *excluded-namespaces*))))
829 (defun parse-extension-element-prefixes! (node env)
830 (stp:with-attributes (extension-element-prefixes)
831 node
832 (dolist (prefix (words (or extension-element-prefixes "")))
833 (if (equal prefix "#default")
834 (setf prefix nil)
835 (unless (cxml-stp-impl::nc-name-p prefix)
836 (xslt-error "invalid prefix: ~A" prefix)))
837 (let ((uri
838 (or (xpath-sys:environment-find-namespace env prefix)
839 (xslt-error "namespace not found: ~A" prefix))))
840 (unless (equal uri *xsl*)
841 (push uri *extension-namespaces*)
842 (push uri *excluded-namespaces*))))))
844 (defun parse-nametest-tokens (str)
845 (labels ((check (boolean)
846 (unless boolean
847 (xslt-error "invalid nametest token")))
848 (check-null (boolean)
849 (check (not boolean))))
850 (cons
851 :patterns
852 (mapcar (lambda (name-test)
853 (destructuring-bind (&optional path &rest junk)
854 (cdr (xpath:parse-pattern-expression name-test))
855 (check-null junk)
856 (check (eq (car path) :path))
857 (destructuring-bind (&optional child &rest junk) (cdr path)
858 (check-null junk)
859 (check (eq (car child) :child))
860 (destructuring-bind (nodetest &rest junk) (cdr child)
861 (check-null junk)
862 (check (or (stringp nodetest)
863 (eq nodetest '*)
864 (and (consp nodetest)
865 (or (eq (car nodetest) :namespace)
866 (eq (car nodetest) :qname)))))))
867 path))
868 (words str)))))
870 (defstruct strip-test
871 compiled-pattern
872 priority
873 position
874 value)
876 (defun parse-strip/preserve-space! (stylesheet <transform> env)
877 (let ((i 0))
878 (do-toplevel (elt "strip-space|preserve-space" <transform>)
879 (let ((*namespaces* (acons-namespaces elt))
880 (value
881 (if (equal (stp:local-name elt) "strip-space")
882 :strip
883 :preserve)))
884 (dolist (expression
885 (cdr (parse-nametest-tokens
886 (stp:attribute-value elt "elements"))))
887 (let* ((compiled-pattern
888 (car (without-xslt-current ()
889 (xpath:compute-patterns
890 `(:patterns ,expression)
891 *import-priority*
892 "will set below"
893 env))))
894 (strip-test
895 (make-strip-test :compiled-pattern compiled-pattern
896 :priority (expression-priority expression)
897 :position i
898 :value value)))
899 (setf (xpath:pattern-value compiled-pattern) strip-test)
900 (push strip-test (stylesheet-strip-tests stylesheet)))))
901 (incf i))))
903 (defstruct (output-specification
904 (:conc-name "OUTPUT-"))
905 method
906 indent
907 omit-xml-declaration
908 encoding
909 doctype-system
910 doctype-public
911 cdata-section-matchers)
913 (defun parse-output! (stylesheet <transform> env)
914 (dolist (<output> (list-toplevel "output" <transform>))
915 (let ((spec (stylesheet-output-specification stylesheet)))
916 (only-with-attributes (version
917 method
918 indent
919 encoding
920 media-type
921 doctype-system
922 doctype-public
923 omit-xml-declaration
924 standalone
925 cdata-section-elements)
926 <output>
927 (declare (ignore version
928 ;; FIXME:
929 media-type
930 standalone))
931 (when method
932 (setf (output-method spec) method))
933 (when indent
934 (setf (output-indent spec) indent))
935 (when encoding
936 (setf (output-encoding spec) encoding))
937 (when doctype-system
938 (setf (output-doctype-system spec) doctype-system))
939 (when doctype-public
940 (setf (output-doctype-public spec) doctype-public))
941 (when omit-xml-declaration
942 (setf (output-omit-xml-declaration spec) omit-xml-declaration))
943 (when cdata-section-elements
944 (dolist (qname (words cdata-section-elements))
945 (decode-qname qname env nil) ;check the syntax
946 (push (xpath:make-pattern-matcher* qname env)
947 (output-cdata-section-matchers spec))))))))
949 (defun make-empty-declaration-array ()
950 (make-array 1 :fill-pointer 0 :adjustable t))
952 (defun make-variable-value-array (n-lexical-variables)
953 (make-array n-lexical-variables :initial-element 'unbound))
955 (defun compile-global-variable (<variable> env) ;; also for <param>
956 (stp:with-attributes (name select) <variable>
957 (when (and select (stp:list-children <variable>))
958 (xslt-error "variable with select and body"))
959 (let* ((*lexical-variable-declarations* (make-empty-declaration-array))
960 (inner (cond
961 (select
962 (compile-xpath select env))
963 ((stp:list-children <variable>)
964 (let* ((inner-sexpr `(progn ,@(parse-body <variable>)))
965 (inner-thunk (compile-instruction inner-sexpr env)))
966 (lambda (ctx)
967 (apply-to-result-tree-fragment ctx inner-thunk))))
969 (lambda (ctx)
970 (declare (ignore ctx))
971 ""))))
972 (n-lexical-variables (length *lexical-variable-declarations*)))
973 (xslt-trace-thunk
974 (lambda (ctx)
975 (let* ((*lexical-variable-values*
976 (make-variable-value-array n-lexical-variables)))
977 (funcall inner ctx)))
978 "global ~s (~s) = ~s" name select :result))))
980 (defstruct (variable-chain
981 (:constructor make-variable-chain)
982 (:conc-name "VARIABLE-CHAIN-"))
983 definitions
984 index
985 local-name
986 thunk
987 uri)
989 (defstruct (import-variable
990 (:constructor make-variable)
991 (:conc-name "VARIABLE-"))
992 value-thunk
993 value-thunk-setter
994 param-p)
996 (defun parse-global-variable! (stylesheet <variable> global-env)
997 (let* ((*namespaces* (acons-namespaces <variable>))
998 (instruction-base-uri (stp:base-uri <variable>))
999 (*instruction-base-uri* instruction-base-uri)
1000 (*excluded-namespaces* (list *xsl*))
1001 (*extension-namespaces* '())
1002 (qname (stp:attribute-value <variable> "name")))
1003 (with-import-magic (<variable> global-env)
1004 (unless qname
1005 (xslt-error "name missing in ~A" (stp:local-name <variable>)))
1006 (multiple-value-bind (local-name uri)
1007 (decode-qname qname global-env nil)
1008 ;; For the normal compilation environment of templates, install it
1009 ;; into *GLOBAL-VARIABLE-DECLARATIONS*:
1010 (let ((index (intern-global-variable local-name uri)))
1011 ;; For the evaluation of a global variable itself, build a thunk
1012 ;; that lazily resolves other variables, stored into
1013 ;; INITIAL-GLOBAL-VARIABLE-THUNKS:
1014 (let* ((value-thunk :unknown)
1015 (sgv (stylesheet-global-variables stylesheet))
1016 (chain
1017 (if (< index (length sgv))
1018 (elt sgv index)
1019 (make-variable-chain
1020 :index index
1021 :local-name local-name
1022 :uri uri)))
1023 (next (car (variable-chain-definitions chain)))
1024 (global-variable-thunk
1025 (lambda (ctx)
1026 (let ((v (global-variable-value index nil)))
1027 (cond
1028 ((eq v 'seen)
1029 (unless next
1030 (xslt-error "no next definition for: ~A"
1031 local-name))
1032 (funcall (variable-value-thunk next) ctx))
1033 ((eq v 'unbound)
1034 (setf (global-variable-value index) 'seen)
1035 (setf (global-variable-value index)
1036 (funcall value-thunk ctx)))
1038 v)))))
1039 (excluded-namespaces *excluded-namespaces*)
1040 (extension-namespaces *extension-namespaces*)
1041 (variable
1042 (make-variable :param-p (namep <variable> "param")))
1043 (value-thunk-setter
1044 (lambda ()
1045 (let* ((*instruction-base-uri* instruction-base-uri)
1046 (*excluded-namespaces* excluded-namespaces)
1047 (*extension-namespaces* extension-namespaces)
1049 (compile-global-variable <variable> global-env)))
1050 (setf value-thunk fn)
1051 (setf (variable-value-thunk variable) fn)))))
1052 (setf (variable-value-thunk-setter variable)
1053 value-thunk-setter)
1054 (setf (gethash (cons local-name uri)
1055 (initial-global-variable-thunks global-env))
1056 global-variable-thunk)
1057 (setf (variable-chain-thunk chain) global-variable-thunk)
1058 (push variable (variable-chain-definitions chain))
1059 chain))))))
1061 (defun parse-keys! (stylesheet <transform> env)
1062 (xpath:with-namespaces ((nil #.*xsl*))
1063 (do-toplevel (<key> "key" <transform>)
1064 (let ((*instruction-base-uri* (stp:base-uri <key>)))
1065 (stp:with-attributes (name match use) <key>
1066 (unless name (xslt-error "key name attribute not specified"))
1067 (unless match (xslt-error "key match attribute not specified"))
1068 (unless use (xslt-error "key use attribute not specified"))
1069 (multiple-value-bind (local-name uri)
1070 (decode-qname name env nil)
1071 (add-key stylesheet
1072 (cons local-name uri)
1073 (compile-xpath `(xpath:xpath ,(parse-key-pattern match))
1074 env)
1075 (compile-xpath use
1076 (make-instance 'key-environment)))))))))
1078 (defun prepare-global-variables (stylesheet <transform>)
1079 (xpath:with-namespaces ((nil #.*xsl*))
1080 (let* ((igvt (stylesheet-initial-global-variable-thunks stylesheet))
1081 (global-env (make-instance 'global-variable-environment
1082 :initial-global-variable-thunks igvt))
1083 (chains '()))
1084 (do-toplevel (<variable> "variable|param" <transform>)
1085 (let ((chain
1086 (parse-global-variable! stylesheet <variable> global-env)))
1087 (xslt-trace "parsing global variable ~s (uri ~s)"
1088 (variable-chain-local-name chain)
1089 (variable-chain-uri chain))
1090 (when (find chain
1091 chains
1092 :test (lambda (a b)
1093 (and (equal (variable-chain-local-name a)
1094 (variable-chain-local-name b))
1095 (equal (variable-chain-uri a)
1096 (variable-chain-uri b)))))
1097 (xslt-error "duplicate definition for global variable ~A"
1098 (variable-chain-local-name chain)))
1099 (push chain chains)))
1100 (setf chains (nreverse chains))
1101 (let ((table (stylesheet-global-variables stylesheet))
1102 (newlen (length *global-variable-declarations*)))
1103 (adjust-array table newlen :fill-pointer newlen)
1104 (dolist (chain chains)
1105 (setf (elt table (variable-chain-index chain)) chain)))
1106 (lambda ()
1107 ;; now that the global environment knows about all variables, run the
1108 ;; thunk setters to perform their compilation
1109 (mapc (lambda (chain)
1110 (dolist (var (variable-chain-definitions chain))
1111 (funcall (variable-value-thunk-setter var))))
1112 chains)))))
1114 (defun parse-templates! (stylesheet <transform> env)
1115 (let ((i 0))
1116 (do-toplevel (<template> "template" <transform>)
1117 (let ((*namespaces* (acons-namespaces <template>))
1118 (*instruction-base-uri* (stp:base-uri <template>)))
1119 (with-import-magic (<template> env)
1120 (dolist (template (compile-template <template> env i))
1121 (let ((name (template-name template)))
1122 (if name
1123 (let* ((table (stylesheet-named-templates stylesheet))
1124 (head (car (gethash name table))))
1125 (when (and head (eql (template-import-priority head)
1126 (template-import-priority template)))
1127 ;; fixme: is this supposed to be a run-time error?
1128 (xslt-error "conflicting templates for ~A" name))
1129 (push template (gethash name table)))
1130 (let ((mode (ensure-mode/qname stylesheet
1131 (template-mode-qname template)
1132 env)))
1133 (setf (template-mode template) mode)
1134 (push template (mode-templates mode))))))))
1135 (incf i))))
1138 ;;;; APPLY-STYLESHEET
1140 (defvar *stylesheet*)
1142 (deftype xml-designator () '(or runes:xstream runes:rod array stream pathname))
1144 (defun unalias-uri (uri)
1145 (let ((result
1146 (gethash uri (stylesheet-namespace-aliases *stylesheet*)
1147 uri)))
1148 (check-type result string)
1149 result))
1151 (defstruct (parameter
1152 (:constructor make-parameter (value local-name &optional uri)))
1153 (uri "")
1154 local-name
1155 value)
1157 (defun find-parameter-value (local-name uri parameters)
1158 (dolist (p parameters)
1159 (when (and (equal (parameter-local-name p) local-name)
1160 (equal (parameter-uri p) uri))
1161 (return (parameter-value p)))))
1163 (defvar *uri-resolver*)
1165 (defun parse-allowing-microsoft-bom (pathname handler)
1166 (with-open-file (s pathname :element-type '(unsigned-byte 8))
1167 (unless (and (eql (read-byte s nil) #xef)
1168 (eql (read-byte s nil) #xbb)
1169 (eql (read-byte s nil) #xbf))
1170 (file-position s 0))
1171 (cxml:parse s handler)))
1173 (defvar *documents*)
1175 (defun %document (uri-string base-uri)
1176 (let* ((absolute-uri
1177 (puri:merge-uris uri-string (or base-uri "")))
1178 (resolved-uri
1179 (if *uri-resolver*
1180 (funcall *uri-resolver* (puri:render-uri absolute-uri nil))
1181 absolute-uri))
1182 (pathname
1183 (handler-case
1184 (uri-to-pathname resolved-uri)
1185 (cxml:xml-parse-error (c)
1186 (xslt-error "cannot find referenced document ~A: ~A"
1187 resolved-uri c))))
1188 (xpath-root-node
1189 (or (gethash pathname *documents*)
1190 (setf (gethash pathname *documents*)
1191 (make-whitespace-stripper
1192 (handler-case
1193 (parse-allowing-microsoft-bom pathname
1194 (stp:make-builder))
1195 ((or file-error cxml:xml-parse-error) (c)
1196 (xslt-error "cannot parse referenced document ~A: ~A"
1197 pathname c)))
1198 (stylesheet-strip-thunk *stylesheet*))))))
1199 (when (puri:uri-fragment absolute-uri)
1200 (xslt-error "use of fragment identifiers in document() not supported"))
1201 xpath-root-node))
1203 (xpath-sys:define-extension xslt *xsl*)
1205 (defun document-base-uri (node)
1206 (xpath-protocol:base-uri
1207 (cond
1208 ((xpath-protocol:node-type-p node :document)
1209 (xpath::find-in-pipe-if
1210 (lambda (x)
1211 (xpath-protocol:node-type-p x :element))
1212 (xpath-protocol:child-pipe node)))
1213 ((xpath-protocol:node-type-p node :element)
1214 node)
1216 (xpath-protocol:parent-node node)))))
1218 (xpath-sys:define-xpath-function/lazy
1219 xslt :document
1220 (object &optional node-set)
1221 (let ((instruction-base-uri *instruction-base-uri*))
1222 (lambda (ctx)
1223 (let* ((object (funcall object ctx))
1224 (node-set (and node-set (funcall node-set ctx)))
1225 (base-uri
1226 (if node-set
1227 (document-base-uri (xpath::textually-first-node node-set))
1228 instruction-base-uri)))
1229 (xpath-sys:make-node-set
1230 (if (xpath:node-set-p object)
1231 (xpath:map-node-set->list
1232 (lambda (node)
1233 (%document (xpath:string-value node)
1234 (if node-set
1235 base-uri
1236 (document-base-uri node))))
1237 object)
1238 (list (%document (xpath:string-value object) base-uri))))))))
1240 (xpath-sys:define-xpath-function/lazy xslt :key (name object)
1241 (let ((namespaces *namespaces*))
1242 (lambda (ctx)
1243 (let* ((qname (xpath:string-value (funcall name ctx)))
1244 (object (funcall object ctx))
1245 (expanded-name
1246 (multiple-value-bind (local-name uri)
1247 (decode-qname/runtime qname namespaces nil)
1248 (cons local-name uri)))
1249 (key (find-key expanded-name *stylesheet*)))
1250 (labels ((get-by-key (value)
1251 (let ((value (xpath:string-value value)))
1252 (xpath::filter-pipe
1253 #'(lambda (node)
1254 (let ((uses
1255 (xpath:evaluate-compiled (key-use key) node)))
1256 (if (xpath:node-set-p uses)
1257 (xpath::find-in-pipe
1258 value
1259 (xpath-sys:pipe-of uses)
1260 :key #'xpath:string-value
1261 :test #'equal)
1262 (equal value (xpath:string-value uses)))))
1263 (xpath-sys:pipe-of
1264 (xpath:node-set-value
1265 (xpath:evaluate-compiled (key-match key) ctx)))))))
1266 (xpath-sys:make-node-set
1267 (xpath::sort-pipe
1268 (if (xpath:node-set-p object)
1269 (xpath::mappend-pipe #'get-by-key (xpath-sys:pipe-of object))
1270 (get-by-key object)))))))))
1272 ;; FIXME: add alias mechanism for XPath extensions in order to avoid duplication
1274 (xpath-sys:define-xpath-function/lazy xslt :current ()
1275 (when *without-xslt-current-p*
1276 (xslt-error "current() not allowed here"))
1277 #'(lambda (ctx)
1278 (xpath-sys:make-node-set
1279 (xpath-sys:make-pipe
1280 (xpath:context-starting-node ctx)
1281 nil))))
1283 (xpath-sys:define-xpath-function/lazy xslt :unparsed-entity-uri (name)
1284 #'(lambda (ctx)
1285 (or (xpath-protocol:unparsed-entity-uri (xpath:context-node ctx)
1286 (funcall name ctx))
1287 "")))
1289 (defun %get-node-id (node)
1290 (when (xpath:node-set-p node)
1291 (setf node (xpath::textually-first-node node)))
1292 (when node
1293 (let ((id (xpath-sys:get-node-id node))
1294 (highest-base-uri
1295 (loop
1296 for parent = node then next
1297 for next = (xpath-protocol:parent-node parent)
1298 for this-base-uri = (xpath-protocol:base-uri parent)
1299 for highest-base-uri = (if (plusp (length this-base-uri))
1300 this-base-uri
1301 highest-base-uri)
1302 while next
1303 finally (return highest-base-uri))))
1304 ;; Heuristic: Reverse it so that the /home/david/alwaysthesame prefix is
1305 ;; checked only if everything else matches.
1307 ;; This might be pointless premature optimization, but I like the idea :-)
1308 (nreverse (concatenate 'string highest-base-uri "//" id)))))
1310 (xpath-sys:define-xpath-function/lazy xslt :generate-id (&optional node-set-thunk)
1311 (if node-set-thunk
1312 #'(lambda (ctx)
1313 (%get-node-id (xpath:node-set-value (funcall node-set-thunk ctx))))
1314 #'(lambda (ctx)
1315 (%get-node-id (xpath:context-node ctx)))))
1317 (declaim (special *available-instructions*))
1319 (xpath-sys:define-xpath-function/lazy xslt :element-available (qname)
1320 (let ((namespaces *namespaces*))
1321 #'(lambda (ctx)
1322 (let ((qname (funcall qname ctx)))
1323 (multiple-value-bind (local-name uri)
1324 (decode-qname/runtime qname namespaces nil)
1325 (and (equal uri *xsl*)
1326 (gethash local-name *available-instructions*)
1327 t))))))
1329 (xpath-sys:define-xpath-function/lazy xslt :function-available (qname)
1330 (let ((namespaces *namespaces*))
1331 #'(lambda (ctx)
1332 (let ((qname (funcall qname ctx)))
1333 (multiple-value-bind (local-name uri)
1334 (decode-qname/runtime qname namespaces nil)
1335 (and (zerop (length uri))
1336 (or (xpath-sys:find-xpath-function local-name *xsl*)
1337 (xpath-sys:find-xpath-function local-name uri))
1338 t))))))
1340 (xpath-sys:define-xpath-function/lazy xslt :system-property (qname)
1341 (let ((namespaces *namespaces*))
1342 (lambda (ctx)
1343 (let ((qname (funcall qname ctx)))
1344 (multiple-value-bind (local-name uri)
1345 (decode-qname/runtime qname namespaces nil)
1346 (if (equal uri *xsl*)
1347 (cond
1348 ((equal local-name "version")
1349 "1")
1350 ((equal local-name "vendor")
1351 "Xuriella")
1352 ((equal local-name "vendor-uri")
1353 "http://repo.or.cz/w/xuriella.git")
1355 ""))
1356 ""))))))
1358 (defun apply-stylesheet
1359 (stylesheet source-designator
1360 &key output parameters uri-resolver navigator)
1361 (when (typep stylesheet 'xml-designator)
1362 (setf stylesheet
1363 (handler-bind
1364 ((cxml:xml-parse-error
1365 (lambda (c)
1366 (xslt-error "cannot parse stylesheet: ~A" c))))
1367 (parse-stylesheet stylesheet))))
1368 (with-resignalled-errors ()
1369 (invoke-with-output-sink
1370 (lambda ()
1371 (let* ((*documents* (make-hash-table :test 'equal))
1372 (xpath:*navigator* (or navigator :default-navigator))
1373 (puri:*strict-parse* nil)
1374 (*stylesheet* stylesheet)
1375 (*empty-mode* (make-mode))
1376 (*default-mode* (find-mode stylesheet nil))
1377 (global-variable-chains
1378 (stylesheet-global-variables stylesheet))
1379 (*global-variable-values*
1380 (make-variable-value-array (length global-variable-chains)))
1381 (*uri-resolver* uri-resolver)
1382 (source-document
1383 (if (typep source-designator 'xml-designator)
1384 (cxml:parse source-designator (stp:make-builder))
1385 source-designator))
1386 (xpath-root-node
1387 (make-whitespace-stripper
1388 source-document
1389 (stylesheet-strip-thunk stylesheet)))
1390 (ctx (xpath:make-context xpath-root-node)))
1391 (when (pathnamep source-designator)
1392 (setf (gethash source-designator *documents*) xpath-root-node))
1393 (map nil
1394 (lambda (chain)
1395 (let ((head (car (variable-chain-definitions chain))))
1396 (when (variable-param-p head)
1397 (let ((value
1398 (find-parameter-value
1399 (variable-chain-local-name chain)
1400 (variable-chain-uri chain)
1401 parameters)))
1402 (when value
1403 (setf (global-variable-value
1404 (variable-chain-index chain))
1405 value))))))
1406 global-variable-chains)
1407 (map nil
1408 (lambda (chain)
1409 (funcall (variable-chain-thunk chain) ctx))
1410 global-variable-chains)
1411 ;; zzz we wouldn't have to mask float traps here if we used the
1412 ;; XPath API properly. Unfortunately I've been using FUNCALL
1413 ;; everywhere instead of EVALUATE, so let's paper over that
1414 ;; at a central place to be sure:
1415 (xpath::with-float-traps-masked ()
1416 (apply-templates ctx :mode *default-mode*))))
1417 (stylesheet-output-specification stylesheet)
1418 output)))
1420 (defun find-attribute-set (local-name uri &optional (stylesheet *stylesheet*))
1421 (or (gethash (cons local-name uri) (stylesheet-attribute-sets stylesheet))
1422 (xslt-error "no such attribute set: ~A/~A" local-name uri)))
1424 (defun apply-templates/list (list &key param-bindings sort-predicate mode)
1425 (when sort-predicate
1426 (setf list
1427 (mapcar #'xpath:context-node
1428 (stable-sort (contextify-node-list list)
1429 sort-predicate))))
1430 (let* ((n (length list))
1431 (s/d (lambda () n)))
1432 (loop
1433 for i from 1
1434 for child in list
1436 (apply-templates (xpath:make-context child s/d i)
1437 :param-bindings param-bindings
1438 :mode mode))))
1440 (defvar *stack-limit* 200)
1442 (defun invoke-with-stack-limit (fn)
1443 (let ((*stack-limit* (1- *stack-limit*)))
1444 (unless (plusp *stack-limit*)
1445 (xslt-error "*stack-limit* reached; stack overflow"))
1446 (funcall fn)))
1448 (defun invoke-template (ctx template param-bindings)
1449 (let ((*lexical-variable-values*
1450 (make-variable-value-array (template-n-variables template))))
1451 (with-stack-limit ()
1452 (loop
1453 for (name-cons value) in param-bindings
1454 for (nil index nil) = (find name-cons
1455 (template-params template)
1456 :test #'equal
1457 :key #'car)
1459 (when index
1460 (setf (lexical-variable-value index) value)))
1461 (funcall (template-body template) ctx))))
1463 (defun apply-default-templates (ctx mode)
1464 (let ((node (xpath:context-node ctx)))
1465 (cond
1466 ((or (xpath-protocol:node-type-p node :processing-instruction)
1467 (xpath-protocol:node-type-p node :comment)))
1468 ((or (xpath-protocol:node-type-p node :text)
1469 (xpath-protocol:node-type-p node :attribute))
1470 (write-text (xpath-protocol:node-text node)))
1472 (apply-templates/list
1473 (xpath::force
1474 (xpath-protocol:child-pipe node))
1475 :mode mode)))))
1477 (defvar *apply-imports*)
1479 (defun apply-applicable-templates (ctx templates param-bindings finally)
1480 (labels ((apply-imports (&optional actual-param-bindings)
1481 (if templates
1482 (let* ((this (pop templates))
1483 (low (template-apply-imports-limit this))
1484 (high (template-import-priority this)))
1485 (setf templates
1486 (remove-if-not
1487 (lambda (x)
1488 (<= low (template-import-priority x) high))
1489 templates))
1490 (invoke-template ctx this actual-param-bindings))
1491 (funcall finally))))
1492 (let ((*apply-imports* #'apply-imports))
1493 (apply-imports param-bindings))))
1495 (defun apply-templates (ctx &key param-bindings mode)
1496 (apply-applicable-templates ctx
1497 (find-templates ctx (or mode *default-mode*))
1498 param-bindings
1499 (lambda ()
1500 (apply-default-templates ctx mode))))
1502 (defun call-template (ctx name &optional param-bindings)
1503 (apply-applicable-templates ctx
1504 (find-named-templates name)
1505 param-bindings
1506 (lambda ()
1507 (xslt-error "cannot find named template: ~s"
1508 name))))
1510 (defun find-templates (ctx mode)
1511 (let* ((matching-candidates
1512 (xpath:matching-values (mode-match-thunk mode)
1513 (xpath:context-node ctx)))
1514 (npriorities
1515 (if matching-candidates
1516 (1+ (reduce #'max
1517 matching-candidates
1518 :key #'template-import-priority))
1520 (priority-groups (make-array npriorities :initial-element nil)))
1521 (dolist (template matching-candidates)
1522 (push template
1523 (elt priority-groups (template-import-priority template))))
1524 (loop
1525 for i from (1- npriorities) downto 0
1526 for group = (elt priority-groups i)
1527 for template = (maximize #'template< group)
1528 when template
1529 collect template)))
1531 (defun find-named-templates (name)
1532 (gethash name (stylesheet-named-templates *stylesheet*)))
1534 (defun template< (a b) ;assuming same import priority
1535 (let ((p (template-priority a))
1536 (q (template-priority b)))
1537 (cond
1538 ((< p q) t)
1539 ((> p q) nil)
1541 (xslt-cerror "conflicting templates:~_~A,~_~A"
1542 (template-match-expression a)
1543 (template-match-expression b))
1544 (< (template-position a) (template-position b))))))
1546 (defun maximize (< things)
1547 (when things
1548 (let ((max (car things)))
1549 (dolist (other (cdr things))
1550 (when (funcall < max other)
1551 (setf max other)))
1552 max)))
1554 (defun invoke-with-output-sink (fn output-spec output)
1555 (etypecase output
1556 (pathname
1557 (with-open-file (s output
1558 :direction :output
1559 :element-type '(unsigned-byte 8)
1560 :if-exists :rename-and-delete)
1561 (invoke-with-output-sink fn output-spec s)))
1562 ((or stream null)
1563 (invoke-with-output-sink fn
1564 output-spec
1565 (make-output-sink output-spec output)))
1566 ((or hax:abstract-handler sax:abstract-handler)
1567 (with-xml-output output
1568 (when (typep output '(or combi-sink auto-detect-sink))
1569 (sax:start-dtd output
1570 :autodetect-me-please
1571 (output-doctype-public output-spec)
1572 (output-doctype-system output-spec)))
1573 (funcall fn)))))
1575 (defun make-output-sink (output-spec stream)
1576 (let* ((ystream
1577 (if stream
1578 (let ((et (stream-element-type stream)))
1579 (cond
1580 ((or (null et) (subtypep et '(unsigned-byte 8)))
1581 (runes:make-octet-stream-ystream stream))
1582 ((subtypep et 'character)
1583 (runes:make-character-stream-ystream stream))))
1584 (runes:make-rod-ystream)))
1585 (omit-xml-declaration-p
1586 (boolean-or-error (output-omit-xml-declaration output-spec)))
1587 (sink-encoding (or (output-encoding output-spec) "UTF-8"))
1588 (sax-target
1589 (progn
1590 (setf (runes:ystream-encoding ystream)
1591 (cxml::find-output-encoding sink-encoding))
1592 (make-instance 'cxml::sink
1593 :ystream ystream
1594 :omit-xml-declaration-p omit-xml-declaration-p
1595 :encoding sink-encoding))))
1596 (flet ((make-combi-sink ()
1597 (make-instance 'combi-sink
1598 :hax-target (make-instance 'chtml::sink
1599 :ystream ystream)
1600 :sax-target sax-target
1601 :encoding sink-encoding)))
1602 (let ((method-key
1603 (cond
1604 ((equalp (output-method output-spec) "HTML") :html)
1605 ((equalp (output-method output-spec) "TEXT") :text)
1606 ((equalp (output-method output-spec) "XML") :xml)
1607 (t nil))))
1608 (cond
1609 ((and (eq method-key :html)
1610 (null (output-doctype-system output-spec))
1611 (null (output-doctype-public output-spec)))
1612 (make-combi-sink))
1613 ((eq method-key :text)
1614 (make-text-filter sax-target))
1615 ((and (eq method-key :xml)
1616 (null (output-doctype-system output-spec)))
1617 sax-target)
1619 (make-auto-detect-sink (make-combi-sink) method-key)))))))
1621 (defstruct template
1622 match-expression
1623 compiled-pattern
1624 name
1625 import-priority
1626 apply-imports-limit
1627 priority
1628 position
1629 mode
1630 mode-qname
1631 params
1632 body
1633 n-variables)
1635 (defun expression-priority (form)
1636 (let ((step (second form)))
1637 (if (and (null (cddr form))
1638 (listp step)
1639 (member (car step) '(:child :attribute))
1640 (null (cddr step)))
1641 (let ((name (second step)))
1642 (cond
1643 ((or (stringp name)
1644 (and (consp name)
1645 (or (eq (car name) :qname)
1646 (eq (car name) :processing-instruction))))
1647 0.0)
1648 ((and (consp name)
1649 (or (eq (car name) :namespace)
1650 (eq (car name) '*)))
1651 -0.25)
1653 -0.5)))
1654 0.5)))
1656 (defun parse-xpath (str)
1657 (with-resignalled-errors ()
1658 (xpath:parse-xpath str)))
1660 (defun parse-key-pattern (str)
1661 (let ((parsed
1662 (mapcar #'(lambda (item)
1663 `(:path (:root :node)
1664 (:descendant-or-self *)
1665 ,@(cdr item)))
1666 (parse-pattern str))))
1667 (if (null (rest parsed))
1668 (first parsed)
1669 `(:union ,@parsed))))
1671 (defun parse-pattern (str)
1672 (with-resignalled-errors ()
1673 (cdr (xpath::parse-pattern-expression str))))
1675 (defun compile-value-thunk (value env)
1676 (if (and (listp value) (eq (car value) 'progn))
1677 (let ((inner-thunk (compile-instruction value env)))
1678 (lambda (ctx)
1679 (apply-to-result-tree-fragment ctx inner-thunk)))
1680 (compile-xpath value env)))
1682 (defun compile-var-binding (name value env)
1683 (multiple-value-bind (local-name uri)
1684 (decode-qname name env nil)
1685 (let ((thunk (xslt-trace-thunk
1686 (compile-value-thunk value env)
1687 "local variable ~s = ~s" name :result)))
1688 (list (cons local-name uri)
1689 (push-variable local-name
1691 *lexical-variable-declarations*)
1692 thunk))))
1694 (defun compile-var-bindings (forms env)
1695 (loop
1696 for (name value) in forms
1697 collect (compile-var-binding name value env)))
1699 (defun compile-template (<template> env position)
1700 (stp:with-attributes (match name priority mode) <template>
1701 (unless (or name match)
1702 (xslt-error "missing match in template"))
1703 (multiple-value-bind (params body-pos)
1704 (loop
1705 for i from 0
1706 for child in (stp:list-children <template>)
1707 while (namep child "param")
1708 collect (parse-param child) into params
1709 finally (return (values params i)))
1710 (let* ((*lexical-variable-declarations* (make-empty-declaration-array))
1711 (param-bindings (compile-var-bindings params env))
1712 (body (parse-body <template> body-pos (mapcar #'car params)))
1713 (body-thunk (compile-instruction `(progn ,@body) env))
1714 (outer-body-thunk
1715 (xslt-trace-thunk
1716 #'(lambda (ctx)
1717 (unwind-protect
1718 (progn
1719 ;; set params that weren't initialized by apply-templates
1720 (loop for (name index param-thunk) in param-bindings
1721 when (eq (lexical-variable-value index nil) 'unbound)
1722 do (setf (lexical-variable-value index)
1723 (funcall param-thunk ctx)))
1724 (funcall body-thunk ctx))))
1725 "template: match = ~s name = ~s" match name))
1726 (n-variables (length *lexical-variable-declarations*)))
1727 (append
1728 (when name
1729 (multiple-value-bind (local-name uri)
1730 (decode-qname name env nil)
1731 (list
1732 (make-template :name (cons local-name uri)
1733 :import-priority *import-priority*
1734 :apply-imports-limit *apply-imports-limit*
1735 :params param-bindings
1736 :body outer-body-thunk
1737 :n-variables n-variables))))
1738 (when match
1739 (mapcar (lambda (expression)
1740 (let* ((compiled-pattern
1741 (xslt-trace-thunk
1742 (car (without-xslt-current ()
1743 (xpath:compute-patterns
1744 `(:patterns ,expression)
1746 :dummy
1747 env)))
1748 "match-thunk for template (match ~s): ~s --> ~s"
1749 match expression :result))
1750 (p (if priority
1751 (xpath::parse-xnum priority)
1752 (expression-priority expression)))
1754 (progn
1755 (unless (and (numberp p)
1756 (not (xpath::inf-p p))
1757 (not (xpath::nan-p p)))
1758 (xslt-error "failed to parse priority"))
1759 (float p 1.0d0)))
1760 (template
1761 (make-template :match-expression expression
1762 :compiled-pattern compiled-pattern
1763 :import-priority *import-priority*
1764 :apply-imports-limit *apply-imports-limit*
1765 :priority p
1766 :position position
1767 :mode-qname mode
1768 :params param-bindings
1769 :body outer-body-thunk
1770 :n-variables n-variables)))
1771 (setf (xpath:pattern-value compiled-pattern)
1772 template)
1773 template))
1774 (cdr (xpath:parse-pattern-expression match)))))))))
1775 #+(or)
1776 (xuriella::parse-stylesheet #p"/home/david/src/lisp/xuriella/test.xsl")