xslt.lisp

   1 ;;; -*- show-trailing-whitespace: t; indent-tabs: 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 ;;;; XSLT-ERROR
  37
  38 (define-condition xslt-error (simple-error)
  39   ()
  40   (:documentation "The class of all XSLT errors."))
  41
  42 (defun xslt-error (fmt &rest args)
  43   (error 'xslt-error :format-control fmt :format-arguments args))
  44
  45 (defun xslt-cerror (fmt &rest args)
  46   (with-simple-restart (recover "recover")
  47     (error 'xslt-error :format-control fmt :format-arguments args)))
  48
  49 (defvar *debug* nil)
  50
  51 (defmacro handler-case* (form &rest clauses)
  52   ;; like HANDLER-CASE if *DEBUG* is off.  If it's on, don't establish
  53   ;; a handler at all so that we see the real stack traces.  (We could use
  54   ;; HANDLER-BIND here and check at signalling time, but doesn't seem
  55   ;; important.)
  56   (let ((doit (gensym)))
  57     `(flet ((,doit () ,form))
  58        (if *debug*
  59            (,doit)
  60            (handler-case
  61                (,doit)
  62              ,@clauses)))))
  63
  64 (defun compile-xpath (xpath &optional env)
  65   (handler-case*
  66       (xpath:compile-xpath xpath env)
  67     (xpath:xpath-error (c)
  68       (xslt-error "~A" c))))
  69
  70 (defmacro with-stack-limit ((&optional) &body body)
  71   `(invoke-with-stack-limit (lambda () ,@body)))
  72
  73
  74 ;;;; Helper function and macro
  75
  76 (defun map-pipe-eagerly (fn pipe)
  77   (xpath::enumerate pipe :key fn :result nil))
  78
  79 (defmacro do-pipe ((var pipe &optional result) &body body)
  80   `(block nil
  81      (map-pipe-eagerly #'(lambda (,var) ,@body) ,pipe)
  82      ,result))
  83
  84
  85 ;;;; XSLT-ENVIRONMENT and XSLT-CONTEXT
  86
  87 (defparameter *initial-namespaces*
  88   '((nil . "")
  89     ("xmlns" . #"http://www.w3.org/2000/xmlns/")
  90     ("xml" . #"http://www.w3.org/XML/1998/namespace")))
  91
  92 (defparameter *namespaces* *initial-namespaces*)
  93
  94 (defvar *global-variable-declarations*)
  95 (defvar *lexical-variable-declarations*)
  96
  97 (defvar *global-variable-values*)
  98 (defvar *lexical-variable-values*)
  99
 100 (defclass xslt-environment () ())
 101
 102 (defun split-qname (str)
 103   (handler-case
 104       (multiple-value-bind (prefix local-name)
 105           (cxml::split-qname str)
 106         (unless
 107             ;; FIXME: cxml should really offer a function that does
 108             ;; checks for NCName and QName in a sensible way for user code.
 109             ;; cxml::split-qname is tailored to the needs of the parser.
 110             ;;
 111             ;; For now, let's just check the syntax explicitly.
 112             (and (or (null prefix) (xpath::nc-name-p prefix))
 113                  (xpath::nc-name-p local-name))
 114           (xslt-error "not a qname: ~A" str))
 115         (values prefix local-name))
 116     (cxml:well-formedness-violation ()
 117       (xslt-error "not a qname: ~A" str))))
 118
 119 (defun decode-qname (qname env attributep)
 120   (multiple-value-bind (prefix local-name)
 121       (split-qname qname)
 122     (values local-name
 123             (if (or prefix (not attributep))
 124                 (xpath:environment-find-namespace env prefix)
 125                 "")
 126             prefix)))
 127
 128 (defmethod xpath:environment-find-namespace ((env xslt-environment) prefix)
 129   (cdr (assoc prefix *namespaces* :test 'equal)))
 130
 131 (defun find-variable-index (local-name uri table)
 132   (position (cons local-name uri) table :test 'equal))
 133
 134 (defun intern-global-variable (local-name uri)
 135   (or (find-variable-index local-name uri *global-variable-declarations*)
 136       (push-variable local-name uri *global-variable-declarations*)))
 137
 138 (defun push-variable (local-name uri table)
 139   (prog1
 140       (length table)
 141     (vector-push-extend (cons local-name uri) table)))
 142
 143 (defun lexical-variable-value (index &optional (errorp t))
 144   (let ((result (svref *lexical-variable-values* index)))
 145     (when errorp
 146       (assert (not (eq result 'unbound))))
 147     result))
 148
 149 (defun (setf lexical-variable-value) (newval index)
 150   (assert (not (eq newval 'unbound)))
 151   (setf (svref *lexical-variable-values* index) newval))
 152
 153 (defun global-variable-value (index &optional (errorp t))
 154   (let ((result (svref *global-variable-values* index)))
 155     (when errorp
 156       (assert (not (eq result 'unbound))))
 157     result))
 158
 159 (defun (setf global-variable-value) (newval index)
 160   (assert (not (eq newval 'unbound)))
 161   (setf (svref *global-variable-values* index) newval))
 162
 163 (defmethod xpath:environment-find-variable
 164     ((env xslt-environment) lname uri)
 165   (let ((index
 166          (find-variable-index lname uri *lexical-variable-declarations*)))
 167     (when index
 168       (lambda (ctx)
 169         (declare (ignore ctx))
 170         (svref *lexical-variable-values* index)))))
 171
 172 (defclass lexical-xslt-environment (xslt-environment) ())
 173
 174 (defmethod xpath:environment-find-variable
 175     ((env lexical-xslt-environment) lname uri)
 176   (or (call-next-method)
 177       (let ((index
 178              (find-variable-index lname uri *global-variable-declarations*)))
 179         (when index
 180           (lambda (ctx)
 181             (declare (ignore ctx))
 182             (svref *global-variable-values* index))))))
 183
 184 (defclass global-variable-environment (xslt-environment)
 185   ((initial-global-variable-thunks
 186     :initarg :initial-global-variable-thunks
 187     :accessor initial-global-variable-thunks)))
 188
 189 (defmethod xpath:environment-find-variable
 190     ((env global-variable-environment) lname uri)
 191   (or (call-next-method)
 192       (gethash (cons lname uri) (initial-global-variable-thunks env))))
 193
 194
 195 ;;;; TEXT-OUTPUT-SINK
 196 ;;;;
 197 ;;;; A sink that serializes only text and will error out on any other
 198 ;;;; SAX event.
 199
 200 (defmacro with-text-output-sink ((var) &body body)
 201   `(invoke-with-text-output-sink (lambda (,var) ,@body)))
 202
 203 (defclass text-output-sink (sax:default-handler)
 204   ((target :initarg :target :accessor text-output-sink-target)))
 205
 206 (defmethod sax:characters ((sink text-output-sink) data)
 207   (write-string data (text-output-sink-target sink)))
 208
 209 (defun invoke-with-text-output-sink (fn)
 210   (with-output-to-string (s)
 211     (funcall fn (make-instance 'text-output-sink :target s))))
 212
 213
 214 ;;;; Names
 215
 216 (eval-when (:compile-toplevel :load-toplevel :execute)
 217   (defvar *xsl* "http://www.w3.org/1999/XSL/Transform")
 218   (defvar *xml* "http://www.w3.org/XML/1998/namespace")
 219   (defvar *html* "http://www.w3.org/1999/xhtml"))
 220
 221 (defun of-name (local-name)
 222   (stp:of-name local-name *xsl*))
 223
 224 (defun namep (node local-name)
 225   (and (typep node '(or stp:element stp:attribute))
 226        (equal (stp:namespace-uri node) *xsl*)
 227        (equal (stp:local-name node) local-name)))
 228
 229
 230 ;;;; PARSE-STYLESHEET
 231
 232 (defstruct stylesheet
 233   (modes (make-hash-table :test 'equal))
 234   (global-variables ())
 235   (output-specification (make-output-specification))
 236   (strip-tests nil)
 237   (named-templates (make-hash-table :test 'equal))
 238   (attribute-sets (make-hash-table :test 'equal)))
 239
 240 (defstruct mode (templates nil))
 241
 242 (defun find-mode (stylesheet local-name &optional uri)
 243   (gethash (cons local-name uri) (stylesheet-modes stylesheet)))
 244
 245 (defun ensure-mode (stylesheet &optional local-name uri)
 246   (or (find-mode stylesheet local-name uri)
 247       (setf (gethash (cons local-name uri) (stylesheet-modes stylesheet))
 248             (make-mode))))
 249
 250 (defun ensure-mode/qname (stylesheet qname env)
 251   (if qname
 252       (multiple-value-bind (local-name uri)
 253           (decode-qname qname env nil)
 254         (ensure-mode stylesheet local-name uri))
 255       (find-mode stylesheet nil)))
 256
 257 (defun acons-namespaces (element &optional (bindings *namespaces*))
 258   (map-namespace-declarations (lambda (prefix uri)
 259                                 (push (cons prefix uri) bindings))
 260                               element)
 261   bindings)
 262
 263 (defvar *excluded-namespaces* (list *xsl*))
 264 (defvar *empty-mode*)
 265
 266 (defvar *xsl-include-stack* nil)
 267
 268 (defun parse-stylesheet-to-stp (input uri-resolver)
 269   (let* ((d (cxml:parse input (make-text-normalizer (cxml-stp:make-builder))))
 270          (<transform> (stp:document-element d)))
 271     (strip-stylesheet <transform>)
 272     ;; FIXME: handle embedded stylesheets
 273     (unless (and (equal (stp:namespace-uri <transform>) *xsl*)
 274                  (or (equal (stp:local-name <transform>) "transform")
 275                      (equal (stp:local-name <transform>) "stylesheet")))
 276       (xslt-error "not a stylesheet"))
 277     (dolist (include (stp:filter-children (of-name "include") <transform>))
 278       (let* ((uri (puri:merge-uris (stp:attribute-value include "href")
 279                                    (stp:base-uri include)))
 280              (uri (if uri-resolver
 281                       (funcall uri-resolver (puri:render-uri uri nil))
 282                       uri))
 283              (str (puri:render-uri uri nil))
 284              (pathname
 285               (handler-case
 286                   (cxml::uri-to-pathname uri)
 287                 (cxml:xml-parse-error (c)
 288                   (xslt-error "cannot find included stylesheet ~A: ~A"
 289                               uri c)))))
 290         (with-open-file
 291             (stream pathname
 292                     :element-type '(unsigned-byte 8)
 293                     :if-does-not-exist nil)
 294           (unless stream
 295             (xslt-error "cannot find included stylesheet ~A at ~A"
 296                         uri pathname))
 297           (when (find str *xsl-include-stack* :test #'equal)
 298             (xslt-error "recursive inclusion of ~A" uri))
 299           (let* ((*xsl-include-stack* (cons str *xsl-include-stack*))
 300                  (<transform>2 (parse-stylesheet-to-stp stream uri-resolver)))
 301             (stp:do-children (child <transform>2)
 302               (stp:insert-child-after <transform>
 303                                       (stp:copy child)
 304                                       include))
 305             (stp:detach include)))))
 306     <transform>))
 307
 308 (defvar *instruction-base-uri*)
 309 (defvar *apply-imports-limit*)
 310 (defvar *import-priority*)
 311
 312 (defun parse-1-stylesheet (env stylesheet designator uri-resolver)
 313   (let* ((<transform> (parse-stylesheet-to-stp designator uri-resolver))
 314          (*instruction-base-uri* (stp:base-uri <transform>))
 315          (*namespaces* (acons-namespaces <transform>))
 316          (*apply-imports-limit* (1+ *import-priority*)))
 317     (dolist (import (stp:filter-children (of-name "import") <transform>))
 318       (let ((uri (puri:merge-uris (stp:attribute-value import "href")
 319                                   (stp:base-uri import))))
 320         (parse-imported-stylesheet env stylesheet uri uri-resolver)))
 321     (incf *import-priority*)
 322     (parse-exclude-result-prefixes! <transform> env)
 323     (parse-global-variables! stylesheet <transform>)
 324     (parse-templates! stylesheet <transform> env)
 325     (parse-output! stylesheet <transform>)
 326     (parse-strip/preserve-space! stylesheet <transform> env)
 327     (parse-attribute-sets! stylesheet <transform> env)))
 328
 329 (defvar *xsl-import-stack* nil)
 330
 331 (defun parse-imported-stylesheet (env stylesheet uri uri-resolver)
 332   (let* ((uri (if uri-resolver
 333                   (funcall uri-resolver (puri:render-uri uri nil))
 334                   uri))
 335          (str (puri:render-uri uri nil))
 336          (pathname
 337           (handler-case
 338               (cxml::uri-to-pathname uri)
 339             (cxml:xml-parse-error (c)
 340               (xslt-error "cannot find imported stylesheet ~A: ~A"
 341                           uri c)))))
 342     (with-open-file
 343         (stream pathname
 344                 :element-type '(unsigned-byte 8)
 345                 :if-does-not-exist nil)
 346       (unless stream
 347         (xslt-error "cannot find imported stylesheet ~A at ~A"
 348                     uri pathname))
 349       (when (find str *xsl-import-stack* :test #'equal)
 350         (xslt-error "recursive inclusion of ~A" uri))
 351       (let ((*xsl-import-stack* (cons str *xsl-import-stack*)))
 352         (parse-1-stylesheet env stylesheet stream uri-resolver)))))
 353
 354 (defun parse-stylesheet (designator &key uri-resolver)
 355   (let* ((*import-priority* 0)
 356          (puri:*strict-parse* nil)
 357          (stylesheet (make-stylesheet))
 358          (env (make-instance 'lexical-xslt-environment))
 359          (*excluded-namespaces* *excluded-namespaces*)
 360          (*global-variable-declarations* (make-empty-declaration-array)))
 361     (ensure-mode stylesheet nil)
 362     (parse-1-stylesheet env stylesheet designator uri-resolver)
 363     stylesheet))
 364
 365 (defun parse-attribute-sets! (stylesheet <transform> env)
 366   (dolist (elt (stp:filter-children (of-name "attribute-set") <transform>))
 367     (push (let* ((sets
 368                   (mapcar (lambda (qname)
 369                             (multiple-value-list (decode-qname qname env nil)))
 370                           (words
 371                            (stp:attribute-value elt "use-attribute-sets"))))
 372                  (instructions
 373                   (stp:map-children 'list #'parse-instruction elt))
 374                  (thunk
 375                   (compile-instruction `(progn ,@instructions) env)))
 376             (lambda (ctx)
 377               (with-stack-limit ()
 378                 (loop for (local-name uri nil) in sets do
 379                      (dolist (thunk (find-attribute-set local-name uri))
 380                        (funcall thunk ctx)))
 381                 (funcall thunk ctx))))
 382           (gethash (multiple-value-bind (local-name uri)
 383                        (decode-qname (stp:attribute-value elt "name") env nil)
 384                      (cons local-name uri))
 385                    (stylesheet-attribute-sets stylesheet)))))
 386
 387 (defun parse-exclude-result-prefixes! (<transform> env)
 388   (stp:with-attributes (exclude-result-prefixes) <transform>
 389       (dolist (prefix (words (or exclude-result-prefixes "")))
 390     (when (equal prefix "#default")
 391       (setf prefix nil))
 392     (push (or (xpath:environment-find-namespace env prefix)
 393               (xslt-error "namespace not found: ~A" prefix))
 394           *excluded-namespaces*))))
 395
 396 (xpath:with-namespaces ((nil #.*xsl*))
 397   (defun parse-strip/preserve-space! (stylesheet <transform> env)
 398     (dolist (elt (stp:filter-children (lambda (x)
 399                                         (or (namep x "strip-space")
 400                                             (namep x "preserve-space")))
 401                                       <transform>))
 402       (let ((*namespaces* (acons-namespaces elt))
 403             (mode
 404              (if (equal (stp:local-name elt) "strip-space")
 405                  :strip
 406                  :preserve)))
 407         (dolist (name-test (words (stp:attribute-value elt "elements")))
 408           (let* ((pos (search ":*" name-test))
 409                  (test-function
 410                   (cond
 411                     ((eql pos (- (length name-test) 2))
 412                      (let* ((prefix (subseq name-test 0 pos))
 413                             (name-test-uri
 414                              (xpath:environment-find-namespace env prefix)))
 415                        (unless (xpath::nc-name-p prefix)
 416                          (xslt-error "not an NCName: ~A" prefix))
 417                        (lambda (local-name uri)
 418                          (declare (ignore local-name))
 419                          (if (equal uri name-test-uri)
 420                              mode
 421                              nil))))
 422                     ((equal name-test "*")
 423                      (lambda (local-name uri)
 424                        (declare (ignore local-name uri))
 425                        mode))
 426                     (t
 427                      (multiple-value-bind (name-test-local-name name-test-uri)
 428                          (decode-qname name-test env nil)
 429                        (lambda (local-name uri)
 430                          (if (and (equal local-name name-test-local-name)
 431                                   (equal uri name-test-uri))
 432                              mode
 433                              nil)))))))
 434             (push test-function (stylesheet-strip-tests stylesheet))))))))
 435
 436 (defstruct (output-specification
 437              (:conc-name "OUTPUT-"))
 438   method
 439   indent
 440   omit-xml-declaration
 441   encoding)
 442
 443 (defun parse-output! (stylesheet <transform>)
 444   (let ((outputs (stp:filter-children (of-name "output") <transform>)))
 445     (when outputs
 446       (when (cdr outputs)
 447         ;; FIXME:
 448         ;;   - concatenate cdata-section-elements
 449         ;;   - the others must not conflict
 450         (error "oops, merging of output elements not supported yet"))
 451       (let ((<output> (car outputs))
 452             (spec (stylesheet-output-specification stylesheet)))
 453         (stp:with-attributes (;; version
 454                               method
 455                               indent
 456                               encoding
 457 ;;;                           media-type
 458 ;;;                           doctype-system
 459 ;;;                           doctype-public
 460                               omit-xml-declaration
 461 ;;;                           standalone
 462 ;;;                           cdata-section-elements
 463                               )
 464             <output>
 465           (setf (output-method spec) method)
 466           (setf (output-indent spec) indent)
 467           (setf (output-encoding spec) encoding)
 468           (setf (output-omit-xml-declaration spec) omit-xml-declaration))))))
 469
 470 (defun make-empty-declaration-array ()
 471   (make-array 1 :fill-pointer 0 :adjustable t))
 472
 473 (defun make-variable-value-array (n-lexical-variables)
 474   (make-array n-lexical-variables :initial-element 'unbound))
 475
 476 (defun compile-global-variable (<variable> env) ;; also for <param>
 477   (stp:with-attributes (name select) <variable>
 478     (when (and select (stp:list-children <variable>))
 479       (xslt-error "variable with select and body"))
 480     (let* ((*lexical-variable-declarations* (make-empty-declaration-array))
 481            (inner (cond
 482                     (select
 483                      (compile-xpath select env))
 484                     ((stp:list-children <variable>)
 485                      (let* ((inner-sexpr `(progn ,@(parse-body <variable>)))
 486                             (inner-thunk (compile-instruction inner-sexpr env)))
 487                        (lambda (ctx)
 488                          (apply-to-result-tree-fragment ctx inner-thunk))))
 489                     (t
 490                      (lambda (ctx)
 491                        (declare (ignore ctx))
 492                        ""))))
 493            (n-lexical-variables (length *lexical-variable-declarations*)))
 494       (lambda (ctx)
 495         (let ((*lexical-variable-values*
 496                (make-variable-value-array n-lexical-variables)))
 497           (funcall inner ctx))))))
 498
 499 (defstruct (variable-information
 500              (:constructor make-variable)
 501              (:conc-name "VARIABLE-"))
 502   index
 503   thunk
 504   local-name
 505   uri
 506   param-p
 507   thunk-setter)
 508
 509 (defun parse-global-variable! (<variable> global-env) ;; also for <param>
 510   (let ((*namespaces* (acons-namespaces <variable>))
 511         (qname (stp:attribute-value <variable> "name")))
 512     (unless qname
 513       (xslt-error "name missing in ~A" (stp:local-name <variable>)))
 514     (multiple-value-bind (local-name uri)
 515         (decode-qname qname global-env nil)
 516       ;; For the normal compilation environment of templates, install it
 517       ;; into *GLOBAL-VARIABLE-DECLARATIONS*:
 518       (let ((index (intern-global-variable local-name uri)))
 519         ;; For the evaluation of a global variable itself, build a thunk
 520         ;; that lazily resolves other variables, stored into
 521         ;; INITIAL-GLOBAL-VARIABLE-THUNKS:
 522         (let* ((value-thunk :unknown)
 523                (global-variable-thunk
 524                 (lambda (ctx)
 525                   (let ((v (global-variable-value index nil)))
 526                     (when (eq v 'seen)
 527                       (xslt-error "recursive variable definition"))
 528                     (cond
 529                       ((eq v 'unbound)
 530                        ;; (print (list :computing index))
 531                        (setf (global-variable-value index) 'seen)
 532                        (setf (global-variable-value index)
 533                              (funcall value-thunk ctx))
 534                        #+nil (print (list :done-computing index
 535                                     (global-variable-value index)))
 536                        #+nil (global-variable-value index))
 537                       (t
 538                        #+nil(print (list :have
 539                                     index v))
 540                        v)))))
 541                (thunk-setter
 542                 (lambda ()
 543                   (setf value-thunk
 544                         (compile-global-variable <variable> global-env)))))
 545           (setf (gethash (cons local-name uri)
 546                          (initial-global-variable-thunks global-env))
 547                 global-variable-thunk)
 548           (make-variable :index index
 549                          :local-name local-name
 550                          :uri uri
 551                          :thunk global-variable-thunk
 552                          :param-p (namep <variable> "param")
 553                          :thunk-setter thunk-setter))))))
 554
 555 (xpath:with-namespaces ((nil #.*xsl*))
 556   (defun parse-global-variables! (stylesheet <transform>)
 557     (let* ((table (make-hash-table :test 'equal))
 558            (global-env (make-instance 'global-variable-environment
 559                                       :initial-global-variable-thunks table))
 560            (specs '()))
 561       (xpath:do-node-set
 562           (<variable> (xpath:evaluate "variable|param" <transform>))
 563         (let ((var (parse-global-variable! <variable> global-env)))
 564           (when (find var
 565                       specs
 566                       :test (lambda (a b)
 567                               (and (equal (variable-local-name a)
 568                                           (variable-local-name b))
 569                                    (equal (variable-uri a)
 570                                           (variable-uri b)))))
 571             (xslt-error "duplicate definition for global variable ~A"
 572                         (variable-local-name var)))
 573           (push var specs)))
 574       ;; now that the global environment knows about all variables, run the
 575       ;; thunk setters to perform their compilation
 576       (mapc (lambda (spec) (funcall (variable-thunk-setter spec))) specs)
 577       (setf (stylesheet-global-variables stylesheet) specs))))
 578
 579 (defun parse-templates! (stylesheet <transform> env)
 580   (dolist (<template> (stp:filter-children (of-name "template") <transform>))
 581     (let ((*namespaces* (acons-namespaces <template>)))
 582       (dolist (template (compile-template <template> env))
 583         (let ((name (template-name template)))
 584           (if name
 585               (let* ((table (stylesheet-named-templates stylesheet))
 586                      (head (car (gethash name table))))
 587                 (when (and head (eql (template-import-priority head)
 588                                      (template-import-priority template)))
 589                   ;; fixme: is this supposed to be a run-time error?
 590                   (xslt-error "conflicting templates for ~A" name))
 591                 (push template (gethash name table)))
 592               (let ((mode (ensure-mode/qname stylesheet
 593                                              (template-mode-qname template)
 594                                              env)))
 595                 (setf (template-mode template) mode)
 596                 (push template (mode-templates mode)))))))))
 597
 598
 599 ;;;; APPLY-STYLESHEET
 600
 601 (defvar *stylesheet*)
 602 (defvar *mode*)
 603
 604 (deftype xml-designator () '(or runes:xstream runes:rod array stream pathname))
 605
 606 (defstruct (parameter
 607              (:constructor make-parameter (value local-name &optional uri)))
 608   (uri "")
 609   local-name
 610   value)
 611
 612 (defun find-parameter-value (local-name uri parameters)
 613   (dolist (p parameters)
 614     (when (and (equal (parameter-local-name p) local-name)
 615                (equal (parameter-uri p) uri))
 616       (return (parameter-value p)))))
 617
 618 (defvar *uri-resolver*)
 619
 620 (defun parse-allowing-microsoft-bom (pathname handler)
 621   (with-open-file (s pathname :element-type '(unsigned-byte 8))
 622     (unless (and (eql (read-byte s nil) #xef)
 623                  (eql (read-byte s nil) #xbb)
 624                  (eql (read-byte s nil) #xbf))
 625       (file-position s 0))
 626     (cxml:parse s handler)))
 627
 628 (defun %document (uri-string base-uri)
 629   (let* ((absolute-uri
 630           (puri:merge-uris uri-string base-uri))
 631          (resolved-uri
 632           (if *uri-resolver*
 633               (funcall *uri-resolver* (puri:render-uri absolute-uri nil))
 634               absolute-uri))
 635          (pathname
 636           (handler-case
 637               (cxml::uri-to-pathname resolved-uri)
 638             (cxml:xml-parse-error (c)
 639               (xslt-error "cannot find referenced document ~A: ~A"
 640                           resolved-uri c))))
 641          (document
 642           (handler-case
 643               (parse-allowing-microsoft-bom pathname (stp:make-builder))
 644             ((or file-error cxml:xml-parse-error) (c)
 645               (xslt-error "cannot parse referenced document ~A: ~A"
 646                           pathname c))))
 647          (xpath-root-node
 648           (make-whitespace-stripper document
 649                                     (stylesheet-strip-tests *stylesheet*))))
 650     (when (puri:uri-fragment absolute-uri)
 651       (xslt-error "use of fragment identifiers in document() not supported"))
 652     (record-document-order xpath-root-node)
 653     xpath-root-node))
 654
 655 (xpath::define-xpath-function/lazy
 656     :document
 657     (object &optional node-set)
 658   (let ((instruction-base-uri *instruction-base-uri*))
 659     (lambda (ctx)
 660       (declare (ignore ctx))
 661       (let* ((object (funcall object))
 662              (node-set (and node-set (funcall node-set)))
 663              (uri
 664               (when node-set
 665                 ;; FIXME: should use first node of the node set
 666                 ;; _in document order_
 667                 (xpath-protocol:base-uri (xpath:first-node node-set)))))
 668         (xpath::make-node-set
 669          (if (xpath:node-set-p object)
 670              (xpath:map-node-set->list
 671               (lambda (node)
 672                 (%document (xpath:string-value node)
 673                            (or uri (xpath-protocol:base-uri node))))
 674               object)
 675              (list (%document (xpath:string-value object)
 676                               (or uri instruction-base-uri)))))))))
 677
 678 (defvar *document-order*)
 679
 680 (defun apply-stylesheet
 681     (stylesheet source-document &key output parameters uri-resolver)
 682   (when (typep stylesheet 'xml-designator)
 683     (setf stylesheet (parse-stylesheet stylesheet)))
 684   (when (typep source-document 'xml-designator)
 685     (setf source-document (cxml:parse source-document (stp:make-builder))))
 686   (invoke-with-output-sink
 687    (lambda ()
 688      (handler-case*
 689          (let* ((puri:*strict-parse* nil)
 690                 (*stylesheet* stylesheet)
 691                 (*mode* (find-mode stylesheet nil))
 692                 (*document-order* (make-hash-table))
 693                 (*empty-mode* (make-mode))
 694                 (global-variable-specs
 695                  (stylesheet-global-variables stylesheet))
 696                 (*global-variable-values*
 697                  (make-variable-value-array (length global-variable-specs)))
 698                 (*uri-resolver* uri-resolver)
 699                 (xpath-root-node
 700                  (make-whitespace-stripper
 701                   source-document
 702                   (stylesheet-strip-tests stylesheet)))
 703                 (ctx (xpath:make-context xpath-root-node)))
 704            (record-document-order xpath-root-node)
 705            (mapc (lambda (spec)
 706                    (when (variable-param-p spec)
 707                      (let ((value
 708                             (find-parameter-value (variable-local-name spec)
 709                                                   (variable-uri spec)
 710                                                   parameters)))
 711                        (when value
 712                          (setf (global-variable-value (variable-index spec))
 713                                value)))))
 714                  global-variable-specs)
 715            (mapc (lambda (spec)
 716                    (funcall (variable-thunk spec) ctx))
 717                  global-variable-specs)
 718            #+nil (print global-variable-specs)
 719            #+nil (print *global-variable-values*)
 720            (apply-templates ctx))
 721        (xpath:xpath-error (c)
 722                           (xslt-error "~A" c))))
 723    stylesheet
 724    output))
 725
 726 ;;; FIXME: this completely negates the benefits of doing whitespace stripping
 727 ;;; incrementally.  If we need to handle the ordering issues like this, we
 728 ;;; should also do whitespace stripping right here.
 729 (defun record-document-order (node)
 730   (let ((n (hash-table-count *document-order* )))
 731     (labels ((recurse (node)
 732                (setf (gethash node *document-order*) n)
 733                (incf n)
 734                (mapc #'recurse
 735                      (xpath::force
 736                       (xpath-protocol:namespace-pipe node)))
 737                (mapc #'recurse
 738                      (xpath::force
 739                       (xpath-protocol:attribute-pipe node)))
 740                (mapc #'recurse
 741                      (xpath::force
 742                       (xpath-protocol:child-pipe node)))))
 743       (recurse node))))
 744
 745 (defun document-order (node)
 746   (gethash node *document-order*))
 747
 748 (defun find-attribute-set (local-name uri)
 749   (or (gethash (cons local-name uri) (stylesheet-attribute-sets *stylesheet*))
 750       (xslt-error "no such attribute set: ~A/~A" local-name uri)))
 751
 752 (defun apply-templates/list (list &optional param-bindings sort-predicate)
 753   (when sort-predicate
 754     (setf list (sort list sort-predicate)))
 755   (let* ((n (length list))
 756          (s/d (lambda () n)))
 757     (loop
 758        for i from 1
 759        for child in list
 760        do
 761          (apply-templates (xpath:make-context child s/d i)
 762            param-bindings))))
 763
 764 (defvar *stack-limit* 200)
 765
 766 (defun invoke-with-stack-limit (fn)
 767   (let ((*stack-limit* (1- *stack-limit*)))
 768     (unless (plusp *stack-limit*)
 769       (xslt-error "*stack-limit* reached; stack overflow"))
 770     (funcall fn)))
 771
 772 (defun invoke-template (ctx template param-bindings)
 773   (let ((*lexical-variable-values*
 774          (make-variable-value-array (template-n-variables template))))
 775     (with-stack-limit ()
 776       (loop
 777          for (name-cons value) in param-bindings
 778          for (nil index nil) = (find name-cons
 779                                      (template-params template)
 780                                      :test #'equal
 781                                      :key #'car)
 782          do
 783          (unless index
 784            (xslt-error "invalid template parameter ~A" name-cons))
 785          (setf (lexical-variable-value index) value))
 786       (funcall (template-body template) ctx))))
 787
 788 (defun apply-default-templates (ctx)
 789   (let ((node (xpath:context-node ctx)))
 790     (cond
 791       ((or (xpath-protocol:node-type-p node :processing-instruction)
 792            (xpath-protocol:node-type-p node :comment)))
 793       ((or (xpath-protocol:node-type-p node :text)
 794            (xpath-protocol:node-type-p node :attribute))
 795        (write-text (xpath-protocol:string-value node)))
 796       (t
 797        (apply-templates/list
 798         (xpath::force
 799          (xpath-protocol:child-pipe node)))))))
 800
 801 (defvar *apply-imports*)
 802
 803 (defun apply-applicable-templates (ctx templates param-bindings finally)
 804   (labels ((apply-imports ()
 805              (if templates
 806                  (let* ((this (pop templates))
 807                         (low (template-apply-imports-limit this))
 808                         (high (template-import-priority this)))
 809                    (setf templates
 810                          (remove-if-not
 811                           (lambda (x)
 812                             (<= low (template-import-priority x) high))
 813                           templates))
 814                    (invoke-template ctx this param-bindings))
 815                  (funcall finally))))
 816     (let ((*apply-imports* #'apply-imports))
 817       (apply-imports))))
 818
 819 (defun apply-templates (ctx &optional param-bindings)
 820   (apply-applicable-templates ctx
 821                               (find-templates ctx)
 822                               param-bindings
 823                               (lambda ()
 824                                 (apply-default-templates ctx))))
 825
 826 (defun call-template (ctx name &optional param-bindings)
 827   (apply-applicable-templates ctx
 828                               (find-named-templates name)
 829                               param-bindings
 830                               (lambda ()
 831                                 (error "cannot find named template: ~s"
 832                                        name))))
 833
 834 (defun find-templates (ctx)
 835   (let* ((matching-candidates
 836           (remove-if-not (lambda (template)
 837                            (template-matches-p template ctx))
 838                          (mode-templates *mode*)))
 839          (npriorities
 840           (if matching-candidates
 841               (1+ (reduce #'max
 842                           matching-candidates
 843                           :key #'template-import-priority))
 844               0))
 845          (priority-groups (make-array npriorities :initial-element nil)))
 846     (dolist (template matching-candidates)
 847       (push template
 848             (elt priority-groups (template-import-priority template))))
 849 ;;;     (print (map 'list #'length priority-groups))
 850 ;;;     (force-output)
 851     (loop
 852        for i from (1- npriorities) downto 0
 853        for group = (elt priority-groups i)
 854        for template = (maximize #'template< group)
 855        when template
 856        collect template)))
 857
 858 (defun find-named-templates (name)
 859   (gethash name (stylesheet-named-templates *stylesheet*)))
 860
 861 (defun template< (a b)                  ;assuming same import priority
 862   (let ((p (template-priority a))
 863         (q (template-priority b)))
 864     (cond
 865       ((< p q) t)
 866       ((> p q) nil)
 867       (t
 868        (xslt-error "conflicting templates:~_~A,~_~A"
 869                    (template-match-expression a)
 870                    (template-match-expression b))))))
 871
 872 (defun maximize (< things)
 873   (when things
 874     (let ((max (car things)))
 875       (dolist (other (cdr things))
 876         (when (funcall < max other)
 877           (setf max other)))
 878       max)))
 879
 880 (defun template-matches-p (template ctx)
 881   (find (xpath:context-node ctx)
 882         (xpath:all-nodes (funcall (template-match-thunk template) ctx))))
 883
 884 (defun invoke-with-output-sink (fn stylesheet output)
 885   (etypecase output
 886     (pathname
 887      (with-open-file (s output
 888                         :direction :output
 889                         :element-type '(unsigned-byte 8)
 890                         :if-exists :rename-and-delete)
 891        (invoke-with-output-sink fn stylesheet s)))
 892     ((or stream null)
 893      (invoke-with-output-sink fn
 894                               stylesheet
 895                               (make-output-sink stylesheet output)))
 896     ((or hax:abstract-handler sax:abstract-handler)
 897      (with-xml-output output
 898        (funcall fn)))))
 899
 900 (defun make-output-sink (stylesheet stream)
 901   (let* ((ystream
 902           (if stream
 903               (let ((et (stream-element-type stream)))
 904                 (cond
 905                   ((or (null et) (subtypep et '(unsigned-byte 8)))
 906                    (runes:make-octet-stream-ystream stream))
 907                   ((subtypep et 'character)
 908                    (runes:make-character-stream-ystream stream))))
 909               (runes:make-rod-ystream)))
 910          (output-spec (stylesheet-output-specification stylesheet))
 911          (omit-xml-declaration-p
 912           (equal (output-omit-xml-declaration output-spec) "yes"))
 913          (sax-target
 914           (make-instance 'cxml::sink
 915                          :ystream ystream
 916                          :omit-xml-declaration-p omit-xml-declaration-p)))
 917     (if (equalp (output-method (stylesheet-output-specification stylesheet))
 918                 "HTML")
 919         (make-instance 'combi-sink
 920                        :hax-target (make-instance 'chtml::sink
 921                                                   :ystream ystream)
 922                        :sax-target sax-target
 923                        :encoding (output-encoding output-spec))
 924         sax-target)))
 925
 926 (defstruct template
 927   match-expression
 928   match-thunk
 929   name
 930   import-priority
 931   apply-imports-limit
 932   priority
 933   mode
 934   mode-qname
 935   params
 936   body
 937   n-variables)
 938
 939 (defun expression-priority (form)
 940   (let ((first-step (second form)))
 941     (if (and (null (cddr form))
 942              (eq :child (car first-step))
 943              (null (cddr first-step)))
 944         (let ((name (second first-step)))
 945           (cond
 946             ((or (stringp name)
 947                  (eq (car name) :qname)
 948                  (eq (car name) :processing-instruction))
 949              0.0)
 950             ((eq (car name) :namespace)
 951              -0.25)
 952             (t
 953              -0.5)))
 954         0.5)))
 955
 956 (defun parse-pattern (str)
 957   ;; zzz check here for anything not allowed as an XSLT pattern
 958   ;; zzz can we hack id() and key() here?
 959   (let ((form (xpath:parse-xpath str)))
 960     (unless (consp form)
 961       (xslt-error "not a valid pattern: ~A" str))
 962     (mapcar (lambda (case)
 963               (unless (eq (car case) :path) ;zzz: filter statt path
 964                 (xslt-error "not a valid pattern: ~A" str))
 965               `(:path (:ancestor-or-self :node) ,@(cdr case)))
 966             (if (eq (car form) :union)
 967                 (cdr form)
 968                 (list form)))))
 969
 970 (defun compile-value-thunk (value env)
 971   (if (and (listp value) (eq (car value) 'progn))
 972       (let ((inner-thunk (compile-instruction value env)))
 973         (lambda (ctx)
 974           (apply-to-result-tree-fragment ctx inner-thunk)))
 975       (compile-xpath value env)))
 976
 977 (defun compile-var-bindings/nointern (forms env)
 978   (loop
 979     for (name value) in forms
 980     collect (multiple-value-bind (local-name uri)
 981                 (decode-qname name env nil)
 982               (list (cons local-name uri)
 983                     (compile-value-thunk value env)))))
 984
 985 (defun compile-var-bindings (forms env)
 986   (loop
 987      for (cons thunk) in (compile-var-bindings/nointern forms env)
 988      for (local-name . uri) = cons
 989      collect (list cons
 990                    (push-variable local-name
 991                                   uri
 992                                   *lexical-variable-declarations*)
 993                    thunk)))
 994
 995 (defun compile-template (<template> env)
 996   (stp:with-attributes (match name priority mode) <template>
 997     (unless (or name match)
 998       (xslt-error "missing match in template"))
 999     (multiple-value-bind (params body-pos)
1000         (loop
1001           for i from 0
1002           for child in (stp:list-children <template>)
1003           while (namep child "param")
1004           collect (parse-param child) into params
1005           finally (return (values params i)))
1006       (let* ((*lexical-variable-declarations* (make-empty-declaration-array))
1007              (param-bindings (compile-var-bindings params env))
1008              (body (parse-body <template> body-pos (mapcar #'car params)))
1009              (body-thunk (compile-instruction `(progn ,@body) env))
1010              (outer-body-thunk
1011               #'(lambda (ctx)
1012                   ;; set params that weren't initialized by apply-templates
1013                   (loop for (name index param-thunk) in param-bindings
1014                         when (eq (lexical-variable-value index nil) 'unbound)
1015                           do (setf (lexical-variable-value index)
1016                                    (funcall param-thunk ctx)))
1017                   (funcall body-thunk ctx)))
1018              (n-variables (length *lexical-variable-declarations*)))
1019         (append
1020          (when name
1021            (multiple-value-bind (local-name uri)
1022                (decode-qname name env nil)
1023              (list
1024               (make-template :name (cons local-name uri)
1025                              :import-priority *import-priority*
1026                              :apply-imports-limit *apply-imports-limit*
1027                              :params param-bindings
1028                              :body outer-body-thunk
1029                              :n-variables n-variables))))
1030          (when match
1031            (mapcar (lambda (expression)
1032                      (let ((match-thunk
1033                             (compile-xpath `(xpath:xpath ,expression) env))
1034                            (p (if priority
1035                                   (parse-number:parse-number priority)
1036                                   (expression-priority expression))))
1037                        (make-template :match-expression expression
1038                                       :match-thunk match-thunk
1039                                       :import-priority *import-priority*
1040                                       :apply-imports-limit *apply-imports-limit*
1041                                       :priority p
1042                                       :mode-qname mode
1043                                       :params param-bindings
1044                                       :body outer-body-thunk
1045                                       :n-variables n-variables)))
1046                    (parse-pattern match))))))))
1047 #+(or)
1048 (xuriella::parse-stylesheet #p"/home/david/src/lisp/xuriella/test.xsl")