xslt.lisp

   1 ;;; -*- show-trailing-whitespace: t; indent-tabs-mode: nil -*-
   2
   3 ;;; Copyright (c) 2007,2008 David Lichteblau, Ivan Shvedunov.
   4 ;;; All rights reserved.
   5
   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.
  29
  30 (in-package :xuriella)
  31
  32 #+sbcl
  33 (declaim (optimize (debug 2)))
  34
  35
  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"))
  40
  41
  42 ;;;; XSLT-ERROR
  43
  44 (define-condition xslt-error (simple-error)
  45   ()
  46   (:documentation "The class of all XSLT errors."))
  47
  48 (define-condition recoverable-xslt-error (xslt-error)
  49   ()
  50   (:documentation "The class of recoverable XSLT errors."))
  51
  52 (defun xslt-error (fmt &rest args)
  53   (error 'xslt-error :format-control fmt :format-arguments args))
  54
  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.
  59 ;;
  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.
  63 ;;
  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)))
  73
  74 (defvar *debug* nil)
  75
  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)))))
  88
  89 (defmacro with-resignalled-errors ((&optional) &body body)
  90   `(invoke-with-resignalled-errors (lambda () ,@body)))
  91
  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)))
 101
 102 (defun compile-xpath (xpath &optional env)
 103   (with-resignalled-errors ()
 104     (xpath:compile-xpath xpath env)))
 105
 106 (defmacro with-stack-limit ((&optional) &body body)
 107   `(invoke-with-stack-limit (lambda () ,@body)))
 108
 109 (defparameter *without-xslt-current-p* nil)
 110
 111 (defmacro without-xslt-current ((&optional) &body body)
 112   `(invoke-without-xslt-current (lambda () ,@body)))
 113
 114 (defun invoke-without-xslt-current (fn)
 115   (let ((*without-xslt-current-p* t))
 116     (funcall fn)))
 117
 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)))
 125
 126
 127 ;;;; Helper functions and macros
 128
 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)))
 141
 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))))
 159
 160 (defun map-pipe-eagerly (fn pipe)
 161   (xpath::enumerate pipe :key fn :result nil))
 162
 163 (defmacro do-pipe ((var pipe &optional result) &body body)
 164   `(block nil
 165      (map-pipe-eagerly #'(lambda (,var) ,@body) ,pipe)
 166      ,result))
 167
 168
 169 ;;;; XSLT-ENVIRONMENT and XSLT-CONTEXT
 170
 171 (defparameter *namespaces*
 172   '((nil . "")
 173     ("xmlns" . #"http://www.w3.org/2000/xmlns/")
 174     ("xml" . #"http://www.w3.org/XML/1998/namespace")))
 175
 176 (defvar *global-variable-declarations*)
 177 (defvar *lexical-variable-declarations*)
 178
 179 (defvar *global-variable-values*)
 180 (defvar *lexical-variable-values*)
 181
 182 (defclass xslt-environment () ())
 183
 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.
 192             ;;
 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))))
 200
 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 ""))
 209                 "")
 210             prefix)))
 211
 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)))))
 221
 222 (defun find-variable-index (local-name uri table)
 223   (position (cons local-name uri) table :test 'equal))
 224
 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*)))
 228
 229 (defun push-variable (local-name uri table)
 230   (prog1
 231       (length table)
 232     (vector-push-extend (cons local-name uri) table)))
 233
 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))
 239
 240 (defun (setf lexical-variable-value) (newval index)
 241   (assert (not (eq newval 'unbound)))
 242   (setf (svref *lexical-variable-values* index) newval))
 243
 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))
 249
 250 (defun (setf global-variable-value) (newval index)
 251   (assert (not (eq newval 'unbound)))
 252   (setf (svref *global-variable-values* index) newval))
 253
 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)))
 260
 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)))))
 269
 270 (defclass lexical-xslt-environment (xslt-environment) ())
 271
 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)))))
 283
 284 (defclass key-environment (xslt-environment) ())
 285
 286 (defmethod xpath-sys:environment-find-variable
 287     ((env key-environment) lname uri)
 288   (declare (ignore lname uri))
 289   (xslt-error "disallowed variable reference"))
 290
 291 (defclass global-variable-environment (xslt-environment)
 292   ((initial-global-variable-thunks
 293     :initarg :initial-global-variable-thunks
 294     :accessor initial-global-variable-thunks)))
 295
 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))))
 300
 301
 302 ;;;; TOPLEVEL-TEXT-OUTPUT-SINK
 303 ;;;;
 304 ;;;; A sink that serializes only text not contained in any element.
 305
 306 (defmacro with-toplevel-text-output-sink ((var) &body body)
 307   `(invoke-with-toplevel-text-output-sink (lambda (,var) ,@body)))
 308
 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)))
 312
 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)))
 317
 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))))
 321
 322 (defmethod sax:unescaped ((sink toplevel-text-output-sink) data)
 323   (sax:characters sink data))
 324
 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)))
 329
 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))))
 333
 334
 335 ;;;; TEXT-FILTER
 336 ;;;;
 337 ;;;; A sink that passes through only text (at any level) and turns to
 338 ;;;; into unescaped characters.
 339
 340 (defclass text-filter (sax:default-handler)
 341   ((target :initarg :target :accessor text-filter-target)))
 342
 343 (defmethod sax:characters ((sink text-filter) data)
 344   (sax:unescaped (text-filter-target sink) data))
 345
 346 (defmethod sax:unescaped ((sink text-filter) data)
 347   (sax:unescaped (text-filter-target sink) data))
 348
 349 (defmethod sax:end-document ((sink text-filter))
 350   (sax:end-document (text-filter-target sink)))
 351
 352 (defun make-text-filter (target)
 353   (make-instance 'text-filter :target target))
 354
 355
 356 ;;;; ESCAPER
 357 ;;;;
 358 ;;;; A sink that recovers from sax:unescaped using sax:characters, as per
 359 ;;;; XSLT 16.4.
 360
 361 (defclass escaper (cxml:broadcast-handler)
 362   ())
 363
 364 (defmethod sax:unescaped ((sink escaper) data)
 365   (sax:characters sink data))
 366
 367 (defun make-escaper (target)
 368   (make-instance 'escaper :handlers (list target)))
 369
 370
 371 ;;;; Names
 372
 373 (defun of-name (local-name)
 374   (stp:of-name local-name *xsl*))
 375
 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)))
 380
 381
 382 ;;;; PARSE-STYLESHEET
 383
 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)))
 396
 397 (defstruct mode
 398   (templates nil)
 399   (match-thunk (lambda (ignore) (declare (ignore ignore)) nil)))
 400
 401 (defun find-mode (stylesheet local-name &optional uri)
 402   (gethash (cons local-name uri) (stylesheet-modes stylesheet)))
 403
 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))))
 408
 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)))
 415
 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)
 421
 422 (defun find-key (name stylesheet)
 423   (or (gethash name (stylesheet-keys stylesheet))
 424       (xslt-error "unknown key: ~a" name)))
 425
 426 (defun make-key (match use) (cons match use))
 427
 428 (defun key-match (key) (car key))
 429
 430 (defun key-use (key) (cdr key))
 431
 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))))
 437
 438 (defvar *excluded-namespaces* (list *xsl*))
 439 (defvar *empty-mode*)
 440 (defvar *default-mode*)
 441
 442 (defvar *xsl-include-stack* nil)
 443
 444 (defun uri-to-pathname (uri)
 445   (cxml::uri-to-pathname (puri:parse-uri uri)))
 446
 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")))))))
 468
 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))
 482
 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>))
 532
 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*)
 538
 539 (defmacro do-toplevel ((var xpath <transform>) &body body)
 540   `(map-toplevel (lambda (,var) ,@body) ,xpath ,<transform>))
 541
 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))))
 549
 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>))))
 559
 560 (defmacro with-import-magic ((node env) &body body)
 561   `(invoke-with-import-magic (lambda () ,@body) ,node ,env))
 562
 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)))
 573
 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))))))))
 631
 632 (defvar *xsl-import-stack* nil)
 633
 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)))))
 656
 657 (defvar *included-attribute-sets*)
 658
 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)
 688            do
 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))))
 700
 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"))
 741                                        env
 742                                        nil)
 743                        (cons local-name uri))
 744                      (stylesheet-attribute-sets stylesheet))))))
 745
 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")
 755                  ""
 756                  (xpath-sys:environment-find-namespace env stylesheet-prefix))
 757              (stylesheet-namespace-aliases stylesheet))
 758             (xpath-sys:environment-find-namespace
 759              env
 760              (if (equal result-prefix "#default")
 761                  ""
 762                  result-prefix))))))
 763
 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)
 779         elt
 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)))))))
 816
 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*))))
 828
 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*))))))
 843
 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)))))
 869
 870 (defstruct strip-test
 871   compiled-pattern
 872   priority
 873   position
 874   value)
 875
 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))))
 902
 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)
 912
 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))))))))
 948
 949 (defun make-empty-declaration-array ()
 950   (make-array 1 :fill-pointer 0 :adjustable t))
 951
 952 (defun make-variable-value-array (n-lexical-variables)
 953   (make-array n-lexical-variables :initial-element 'unbound))
 954
 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))))
 968                     (t
 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))))
 979
 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)
 988
 989 (defstruct (import-variable
 990              (:constructor make-variable)
 991              (:conc-name "VARIABLE-"))
 992   value-thunk
 993   value-thunk-setter
 994   param-p)
 995
 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)))
1037                         (t
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)
1048                            (fn
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))))))
1060
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)))))))))
1077
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)))))
1113
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))))
1136
1137
1138 ;;;; APPLY-STYLESHEET
1139
1140 (defvar *stylesheet*)
1141
1142 (deftype xml-designator () '(or runes:xstream runes:rod array stream pathname))
1143
1144 (defun unalias-uri (uri)
1145   (let ((result
1146          (gethash uri (stylesheet-namespace-aliases *stylesheet*)
1147                   uri)))
1148     (check-type result string)
1149     result))
1150
1151 (defstruct (parameter
1152              (:constructor make-parameter (value local-name &optional uri)))
1153   (uri "")
1154   local-name
1155   value)
1156
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)))))
1162
1163 (defvar *uri-resolver*)
1164
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)))
1172
1173 (defvar *documents*)
1174
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))
1202
1203 (xpath-sys:define-extension xslt *xsl*)
1204
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)
1215      (t
1216       (xpath-protocol:parent-node node)))))
1217
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))))))))
1239
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)))))))))
1271
1272 ;; FIXME: add alias mechanism for XPath extensions in order to avoid duplication
1273
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))))
1282
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           "")))
1288
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.
1306       ;;
1307       ;; This might be pointless premature optimization, but I like the idea :-)
1308       (nreverse (concatenate 'string highest-base-uri "//" id)))))
1309
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)))))
1316
1317 (declaim (special *available-instructions*))
1318
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))))))
1328
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))))))
1339
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")
1354                 (t
1355                  ""))
1356               ""))))))
1357
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)))
1419
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)))
1423
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
1435        do
1436          (apply-templates (xpath:make-context child s/d i)
1437                           :param-bindings param-bindings
1438                           :mode mode))))
1439
1440 (defvar *stack-limit* 200)
1441
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)))
1447
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)
1458          do
1459            (when index
1460              (setf (lexical-variable-value index) value)))
1461       (funcall (template-body template) ctx))))
1462
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)))
1471       (t
1472        (apply-templates/list
1473         (xpath::force
1474          (xpath-protocol:child-pipe node))
1475         :mode mode)))))
1476
1477 (defvar *apply-imports*)
1478
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))))
1494
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))))
1501
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))))
1509
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))
1519               0))
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)))
1530
1531 (defun find-named-templates (name)
1532   (gethash name (stylesheet-named-templates *stylesheet*)))
1533
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)
1540       (t
1541        (xslt-cerror "conflicting templates:~_~A,~_~A"
1542                     (template-match-expression a)
1543                     (template-match-expression b))
1544        (< (template-position a) (template-position b))))))
1545
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)))
1553
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)))))
1574
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           (equal (output-omit-xml-declaration output-spec) "yes"))
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)
1618           (t
1619            (make-auto-detect-sink (make-combi-sink) method-key)))))))
1620
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)
1634
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)
1652             (t
1653              -0.5)))
1654         0.5)))
1655
1656 (defun parse-xpath (str)
1657   (with-resignalled-errors ()
1658     (xpath:parse-xpath str)))
1659
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))))
1670
1671 (defun parse-pattern (str)
1672   (with-resignalled-errors ()
1673     (cdr (xpath::parse-pattern-expression str))))
1674
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)))
1681
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
1690                            uri
1691                            *lexical-variable-declarations*)
1692             thunk))))
1693
1694 (defun compile-var-bindings (forms env)
1695   (loop
1696      for (name value) in forms
1697      collect (compile-var-binding name value env)))
1698
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)
1745                                       42
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)))
1753                             (p
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")