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