1 ;;; -*- show-trailing-whitespace: t; indent-tabs-mode: nil -*-
3 ;;; Copyright (c) 2007,2008 Ivan Shvedunov. All rights reserved.
4 ;;; Copyright (c) 2007,2008 David Lichteblau. All rights reserved.
6 ;;; Redistribution and use in source and binary forms, with or without
7 ;;; modification, are permitted provided that the following conditions
10 ;;; * Redistributions of source code must retain the above copyright
11 ;;; notice, this list of conditions and the following disclaimer.
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.
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
)
35 (defvar *extension-groups
* (make-hash-table :test
#'equal
))
37 (defstruct extension-group
40 (elements (make-hash-table :test
#'equal
)))
42 (defstruct extension-element
44 (parser (lambda (&rest ignore
)
45 (declare (ignore ignore
))
46 (xslt-error "extension parser not defined"))))
48 (defun %define-extension-group
(name uri documentation
)
49 (check-type uri string
)
50 (let* ((current-ext (get name
'extension-group
))
53 (setf (gethash (extension-group-uri current-ext
)
56 (gethash (extension-group-uri current-ext
)
58 (extension-group-uri current-ext
) uri
59 (extension-group-documentation current-ext
) documentation
)
62 (setf (get name
'extension-group
)
63 (make-extension-group :uri uri
64 :documentation documentation
))))))
65 (push new-ext
(gethash uri
*extension-groups
*))))
67 (defmacro define-extension-group
(name uri
&optional documentation
)
68 (check-type name symbol
)
69 `(%define-extension-group
',name
,uri
,documentation
))
71 (defun find-extension-element (local-name uri
)
72 (loop for ext in
(gethash uri
*extension-groups
*)
73 for match
= (gethash local-name
(extension-group-elements ext
))
77 (defun ensure-extension-element (ext name
)
78 (check-type name string
)
80 (extension-group-elements
81 (or (get ext
'extension-group
)
82 (error "no such extension: ~s" ext
))))
83 (make-extension-element :local-name name
)))
85 (defmacro define-extension-parser
(ext name
(node-var) &body body
)
86 `(setf (extension-element-parser
87 (ensure-extension-element ',ext
',name
))
91 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
92 (defun parse-extension-lambda-list (lambda-list)
95 for
(form . rest
) on lambda-list
96 when
(eq form
'&environment
)
98 (destructuring-bind (env-var &rest rest-rest
) rest
99 (check-type env-var
(and symbol
(not null
)))
100 (when (find '&environment rest-rest
)
101 (error "duplicate &environment in extension lambda list"))
103 (values env-var
(append normal-forms rest-rest
))))
104 collect form into normal-forms
106 (return (values 'ignore normal-forms
)))))
108 (defmacro define-extension-compiler
(symbol (&rest lambda-list
) &body body
)
109 (when (find (symbol-package symbol
)
110 ;; reserved for built-in instructions:
111 (list (find-package :common-lisp
)
113 (find-package :xuriella
)))
114 (error "cannot define XSLT extensions in the ~A package"
115 (symbol-package symbol
)))
116 (multiple-value-bind (env argument-lambda-list
)
117 (parse-extension-lambda-list lambda-list
)
118 (let ((args (gensym)))
119 `(setf (get ',symbol
'extension-compiler
)
121 (declare (ignorable ,env
))
122 (destructuring-bind (,@argument-lambda-list
) ,ARGS
127 ;;;; our <document> extension
129 (define-extension-group :xuriella
"http://common-lisp.net/project/xuriella"
130 "XSLT extensions provided by Xuriella.")
132 (define-extension-parser :xuriella
"document" (node)
133 (only-with-attributes
134 (href method indent doctype-public doctype-system
) node
135 `(xuriella-extensions:document
136 (,href
:method
,method
138 :doctype-public
,doctype-public
139 :doctype-system
,doctype-system
)
140 ,@(parse-body node
))))
142 (define-extension-compiler xuriella-extensions
:document
143 ((href &key method indent doctype-public doctype-system
)
146 (declare (ignore doctype-public doctype-system
)) ;fixme
147 (let ((thunk (compile-instruction `(progn ,@body
) env
))
148 (href-thunk (compile-avt href env
)))
152 (puri:merge-uris
(funcall href-thunk ctx
)
153 (xpath-protocol:base-uri
154 (xpath:context-node ctx
))))))
155 (ensure-directories-exist pathname
) ;really?
156 (invoke-with-output-sink
159 (make-output-specification
161 ((or (null method
) (equalp method
"XML")) :xml
)
162 ((equalp method
"HTML") :html
)
163 ((equalp method
"TEXT") :text
)
165 (xslt-error "invalid output method: ~A" method
)))