1 ;;; -*- show-trailing-whitespace: t; indent-tabs: nil -*-
3 ;;; Copyright (c) 2007 David Lichteblau. All rights reserved.
5 ;;; Redistribution and use in source and binary forms, with or without
6 ;;; modification, are permitted provided that the following conditions
9 ;;; * Redistributions of source code must retain the above copyright
10 ;;; notice, this list of conditions and the following disclaimer.
12 ;;; * Redistributions in binary form must reproduce the above
13 ;;; copyright notice, this list of conditions and the following
14 ;;; disclaimer in the documentation and/or other materials
15 ;;; provided with the distribution.
17 ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
18 ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
19 ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
20 ;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
21 ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
22 ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
23 ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
24 ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
25 ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
26 ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
27 ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
29 (in-package :xuriella
)
32 (declaim (optimize (debug 2)))
35 ;;;; XSLT-ENVIRONMENT and XSLT-CONTEXT
37 (defparameter *namespaces
*
39 ("xmlns" .
#"http://www.w3.org/2000/xmlns/")
40 ("xml" .
#"http://www.w3.org/XML/1998/namespace")))
41 (defparameter *variable-declarations
* '())
43 (defclass xslt-environment
() ())
45 (defun make-xslt-environment ()
46 (make-instance 'xslt-environment
))
48 (defun decode-qname (qname env attributep
)
49 (multiple-value-bind (prefix local-name
)
50 (cxml::split-qname qname
)
52 (if (or prefix
(not attributep
))
53 (xpath:environment-find-namespace env prefix
)
56 (defmethod xpath:environment-find-namespace
((env xslt-environment
) prefix
)
57 (cdr (assoc prefix
*namespaces
* :test
'equal
)))
59 (defmethod xpath:environment-find-variable
60 ((env xslt-environment
) lname uri
)
61 (cdr (assoc (cons lname uri
) *variable-declarations
* :test
'equal
)))
66 ;;;; A sink that serializes only text and will error out on any other
69 (defmacro with-text-output-sink
((var) &body body
)
70 `(invoke-with-text-output-sink (lambda (,var
) ,@body
)))
72 (defclass text-output-sink
(sax:content-handler
)
73 ((target :initarg
:target
:accessor text-output-sink-target
)))
75 (defmethod sax:characters
((sink text-output-sink
) data
)
76 (write-string data
(text-output-sink-target sink
)))
78 (defun invoke-with-text-output-sink (fn)
79 (with-output-to-string (s)
80 (funcall fn
(make-instance 'text-output-sink
:target s
))))
85 (defvar *xsl
* "http://www.w3.org/1999/XSL/Transform")
86 (defvar *xml
* "http://www.w3.org/XML/1998/namespace")
88 (defun of-name (local-name)
89 (stp:of-name local-name
*xsl
*))
91 (defun namep (node local-name
)
92 (and (typep node
'(or stp
:element stp
:attribute
))
93 (equal (stp:namespace-uri node
) *xsl
*)
94 (equal (stp:local-name node
) local-name
)))
99 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
100 (defparameter *whitespace
*
101 (format nil
"~C~C~C~C"
107 (defun normalize-whitespace (str)
108 (cl-ppcre:regex-replace-all
#.
(format nil
"[~A]+" *whitespace
*)
109 (string-trim *whitespace
* str
)
112 (defun whitespacep (str)
113 (cl-ppcre:all-matches
#.
(format nil
"^[~A]+$" *whitespace
*) str
))
115 ;; For stylesheets, not source documents. Also strips comments and PIs.
116 (defun strip-stylesheet (parent &optional preserve
)
118 (loop while
(< i
(length (cxml-stp-impl::%children parent
))) do
119 (let ((child (stp:nth-child i parent
)))
122 (if (and (whitespacep (stp:data child
))
124 (stp:delete-nth-child i parent
)
126 ((or stp
:comment stp
:processing-instruction
)
127 (stp:delete-nth-child i parent
))
129 (stp:with-attributes
((space "space" *xml
*))
133 ((namep child
"text") t
)
134 ((not space
) preserve
)
135 ((equal space
"preserve") t
)
137 (strip-stylesheet child new-preserve
)))
141 ;;;; PARSE-STYLESHEET
143 (defstruct stylesheet
144 (modes (make-hash-table :test
'equal
))
148 (named-templates (make-hash-table :test
'equal
))
149 (other-templates nil
))
151 (defun find-mode (mode stylesheet
)
152 (gethash mode
(stylesheet-modes stylesheet
)))
154 (defun ensure-mode (mode stylesheet
)
155 (or (find-mode mode stylesheet
)
156 (setf (gethash mode
(stylesheet-modes stylesheet
))
159 (defun parse-stylesheet (d)
160 ;; FIXME: I was originally planning on rewriting this using klacks
161 ;; eventually, but now let's just build an STP document
162 (let* ((d (cxml:parse d
(cxml-stp:make-builder
)))
163 (<transform
> (stp:document-element d
))
164 (stylesheet (make-stylesheet))
165 (env (make-xslt-environment)))
166 (strip-stylesheet <transform
>)
167 ;; FIXME: handle embedded stylesheets
168 (unless (and (equal (stp:namespace-uri
<transform
>) *xsl
*)
169 (or (equal (stp:local-name
<transform
>) "transform")
170 (equal (stp:local-name
<transform
>) "stylesheet")))
171 (error "not a stylesheet"))
172 (ensure-mode "" stylesheet
)
173 (dolist (<template
> (stp:filter-children
(of-name "template") <transform
>))
174 (dolist (template (compile-template <template
> env
))
175 (let ((mode (ensure-mode (template-mode template
) stylesheet
))
176 (name-test (template-qname-test template
)))
178 (multiple-value-bind (local-name uri
)
179 (decode-qname name-test env nil
)
181 (gethash (cons local-name uri
)
182 (mode-named-templates mode
))))
183 (push template
(mode-other-templates mode
))))))
187 ;;;; APPLY-STYLESHEET
191 (deftype xml-designator
() '(or runes
:xstream runes
:rod array stream pathname
))
193 (defun apply-stylesheet (stylesheet source-document
&optional output-spec
)
194 (when (typep stylesheet
'xml-designator
)
195 (setf stylesheet
(parse-stylesheet stylesheet
)))
196 (when (typep source-document
'xml-designator
)
197 (setf source-document
(cxml:parse source-document
(stp:make-builder
))))
198 (invoke-with-output-sink
200 (let ((*mode
* (find-mode "" stylesheet
)))
201 (apply-templates (xpath::make-context source-document
))))
205 (defun apply-templates/list
(list)
206 (let* ((n (length list
))
212 (apply-templates (xpath::make-context child s
/d i
)))))
214 (defun apply-templates (ctx)
215 (let ((template (find-template ctx
)))
217 (funcall (template-body template
) ctx
)
218 (let ((node (xpath::context-node ctx
)))
220 ((or (xpath-protocol:node-type-p node
:processing-instruction
)
221 (xpath-protocol:node-type-p node
:comment
)))
222 ((xpath-protocol:node-type-p node
:text
)
223 (cxml:text
(xpath-protocol:string-value node
)))
225 (apply-templates/list
227 (xpath-protocol:child-pipe node
)))))))))
229 (defun find-template (ctx)
231 (xpath::context-node ctx
))
233 (when (xpath-protocol:node-type-p node
:element
)
234 (cons (xpath-protocol:local-name node
)
235 (xpath-protocol:namespace-uri node
))))
237 (append (and key
(gethash key
(mode-named-templates *mode
*)))
238 (mode-other-templates *mode
*)))
240 (remove-if-not (lambda (template)
241 (template-matches-p template ctx
))
243 (maximize #'template
< matching-candidates
)))
245 (defun template< (a b
)
246 (let ((i (template-import-precedence a
))
247 (j (template-import-precedence b
))
248 (p (template-priority a
))
249 (q (template-priority b
)))
258 (error "conflicting templates: ~A, ~A" a b
)))))))
260 (defun maximize (< things
)
262 (let ((max (car things
)))
263 (dolist (other (cdr things
))
264 (when (funcall < max other
)
268 (defun template-matches-p (template ctx
)
269 (find (xpath::context-node ctx
)
270 (xpath:all-nodes
(funcall (template-match-thunk template
) ctx
))))
272 (defun invoke-with-output-sink (fn stylesheet output
)
275 (with-open-file (s output
277 :element-type
'(unsigned-byte 8)
278 :if-exists
:rename-and-delete
)
279 (invoke-with-output-sink fn stylesheet s
)))
281 (cxml:with-xml-output
(make-output-sink stylesheet output
)
283 ((or hax
:abstract-handler sax
:abstract-handler
)
284 (cxml:with-xml-output output
287 (defun make-output-sink (stylesheet stream
)
288 (if (stylesheet-html-output-p stylesheet
)
290 (let ((et (stream-element-type stream
)))
292 ((or (null et
) (subtypep et
'(unsigned-byte 8)))
293 (chtml:make-character-stream-sink stream
))
294 ((subtypep et
'character
)
295 (chtml:make-octet-stream-sink stream
))))
296 (chtml:make-string-sink
))
298 (let ((et (stream-element-type stream
)))
300 ((or (null et
) (subtypep et
'(unsigned-byte 8)))
301 (cxml:make-character-stream-sink stream
))
302 ((subtypep et
'character
)
303 (cxml:make-octet-stream-sink stream
))))
304 (cxml:make-string-sink
))))
314 (defun template-import-precedence (template)
319 (defun template-qname-test (template)
320 (let* ((form (template-match-expression template
))
321 (first-step (second form
)))
322 (when (and (null (cddr form
))
323 (eq :child
(car first-step
)))
324 (second first-step
))))
326 (defun expression-priority (form)
327 (let ((first-step (second form
)))
328 (if (and (null (cddr form
))
329 (eq :child
(car first-step
))
330 (null (cddr first-step
)))
331 (let ((name (second first-step
)))
334 (eq (car name
) :qname
)
335 (eq (car name
) :processing-instruction
))
337 ((eq (car name
) :namespace
)
343 (defun parse-pattern (str)
344 ;; zzz check here for anything not allowed as an XSLT pattern
345 ;; zzz can we hack id() and key() here?
346 (let ((form (xpath:parse-xpath str
)))
348 (error "not a valid pattern: ~A" str
))
349 (mapcar (lambda (case)
350 (unless (eq (car case
) :path
) ;zzz: filter statt path
351 (error "not a valid pattern: ~A" str
))
352 `(:path
(:ancestor-or-self
:node
) ,@(cdr case
)))
353 (if (eq (car form
) :union
)
357 (defun compile-template (<template
> env
)
358 (stp:with-attributes
(match name priority mode
) <template
>
359 (unless (or name match
)
360 (error "missing match in template"))
361 (let ((body (parse-body <template
>)))
362 (mapcar (lambda (expression)
364 (compile-instruction `(progn ,@body
) env
))
366 (xpath:compile-xpath
`(xpath:xpath
,expression
) env
))
368 (parse-number:parse-number priority
)
369 (expression-priority expression
))))
370 (make-template :match-expression expression
371 :match-thunk match-thunk
376 (parse-pattern match
)))))
379 (xuriella::parse-stylesheet
#p
"/home/david/src/lisp/xuriella/test.xsl")