xsl:sort parameters are AVTs
[xuriella.git] / instructions.lisp
blob3af1a314819bdd54d5a22c0dd1b6b2770424f4d9
1 ;;; -*- show-trailing-whitespace: t; indent-tabs-mode: nil -*-
3 ;;; Copyright (c) 2007,2008 David Lichteblau, Ivan Shvedunov.
4 ;;; All rights reserved.
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.
30 (in-package :xuriella)
32 #+sbcl
33 (declaim (optimize (debug 2)))
36 ;;;; Instructions
38 (defparameter *available-instructions* (make-hash-table :test 'equal))
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)))
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)))))))
58 (define-instruction when (args env)
59 (destructuring-bind (test &rest body) args
60 (compile-instruction `(if ,test (progn ,@body)) env)))
62 (define-instruction unless (args env)
63 (destructuring-bind (test &rest body) args
64 (compile-instruction `(if (:not ,test) (progn ,@body)) env)))
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)))
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)))
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))))
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)))))))
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)))
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)))))))
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)))))))
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)))))))
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)))))))
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))))
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))))))
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* "")
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))
223 (push cons koerbchen))))
224 koerbchen))
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))))))
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
245 (funcall value-thunk ctx)
246 :process-aliases t
247 :suggested-prefix suggested-prefix)))))
249 (define-instruction xsl:text (args env)
250 (destructuring-bind (str) args
251 (lambda (ctx)
252 (declare (ignore ctx))
253 (write-text str))))
255 (define-instruction xsl:unescaped-text (args env)
256 (destructuring-bind (str) args
257 (lambda (ctx)
258 (declare (ignore ctx))
259 (write-unescaped str))))
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))))))))
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)))))))
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))))
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)))))))
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))
307 (write-text (xpath:string-value result))))))
308 "copy-of ~s" xpath))))
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)))
328 (copy-leaf-node node))))
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))
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))
346 (defun collation-char (char table)
347 (let ((code (char-code char)))
348 (if (<= 32 code 127)
349 (elt table (- code 32))
350 char)))
352 (defun make-collation-key (str table)
353 (map 'string (lambda (char) (collation-char char table)) str))
355 (defun compare-numbers (n-a n-b)
356 (cond ((and (xpath::nan-p n-a)
357 (not (xpath::nan-p n-b)))
359 ((and (not (xpath::nan-p n-a))
360 (xpath::nan-p n-b))
362 ((xpath::compare-numbers '< n-a n-b) -1)
363 ((xpath::compare-numbers '> n-a n-b) 1)
364 (t 0)))
366 (defun mismatch* (a b)
367 (let ((pos (mismatch a b)))
368 (if (and pos (< pos (min (length a) (length b))))
370 nil)))
372 (defun compare-strings (i j char-table)
373 ;; zzz Unicode support!
374 (let ((pos
375 (or (mismatch* (string-downcase i) (string-downcase j))
376 (mismatch* i j))))
377 (if pos
378 (let ((c (collation-char (elt i pos) char-table))
379 (d (collation-char (elt j pos) char-table)))
380 (cond
381 ((char< c d) -1)
382 ((char= c d) 0)
383 (t 1)))
384 (signum (- (length i) (length j))))))
386 (defun make-sorter/lazy (spec env)
387 (destructuring-bind (&key select lang data-type order case-order)
388 (cdr spec)
389 (let ((select-thunk (compile-xpath (or select ".") env))
390 (lang-thunk (compile-avt (or lang "") env))
391 (data-type-thunk (compile-avt (or data-type "") env))
392 (order-thunk (compile-avt (or order "") env))
393 (case-order-thunk (compile-avt (or case-order "") env)))
394 (lambda (ctx)
395 (let ((numberp
396 (equal (funcall data-type-thunk ctx) "number"))
397 (char-table
398 (if (equal (funcall case-order-thunk ctx) "lower-first")
399 *lower-first-order*
400 *upper-first-order*))
402 (if (equal (funcall order-thunk ctx) "descending") -1 1))
403 (lang
404 (funcall lang-thunk ctx)))
405 (declare (ignore lang))
406 (lambda (a b)
407 (let ((i (xpath:string-value (funcall select-thunk a)))
408 (j (xpath:string-value (funcall select-thunk b))))
409 (* f
410 (if numberp
411 (compare-numbers (xpath:number-value i)
412 (xpath:number-value j))
413 (compare-strings i j char-table))))))))))
415 (defun compose-sorters/lazy (sorters)
416 (if sorters
417 (let ((this-thunk (car sorters))
418 (next-thunk (compose-sorters/lazy (rest sorters))))
419 (lambda (ctx)
420 (let ((this (funcall this-thunk ctx))
421 (next (funcall next-thunk ctx)))
422 (lambda (a b)
423 (let ((d (funcall this a b)))
424 (if (zerop d)
425 (funcall next a b)
426 d))))))
427 (lambda (ctx)
428 (declare (ignore ctx))
429 (constantly 0))))
431 (defun make-sort-predicate/lazy (decls env)
432 (let ((sorter-thunk
433 (compose-sorters/lazy
434 (mapcar (lambda (x) (make-sorter/lazy x env)) decls))))
435 (lambda (ctx)
436 (let ((sorter (funcall sorter-thunk ctx)))
437 (lambda (a b)
438 (minusp (funcall sorter a b)))))))
440 (defun contextify-node-list (nodes)
441 (let ((size (length nodes)))
442 (loop
443 for position from 1
444 for node in nodes
445 collect
446 (xpath:make-context node size position))))
448 (define-instruction xsl:for-each (args env)
449 (destructuring-bind (select &optional decls &rest body) args
450 (unless (and (consp decls)
451 (eq (car decls) 'declare))
452 (push decls body)
453 (setf decls nil))
454 (let ((select-thunk (compile-xpath select env))
455 (body-thunk (compile-instruction `(progn ,@body) env))
456 (sort-predicate-thunk
457 (when (cdr decls)
458 (make-sort-predicate/lazy (cdr decls) env))))
459 (lambda (ctx)
460 (let ((selected (funcall select-thunk ctx)))
461 (unless (xpath:node-set-p selected)
462 (xslt-error "for-each select expression should yield a node-set"))
463 (let ((nodes (xpath::force (xpath::sorted-pipe-of selected))))
464 (when sort-predicate-thunk
465 (setf nodes
466 (mapcar #'xpath:context-node
467 (stable-sort (contextify-node-list nodes)
468 (funcall sort-predicate-thunk ctx)))))
469 (dolist (ctx (contextify-node-list nodes))
470 (funcall body-thunk ctx))))))))
472 (define-instruction xsl:with-namespaces (args env)
473 (destructuring-bind ((&rest forms) &rest body) args
474 (let ((*namespaces* *namespaces*))
475 (dolist (form forms)
476 (destructuring-bind (prefix uri) form
477 (push (cons prefix uri) *namespaces*)))
478 (compile-instruction `(progn ,@body) env))))
480 (define-instruction xsl:with-excluded-namespaces (args env)
481 (destructuring-bind ((&rest uris) &rest body) args
482 (let ((*excluded-namespaces* (append uris *excluded-namespaces*)))
483 (compile-instruction `(progn ,@body) env))))
485 (define-instruction xsl:with-extension-namespaces (args env)
486 (destructuring-bind ((&rest uris) &rest body) args
487 (let ((*extension-namespaces* (append uris *extension-namespaces*)))
488 (compile-instruction `(progn ,@body) env))))
490 ;; XSLT disallows multiple definitions of the same variable within a
491 ;; template. Local variables can shadow global variables though.
492 ;; Since our LET syntax makes it natural to shadow local variables the
493 ;; Lisp way, we check for duplicate variables only where instructed to
494 ;; by the XML syntax parser using WITH-DUPLICATES-CHECK:
495 (defvar *template-variables* nil)
497 (define-instruction xsl:with-duplicates-check (args env)
498 (let ((*template-variables* *template-variables*))
499 (destructuring-bind ((&rest qnames) &rest body) args
500 (dolist (qname qnames)
501 (multiple-value-bind (local-name uri)
502 (decode-qname qname env nil)
503 (let ((key (cons local-name uri)))
504 (when (find key *template-variables* :test #'equal)
505 (xslt-error "duplicate variable: ~A, ~A" local-name uri))
506 (push key *template-variables*))))
507 (compile-instruction `(progn ,@body) env))))
509 (define-instruction xsl:with-base-uri (args env)
510 (destructuring-bind (uri &rest body) args
511 (let ((*instruction-base-uri* uri))
512 (compile-instruction `(progn ,@body) env))))
514 (defstruct (result-tree-fragment
515 (:constructor make-result-tree-fragment (node)))
516 node)
518 (define-default-method xpath-protocol:node-p
519 ((node result-tree-fragment))
522 (define-default-method xpath-protocol:node-text
523 ((node result-tree-fragment))
524 (xpath-protocol:node-text (result-tree-fragment-node node)))
526 (defun apply-to-result-tree-fragment (ctx thunk)
527 (let ((document
528 (with-xml-output (make-stpx-builder)
529 (with-element ("fragment" "")
530 (funcall thunk ctx)))))
531 (make-result-tree-fragment (stp:document-element document))))
533 (define-instruction let (args env)
534 (destructuring-bind ((&rest forms) &rest body) args
535 (let* ((old-top (length *lexical-variable-declarations*))
536 (vars-and-names (compile-var-bindings/nointern forms env))
537 (vars-and-positions
538 (loop for ((local-name . uri) thunk) in vars-and-names
539 collect
540 (list (push-variable local-name
542 *lexical-variable-declarations*)
543 thunk))))
544 (let ((thunk (compile-instruction `(progn ,@body) env)))
545 (fill *lexical-variable-declarations* nil :start old-top)
546 (lambda (ctx)
547 (loop for (index var-thunk) in vars-and-positions
548 do (setf (lexical-variable-value index)
549 (funcall var-thunk ctx)))
550 (funcall thunk ctx))))))
552 (define-instruction let* (args env)
553 (destructuring-bind ((&rest forms) &rest body) args
554 (if forms
555 (compile-instruction `(let (,(car forms))
556 (let* (,@(cdr forms))
557 ,@body))
558 env)
559 (compile-instruction `(progn ,@body) env))))
561 (define-instruction xsl:message (args env)
562 (compile-message #'warn args env))
564 (define-instruction xsl:terminate (args env)
565 (compile-message #'error args env))
567 (defun namespaces-as-alist (element)
568 (let ((namespaces '()))
569 (do-pipe (ns (xpath-protocol:namespace-pipe element))
570 (push (cons (xpath-protocol:local-name ns)
571 (xpath-protocol:node-text ns))
572 namespaces))
573 namespaces))
575 (define-instruction xsl:copy (args env)
576 (let ((body (compile-instruction `(progn ,@args) env)))
577 (lambda (ctx)
578 (let ((node (xpath:context-node ctx)))
579 (cond
580 ((xpath-protocol:node-type-p node :element)
581 (with-element
582 ((xpath-protocol:local-name node)
583 (xpath-protocol:namespace-uri node)
584 :suggested-prefix (xpath-protocol:namespace-prefix node)
585 :extra-namespaces (namespaces-as-alist node))
586 (funcall body ctx)))
587 ((xpath-protocol:node-type-p node :document)
588 (funcall body ctx))
590 (copy-leaf-node node)))))))
592 (defun copy-leaf-node (node)
593 (cond
594 ((xpath-protocol:node-type-p node :text)
595 (etypecase (if (typep node 'stripping-node)
596 (stripping-node-target node)
597 node)
598 (unescaped-text (write-unescaped (xpath-protocol:node-text node)))
599 (stp:text (write-text (xpath-protocol:node-text node)))))
600 ((xpath-protocol:node-type-p node :comment)
601 (write-comment (xpath-protocol:node-text node)))
602 ((xpath-protocol:node-type-p node :processing-instruction)
603 (write-processing-instruction
604 (xpath-protocol:processing-instruction-target node)
605 (xpath-protocol:node-text node)))
606 ((xpath-protocol:node-type-p node :attribute)
607 (write-attribute
608 (xpath-protocol:local-name node)
609 (xpath-protocol:namespace-uri node)
610 (xpath-protocol:node-text node)
611 :suggested-prefix (xpath-protocol:namespace-prefix node)))
612 ((xpath-protocol:node-type-p node :namespace)
613 (write-extra-namespace
614 (xpath-protocol:local-name node)
615 (xpath-protocol:node-text node)
616 nil))
618 (error "don't know how to copy node ~A" node))))
620 (defun compile-message (fn args env)
621 (let ((thunk (compile-instruction `(progn ,@args) env)))
622 (lambda (ctx)
623 (funcall fn
624 (with-xml-output (cxml:make-string-sink)
625 (funcall thunk ctx))))))
627 (define-instruction xsl:apply-templates (args env)
628 (destructuring-bind ((&key select mode) &rest param-binding-specs) args
629 (let* ((decls
630 (when (and (consp (car param-binding-specs))
631 (eq (caar param-binding-specs) 'declare))
632 (cdr (pop param-binding-specs))))
633 (select-thunk
634 (compile-xpath (or select "child::node()") env))
635 (param-bindings
636 (compile-var-bindings param-binding-specs env))
637 (sort-predicate-thunk
638 (when decls
639 (make-sort-predicate/lazy decls env))))
640 (multiple-value-bind (mode-local-name mode-uri)
641 (and mode (decode-qname mode env nil))
642 (lambda (ctx)
643 (apply-templates/list
644 (xpath::force
645 (xpath::sorted-pipe-of (funcall select-thunk ctx)))
646 :param-bindings
647 (loop for (name nil value-thunk) in param-bindings
648 collect (list name (funcall value-thunk ctx)))
649 :sort-predicate (when sort-predicate-thunk
650 (funcall sort-predicate-thunk ctx))
651 :mode (when mode
652 (or (find-mode *stylesheet*
653 mode-local-name
654 mode-uri)
655 *empty-mode*))))))))
657 (define-instruction xsl:apply-imports (args env)
658 (declare (ignore args env))
659 (lambda (ctx)
660 (declare (ignore ctx))
661 (funcall *apply-imports*)))
663 (define-instruction xsl:call-template (args env)
664 (destructuring-bind (name &rest param-binding-specs) args
665 (let ((param-bindings
666 (compile-var-bindings param-binding-specs env)))
667 (multiple-value-bind (local-name uri)
668 (decode-qname name env nil)
669 (setf name (cons local-name uri)))
670 (lambda (ctx)
671 (call-template ctx name
672 (loop for (name nil value-thunk) in param-bindings
673 collect (list name (funcall value-thunk ctx))))))))
675 ;; fixme: incompatible with XSLT 2.0
676 (define-instruction xsl:document (args env)
677 (destructuring-bind ((href &key method indent doctype-public doctype-system)
678 &body body)
679 args
680 (declare (ignore doctype-public doctype-system)) ;fixme
681 (let ((thunk (compile-instruction `(progn ,@body) env))
682 (href-thunk (compile-avt href env)))
683 (lambda (ctx)
684 (let ((pathname
685 (uri-to-pathname
686 (puri:merge-uris (funcall href-thunk ctx)
687 (xpath-protocol:base-uri
688 (xpath:context-node ctx))))))
689 (ensure-directories-exist pathname) ;really?
690 (invoke-with-output-sink
691 (lambda ()
692 (funcall thunk ctx))
693 (make-output-specification :method (or method "XML") :indent indent)
694 pathname))))))
696 (defun compile-instruction (form env)
697 (xslt-trace-thunk
698 (funcall (or (get (car form) 'xslt-instruction)
699 (error "undefined instruction: ~A" (car form)))
700 (cdr form)
701 env)
702 "instruction ~s" (car form)))
704 ;;: WTF: "A right curly brace inside a Literal in an expression is not
705 ;;; recognized as terminating the expression."
707 ;;; Da hilft nur tagbody.
708 (defun parse-attribute-value-template (template-string)
709 (with-input-from-string (input template-string)
710 (let ((ordinary (make-string-output-stream))
711 (xpath (make-string-output-stream))
712 (tokens '())
713 (c (read-char input nil :eof)))
714 (flet ((emit ()
715 (let ((o (get-output-stream-string ordinary)))
716 (when (plusp (length o))
717 (push (list :data o) tokens)))
718 (let ((x (get-output-stream-string xpath)))
719 (when (plusp (length x))
720 (push (list :xpath x) tokens))))
721 (collect-ordinary ()
722 (write-char c ordinary))
723 (collect-xpath ()
724 (write-char c xpath)))
725 (macrolet ((goto (target)
726 `(progn
727 (setf c (read-char input nil :eof))
728 (go ,target))))
729 (tagbody
730 ordinary
731 (case c
732 (#\{
733 (goto seen{))
734 (#\}
735 (goto seen-stray-}))
736 (:eof
737 (go done)))
738 (collect-ordinary)
739 (goto ordinary)
741 seen{
742 (case c
743 (#\{
744 (collect-ordinary)
745 (goto ordinary))
746 (#\'
747 (collect-xpath)
748 (goto in-single-quote))
749 (:eof
750 (xslt-error "unexpected end of avt")))
751 (emit)
752 (collect-xpath)
753 (goto xpath)
755 xpath
756 (case c
757 (#\'
758 (collect-xpath)
759 (goto in-single-quote))
760 (#\"
761 (collect-xpath)
762 (goto in-double-quote))
763 (#\}
764 (goto seen-closing-}))
765 (:eof
766 (xslt-error "unexpected end of avt")))
767 (collect-xpath)
768 (goto xpath)
770 in-single-quote
771 (case c
772 (#\'
773 (collect-xpath)
774 (goto xpath))
775 (:eof
776 (xslt-error "unexpected end of avt")))
777 (collect-xpath)
778 (goto in-single-quote)
780 in-double-quote
781 (case c
782 (#\"
783 (collect-xpath)
784 (goto xpath))
785 (:eof
786 (xslt-error "unexpected end of avt")))
787 (collect-xpath)
788 (goto in-double-quote)
790 seen-closing-}
791 (case c
792 (#\}
793 (collect-xpath)
794 (goto xpath))
795 (#\{
796 (emit)
797 (goto xpath))
798 (:eof
799 (goto done)))
800 (emit)
801 (collect-ordinary)
802 (goto ordinary)
804 seen-stray-}
805 (case c
806 (#\}
807 (collect-ordinary)
808 (goto ordinary)))
809 (xslt-error "unexpected closing brace in avt")
811 done
812 (emit))))
813 (nreverse tokens))))
815 (defun compile-avt (template-string env)
816 (let* ((constantp t)
817 (fns
818 (mapcar (lambda (x)
819 (ecase (car x)
820 (:data
821 (constantly (second x)))
822 (:xpath
823 (setf constantp nil)
824 (compile-xpath (second x) env))))
825 (parse-attribute-value-template template-string))))
826 (values (lambda (ctx)
827 (with-output-to-string (s)
828 (dolist (fn fns)
829 (write-string (xpath:string-value (funcall fn ctx)) s))))
830 constantp)))
833 ;;;; Indentation for slime
835 (defmacro define-indentation (name (&rest args))
836 (labels ((collect-variables (list)
837 (loop
838 for sub in list
839 append
840 (etypecase sub
841 (list
842 (collect-variables sub))
843 (symbol
844 (if (eql (mismatch "&" (symbol-name sub)) 1)
846 (list sub)))))))
847 `(defmacro ,name (,@args)
848 (declare (ignorable ,@(collect-variables args)))
849 (error "XSL indentation helper ~A used literally in lisp code"
850 ',name))))
852 (define-indentation xsl:element
853 ((name &key namespace use-attribute-sets) &body body))
854 (define-indentation xsl:literal-element ((name &optional uri) &body body))
855 (define-indentation xsl:attribute ((name &key namespace) &body body))
856 (define-indentation xsl:literal-attribute ((name &optional uri) &body body))
857 (define-indentation xsl:text (str))
858 (define-indentation xsl:processing-instruction (name &body body))
859 (define-indentation xsl:comment (&body body))
860 (define-indentation xsl:value-of (xpath))
861 (define-indentation xsl:unescaped-value-of (xpath))
862 (define-indentation xsl:for-each (select &body decls-and-body))
863 (define-indentation xsl:message (&body body))
864 (define-indentation xsl:terminate (&body body))
865 (define-indentation xsl:apply-templates ((&key select mode) &body decls-and-body))
866 (define-indentation xsl:call-template (name &rest parameters))
867 (define-indentation xsl:copy-of (xpath))
869 ;;;;
871 (defun test-instruction (form document)
872 (let ((thunk (compile-instruction form (make-instance 'lexical-environment)))
873 (root (cxml:parse document (stp:make-builder))))
874 (with-xml-output (cxml:make-string-sink)
875 (funcall thunk (xpath:make-context root)))))