instructions.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 ;;;; Instructions
  37
  38 (defparameter *available-instructions* (make-hash-table :test 'equal))
  39
  40 (defmacro define-instruction (name (args-var env-var) &body body)
  41   `(setf (get ',name 'xslt-instruction)
  42          (lambda (,args-var ,env-var)
  43            (declare (ignorable ,env-var))
  44            ,@body)))
  45
  46 (define-instruction if (args env)
  47   (destructuring-bind (test then &optional else) args
  48     (let ((test-thunk (compile-xpath test env))
  49           (then-thunk (compile-instruction then env))
  50           (else-thunk (when else (compile-instruction else env))))
  51       (lambda (ctx)
  52         (cond
  53           ((xpath:boolean-value (funcall test-thunk ctx))
  54            (funcall then-thunk ctx))
  55           (else-thunk
  56            (funcall else-thunk ctx)))))))
  57
  58 (define-instruction when (args env)
  59   (destructuring-bind (test &rest body) args
  60     (compile-instruction `(if ,test (progn ,@body)) env)))
  61
  62 (define-instruction unless (args env)
  63   (destructuring-bind (test &rest body) args
  64     (compile-instruction `(if (:not ,test) (progn ,@body)) env)))
  65
  66 (define-instruction cond (args env)
  67   (if args
  68       (destructuring-bind ((test &body body) &rest clauses) args
  69         (compile-instruction (if (eq test t)
  70                                  `(progn ,@body)
  71                                  `(if ,test
  72                                       (progn ,@body)
  73                                       (cond ,@clauses)))
  74                              env))
  75       (constantly nil)))
  76
  77 (define-instruction progn (args env)
  78   (if args
  79       (let ((first-thunk (compile-instruction (first args) env))
  80             (rest-thunk (compile-instruction `(progn ,@(rest args)) env)))
  81         (lambda (ctx)
  82           (funcall first-thunk ctx)
  83           (funcall rest-thunk ctx)))
  84       (constantly nil)))
  85
  86 (defun decode-qname/runtime (qname namespaces attributep)
  87   (handler-case
  88       (multiple-value-bind (prefix local-name)
  89           (split-qname qname)
  90         (values local-name
  91                 (if (or prefix (not attributep))
  92                     (cdr (assoc prefix namespaces :test 'equal))
  93                     "")
  94                 prefix))
  95     (cxml:well-formedness-violation ()
  96       (xslt-error "not a qname: ~A" qname))))
  97
  98 (define-instruction xsl:element (args env)
  99   (destructuring-bind ((name &key namespace use-attribute-sets)
 100                        &body body)
 101       args
 102     (declare (ignore use-attribute-sets)) ;fixme
 103     (multiple-value-bind (name-thunk constant-name-p)
 104         (compile-avt name env)
 105       (multiple-value-bind (ns-thunk constant-ns-p)
 106           (if namespace
 107               (compile-avt namespace env)
 108               (values nil t))
 109         (let ((body-thunk (compile-instruction `(progn ,@body) env)))
 110           (if (and constant-name-p constant-ns-p)
 111               (compile-element/constant-name name namespace env body-thunk)
 112               (compile-element/runtime name-thunk ns-thunk body-thunk)))))))
 113
 114 (defun compile-element/constant-name (qname namespace env body-thunk)
 115   ;; the simple case: compile-time decoding of the QName
 116   (multiple-value-bind (local-name uri prefix)
 117       (decode-qname qname env nil)
 118     (when namespace
 119       (setf uri namespace))
 120     (lambda (ctx)
 121       (cond
 122         (uri
 123          (with-element (local-name uri :suggested-prefix prefix)
 124            (funcall body-thunk ctx)))
 125         (t
 126          ;; ERROR rather than CERROR because saxon doesn't do the recovery,
 127          ;; and the official output illustrates recovery but is useless as
 128          ;; always.
 129          (xslt-error "namespace not found: ~A" prefix)
 130          #+(or)
 131          (let ((*start-tag-written-p* t))
 132            (declare (special *start-tag-written-p*))
 133            (funcall body-thunk ctx)))))))
 134
 135 (defun compile-element/runtime (name-thunk ns-thunk body-thunk)
 136   ;; run-time decoding of the QName, but using the same namespaces
 137   ;; that would have been known at compilation time.
 138   (let ((namespaces *namespaces*))
 139     (lambda (ctx)
 140       (let ((qname (funcall name-thunk ctx)))
 141         (multiple-value-bind (local-name uri prefix)
 142             (decode-qname/runtime qname namespaces nil)
 143           (when ns-thunk
 144             (setf uri (funcall ns-thunk ctx)))
 145           (unless uri
 146             (setf uri ""))
 147           (with-element (local-name uri :suggested-prefix prefix)
 148             (funcall body-thunk ctx)))))))
 149
 150 (define-instruction xsl:use-attribute-sets (args env)
 151   (destructuring-bind (str) args
 152     (let ((sets (mapcar (lambda (qname)
 153                           (multiple-value-list (decode-qname qname env nil)))
 154                         (words str))))
 155       (lambda (ctx)
 156         (loop for (local-name uri nil) in sets do
 157              (dolist (thunk (find-attribute-set local-name uri))
 158                (funcall thunk ctx)))))))
 159
 160 (define-instruction xsl:attribute (args env)
 161   (destructuring-bind ((name &key namespace) &body body) args
 162     (when (null name)
 163       (xslt-error "xsl:attribute: name not specified"))
 164     (multiple-value-bind (name-thunk constant-name-p)
 165         (compile-avt name env)
 166       (multiple-value-bind (ns-thunk constant-ns-p)
 167           (if namespace
 168               (compile-avt namespace env)
 169               (values nil t))
 170         (let ((value-thunk (compile-instruction `(progn ,@body) env)))
 171           (if (and constant-name-p constant-ns-p)
 172               (compile-attribute/constant-name name namespace env value-thunk)
 173               (compile-attribute/runtime name-thunk ns-thunk value-thunk)))))))
 174
 175 (defun compile-attribute/constant-name (qname namespace env value-thunk)
 176   ;; the simple case: compile-time decoding of the QName
 177   (multiple-value-bind (local-name uri prefix)
 178       (decode-qname qname env t)
 179     (when namespace
 180       (setf uri namespace))
 181     (lambda (ctx)
 182       (write-attribute local-name
 183                        (or uri "")
 184                        (with-toplevel-text-output-sink (s)
 185                          (with-xml-output s
 186                            (funcall value-thunk ctx)))
 187                        :suggested-prefix prefix))))
 188
 189 (defun compile-attribute/runtime (name-thunk ns-thunk value-thunk)
 190   ;; run-time decoding of the QName, but using the same namespaces
 191   ;; that would have been known at compilation time.
 192   (let ((namespaces *namespaces*))
 193     (lambda (ctx)
 194       (let ((qname (funcall name-thunk ctx)))
 195         (multiple-value-bind (local-name uri prefix)
 196             (decode-qname/runtime qname namespaces t)
 197           (when ns-thunk
 198             (setf uri (funcall ns-thunk ctx)))
 199           (write-attribute local-name
 200                            (or uri "")
 201                            (with-toplevel-text-output-sink (s)
 202                              (with-xml-output s
 203                                (funcall value-thunk ctx)))
 204                            :suggested-prefix prefix))))))
 205
 206 ;; zzz Also elides (later) namespaces hidden by (earlier) ones.
 207 ;; zzz Reverses order.
 208 (defun remove-excluded-namespaces
 209     (namespaces &optional (excluded-uris *excluded-namespaces*))
 210   (let ((koerbchen '())
 211         (kroepfchen '()))
 212     (loop
 213        for cons in namespaces
 214        for (prefix* . uri) = cons
 215        for prefix = (or prefix* "")
 216        do
 217          (cond
 218            ((find prefix kroepfchen :test #'equal))
 219            ((find prefix koerbchen :test #'equal :key #'car))
 220            ((find uri excluded-uris :test #'equal)
 221             (push prefix kroepfchen))
 222            (t
 223             (push cons koerbchen))))
 224     koerbchen))
 225
 226 (define-instruction xsl:literal-element (args env)
 227   (destructuring-bind
 228         ((local-name &optional (uri "") suggested-prefix) &body body)
 229       args
 230     (let ((body-thunk (compile-instruction `(progn ,@body) env))
 231           (namespaces (remove-excluded-namespaces *namespaces*)))
 232       (lambda (ctx)
 233         (with-element (local-name (or uri "")
 234                                   :suggested-prefix suggested-prefix
 235                                   :extra-namespaces namespaces
 236                                   :process-aliases t)
 237           (funcall body-thunk ctx))))))
 238
 239 (define-instruction xsl:literal-attribute (args env)
 240   (destructuring-bind ((local-name &optional uri suggested-prefix) value) args
 241     (let ((value-thunk (compile-avt value env)))
 242       (lambda (ctx)
 243         (write-attribute local-name
 244                          uri
 245                          (funcall value-thunk ctx)
 246                          :process-aliases t
 247                          :suggested-prefix suggested-prefix)))))
 248
 249 (define-instruction xsl:text (args env)
 250   (destructuring-bind (str) args
 251     (lambda (ctx)
 252       (declare (ignore ctx))
 253       (write-text str))))
 254
 255 (define-instruction xsl:unescaped-text (args env)
 256   (destructuring-bind (str) args
 257     (lambda (ctx)
 258       (declare (ignore ctx))
 259       (write-unescaped str))))
 260
 261 (define-instruction xsl:processing-instruction (args env)
 262   (destructuring-bind (name &rest body) args
 263     (let ((name-thunk (compile-avt name env))
 264           (value-thunk (compile-instruction `(progn ,@body) env)))
 265       (lambda (ctx)
 266         (write-processing-instruction
 267          (funcall name-thunk ctx)
 268          (with-toplevel-text-output-sink (s)
 269            (with-xml-output s
 270              (funcall value-thunk ctx))))))))
 271
 272 (define-instruction xsl:comment (args env)
 273   (let ((value-thunk (compile-instruction `(progn ,@args) env)))
 274     (lambda (ctx)
 275       (write-comment (with-toplevel-text-output-sink (s)
 276                        (with-xml-output s
 277                          (funcall value-thunk ctx)))))))
 278
 279 (define-instruction xsl:value-of (args env)
 280   (destructuring-bind (xpath) args
 281     (let ((thunk (compile-xpath xpath env)))
 282       (xslt-trace-thunk
 283        (lambda (ctx)
 284          (write-text (xpath:string-value (funcall thunk ctx))))
 285        "value-of ~s = ~s" xpath :result))))
 286
 287 (define-instruction xsl:unescaped-value-of (args env)
 288   (destructuring-bind (xpath) args
 289     (let ((thunk (compile-xpath xpath env)))
 290       (lambda (ctx)
 291         (write-unescaped (xpath:string-value (funcall thunk ctx)))))))
 292
 293 (define-instruction xsl:copy-of (args env)
 294   (destructuring-bind (xpath) args
 295     (let ((thunk (compile-xpath xpath env))
 296           ;; FIXME: what was this for?  --david
 297           #+(or) (v (intern-variable "varName" "")))
 298       (xslt-trace-thunk
 299        (lambda (ctx)
 300          (let ((result (funcall thunk ctx)))
 301            (typecase result
 302              (xpath:node-set ;; FIXME: variables can contain node sets w/fragments inside. Maybe just fragments would do?
 303               (xpath:map-node-set #'copy-into-result (xpath:sort-node-set result)))
 304              (result-tree-fragment
 305               (copy-into-result result))
 306              (t
 307               (write-text (xpath:string-value result))))))
 308        "copy-of ~s" xpath))))
 309
 310 (defun copy-into-result (node)
 311   (cond
 312     ((result-tree-fragment-p node)
 313      (stp:do-children (child (result-tree-fragment-node node))
 314        (copy-into-result child)))
 315     ((xpath-protocol:node-type-p node :element)
 316      (with-element ((xpath-protocol:local-name node)
 317                     (xpath-protocol:namespace-uri node)
 318                     :suggested-prefix (xpath-protocol:namespace-prefix node)
 319                     :extra-namespaces (namespaces-as-alist node))
 320        (map-pipe-eagerly #'copy-into-result
 321                          (xpath-protocol:attribute-pipe node))
 322        (map-pipe-eagerly #'copy-into-result
 323                          (xpath-protocol:child-pipe node))))
 324     ((xpath-protocol:node-type-p node :document)
 325      (map-pipe-eagerly #'copy-into-result
 326                        (xpath-protocol:child-pipe node)))
 327     (t
 328      (copy-leaf-node node))))
 329
 330 (defparameter *lower-first-order*
 331   #(#\  #\! #\" #\# #\$ #\% #\& #\' #\( #\) #\* #\+ #\, #\- #\. #\/ #\0 #\1 #\2
 332     #\3 #\4 #\5 #\6 #\7 #\8 #\9 #\: #\; #\< #\= #\> #\? #\@ #\H #\J #\L #\N #\P
 333     #\R #\T #\V #\X #\Z #\\ #\^ #\` #\b #\d #\f #\h #\j #\l #\n #\p #\r #\t #\v
 334     #\x #\z #\A #\B #\C #\D #\E #\F #\G #\I #\K #\M #\O #\Q #\S #\U #\W #\Y #\[
 335     #\] #\_ #\a #\c #\e #\g #\i #\k #\m #\o #\q #\s #\u #\w #\y #\{ #\| #\} #\~
 336     #\Rubout))
 337
 338 (defparameter *upper-first-order*
 339   #(#\  #\! #\" #\# #\$ #\% #\& #\' #\( #\) #\* #\+ #\, #\- #\. #\/ #\0 #\1 #\2
 340     #\3 #\4 #\5 #\6 #\7 #\8 #\9 #\: #\; #\< #\= #\> #\? #\@ #\G #\I #\K #\M #\O
 341     #\Q #\S #\U #\W #\Y #\[ #\] #\_ #\a #\c #\e #\g #\i #\k #\m #\o #\q #\s #\u
 342     #\w #\y #\A #\B #\C #\D #\E #\F #\H #\J #\L #\N #\P #\R #\T #\V #\X #\Z #\\
 343     #\^ #\` #\b #\d #\f #\h #\j #\l #\n #\p #\r #\t #\v #\x #\z #\{ #\| #\} #\~
 344     #\Rubout))
 345
 346 (defun collation-char (char table)
 347   (let ((code (char-code char)))
 348     (if (<= 32 code 127)
 349         (elt table (- code 32))
 350         char)))
 351
 352 (defun make-collation-key (str table)
 353   (map 'string (lambda (char) (collation-char char table)) str))
 354
 355 (defun mismatch* (a b)
 356   (let ((pos (mismatch a b)))
 357     (if (and pos (< pos (min (length a) (length b))))
 358         pos
 359         nil)))
 360
 361 (defun make-sorter (spec env)
 362   (destructuring-bind (&key select lang data-type order case-order)
 363       (cdr spec)
 364     (declare (ignore lang))
 365     (let ((select-thunk (compile-xpath (or select ".") env))
 366           (numberp (equal data-type "number"))
 367           (f (if (equal order "descending") -1 1))
 368           (char-table (if (equal case-order "lower-first")
 369                           *lower-first-order*
 370                           *upper-first-order*)))
 371       (lambda (a b)
 372         (let ((i (xpath:string-value
 373                   (funcall select-thunk (xpath:make-context a))))
 374               (j (xpath:string-value
 375                   (funcall select-thunk (xpath:make-context b)))))
 376           (* f
 377              (if numberp
 378                  (let ((n-a (xpath:number-value i))
 379                        (n-b (xpath:number-value j)))
 380                    (cond ((and (xpath::nan-p n-a)
 381                                (not (xpath::nan-p n-b)))
 382                           -1)
 383                          ((and (not (xpath::nan-p n-a))
 384                                (xpath::nan-p n-b))
 385                           1)
 386                          ((xpath::compare-numbers '< n-a n-b) -1)
 387                          ((xpath::compare-numbers '> n-a n-b) 1)
 388                          (t 0)))
 389                  ;; zzz Unicode support!
 390                  (let ((pos
 391                         (or (mismatch* (string-downcase i) (string-downcase j))
 392                             (mismatch* i j))))
 393                    (if pos
 394                        (let ((c (collation-char (elt i pos) char-table))
 395                              (d (collation-char (elt j pos) char-table)))
 396                          (cond
 397                            ((char< c d) -1)
 398                            ((char= c d) 0)
 399                            (t 1)))
 400                        (signum (- (length i) (length j))))))))))))
 401
 402 (defun compose-sorters (sorters)
 403   (if sorters
 404       (let ((this (car sorters))
 405             (next (compose-sorters (rest sorters))))
 406         (lambda (a b)
 407           (let ((d (funcall this a b)))
 408             (if (zerop d)
 409                 (funcall next a b)
 410                 d))))
 411       (constantly 0)))
 412
 413 (defun make-sort-predicate (decls env)
 414   (let ((sorter
 415          (compose-sorters
 416           (mapcar (lambda (x) (make-sorter x env)) decls))))
 417     (lambda (a b)
 418       (minusp (funcall sorter a b)))))
 419
 420 (define-instruction xsl:for-each (args env)
 421   (destructuring-bind (select &optional decls &rest body) args
 422     (unless (and (consp decls)
 423                  (eq (car decls) 'declare))
 424       (push decls body)
 425       (setf decls nil))
 426     (let ((select-thunk (compile-xpath select env))
 427           (body-thunk (compile-instruction `(progn ,@body) env))
 428           (sort-predicate
 429            (when (cdr decls)
 430              (make-sort-predicate (cdr decls) env))))
 431       (lambda (ctx)
 432         (let ((selected (funcall select-thunk ctx)))
 433           (unless (xpath:node-set-p selected)
 434             (xslt-error "for-each select expression should yield a node-set"))
 435           (let ((nodes (xpath::force
 436                         (xpath::sorted-pipe-of selected))))
 437             (when sort-predicate
 438               (setf nodes (stable-sort (copy-list nodes) sort-predicate)))
 439             (loop
 440               with n = (length nodes)
 441               for node in nodes
 442               for i from 1
 443               do
 444            (funcall body-thunk
 445                     (xpath:make-context node (lambda () n) i)))))))))
 446
 447 (define-instruction xsl:with-namespaces (args env)
 448   (destructuring-bind ((&rest forms) &rest body) args
 449     (let ((*namespaces* *namespaces*))
 450       (dolist (form forms)
 451         (destructuring-bind (prefix uri) form
 452           (push (cons prefix uri) *namespaces*)))
 453       (compile-instruction `(progn ,@body) env))))
 454
 455 (define-instruction xsl:with-excluded-namespaces (args env)
 456   (destructuring-bind ((&rest uris) &rest body) args
 457     (let ((*excluded-namespaces* (append uris *excluded-namespaces*)))
 458       (compile-instruction `(progn ,@body) env))))
 459
 460 (define-instruction xsl:with-extension-namespaces (args env)
 461   (destructuring-bind ((&rest uris) &rest body) args
 462     (let ((*extension-namespaces* (append uris *extension-namespaces*)))
 463       (compile-instruction `(progn ,@body) env))))
 464
 465 ;; XSLT disallows multiple definitions of the same variable within a
 466 ;; template.  Local variables can shadow global variables though.
 467 ;; Since our LET syntax makes it natural to shadow local variables the
 468 ;; Lisp way, we check for duplicate variables only where instructed to
 469 ;; by the XML syntax parser using WITH-DUPLICATES-CHECK:
 470 (defvar *template-variables* nil)
 471
 472 (define-instruction xsl:with-duplicates-check (args env)
 473   (let ((*template-variables* *template-variables*))
 474     (destructuring-bind ((&rest qnames) &rest body) args
 475       (dolist (qname qnames)
 476         (multiple-value-bind (local-name uri)
 477             (decode-qname qname env nil)
 478           (let ((key (cons local-name uri)))
 479             (when (find key *template-variables* :test #'equal)
 480               (xslt-error "duplicate variable: ~A, ~A" local-name uri))
 481             (push key *template-variables*))))
 482       (compile-instruction `(progn ,@body) env))))
 483
 484 (define-instruction xsl:with-base-uri (args env)
 485   (destructuring-bind (uri &rest body) args
 486     (let ((*instruction-base-uri* uri))
 487       (compile-instruction `(progn ,@body) env))))
 488
 489 (defstruct (result-tree-fragment
 490              (:constructor make-result-tree-fragment (node)))
 491   node)
 492
 493 (define-default-method xpath-protocol:node-p
 494     ((node result-tree-fragment))
 495   t)
 496
 497 (define-default-method xpath-protocol:node-text
 498     ((node result-tree-fragment))
 499   (xpath-protocol:node-text (result-tree-fragment-node node)))
 500
 501 (defun apply-to-result-tree-fragment (ctx thunk)
 502   (let ((document
 503          (with-xml-output (make-stpx-builder)
 504            (with-element ("fragment" "")
 505              (funcall thunk ctx)))))
 506     (make-result-tree-fragment (stp:document-element document))))
 507
 508 (define-instruction let (args env)
 509   (destructuring-bind ((&rest forms) &rest body) args
 510     (let* ((old-top (length *lexical-variable-declarations*))
 511            (vars-and-names (compile-var-bindings/nointern forms env))
 512            (vars-and-positions
 513             (loop for ((local-name . uri) thunk) in vars-and-names
 514                collect
 515                  (list (push-variable local-name
 516                                       uri
 517                                       *lexical-variable-declarations*)
 518                        thunk))))
 519       (let ((thunk (compile-instruction `(progn ,@body) env)))
 520         (fill *lexical-variable-declarations* nil :start old-top)
 521         (lambda (ctx)
 522           (loop for (index var-thunk) in vars-and-positions
 523              do (setf (lexical-variable-value index)
 524                       (funcall var-thunk ctx)))
 525           (funcall thunk ctx))))))
 526
 527 (define-instruction let* (args env)
 528   (destructuring-bind ((&rest forms) &rest body) args
 529     (if forms
 530         (compile-instruction `(let (,(car forms))
 531                                 (let* (,@(cdr forms))
 532                                   ,@body))
 533                              env)
 534         (compile-instruction `(progn ,@body) env))))
 535
 536 (define-instruction xsl:message (args env)
 537   (compile-message #'warn args env))
 538
 539 (define-instruction xsl:terminate (args env)
 540   (compile-message #'error args env))
 541
 542 (defun namespaces-as-alist (element)
 543   (let ((namespaces '()))
 544     (do-pipe (ns (xpath-protocol:namespace-pipe element))
 545       (push (cons (xpath-protocol:local-name ns)
 546                   (xpath-protocol:node-text ns))
 547             namespaces))
 548     namespaces))
 549
 550 (define-instruction xsl:copy (args env)
 551   (let ((body (compile-instruction `(progn ,@args) env)))
 552     (lambda (ctx)
 553       (let ((node (xpath:context-node ctx)))
 554         (cond
 555           ((xpath-protocol:node-type-p node :element)
 556            (with-element
 557                ((xpath-protocol:local-name node)
 558                 (xpath-protocol:namespace-uri node)
 559                 :suggested-prefix (xpath-protocol:namespace-prefix node)
 560                 :extra-namespaces (namespaces-as-alist node))
 561              (funcall body ctx)))
 562           ((xpath-protocol:node-type-p node :document)
 563            (funcall body ctx))
 564           (t
 565            (copy-leaf-node node)))))))
 566
 567 (defun copy-leaf-node (node)
 568   (cond
 569     ((xpath-protocol:node-type-p node :text)
 570      (etypecase (if (typep node 'stripping-node)
 571                     (stripping-node-target node)
 572                     node)
 573        (unescaped-text (write-unescaped (xpath-protocol:node-text node)))
 574        (stp:text (write-text (xpath-protocol:node-text node)))))
 575     ((xpath-protocol:node-type-p node :comment)
 576      (write-comment (xpath-protocol:node-text node)))
 577     ((xpath-protocol:node-type-p node :processing-instruction)
 578      (write-processing-instruction
 579          (xpath-protocol:processing-instruction-target node)
 580        (xpath-protocol:node-text node)))
 581     ((xpath-protocol:node-type-p node :attribute)
 582      (write-attribute
 583       (xpath-protocol:local-name node)
 584       (xpath-protocol:namespace-uri node)
 585       (xpath-protocol:node-text node)
 586       :suggested-prefix (xpath-protocol:namespace-prefix node)))
 587     ((xpath-protocol:node-type-p node :namespace)
 588      (write-extra-namespace
 589       (xpath-protocol:local-name node)
 590       (xpath-protocol:node-text node)
 591       nil))
 592     (t
 593      (error "don't know how to copy node ~A" node))))
 594
 595 (defun compile-message (fn args env)
 596   (let ((thunk (compile-instruction `(progn ,@args) env)))
 597     (lambda (ctx)
 598       (funcall fn
 599                (with-xml-output (cxml:make-string-sink)
 600                  (funcall thunk ctx))))))
 601
 602 (define-instruction xsl:apply-templates (args env)
 603   (destructuring-bind ((&key select mode) &rest param-binding-specs) args
 604     (let* ((decls
 605             (when (and (consp (car param-binding-specs))
 606                        (eq (caar param-binding-specs) 'declare))
 607               (cdr (pop param-binding-specs))))
 608            (select-thunk
 609             (compile-xpath (or select "child::node()") env))
 610            (param-bindings
 611             (compile-var-bindings param-binding-specs env))
 612            (sort-predicate
 613             (when decls
 614               (make-sort-predicate decls env))))
 615       (multiple-value-bind (mode-local-name mode-uri)
 616           (and mode (decode-qname mode env nil))
 617         (lambda (ctx)
 618           (apply-templates/list
 619            (xpath::force
 620             (xpath::sorted-pipe-of (funcall select-thunk ctx)))
 621            :param-bindings
 622            (loop for (name nil value-thunk) in param-bindings
 623               collect (list name (funcall value-thunk ctx)))
 624            :sort-predicate sort-predicate
 625            :mode (when mode
 626                    (or (find-mode *stylesheet*
 627                                   mode-local-name
 628                                   mode-uri)
 629                        *empty-mode*))))))))
 630
 631 (define-instruction xsl:apply-imports (args env)
 632   (declare (ignore args env))
 633   (lambda (ctx)
 634     (declare (ignore ctx))
 635     (funcall *apply-imports*)))
 636
 637 (define-instruction xsl:call-template (args env)
 638   (destructuring-bind (name &rest param-binding-specs) args
 639       (let ((param-bindings
 640              (compile-var-bindings param-binding-specs env)))
 641         (multiple-value-bind (local-name uri)
 642             (decode-qname name env nil)
 643           (setf name (cons local-name uri)))
 644         (lambda (ctx)
 645           (call-template ctx name
 646                          (loop for (name nil value-thunk) in param-bindings
 647                                collect (list name (funcall value-thunk ctx))))))))
 648
 649 ;; fixme: incompatible with XSLT 2.0
 650 (define-instruction xsl:document (args env)
 651   (destructuring-bind ((href &key method indent doctype-public doctype-system)
 652                        &body body)
 653       args
 654     (declare (ignore doctype-public doctype-system)) ;fixme
 655     (let ((thunk (compile-instruction `(progn ,@body) env))
 656           (href-thunk (compile-avt href env)))
 657       (lambda (ctx)
 658         (let ((pathname
 659                (uri-to-pathname
 660                 (puri:merge-uris (funcall href-thunk ctx)
 661                                  (xpath-protocol:base-uri
 662                                   (xpath:context-node ctx))))))
 663           (ensure-directories-exist pathname) ;really?
 664           (invoke-with-output-sink
 665            (lambda ()
 666              (funcall thunk ctx))
 667            (make-output-specification :method (or method "XML") :indent indent)
 668            pathname))))))
 669
 670 (defun compile-instruction (form env)
 671   (xslt-trace-thunk
 672    (funcall (or (get (car form) 'xslt-instruction)
 673                 (error "undefined instruction: ~A" (car form)))
 674             (cdr form)
 675             env)
 676    "instruction ~s" (car form)))
 677
 678 ;;: WTF: "A right curly brace inside a Literal in an expression is not
 679 ;;; recognized as terminating the expression."
 680 ;;;
 681 ;;; Da hilft nur tagbody.
 682 (defun parse-attribute-value-template (template-string)
 683   (with-input-from-string (input template-string)
 684     (let ((ordinary (make-string-output-stream))
 685           (xpath (make-string-output-stream))
 686           (tokens '())
 687           (c (read-char input nil :eof)))
 688       (flet ((emit ()
 689                (let ((o (get-output-stream-string ordinary)))
 690                  (when (plusp (length o))
 691                    (push (list :data o) tokens)))
 692                (let ((x (get-output-stream-string xpath)))
 693                  (when (plusp (length x))
 694                    (push (list :xpath x) tokens))))
 695              (collect-ordinary ()
 696                (write-char c ordinary))
 697              (collect-xpath ()
 698                (write-char c xpath)))
 699         (macrolet ((goto (target)
 700                      `(progn
 701                         (setf c (read-char input nil :eof))
 702                         (go ,target))))
 703           (tagbody
 704            ordinary
 705              (case c
 706                (#\{
 707                 (goto seen{))
 708                (#\}
 709                 (goto seen-stray-}))
 710                (:eof
 711                 (go done)))
 712              (collect-ordinary)
 713              (goto ordinary)
 714
 715            seen{
 716              (case c
 717                (#\{
 718                 (collect-ordinary)
 719                 (goto ordinary))
 720                (#\'
 721                 (collect-xpath)
 722                 (goto in-single-quote))
 723                (:eof
 724                 (xslt-error "unexpected end of avt")))
 725              (emit)
 726              (collect-xpath)
 727              (goto xpath)
 728
 729            xpath
 730              (case c
 731                (#\'
 732                 (collect-xpath)
 733                 (goto in-single-quote))
 734                (#\"
 735                 (collect-xpath)
 736                 (goto in-double-quote))
 737                (#\}
 738                 (goto seen-closing-}))
 739                (:eof
 740                 (xslt-error "unexpected end of avt")))
 741              (collect-xpath)
 742              (goto xpath)
 743
 744            in-single-quote
 745              (case c
 746                (#\'
 747                 (collect-xpath)
 748                 (goto xpath))
 749                (:eof
 750                 (xslt-error "unexpected end of avt")))
 751              (collect-xpath)
 752              (goto in-single-quote)
 753
 754            in-double-quote
 755              (case c
 756                (#\"
 757                 (collect-xpath)
 758                 (goto xpath))
 759                (:eof
 760                 (xslt-error "unexpected end of avt")))
 761              (collect-xpath)
 762              (goto in-double-quote)
 763
 764            seen-closing-}
 765              (case c
 766                (#\}
 767                 (collect-xpath)
 768                 (goto xpath))
 769                (#\{
 770                 (emit)
 771                 (goto xpath))
 772                (:eof
 773                 (goto done)))
 774              (emit)
 775              (collect-ordinary)
 776              (goto ordinary)
 777
 778            seen-stray-}
 779              (case c
 780                (#\}
 781                 (collect-ordinary)
 782                 (goto ordinary)))
 783              (xslt-error "unexpected closing brace in avt")
 784
 785            done
 786              (emit))))
 787       (nreverse tokens))))
 788
 789 (defun compile-avt (template-string env)
 790   (let* ((constantp t)
 791          (fns
 792           (mapcar (lambda (x)
 793                     (ecase (car x)
 794                       (:data
 795                        (constantly (second x)))
 796                       (:xpath
 797                        (setf constantp nil)
 798                        (compile-xpath (second x) env))))
 799                   (parse-attribute-value-template template-string))))
 800     (values (lambda (ctx)
 801               (with-output-to-string (s)
 802                 (dolist (fn fns)
 803                   (write-string (xpath:string-value (funcall fn ctx)) s))))
 804             constantp)))
 805
 806
 807 ;;;; Indentation for slime
 808
 809 (defmacro define-indentation (name (&rest args))
 810   (labels ((collect-variables (list)
 811              (loop
 812                 for sub in list
 813                 append
 814                 (etypecase sub
 815                   (list
 816                    (collect-variables sub))
 817                   (symbol
 818                    (if (eql (mismatch "&" (symbol-name sub)) 1)
 819                        nil
 820                        (list sub)))))))
 821     `(defmacro ,name (,@args)
 822        (declare (ignorable ,@(collect-variables args)))
 823        (error "XSL indentation helper ~A used literally in lisp code"
 824               ',name))))
 825
 826 (define-indentation xsl:element
 827     ((name &key namespace use-attribute-sets) &body body))
 828 (define-indentation xsl:literal-element ((name &optional uri) &body body))
 829 (define-indentation xsl:attribute ((name &key namespace) &body body))
 830 (define-indentation xsl:literal-attribute ((name &optional uri) &body body))
 831 (define-indentation xsl:text (str))
 832 (define-indentation xsl:processing-instruction (name &body body))
 833 (define-indentation xsl:comment (&body body))
 834 (define-indentation xsl:value-of (xpath))
 835 (define-indentation xsl:unescaped-value-of (xpath))
 836 (define-indentation xsl:for-each (select &body decls-and-body))
 837 (define-indentation xsl:message (&body body))
 838 (define-indentation xsl:terminate (&body body))
 839 (define-indentation xsl:apply-templates ((&key select mode) &body decls-and-body))
 840 (define-indentation xsl:call-template (name &rest parameters))
 841 (define-indentation xsl:copy-of (xpath))
 842
 843 ;;;;
 844
 845 (defun test-instruction (form document)
 846   (let ((thunk (compile-instruction form (make-instance 'lexical-environment)))
 847         (root (cxml:parse document (stp:make-builder))))
 848     (with-xml-output (cxml:make-string-sink)
 849       (funcall thunk (xpath:make-context root)))))