Fixed non-strings in format-number
[xuriella.git] / xslt.lisp
bloba6192baf4d850f0649ec29c9927bc116c806320f
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 (defmacro with-forward-compatible-errors (error-form &body body)
103 `(invoke-with-forward-compatible-errors (lambda () ,@body)
104 (lambda () ,error-form)))
106 (defun invoke-with-forward-compatible-errors (fn error-fn)
107 (let ((result))
108 (tagbody
109 (handler-bind
110 ((xpath:xpath-error
111 (lambda (c)
112 (declare (ignore c))
113 (when *forwards-compatible-p*
114 (go error)))))
115 (setf result (funcall fn)))
116 (go done)
117 error
118 (setf result (funcall error-fn))
119 done)
120 result))
122 (defun compile-xpath (xpath &optional env)
123 (with-resignalled-errors ()
124 (with-forward-compatible-errors
125 (lambda (ctx)
126 (xslt-error "attempt to evaluate an XPath expression with compile-time errors, delayed due to forwards compatible processing: ~A"
127 xpath))
128 (xpath:compile-xpath xpath env))))
130 (defmacro with-stack-limit ((&optional) &body body)
131 `(invoke-with-stack-limit (lambda () ,@body)))
133 (defparameter *without-xslt-current-p* nil)
135 (defmacro without-xslt-current ((&optional) &body body)
136 `(invoke-without-xslt-current (lambda () ,@body)))
138 (defun invoke-without-xslt-current (fn)
139 (let ((*without-xslt-current-p* t))
140 (funcall fn)))
142 ;;; (defun invoke-without-xslt-current (fn)
143 ;;; (let ((non-extensions (gethash "" xpath::*extensions*))
144 ;;; (xpath::*extensions*
145 ;;; ;; hide XSLT extensions
146 ;;; (make-hash-table :test #'equal)))
147 ;;; (setf (gethash "" xpath::*extensions*) non-extensions)
148 ;;; (funcall fn)))
151 ;;;; Helper functions and macros
153 (defun check-for-invalid-attributes (valid-names node)
154 (labels ((check-attribute (a)
155 (unless
156 (let ((uri (stp:namespace-uri a)))
157 (or (and (plusp (length uri)) (not (equal uri *xsl*)))
158 (find (cons (stp:local-name a) uri)
159 valid-names
160 :test #'equal)))
161 (xslt-error "attribute ~A not allowed on ~A"
162 (stp:local-name a)
163 (stp:local-name node)))))
164 (stp:map-attributes nil #'check-attribute node)))
166 (defmacro only-with-attributes ((&rest specs) node &body body)
167 (let ((valid-names
168 (mapcar (lambda (entry)
169 (if (and (listp entry) (cdr entry))
170 (destructuring-bind (name &optional (uri ""))
171 (cdr entry)
172 (cons name uri))
173 (cons (string-downcase
174 (princ-to-string
175 (symbol-name entry)))
176 "")))
177 specs))
178 (%node (gensym)))
179 `(let ((,%NODE ,node))
180 (check-for-invalid-attributes ',valid-names ,%NODE)
181 (stp:with-attributes ,specs ,%NODE
182 ,@body))))
184 (defun map-pipe-eagerly (fn pipe)
185 (xpath::enumerate pipe :key fn :result nil))
187 (defmacro do-pipe ((var pipe &optional result) &body body)
188 `(block nil
189 (map-pipe-eagerly #'(lambda (,var) ,@body) ,pipe)
190 ,result))
193 ;;;; XSLT-ENVIRONMENT and XSLT-CONTEXT
195 (defparameter *initial-namespaces*
196 '((nil . "")
197 ("xmlns" . #"http://www.w3.org/2000/xmlns/")
198 ("xml" . #"http://www.w3.org/XML/1998/namespace")))
200 (defparameter *namespaces*
201 *initial-namespaces*)
203 (defvar *global-variable-declarations*)
204 (defvar *lexical-variable-declarations*)
206 (defvar *global-variable-values*)
207 (defvar *lexical-variable-values*)
209 (defclass xslt-environment () ())
211 (defun split-qname (str)
212 (handler-case
213 (multiple-value-bind (prefix local-name)
214 (cxml::split-qname str)
215 (unless
216 ;; FIXME: cxml should really offer a function that does
217 ;; checks for NCName and QName in a sensible way for user code.
218 ;; cxml::split-qname is tailored to the needs of the parser.
220 ;; For now, let's just check the syntax explicitly.
221 (and (or (null prefix) (xpath::nc-name-p prefix))
222 (xpath::nc-name-p local-name))
223 (xslt-error "not a qname: ~A" str))
224 (values prefix local-name))
225 (cxml:well-formedness-violation ()
226 (xslt-error "not a qname: ~A" str))))
228 (defun decode-qname (qname env attributep &key allow-unknown-namespace)
229 (unless qname
230 (xslt-error "missing name"))
231 (multiple-value-bind (prefix local-name)
232 (split-qname qname)
233 (values local-name
234 (if (or prefix (not attributep))
235 (or (xpath-sys:environment-find-namespace env (or prefix ""))
236 (if allow-unknown-namespace
238 (xslt-error "namespace not found: ~A" prefix)))
240 prefix)))
242 (defmethod xpath-sys:environment-find-namespace ((env xslt-environment) prefix)
243 (or (cdr (assoc prefix *namespaces* :test 'equal))
244 ;; zzz gross hack.
245 ;; Change the entire code base to represent "no prefix" as the
246 ;; empty string consistently. unparse.lisp has already been changed.
247 (and (equal prefix "")
248 (cdr (assoc nil *namespaces* :test 'equal)))
249 (and (eql prefix nil)
250 (cdr (assoc "" *namespaces* :test 'equal)))))
252 (defun find-variable-index (local-name uri table)
253 (position (cons local-name uri) table :test 'equal))
255 (defun intern-global-variable (local-name uri)
256 (or (find-variable-index local-name uri *global-variable-declarations*)
257 (push-variable local-name uri *global-variable-declarations*)))
259 (defun push-variable (local-name uri table)
260 (prog1
261 (length table)
262 (vector-push-extend (cons local-name uri) table)))
264 (defun lexical-variable-value (index &optional (errorp t))
265 (let ((result (svref *lexical-variable-values* index)))
266 (when errorp
267 (assert (not (eq result 'unbound))))
268 result))
270 (defun (setf lexical-variable-value) (newval index)
271 (assert (not (eq newval 'unbound)))
272 (setf (svref *lexical-variable-values* index) newval))
274 (defun global-variable-value (index &optional (errorp t))
275 (let ((result (svref *global-variable-values* index)))
276 (when errorp
277 (assert (not (eq result 'unbound))))
278 result))
280 (defun (setf global-variable-value) (newval index)
281 (assert (not (eq newval 'unbound)))
282 (setf (svref *global-variable-values* index) newval))
284 (defmethod xpath-sys:environment-find-function
285 ((env xslt-environment) lname uri)
286 (or (if (string= uri "")
287 (or (xpath-sys:find-xpath-function lname *xsl*)
288 (xpath-sys:find-xpath-function lname uri))
289 (xpath-sys:find-xpath-function lname uri))
290 (when *forwards-compatible-p*
291 (lambda (&rest ignore)
292 (declare (ignore ignore))
293 (xslt-error "attempt to call an unknown XPath function (~A); error delayed until run-time due to forwards compatible processing"
294 lname)))))
296 (defmethod xpath-sys:environment-find-variable
297 ((env xslt-environment) lname uri)
298 (let ((index
299 (find-variable-index lname uri *lexical-variable-declarations*)))
300 (when index
301 (lambda (ctx)
302 (declare (ignore ctx))
303 (svref *lexical-variable-values* index)))))
305 (defclass lexical-xslt-environment (xslt-environment) ())
307 (defmethod xpath-sys:environment-find-variable
308 ((env lexical-xslt-environment) lname uri)
309 (or (call-next-method)
310 (let ((index
311 (find-variable-index lname uri *global-variable-declarations*)))
312 (when index
313 (xslt-trace-thunk
314 (lambda (ctx)
315 (declare (ignore ctx))
316 (svref *global-variable-values* index))
317 "global ~s (uri ~s) = ~s" lname uri :result)))))
319 (defclass key-environment (xslt-environment) ())
321 (defmethod xpath-sys:environment-find-variable
322 ((env key-environment) lname uri)
323 (declare (ignore lname uri))
324 (xslt-error "disallowed variable reference"))
326 (defclass global-variable-environment (xslt-environment)
327 ((initial-global-variable-thunks
328 :initarg :initial-global-variable-thunks
329 :accessor initial-global-variable-thunks)))
331 (defmethod xpath-sys:environment-find-variable
332 ((env global-variable-environment) lname uri)
333 (or (call-next-method)
334 (gethash (cons lname uri) (initial-global-variable-thunks env))))
337 ;;;; TOPLEVEL-TEXT-OUTPUT-SINK
338 ;;;;
339 ;;;; A sink that serializes only text not contained in any element.
341 (defmacro with-toplevel-text-output-sink ((var) &body body)
342 `(invoke-with-toplevel-text-output-sink (lambda (,var) ,@body)))
344 (defclass toplevel-text-output-sink (sax:default-handler)
345 ((target :initarg :target :accessor text-output-sink-target)
346 (depth :initform 0 :accessor textoutput-sink-depth)))
348 (defmethod sax:start-element ((sink toplevel-text-output-sink)
349 namespace-uri local-name qname attributes)
350 (declare (ignore namespace-uri local-name qname attributes))
351 (incf (textoutput-sink-depth sink)))
353 (defmethod sax:characters ((sink toplevel-text-output-sink) data)
354 (when (zerop (textoutput-sink-depth sink))
355 (write-string data (text-output-sink-target sink))))
357 (defmethod sax:unescaped ((sink toplevel-text-output-sink) data)
358 (sax:characters sink data))
360 (defmethod sax:end-element ((sink toplevel-text-output-sink)
361 namespace-uri local-name qname)
362 (declare (ignore namespace-uri local-name qname))
363 (decf (textoutput-sink-depth sink)))
365 (defun invoke-with-toplevel-text-output-sink (fn)
366 (with-output-to-string (s)
367 (funcall fn (make-instance 'toplevel-text-output-sink :target s))))
370 ;;;; TEXT-FILTER
371 ;;;;
372 ;;;; A sink that passes through only text (at any level) and turns to
373 ;;;; into unescaped characters.
375 (defclass text-filter (sax:default-handler)
376 ((target :initarg :target :accessor text-filter-target)))
378 (defmethod sax:characters ((sink text-filter) data)
379 (sax:unescaped (text-filter-target sink) data))
381 (defmethod sax:unescaped ((sink text-filter) data)
382 (sax:unescaped (text-filter-target sink) data))
384 (defmethod sax:end-document ((sink text-filter))
385 (sax:end-document (text-filter-target sink)))
387 (defun make-text-filter (target)
388 (make-instance 'text-filter :target target))
391 ;;;; ESCAPER
392 ;;;;
393 ;;;; A sink that recovers from sax:unescaped using sax:characters, as per
394 ;;;; XSLT 16.4.
396 (defclass escaper (cxml:broadcast-handler)
399 (defmethod sax:unescaped ((sink escaper) data)
400 (sax:characters sink data))
402 (defun make-escaper (target)
403 (make-instance 'escaper :handlers (list target)))
406 ;;;; Names
408 (defun of-name (local-name)
409 (stp:of-name local-name *xsl*))
411 (defun namep (node local-name)
412 (and (typep node '(or stp:element stp:attribute))
413 (equal (stp:namespace-uri node) *xsl*)
414 (equal (stp:local-name node) local-name)))
417 ;;;; PARSE-STYLESHEET
419 (defstruct stylesheet
420 (modes (make-hash-table :test 'equal))
421 (global-variables (make-empty-declaration-array))
422 (output-specification (make-output-specification))
423 (strip-tests nil)
424 (strip-thunk nil)
425 (named-templates (make-hash-table :test 'equal))
426 (attribute-sets (make-hash-table :test 'equal))
427 (keys (make-hash-table :test 'equal))
428 (namespace-aliases (make-hash-table :test 'equal))
429 (decimal-formats (make-hash-table :test 'equal))
430 (initial-global-variable-thunks (make-hash-table :test 'equal)))
432 (defstruct mode
433 (templates nil)
434 (match-thunk (lambda (ignore) (declare (ignore ignore)) nil)))
436 (defun find-mode (stylesheet local-name &optional uri)
437 (gethash (cons local-name uri) (stylesheet-modes stylesheet)))
439 (defun ensure-mode (stylesheet &optional local-name uri)
440 (or (find-mode stylesheet local-name uri)
441 (setf (gethash (cons local-name uri) (stylesheet-modes stylesheet))
442 (make-mode))))
444 (defun ensure-mode/qname (stylesheet qname env)
445 (if qname
446 (multiple-value-bind (local-name uri)
447 (decode-qname qname env nil)
448 (ensure-mode stylesheet local-name uri))
449 (find-mode stylesheet nil)))
451 (defun acons-namespaces
452 (element &optional (bindings *namespaces*) include-redeclared)
453 (map-namespace-declarations (lambda (prefix uri)
454 (push (cons prefix uri) bindings))
455 element
456 include-redeclared)
457 bindings)
459 (defun find-key (name stylesheet)
460 (or (gethash name (stylesheet-keys stylesheet))
461 (xslt-error "unknown key: ~a" name)))
463 (defun make-key (match use) (cons match use))
465 (defun key-match (key) (car key))
467 (defun key-use (key) (cdr key))
469 (defun add-key (stylesheet name match use)
470 (push (make-key match use)
471 (gethash name (stylesheet-keys stylesheet))))
473 (defvar *excluded-namespaces* (list *xsl*))
474 (defvar *empty-mode*)
475 (defvar *default-mode*)
477 (defvar *xsl-include-stack* nil)
479 (defun uri-to-pathname (uri)
480 (cxml::uri-to-pathname (puri:parse-uri uri)))
482 ;; Why this extra check for literal result element used as stylesheets,
483 ;; instead of a general check for every literal result element? Because
484 ;; Stylesheet__91804 says so.
485 (defun check-Errors_err035 (literal-result-element)
486 (let ((*namespaces* (acons-namespaces literal-result-element))
487 (env (make-instance 'lexical-xslt-environment)))
488 (stp:with-attributes ((extension-element-prefixes
489 "extension-element-prefixes"
490 *xsl*))
491 literal-result-element
492 (dolist (prefix (words (or extension-element-prefixes "")))
493 (if (equal prefix "#default")
494 (setf prefix nil)
495 (unless (cxml-stp-impl::nc-name-p prefix)
496 (xslt-error "invalid prefix: ~A" prefix)))
497 (let ((uri
498 (or (xpath-sys:environment-find-namespace env prefix)
499 (xslt-error "namespace not found: ~A" prefix))))
500 (when (equal uri (stp:namespace-uri literal-result-element))
501 (xslt-error "literal result element used as stylesheet, but is ~
502 declared as an extension element")))))))
504 (defun unwrap-2.3 (document)
505 (let ((literal-result-element (stp:document-element document))
506 (new-template (stp:make-element "template" *xsl*))
507 (new-document-element (stp:make-element "stylesheet" *xsl*)))
508 (check-Errors_err035 literal-result-element)
509 (setf (stp:attribute-value new-document-element "version")
510 (or (stp:attribute-value literal-result-element "version" *xsl*)
511 (xslt-error "not a stylesheet: root element lacks xsl:version")))
512 (setf (stp:attribute-value new-template "match") "/")
513 (setf (stp:document-element document) new-document-element)
514 (stp:append-child new-document-element new-template)
515 (stp:append-child new-template literal-result-element)
516 new-document-element))
518 (defun parse-stylesheet-to-stp (input uri-resolver)
519 (let* ((d (cxml:parse input (make-text-normalizer (cxml-stp:make-builder))))
520 (<transform> (stp:document-element d)))
521 (unless (equal (stp:namespace-uri <transform>) *xsl*)
522 (setf <transform> (unwrap-2.3 d)))
523 (strip-stylesheet <transform>)
524 (unless (and (equal (stp:namespace-uri <transform>) *xsl*)
525 (or (equal (stp:local-name <transform>) "transform")
526 (equal (stp:local-name <transform>) "stylesheet")))
527 (xslt-error "not a stylesheet"))
528 (check-for-invalid-attributes
529 '(("version" . "")
530 ("exclude-result-prefixes" . "")
531 ("extension-element-prefixes" . "")
532 ("space" . "http://www.w3.org/XML/1998/namespace")
533 ("id" . ""))
534 <transform>)
535 (let ((invalid
536 (or (stp:find-child-if (of-name "stylesheet") <transform>)
537 (stp:find-child-if (of-name "transform") <transform>))))
538 (when invalid
539 (xslt-error "invalid top-level element ~A" (stp:local-name invalid))))
540 (dolist (include (stp:filter-children (of-name "include") <transform>))
541 (let* ((uri (puri:merge-uris (or (stp:attribute-value include "href")
542 (xslt-error "include without href"))
543 (stp:base-uri include)))
544 (uri (if uri-resolver
545 (funcall uri-resolver uri)
546 uri))
547 (str (puri:render-uri uri nil))
548 (pathname
549 (handler-case
550 (uri-to-pathname uri)
551 (cxml:xml-parse-error (c)
552 (xslt-error "cannot find included stylesheet ~A: ~A"
553 uri c)))))
554 (with-open-file
555 (stream pathname
556 :element-type '(unsigned-byte 8)
557 :if-does-not-exist nil)
558 (unless stream
559 (xslt-error "cannot find included stylesheet ~A at ~A"
560 uri pathname))
561 (when (find str *xsl-include-stack* :test #'equal)
562 (xslt-error "recursive inclusion of ~A" uri))
563 (let* ((*xsl-include-stack* (cons str *xsl-include-stack*))
564 (<transform>2 (parse-stylesheet-to-stp stream uri-resolver)))
565 (stp:insert-child-after <transform>
566 (stp:copy <transform>2)
567 include)
568 (stp:detach include)))))
569 <transform>))
571 (defvar *instruction-base-uri*) ;misnamed, is also used in other attributes
572 (defvar *apply-imports-limit*)
573 (defvar *import-priority*)
574 (defvar *extension-namespaces*)
575 (defvar *forwards-compatible-p*)
577 (defmacro do-toplevel ((var xpath <transform>) &body body)
578 `(map-toplevel (lambda (,var) ,@body) ,xpath ,<transform>))
580 (defun map-toplevel (fn xpath <transform>)
581 (dolist (node (list-toplevel xpath <transform>))
582 (let ((*namespaces* *initial-namespaces*))
583 (xpath:do-node-set (ancestor (xpath:evaluate "ancestor::node()" node))
584 (xpath:with-namespaces (("" #.*xsl*))
585 (when (xpath:node-matches-p ancestor "stylesheet|transform")
586 ;; discard namespaces from including stylesheets
587 (setf *namespaces* *initial-namespaces*)))
588 (when (xpath-protocol:node-type-p ancestor :element)
589 (setf *namespaces* (acons-namespaces ancestor *namespaces* t))))
590 (funcall fn node))))
592 (defun list-toplevel (xpath <transform>)
593 (labels ((recurse (sub)
594 (let ((subsubs
595 (xpath-sys:pipe-of
596 (xpath:evaluate "transform|stylesheet" sub))))
597 (xpath::append-pipes
598 (xpath-sys:pipe-of (xpath:evaluate xpath sub))
599 (xpath::mappend-pipe #'recurse subsubs)))))
600 (xpath::sort-nodes (recurse <transform>))))
602 (defmacro with-import-magic ((node env) &body body)
603 `(invoke-with-import-magic (lambda () ,@body) ,node ,env))
605 (defun invoke-with-import-magic (fn node env)
606 (unless (or (namep node "stylesheet") (namep node "transform"))
607 (setf node (stp:parent node)))
608 (let ((*excluded-namespaces* (list *xsl*))
609 (*extension-namespaces* '())
610 (*forwards-compatible-p*
611 (not (equal (stp:attribute-value node "version") "1.0"))))
612 (parse-exclude-result-prefixes! node env)
613 (parse-extension-element-prefixes! node env)
614 (funcall fn)))
616 (defun parse-1-stylesheet (env stylesheet designator uri-resolver)
617 (let* ((<transform> (parse-stylesheet-to-stp designator uri-resolver))
618 (instruction-base-uri (stp:base-uri <transform>))
619 (namespaces (acons-namespaces <transform>))
620 (apply-imports-limit (1+ *import-priority*))
621 (continuations '()))
622 (let ((*namespaces* namespaces))
623 (invoke-with-import-magic (constantly t) <transform> env))
624 (do-toplevel (elt "node()" <transform>)
625 (let ((version (stp:attribute-value (stp:parent elt) "version")))
626 (cond
627 ((null version)
628 (xslt-error "stylesheet lacks version"))
629 ((equal version "1.0")
630 (if (typep elt 'stp:element)
631 (when (or (equal (stp:namespace-uri elt) "")
632 (and (equal (stp:namespace-uri elt) *xsl*)
633 (not (find (stp:local-name elt)
634 '("key" "template" "output"
635 "strip-space" "preserve-space"
636 "attribute-set" "namespace-alias"
637 "decimal-format" "variable" "param"
638 "import" "include"
639 ;; for include handling:
640 "stylesheet" "transform")
641 :test #'equal))))
642 (xslt-error "unknown top-level element ~A" (stp:local-name elt)))
643 (xslt-error "text at top-level"))))))
644 (macrolet ((with-specials ((&optional) &body body)
645 `(let ((*instruction-base-uri* instruction-base-uri)
646 (*namespaces* namespaces)
647 (*apply-imports-limit* apply-imports-limit))
648 ,@body)))
649 (with-specials ()
650 (do-toplevel (import "import" <transform>)
651 (when (let ((prev (xpath:first-node
652 (xpath:evaluate "preceding-sibling::*"
653 import
654 t))))
655 (and prev (not (namep prev "import"))))
656 (xslt-error "import not at beginning of stylesheet"))
657 (let ((uri (puri:merge-uris (or (stp:attribute-value import "href")
658 (xslt-error "import without href"))
659 (stp:base-uri import))))
660 (push (parse-imported-stylesheet env stylesheet uri uri-resolver)
661 continuations))))
662 (let ((import-priority
663 (incf *import-priority*))
664 (var-cont (prepare-global-variables stylesheet <transform>)))
665 (parse-namespace-aliases! stylesheet <transform> env)
666 ;; delay the rest of compilation until we've seen all global
667 ;; variables:
668 (lambda ()
669 (mapc #'funcall (nreverse continuations))
670 (with-specials ()
671 (let ((*import-priority* import-priority))
672 (funcall var-cont)
673 (parse-keys! stylesheet <transform> env)
674 (parse-templates! stylesheet <transform> env)
675 (parse-output! stylesheet <transform> env)
676 (parse-strip/preserve-space! stylesheet <transform> env)
677 (parse-attribute-sets! stylesheet <transform> env)
678 (parse-decimal-formats! stylesheet <transform> env))))))))
680 (defvar *xsl-import-stack* nil)
682 (defun parse-imported-stylesheet (env stylesheet uri uri-resolver)
683 (let* ((uri (if uri-resolver
684 (funcall uri-resolver uri)
685 uri))
686 (str (puri:render-uri uri nil))
687 (pathname
688 (handler-case
689 (uri-to-pathname uri)
690 (cxml:xml-parse-error (c)
691 (xslt-error "cannot find imported stylesheet ~A: ~A"
692 uri c)))))
693 (with-open-file
694 (stream pathname
695 :element-type '(unsigned-byte 8)
696 :if-does-not-exist nil)
697 (unless stream
698 (xslt-error "cannot find imported stylesheet ~A at ~A"
699 uri pathname))
700 (when (find str *xsl-import-stack* :test #'equal)
701 (xslt-error "recursive inclusion of ~A" uri))
702 (let ((*xsl-import-stack* (cons str *xsl-import-stack*)))
703 (parse-1-stylesheet env stylesheet stream uri-resolver)))))
705 (defvar *included-attribute-sets*)
707 (defun parse-stylesheet (designator &key uri-resolver)
708 (with-resignalled-errors ()
709 (xpath:with-namespaces ((nil #.*xsl*))
710 (let* ((*import-priority* 0)
711 (xpath:*allow-variables-in-patterns* nil)
712 (puri:*strict-parse* nil)
713 (stylesheet (make-stylesheet))
714 (*stylesheet*
715 ;; zzz this is for remove-excluded-namespaces only
716 stylesheet)
717 (env (make-instance 'lexical-xslt-environment))
718 (*excluded-namespaces* *excluded-namespaces*)
719 (*global-variable-declarations* (make-empty-declaration-array))
720 (*included-attribute-sets* nil))
721 (ensure-mode stylesheet nil)
722 (funcall (parse-1-stylesheet env stylesheet designator uri-resolver))
723 ;; reverse attribute sets:
724 (let ((table (stylesheet-attribute-sets stylesheet)))
725 (maphash (lambda (k v)
726 (setf (gethash k table) (nreverse v)))
727 table))
728 ;; for Errors_err011
729 (dolist (sets *included-attribute-sets*)
730 (loop for (local-name uri nil) in sets do
731 (find-attribute-set local-name uri stylesheet)))
732 ;; add default df
733 (unless (find-decimal-format "" "" stylesheet nil)
734 (setf (find-decimal-format "" "" stylesheet)
735 (make-decimal-format)))
736 ;; compile a template matcher for each mode:
737 (loop
738 for mode being each hash-value in (stylesheet-modes stylesheet)
740 (setf (mode-match-thunk mode)
741 (xpath:make-pattern-matcher
742 (mapcar #'template-compiled-pattern
743 (mode-templates mode)))))
744 ;; and for the strip tests
745 (setf (stylesheet-strip-thunk stylesheet)
746 (let ((patterns (stylesheet-strip-tests stylesheet)))
747 (and patterns
748 (xpath:make-pattern-matcher
749 (mapcar #'strip-test-compiled-pattern patterns)))))
750 stylesheet))))
752 (defun parse-attribute-sets! (stylesheet <transform> env)
753 (do-toplevel (elt "attribute-set" <transform>)
754 (with-import-magic (elt env)
755 (push (let* ((sets
756 (mapcar (lambda (qname)
757 (multiple-value-list (decode-qname qname env nil)))
758 (words
759 (stp:attribute-value elt "use-attribute-sets"))))
760 (instructions
761 (stp:map-children
762 'list
763 (lambda (child)
764 (unless
765 (and (typep child 'stp:element)
766 (or (and (equal (stp:namespace-uri child) *xsl*)
767 (equal (stp:local-name child)
768 "attribute"))
769 (find (stp:namespace-uri child)
770 *extension-namespaces*
771 :test 'equal)))
772 (xslt-error "non-attribute found in attribute set"))
773 (parse-instruction child))
774 elt))
775 (*lexical-variable-declarations*
776 (make-empty-declaration-array))
777 (thunk
778 (compile-instruction `(progn ,@instructions) env))
779 (n-variables (length *lexical-variable-declarations*)))
780 (push sets *included-attribute-sets*)
781 (lambda (ctx)
782 (with-stack-limit ()
783 (loop for (local-name uri nil) in sets do
784 (dolist (thunk (find-attribute-set local-name uri))
785 (funcall thunk ctx)))
786 (let ((*lexical-variable-values*
787 (make-variable-value-array n-variables)))
788 (funcall thunk ctx)))))
789 (gethash (multiple-value-bind (local-name uri)
790 (decode-qname (or (stp:attribute-value elt "name")
791 (xslt-error "missing name"))
793 nil)
794 (cons local-name uri))
795 (stylesheet-attribute-sets stylesheet))))))
797 (defun parse-namespace-aliases! (stylesheet <transform> env)
798 (do-toplevel (elt "namespace-alias" <transform>)
799 (let ((*namespaces* (acons-namespaces elt)))
800 (only-with-attributes (stylesheet-prefix result-prefix) elt
801 (unless stylesheet-prefix
802 (xslt-error "missing stylesheet-prefix in namespace-alias"))
803 (unless result-prefix
804 (xslt-error "missing result-prefix in namespace-alias"))
805 (setf (gethash
806 (if (equal stylesheet-prefix "#default")
808 (or (xpath-sys:environment-find-namespace
810 stylesheet-prefix)
811 (xslt-error "stylesheet namespace not found in alias: ~A"
812 stylesheet-prefix)))
813 (stylesheet-namespace-aliases stylesheet))
814 (or (xpath-sys:environment-find-namespace
816 (if (equal result-prefix "#default")
818 result-prefix))
819 (xslt-error "result namespace not found in alias: ~A"
820 result-prefix)))))))
822 (defun parse-decimal-formats! (stylesheet <transform> env)
823 (do-toplevel (elt "decimal-format" <transform>)
824 (stp:with-attributes (name
825 ;; strings
826 infinity
827 (nan "NaN")
828 ;; characters:
829 decimal-separator
830 grouping-separator
831 zero-digit
832 percent
833 per-mille
834 digit
835 pattern-separator
836 minus-sign)
838 (multiple-value-bind (local-name uri)
839 (if name
840 (decode-qname name env nil)
841 (values "" ""))
842 (let ((current (find-decimal-format local-name uri stylesheet nil))
843 (new
844 (let ((seen '()))
845 (flet ((chr (key x)
846 (when x
847 (unless (eql (length x) 1)
848 (xslt-error "not a single character: ~A" x))
849 (let ((chr (elt x 0)))
850 (when (find chr seen)
851 (xslt-error
852 "conflicting decimal format characters: ~A"
853 chr))
854 (push chr seen)
855 (list key chr))))
856 (str (key x)
857 (when x
858 (list key x))))
859 (apply #'make-decimal-format
860 (append (str :infinity infinity)
861 (str :nan nan)
862 (chr :decimal-separator decimal-separator)
863 (chr :grouping-separator grouping-separator)
864 (chr :zero-digit zero-digit)
865 (chr :percent percent)
866 (chr :per-mille per-mille)
867 (chr :digit digit)
868 (chr :pattern-separator pattern-separator)
869 (chr :minus-sign minus-sign)))))))
870 (if current
871 (unless (decimal-format= current new)
872 (xslt-error "decimal format mismatch for ~S" local-name))
873 (setf (find-decimal-format local-name uri stylesheet) new)))))))
875 (defun parse-exclude-result-prefixes! (node env)
876 (stp:with-attributes (exclude-result-prefixes)
877 node
878 (dolist (prefix (words (or exclude-result-prefixes "")))
879 (if (equal prefix "#default")
880 (setf prefix nil)
881 (unless (cxml-stp-impl::nc-name-p prefix)
882 (xslt-error "invalid prefix: ~A" prefix)))
883 (push (or (xpath-sys:environment-find-namespace env prefix)
884 (xslt-error "namespace not found: ~A" prefix))
885 *excluded-namespaces*))))
887 (defun parse-extension-element-prefixes! (node env)
888 (stp:with-attributes (extension-element-prefixes)
889 node
890 (dolist (prefix (words (or extension-element-prefixes "")))
891 (if (equal prefix "#default")
892 (setf prefix nil)
893 (unless (cxml-stp-impl::nc-name-p prefix)
894 (xslt-error "invalid prefix: ~A" prefix)))
895 (let ((uri
896 (or (xpath-sys:environment-find-namespace env prefix)
897 (xslt-error "namespace not found: ~A" prefix))))
898 (unless (equal uri *xsl*)
899 (push uri *extension-namespaces*)
900 (push uri *excluded-namespaces*))))))
902 (defun parse-nametest-tokens (str)
903 (labels ((check (boolean)
904 (unless boolean
905 (xslt-error "invalid nametest token")))
906 (check-null (boolean)
907 (check (not boolean))))
908 (cons
909 :patterns
910 (mapcar (lambda (name-test)
911 (destructuring-bind (&optional path &rest junk)
912 (cdr (xpath:parse-pattern-expression name-test))
913 (check-null junk)
914 (check (eq (car path) :path))
915 (destructuring-bind (&optional child &rest junk) (cdr path)
916 (check-null junk)
917 (check (eq (car child) :child))
918 (destructuring-bind (nodetest &rest junk) (cdr child)
919 (check-null junk)
920 (check (or (stringp nodetest)
921 (eq nodetest '*)
922 (and (consp nodetest)
923 (or (eq (car nodetest) :namespace)
924 (eq (car nodetest) :qname)))))))
925 path))
926 (words str)))))
928 (defstruct strip-test
929 compiled-pattern
930 priority
931 position
932 value)
934 (defun parse-strip/preserve-space! (stylesheet <transform> env)
935 (let ((i 0))
936 (do-toplevel (elt "strip-space|preserve-space" <transform>)
937 (let ((*namespaces* (acons-namespaces elt))
938 (value
939 (if (equal (stp:local-name elt) "strip-space")
940 :strip
941 :preserve)))
942 (dolist (expression
943 (cdr (parse-nametest-tokens
944 (stp:attribute-value elt "elements"))))
945 (let* ((compiled-pattern
946 (car (without-xslt-current ()
947 (xpath:compute-patterns
948 `(:patterns ,expression)
949 *import-priority*
950 "will set below"
951 env))))
952 (strip-test
953 (make-strip-test :compiled-pattern compiled-pattern
954 :priority (expression-priority expression)
955 :position i
956 :value value)))
957 (setf (xpath:pattern-value compiled-pattern) strip-test)
958 (push strip-test (stylesheet-strip-tests stylesheet)))))
959 (incf i))))
961 (defstruct (output-specification
962 (:conc-name "OUTPUT-"))
963 method
964 indent
965 omit-xml-declaration
966 encoding
967 doctype-system
968 doctype-public
969 cdata-section-matchers
970 standalone-p
971 media-type)
973 (defun parse-output! (stylesheet <transform> env)
974 (dolist (<output> (list-toplevel "output" <transform>))
975 (let ((spec (stylesheet-output-specification stylesheet)))
976 (only-with-attributes (version
977 method
978 indent
979 encoding
980 media-type
981 doctype-system
982 doctype-public
983 omit-xml-declaration
984 standalone
985 cdata-section-elements)
986 <output>
987 (declare (ignore version))
988 (when method
989 (multiple-value-bind (local-name uri)
990 (decode-qname method env t)
991 (setf (output-method spec)
992 (if (plusp (length uri))
994 (cond
995 ((equalp local-name "HTML") :html)
996 ((equalp local-name "TEXT") :text)
997 ((equalp local-name "XML") :xml)
999 (xslt-error "invalid output method: ~A" method)))))))
1000 (when indent
1001 (setf (output-indent spec) indent))
1002 (when encoding
1003 (setf (output-encoding spec) encoding))
1004 (when doctype-system
1005 (setf (output-doctype-system spec) doctype-system))
1006 (when doctype-public
1007 (setf (output-doctype-public spec) doctype-public))
1008 (when omit-xml-declaration
1009 (setf (output-omit-xml-declaration spec) omit-xml-declaration))
1010 (when cdata-section-elements
1011 (dolist (qname (words cdata-section-elements))
1012 (decode-qname qname env nil) ;check the syntax
1013 (push (xpath:make-pattern-matcher* qname env)
1014 (output-cdata-section-matchers spec))))
1015 (when standalone
1016 (setf (output-standalone-p spec)
1017 (boolean-or-error standalone)))
1018 (when media-type
1019 (setf (output-media-type spec) media-type))))))
1021 (defun make-empty-declaration-array ()
1022 (make-array 1 :fill-pointer 0 :adjustable t))
1024 (defun make-variable-value-array (n-lexical-variables)
1025 (make-array n-lexical-variables :initial-element 'unbound))
1027 (defun compile-global-variable (<variable> env) ;; also for <param>
1028 (stp:with-attributes (name select) <variable>
1029 (when (and select (stp:list-children <variable>))
1030 (xslt-error "variable with select and body"))
1031 (let* ((*lexical-variable-declarations* (make-empty-declaration-array))
1032 (inner (cond
1033 (select
1034 (compile-xpath select env))
1035 ((stp:list-children <variable>)
1036 (let* ((inner-sexpr `(progn ,@(parse-body <variable>)))
1037 (inner-thunk (compile-instruction inner-sexpr env)))
1038 (lambda (ctx)
1039 (apply-to-result-tree-fragment ctx inner-thunk))))
1041 (lambda (ctx)
1042 (declare (ignore ctx))
1043 ""))))
1044 (n-lexical-variables (length *lexical-variable-declarations*)))
1045 (xslt-trace-thunk
1046 (lambda (ctx)
1047 (let* ((*lexical-variable-values*
1048 (make-variable-value-array n-lexical-variables)))
1049 (funcall inner ctx)))
1050 "global ~s (~s) = ~s" name select :result))))
1052 (defstruct (variable-chain
1053 (:constructor make-variable-chain)
1054 (:conc-name "VARIABLE-CHAIN-"))
1055 definitions
1056 index
1057 local-name
1058 thunk
1059 uri)
1061 (defstruct (import-variable
1062 (:constructor make-variable)
1063 (:conc-name "VARIABLE-"))
1064 value-thunk
1065 value-thunk-setter
1066 param-p)
1068 (defun parse-global-variable! (stylesheet <variable> global-env)
1069 (let* ((*namespaces* (acons-namespaces <variable>))
1070 (instruction-base-uri (stp:base-uri <variable>))
1071 (*instruction-base-uri* instruction-base-uri)
1072 (*excluded-namespaces* (list *xsl*))
1073 (*extension-namespaces* '())
1074 (qname (stp:attribute-value <variable> "name")))
1075 (with-import-magic (<variable> global-env)
1076 (unless qname
1077 (xslt-error "name missing in ~A" (stp:local-name <variable>)))
1078 (multiple-value-bind (local-name uri)
1079 (decode-qname qname global-env nil)
1080 ;; For the normal compilation environment of templates, install it
1081 ;; into *GLOBAL-VARIABLE-DECLARATIONS*:
1082 (let ((index (intern-global-variable local-name uri)))
1083 ;; For the evaluation of a global variable itself, build a thunk
1084 ;; that lazily resolves other variables, stored into
1085 ;; INITIAL-GLOBAL-VARIABLE-THUNKS:
1086 (let* ((value-thunk :unknown)
1087 (sgv (stylesheet-global-variables stylesheet))
1088 (chain
1089 (if (< index (length sgv))
1090 (elt sgv index)
1091 (make-variable-chain
1092 :index index
1093 :local-name local-name
1094 :uri uri)))
1095 (next (car (variable-chain-definitions chain)))
1096 (global-variable-thunk
1097 (lambda (ctx)
1098 (let ((v (global-variable-value index nil)))
1099 (cond
1100 ((eq v 'seen)
1101 (unless next
1102 (xslt-error "no next definition for: ~A"
1103 local-name))
1104 (funcall (variable-value-thunk next) ctx))
1105 ((eq v 'unbound)
1106 (setf (global-variable-value index) 'seen)
1107 (setf (global-variable-value index)
1108 (funcall value-thunk ctx)))
1110 v)))))
1111 (excluded-namespaces *excluded-namespaces*)
1112 (extension-namespaces *extension-namespaces*)
1113 (variable
1114 (make-variable :param-p (namep <variable> "param")))
1115 (forwards-compatible-p *forwards-compatible-p*)
1116 (value-thunk-setter
1117 (lambda ()
1118 (let* ((*instruction-base-uri* instruction-base-uri)
1119 (*excluded-namespaces* excluded-namespaces)
1120 (*extension-namespaces* extension-namespaces)
1121 (*forwards-compatible-p* forwards-compatible-p)
1123 (compile-global-variable <variable> global-env)))
1124 (setf value-thunk fn)
1125 (setf (variable-value-thunk variable) fn)))))
1126 (setf (variable-value-thunk-setter variable)
1127 value-thunk-setter)
1128 (setf (gethash (cons local-name uri)
1129 (initial-global-variable-thunks global-env))
1130 global-variable-thunk)
1131 (setf (variable-chain-thunk chain) global-variable-thunk)
1132 (push variable (variable-chain-definitions chain))
1133 chain))))))
1135 (defun parse-keys! (stylesheet <transform> env)
1136 (xpath:with-namespaces ((nil #.*xsl*))
1137 (do-toplevel (<key> "key" <transform>)
1138 (with-import-magic (<key> env)
1139 (let ((*instruction-base-uri* (stp:base-uri <key>)))
1140 (only-with-attributes (name match use) <key>
1141 (unless name (xslt-error "key name attribute not specified"))
1142 (unless match (xslt-error "key match attribute not specified"))
1143 (unless use (xslt-error "key use attribute not specified"))
1144 (multiple-value-bind (local-name uri)
1145 (decode-qname name env nil)
1146 (add-key stylesheet
1147 (cons local-name uri)
1148 (compile-xpath `(xpath:xpath ,(parse-key-pattern match))
1149 env)
1150 (compile-xpath use
1151 (make-instance 'key-environment))))))))))
1153 (defun prepare-global-variables (stylesheet <transform>)
1154 (xpath:with-namespaces ((nil #.*xsl*))
1155 (let* ((igvt (stylesheet-initial-global-variable-thunks stylesheet))
1156 (global-env (make-instance 'global-variable-environment
1157 :initial-global-variable-thunks igvt))
1158 (chains '()))
1159 (do-toplevel (<variable> "variable|param" <transform>)
1160 (let ((chain
1161 (parse-global-variable! stylesheet <variable> global-env)))
1162 (xslt-trace "parsing global variable ~s (uri ~s)"
1163 (variable-chain-local-name chain)
1164 (variable-chain-uri chain))
1165 (when (find chain
1166 chains
1167 :test (lambda (a b)
1168 (and (equal (variable-chain-local-name a)
1169 (variable-chain-local-name b))
1170 (equal (variable-chain-uri a)
1171 (variable-chain-uri b)))))
1172 (xslt-error "duplicate definition for global variable ~A"
1173 (variable-chain-local-name chain)))
1174 (push chain chains)))
1175 (setf chains (nreverse chains))
1176 (let ((table (stylesheet-global-variables stylesheet))
1177 (newlen (length *global-variable-declarations*)))
1178 (adjust-array table newlen :fill-pointer newlen)
1179 (dolist (chain chains)
1180 (setf (elt table (variable-chain-index chain)) chain)))
1181 (lambda ()
1182 ;; now that the global environment knows about all variables, run the
1183 ;; thunk setters to perform their compilation
1184 (mapc (lambda (chain)
1185 (dolist (var (variable-chain-definitions chain))
1186 (funcall (variable-value-thunk-setter var))))
1187 chains)))))
1189 (defun parse-templates! (stylesheet <transform> env)
1190 (let ((i 0))
1191 (do-toplevel (<template> "template" <transform>)
1192 (let ((*namespaces* (acons-namespaces <template>))
1193 (*instruction-base-uri* (stp:base-uri <template>)))
1194 (with-import-magic (<template> env)
1195 (dolist (template (compile-template <template> env i))
1196 (let ((name (template-name template)))
1197 (if name
1198 (let* ((table (stylesheet-named-templates stylesheet))
1199 (head (car (gethash name table))))
1200 (when (and head (eql (template-import-priority head)
1201 (template-import-priority template)))
1202 ;; fixme: is this supposed to be a run-time error?
1203 (xslt-error "conflicting templates for ~A" name))
1204 (push template (gethash name table)))
1205 (let ((mode (ensure-mode/qname stylesheet
1206 (template-mode-qname template)
1207 env)))
1208 (setf (template-mode template) mode)
1209 (push template (mode-templates mode))))))))
1210 (incf i))))
1213 ;;;; APPLY-STYLESHEET
1215 (defvar *stylesheet*)
1217 (deftype xml-designator () '(or runes:xstream runes:rod array stream pathname))
1219 (defun unalias-uri (uri)
1220 (let ((result
1221 (gethash uri (stylesheet-namespace-aliases *stylesheet*)
1222 uri)))
1223 (check-type result string)
1224 result))
1226 (defstruct (parameter
1227 (:constructor make-parameter (value local-name &optional uri)))
1228 (uri "")
1229 local-name
1230 value)
1232 (defun find-parameter-value (local-name uri parameters)
1233 (dolist (p parameters)
1234 (when (and (equal (parameter-local-name p) local-name)
1235 (equal (parameter-uri p) uri))
1236 (return (parameter-value p)))))
1238 (defvar *uri-resolver*)
1240 (defun parse-allowing-microsoft-bom (pathname handler)
1241 (with-open-file (s pathname :element-type '(unsigned-byte 8))
1242 (unless (and (eql (read-byte s nil) #xef)
1243 (eql (read-byte s nil) #xbb)
1244 (eql (read-byte s nil) #xbf))
1245 (file-position s 0))
1246 (cxml:parse s handler)))
1248 (defvar *documents*)
1250 (defun %document (uri-string base-uri)
1251 (let* ((absolute-uri
1252 (puri:merge-uris uri-string (or base-uri "")))
1253 (resolved-uri
1254 (if *uri-resolver*
1255 (funcall *uri-resolver* absolute-uri)
1256 absolute-uri))
1257 (pathname
1258 (handler-case
1259 (uri-to-pathname resolved-uri)
1260 (cxml:xml-parse-error (c)
1261 (xslt-error "cannot find referenced document ~A: ~A"
1262 resolved-uri c))))
1263 (xpath-root-node
1264 (or (gethash pathname *documents*)
1265 (setf (gethash pathname *documents*)
1266 (make-whitespace-stripper
1267 (handler-case
1268 (parse-allowing-microsoft-bom pathname
1269 (stp:make-builder))
1270 ((or file-error cxml:xml-parse-error) (c)
1271 (xslt-error "cannot parse referenced document ~A: ~A"
1272 pathname c)))
1273 (stylesheet-strip-thunk *stylesheet*))))))
1274 (when (puri:uri-fragment absolute-uri)
1275 (xslt-error "use of fragment identifiers in document() not supported"))
1276 xpath-root-node))
1278 (xpath-sys:define-extension xslt *xsl*)
1280 (defun document-base-uri (node)
1281 (xpath-protocol:base-uri
1282 (cond
1283 ((xpath-protocol:node-type-p node :document)
1284 (xpath::find-in-pipe-if
1285 (lambda (x)
1286 (xpath-protocol:node-type-p x :element))
1287 (xpath-protocol:child-pipe node)))
1288 ((xpath-protocol:node-type-p node :element)
1289 node)
1291 (xpath-protocol:parent-node node)))))
1293 (xpath-sys:define-xpath-function/lazy
1294 xslt :document
1295 (object &optional node-set)
1296 (let ((instruction-base-uri *instruction-base-uri*))
1297 (lambda (ctx)
1298 (let* ((object (funcall object ctx))
1299 (node-set (and node-set (funcall node-set ctx)))
1300 (base-uri
1301 (if node-set
1302 (document-base-uri (xpath::textually-first-node node-set))
1303 instruction-base-uri)))
1304 (xpath-sys:make-node-set
1305 (if (xpath:node-set-p object)
1306 (xpath:map-node-set->list
1307 (lambda (node)
1308 (%document (xpath:string-value node)
1309 (if node-set
1310 base-uri
1311 (document-base-uri node))))
1312 object)
1313 (list (%document (xpath:string-value object) base-uri))))))))
1315 ;; FIXME: the point of keys is that we are meant to optimize this
1316 ;; by building a table mapping nodes to values for each key.
1317 ;; We should run over all matching nodes and store them in such a table
1318 ;; when seeing their document for the first time.
1319 (xpath-sys:define-xpath-function/lazy xslt :key (name object)
1320 (let ((namespaces *namespaces*))
1321 (lambda (ctx)
1322 (let* ((qname (xpath:string-value (funcall name ctx)))
1323 (object (funcall object ctx))
1324 (expanded-name
1325 (multiple-value-bind (local-name uri)
1326 (decode-qname/runtime qname namespaces nil)
1327 (cons local-name uri)))
1328 (key-conses (find-key expanded-name *stylesheet*)))
1329 (xpath-sys:make-node-set
1330 (xpath::mappend-pipe
1331 (lambda (key)
1332 (labels ((get-by-key (value)
1333 (let ((value (xpath:string-value value)))
1334 (xpath::filter-pipe
1335 #'(lambda (node)
1336 (let ((uses
1337 (xpath:evaluate-compiled (key-use key)
1338 node)))
1339 (if (xpath:node-set-p uses)
1340 (xpath::find-in-pipe
1341 value
1342 (xpath-sys:pipe-of uses)
1343 :key #'xpath:string-value
1344 :test #'equal)
1345 (equal value (xpath:string-value uses)))))
1346 (xpath-sys:pipe-of
1347 (xpath:node-set-value
1348 (xpath:evaluate-compiled (key-match key) ctx)))))))
1349 (xpath::sort-pipe
1350 (if (xpath:node-set-p object)
1351 (xpath::mappend-pipe #'get-by-key
1352 (xpath-sys:pipe-of object))
1353 (get-by-key object)))))
1354 key-conses))))))
1356 ;; FIXME: add alias mechanism for XPath extensions in order to avoid duplication
1358 (xpath-sys:define-xpath-function/lazy xslt :current ()
1359 (when *without-xslt-current-p*
1360 (xslt-error "current() not allowed here"))
1361 #'(lambda (ctx)
1362 (xpath-sys:make-node-set
1363 (xpath-sys:make-pipe
1364 (xpath:context-starting-node ctx)
1365 nil))))
1367 (xpath-sys:define-xpath-function/lazy xslt :unparsed-entity-uri (name)
1368 #'(lambda (ctx)
1369 (or (xpath-protocol:unparsed-entity-uri (xpath:context-node ctx)
1370 (funcall name ctx))
1371 "")))
1373 (defun %get-node-id (node)
1374 (when (xpath:node-set-p node)
1375 (setf node (xpath::textually-first-node node)))
1376 (when node
1377 (let ((id (xpath-sys:get-node-id node))
1378 (highest-base-uri
1379 (loop
1380 for parent = node then next
1381 for next = (xpath-protocol:parent-node parent)
1382 for this-base-uri = (xpath-protocol:base-uri parent)
1383 for highest-base-uri = (if (plusp (length this-base-uri))
1384 this-base-uri
1385 highest-base-uri)
1386 while next
1387 finally (return highest-base-uri))))
1388 ;; FIXME: Now that we intern documents, we could use a short ID for
1389 ;; the document instead of the base URI.
1390 (nreverse (concatenate 'string highest-base-uri "//" id)))))
1392 (xpath-sys:define-xpath-function/lazy xslt :generate-id (&optional node-set-thunk)
1393 (if node-set-thunk
1394 #'(lambda (ctx)
1395 (%get-node-id (xpath:node-set-value (funcall node-set-thunk ctx))))
1396 #'(lambda (ctx)
1397 (%get-node-id (xpath:context-node ctx)))))
1399 (declaim (special *available-instructions*))
1401 (xpath-sys:define-xpath-function/lazy xslt :element-available (qname)
1402 (let ((namespaces *namespaces*))
1403 #'(lambda (ctx)
1404 (let ((qname (funcall qname ctx)))
1405 (multiple-value-bind (local-name uri)
1406 (decode-qname/runtime qname namespaces nil)
1407 (and (equal uri *xsl*)
1408 (gethash local-name *available-instructions*)
1409 t))))))
1411 (xpath-sys:define-xpath-function/lazy xslt :function-available (qname)
1412 (let ((namespaces *namespaces*))
1413 #'(lambda (ctx)
1414 (let ((qname (funcall qname ctx)))
1415 (multiple-value-bind (local-name uri)
1416 (decode-qname/runtime qname namespaces nil)
1417 (and (zerop (length uri))
1418 (or (xpath-sys:find-xpath-function local-name *xsl*)
1419 (xpath-sys:find-xpath-function local-name uri))
1420 t))))))
1422 (xpath-sys:define-xpath-function/lazy xslt :system-property (qname)
1423 (let ((namespaces *namespaces*))
1424 (lambda (ctx)
1425 (let ((qname (xpath:string-value (funcall qname ctx))))
1426 (multiple-value-bind (local-name uri)
1427 (decode-qname/runtime qname namespaces nil)
1428 (if (equal uri *xsl*)
1429 (cond
1430 ((equal local-name "version")
1431 "1")
1432 ((equal local-name "vendor")
1433 "Xuriella")
1434 ((equal local-name "vendor-url")
1435 "http://repo.or.cz/w/xuriella.git")
1437 ""))
1438 ""))))))
1440 ;; FIXME: should there be separate uri-resolver arguments for stylesheet
1441 ;; and data?
1442 (defun apply-stylesheet
1443 (stylesheet source-designator
1444 &key output parameters uri-resolver navigator)
1445 (when (typep stylesheet 'xml-designator)
1446 (setf stylesheet
1447 (handler-bind
1448 ((cxml:xml-parse-error
1449 (lambda (c)
1450 (xslt-error "cannot parse stylesheet: ~A" c))))
1451 (parse-stylesheet stylesheet :uri-resolver uri-resolver))))
1452 (with-resignalled-errors ()
1453 (invoke-with-output-sink
1454 (lambda ()
1455 (let* ((*documents* (make-hash-table :test 'equal))
1456 (xpath:*navigator* (or navigator :default-navigator))
1457 (puri:*strict-parse* nil)
1458 (*stylesheet* stylesheet)
1459 (*empty-mode* (make-mode))
1460 (*default-mode* (find-mode stylesheet nil))
1461 (global-variable-chains
1462 (stylesheet-global-variables stylesheet))
1463 (*global-variable-values*
1464 (make-variable-value-array (length global-variable-chains)))
1465 (*uri-resolver* uri-resolver)
1466 (source-document
1467 (if (typep source-designator 'xml-designator)
1468 (cxml:parse source-designator (stp:make-builder))
1469 source-designator))
1470 (xpath-root-node
1471 (make-whitespace-stripper
1472 source-document
1473 (stylesheet-strip-thunk stylesheet)))
1474 (ctx (xpath:make-context xpath-root-node)))
1475 (when (pathnamep source-designator)
1476 (setf (gethash source-designator *documents*) xpath-root-node))
1477 (map nil
1478 (lambda (chain)
1479 (let ((head (car (variable-chain-definitions chain))))
1480 (when (variable-param-p head)
1481 (let ((value
1482 (find-parameter-value
1483 (variable-chain-local-name chain)
1484 (variable-chain-uri chain)
1485 parameters)))
1486 (when value
1487 (setf (global-variable-value
1488 (variable-chain-index chain))
1489 value))))))
1490 global-variable-chains)
1491 (map nil
1492 (lambda (chain)
1493 (funcall (variable-chain-thunk chain) ctx))
1494 global-variable-chains)
1495 ;; zzz we wouldn't have to mask float traps here if we used the
1496 ;; XPath API properly. Unfortunately I've been using FUNCALL
1497 ;; everywhere instead of EVALUATE, so let's paper over that
1498 ;; at a central place to be sure:
1499 (xpath::with-float-traps-masked ()
1500 (apply-templates ctx :mode *default-mode*))))
1501 (stylesheet-output-specification stylesheet)
1502 output)))
1504 (defun find-attribute-set (local-name uri &optional (stylesheet *stylesheet*))
1505 (or (gethash (cons local-name uri) (stylesheet-attribute-sets stylesheet))
1506 (xslt-error "no such attribute set: ~A/~A" local-name uri)))
1508 (defun apply-templates/list (list &key param-bindings sort-predicate mode)
1509 (when sort-predicate
1510 (setf list
1511 (mapcar #'xpath:context-node
1512 (stable-sort (contextify-node-list list)
1513 sort-predicate))))
1514 (let* ((n (length list))
1515 (s/d (lambda () n)))
1516 (loop
1517 for i from 1
1518 for child in list
1520 (apply-templates (xpath:make-context child s/d i)
1521 :param-bindings param-bindings
1522 :mode mode))))
1524 (defvar *stack-limit* 200)
1526 (defun invoke-with-stack-limit (fn)
1527 (let ((*stack-limit* (1- *stack-limit*)))
1528 (unless (plusp *stack-limit*)
1529 (xslt-error "*stack-limit* reached; stack overflow"))
1530 (funcall fn)))
1532 (defun invoke-template (ctx template param-bindings)
1533 (let ((*lexical-variable-values*
1534 (make-variable-value-array (template-n-variables template))))
1535 (with-stack-limit ()
1536 (loop
1537 for (name-cons value) in param-bindings
1538 for (nil index nil) = (find name-cons
1539 (template-params template)
1540 :test #'equal
1541 :key #'car)
1543 (when index
1544 (setf (lexical-variable-value index) value)))
1545 (funcall (template-body template) ctx))))
1547 (defun apply-default-templates (ctx mode)
1548 (let ((node (xpath:context-node ctx)))
1549 (cond
1550 ((or (xpath-protocol:node-type-p node :processing-instruction)
1551 (xpath-protocol:node-type-p node :comment)))
1552 ((or (xpath-protocol:node-type-p node :text)
1553 (xpath-protocol:node-type-p node :attribute))
1554 (write-text (xpath-protocol:node-text node)))
1556 (apply-templates/list
1557 (xpath::force
1558 (xpath-protocol:child-pipe node))
1559 :mode mode)))))
1561 (defvar *apply-imports*)
1563 (defun apply-applicable-templates (ctx templates param-bindings finally)
1564 (labels ((apply-imports (&optional actual-param-bindings)
1565 (if templates
1566 (let* ((this (pop templates))
1567 (low (template-apply-imports-limit this))
1568 (high (template-import-priority this)))
1569 (setf templates
1570 (remove-if-not
1571 (lambda (x)
1572 (<= low (template-import-priority x) high))
1573 templates))
1574 (invoke-template ctx this actual-param-bindings))
1575 (funcall finally))))
1576 (let ((*apply-imports* #'apply-imports))
1577 (apply-imports param-bindings))))
1579 (defun apply-templates (ctx &key param-bindings mode)
1580 (apply-applicable-templates ctx
1581 (find-templates ctx (or mode *default-mode*))
1582 param-bindings
1583 (lambda ()
1584 (apply-default-templates ctx mode))))
1586 (defun call-template (ctx name &optional param-bindings)
1587 (apply-applicable-templates ctx
1588 (find-named-templates name)
1589 param-bindings
1590 (lambda ()
1591 (xslt-error "cannot find named template: ~s"
1592 name))))
1594 (defun find-templates (ctx mode)
1595 (let* ((matching-candidates
1596 (xpath:matching-values (mode-match-thunk mode)
1597 (xpath:context-node ctx)))
1598 (npriorities
1599 (if matching-candidates
1600 (1+ (reduce #'max
1601 matching-candidates
1602 :key #'template-import-priority))
1604 (priority-groups (make-array npriorities :initial-element nil)))
1605 (dolist (template matching-candidates)
1606 (push template
1607 (elt priority-groups (template-import-priority template))))
1608 (loop
1609 for i from (1- npriorities) downto 0
1610 for group = (elt priority-groups i)
1611 for template = (maximize #'template< group)
1612 when template
1613 collect template)))
1615 (defun find-named-templates (name)
1616 (gethash name (stylesheet-named-templates *stylesheet*)))
1618 (defun template< (a b) ;assuming same import priority
1619 (let ((p (template-priority a))
1620 (q (template-priority b)))
1621 (cond
1622 ((< p q) t)
1623 ((> p q) nil)
1625 (xslt-cerror "conflicting templates:~_~A,~_~A"
1626 (template-match-expression a)
1627 (template-match-expression b))
1628 (< (template-position a) (template-position b))))))
1630 (defun maximize (< things)
1631 (when things
1632 (let ((max (car things)))
1633 (dolist (other (cdr things))
1634 (when (funcall < max other)
1635 (setf max other)))
1636 max)))
1638 (defun invoke-with-output-sink (fn output-spec output)
1639 (etypecase output
1640 (pathname
1641 (with-open-file (s output
1642 :direction :output
1643 :element-type '(unsigned-byte 8)
1644 :if-exists :rename-and-delete)
1645 (invoke-with-output-sink fn output-spec s)))
1646 ((or stream null)
1647 (invoke-with-output-sink fn
1648 output-spec
1649 (make-output-sink output-spec output)))
1650 ((or hax:abstract-handler sax:abstract-handler)
1651 (with-xml-output output
1652 (when (typep output '(or combi-sink auto-detect-sink))
1653 (sax:start-dtd output
1654 :autodetect-me-please
1655 (output-doctype-public output-spec)
1656 (output-doctype-system output-spec)))
1657 (funcall fn)))))
1659 (defun make-output-sink (output-spec stream)
1660 (let* ((ystream
1661 (if stream
1662 (let ((et (stream-element-type stream)))
1663 (cond
1664 ((or (null et) (subtypep et '(unsigned-byte 8)))
1665 (runes:make-octet-stream-ystream stream))
1666 ((subtypep et 'character)
1667 (runes:make-character-stream-ystream stream))))
1668 (runes:make-rod-ystream)))
1669 (omit-xml-declaration-p
1670 (boolean-or-error (output-omit-xml-declaration output-spec)))
1671 (sink-encoding (or (output-encoding output-spec) "UTF-8"))
1672 (sax-target
1673 (progn
1674 (setf (runes:ystream-encoding ystream)
1675 (cxml::find-output-encoding sink-encoding))
1676 (make-instance 'cxml::sink
1677 :ystream ystream
1678 :omit-xml-declaration-p omit-xml-declaration-p
1679 :encoding sink-encoding))))
1680 (flet ((make-combi-sink ()
1681 (make-instance 'combi-sink
1682 :hax-target (make-instance 'chtml::sink
1683 :ystream ystream)
1684 :sax-target sax-target
1685 :media-type (output-media-type output-spec)
1686 :encoding sink-encoding)))
1687 (let ((method-key (output-method output-spec)))
1688 (cond
1689 ((and (eq method-key :html)
1690 (null (output-doctype-system output-spec))
1691 (null (output-doctype-public output-spec)))
1692 (make-combi-sink))
1693 ((eq method-key :text)
1694 (make-text-filter sax-target))
1695 ((and (eq method-key :xml)
1696 (null (output-doctype-system output-spec)))
1697 sax-target)
1699 (make-auto-detect-sink (make-combi-sink) method-key)))))))
1701 (defstruct template
1702 match-expression
1703 compiled-pattern
1704 name
1705 import-priority
1706 apply-imports-limit
1707 priority
1708 position
1709 mode
1710 mode-qname
1711 params
1712 body
1713 n-variables)
1715 (defun expression-priority (form)
1716 (let ((step (second form)))
1717 (if (and (null (cddr form))
1718 (listp step)
1719 (member (car step) '(:child :attribute))
1720 (null (cddr step)))
1721 (let ((name (second step)))
1722 (cond
1723 ((or (stringp name)
1724 (and (consp name)
1725 (or (eq (car name) :qname)
1726 (eq (car name) :processing-instruction))))
1727 0.0)
1728 ((and (consp name)
1729 (or (eq (car name) :namespace)
1730 (eq (car name) '*)))
1731 -0.25)
1733 -0.5)))
1734 0.5)))
1736 (defun parse-key-pattern (str)
1737 (with-resignalled-errors ()
1738 (with-forward-compatible-errors
1739 (xpath:parse-xpath "compile-time-error()") ;hack
1740 (let ((parsed
1741 (mapcar #'(lambda (item)
1742 `(:path (:root :node)
1743 (:descendant-or-self :node)
1744 ,@(cdr item)))
1745 (cdr (xpath::parse-pattern-expression str)))))
1746 (if (null (rest parsed))
1747 (first parsed)
1748 `(:union ,@parsed))))))
1750 (defun compile-value-thunk (value env)
1751 (if (and (listp value) (eq (car value) 'progn))
1752 (let ((inner-thunk (compile-instruction value env)))
1753 (lambda (ctx)
1754 (apply-to-result-tree-fragment ctx inner-thunk)))
1755 (compile-xpath value env)))
1757 (defun compile-var-binding (name value env)
1758 (multiple-value-bind (local-name uri)
1759 (decode-qname name env nil)
1760 (let ((thunk (xslt-trace-thunk
1761 (compile-value-thunk value env)
1762 "local variable ~s = ~s" name :result)))
1763 (list (cons local-name uri)
1764 (push-variable local-name
1766 *lexical-variable-declarations*)
1767 thunk))))
1769 (defun compile-var-bindings (forms env)
1770 (loop
1771 for (name value) in forms
1772 collect (compile-var-binding name value env)))
1774 (defmacro sometimes-with-attributes ((&rest attrs) node &body body)
1775 (let ((x (gensym)))
1776 `(let ((,x ,node))
1777 (if *forwards-compatible-p*
1778 (stp:with-attributes (,@attrs) ,x ,@body)
1779 (only-with-attributes (,@attrs) ,x ,@body)))))
1781 (defun compile-template (<template> env position)
1782 (sometimes-with-attributes (match name priority mode) <template>
1783 (unless (or name match)
1784 (xslt-error "missing match in template"))
1785 (multiple-value-bind (params body-pos)
1786 (loop
1787 for i from 0
1788 for child in (stp:list-children <template>)
1789 while (namep child "param")
1790 collect (parse-param child) into params
1791 finally (return (values params i)))
1792 (let* ((*lexical-variable-declarations* (make-empty-declaration-array))
1793 (param-bindings (compile-var-bindings params env))
1794 (body (parse-body <template> body-pos (mapcar #'car params)))
1795 (body-thunk (compile-instruction `(progn ,@body) env))
1796 (outer-body-thunk
1797 (xslt-trace-thunk
1798 #'(lambda (ctx)
1799 (unwind-protect
1800 (progn
1801 ;; set params that weren't initialized by apply-templates
1802 (loop for (name index param-thunk) in param-bindings
1803 when (eq (lexical-variable-value index nil) 'unbound)
1804 do (setf (lexical-variable-value index)
1805 (funcall param-thunk ctx)))
1806 (funcall body-thunk ctx))))
1807 "template: match = ~s name = ~s" match name))
1808 (n-variables (length *lexical-variable-declarations*)))
1809 (append
1810 (when name
1811 (multiple-value-bind (local-name uri)
1812 (decode-qname name env nil)
1813 (list
1814 (make-template :name (cons local-name uri)
1815 :import-priority *import-priority*
1816 :apply-imports-limit *apply-imports-limit*
1817 :params param-bindings
1818 :body outer-body-thunk
1819 :n-variables n-variables))))
1820 (when match
1821 (mapcar (lambda (expression)
1822 (let* ((compiled-pattern
1823 (xslt-trace-thunk
1824 (car (without-xslt-current ()
1825 (xpath:compute-patterns
1826 `(:patterns ,expression)
1828 :dummy
1829 env)))
1830 "match-thunk for template (match ~s): ~s --> ~s"
1831 match expression :result))
1832 (p (if priority
1833 (xpath::parse-xnum priority)
1834 (expression-priority expression)))
1836 (progn
1837 (unless (and (numberp p)
1838 (not (xpath::inf-p p))
1839 (not (xpath::nan-p p)))
1840 (xslt-error "failed to parse priority"))
1841 (float p 1.0d0)))
1842 (template
1843 (make-template :match-expression expression
1844 :compiled-pattern compiled-pattern
1845 :import-priority *import-priority*
1846 :apply-imports-limit *apply-imports-limit*
1847 :priority p
1848 :position position
1849 :mode-qname mode
1850 :params param-bindings
1851 :body outer-body-thunk
1852 :n-variables n-variables)))
1853 (setf (xpath:pattern-value compiled-pattern)
1854 template)
1855 template))
1856 (cdr (xpath:parse-pattern-expression match)))))))))
1857 #+(or)
1858 (xuriella::parse-stylesheet #p"/home/david/src/lisp/xuriella/test.xsl")