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