2 ;;;; Copyright (c) 2008 Zachary Beane, All Rights Reserved
4 ;;;; Redistribution and use in source and binary forms, with or without
5 ;;;; modification, are permitted provided that the following conditions
8 ;;;; * Redistributions of source code must retain the above copyright
9 ;;;; notice, this list of conditions and the following disclaimer.
11 ;;;; * Redistributions in binary form must reproduce the above
12 ;;;; copyright notice, this list of conditions and the following
13 ;;;; disclaimer in the documentation and/or other materials
14 ;;;; provided with the distribution.
16 ;;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
17 ;;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
18 ;;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
19 ;;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
20 ;;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
21 ;;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
22 ;;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
23 ;;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
24 ;;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
25 ;;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
26 ;;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
34 (defun skip-document-start (source)
35 (let ((type (klacks:peek source
)))
36 (when (eql :start-document type
)
37 (klacks:consume source
))
40 (defun skip-characters (source)
42 (if (member (klacks:peek source
) '(:characters
:comment
))
43 (klacks:consume source
)
46 (defun collect-characters (source)
47 (with-output-to-string (stream)
49 (multiple-value-bind (type data
)
51 (cond ((eql type
:characters
)
52 (write-string data stream
)
53 (klacks:consume source
))
57 (defun collect-rest-alist (source)
58 "Collect the rest of SOURCE, up to an un-nested closing tag, as an
59 alist of element names and their character contents."
62 (multiple-value-bind (type uri lname
)
64 (declare (ignore uri
))
66 (:characters
(klacks:consume source
))
68 (return (nreverse result
)))
70 (klacks:consume source
)
71 (push (cons lname
(collect-characters source
)) result
)
72 (klacks:find-event source
:end-element
)
73 (klacks:consume source
)))))))
75 ;;; Match failure conditions
77 (define-condition xml-binding-error
(error)
85 (lambda (condition stream
)
86 (format stream
"Unexpected XML structure: expected ~S, got ~S instead"
88 (actual condition
)))))
91 ;;; Creating the matchers/binders
93 (defvar *current-element-name
*)
95 (defun create-element-start-matcher (element-name kk
)
96 "Return a function that expects to see the start of ELEMENT-NAME
98 (lambda (source bindings k
)
99 (skip-characters source
)
100 (multiple-value-bind (type uri lname qname
)
102 (declare (ignore uri qname
))
103 (when (not (eql type
:start-element
))
104 (error 'xml-binding-error
105 :expected
(list :start-element element-name
)
106 :actual
(list :event type
)))
107 (when (string/= element-name lname
)
108 (error 'xml-binding-error
109 :expected
(list :start-element element-name
)
110 :actual
(list type lname
)))
111 (klacks:consume source
)
112 (funcall kk source bindings k
))))
114 (defun create-element-end-matcher (element-name kk
)
115 "Return a function that expects to see the end of ELEMENT-NAME next in
117 (lambda (source bindings k
)
118 (skip-characters source
)
119 (multiple-value-bind (type uri lname qname
)
121 (declare (ignore uri qname
))
122 (when (not (eql type
:end-element
))
123 (error 'xml-binding-error
124 :expected
(list :end-element element-name
)
125 :actual
(list :event type lname
)))
126 (when (string/= element-name lname
)
127 (error 'xml-binding-error
128 :expected
(list :end-element element-name
)
129 :actual
(list type lname
)))
130 (klacks:consume source
)
131 (funcall kk source bindings k
))))
133 (defun create-bindings-extender (key kk
)
134 "Return a function that extends BINDINGS with KEY and a value of
135 whatever character data is pending in SOURCE."
136 (lambda (source bindings k
)
138 (acons key
(collect-characters source
) bindings
)
141 (defun create-skipper (element-name kk
)
142 "Return a function that skips input in SOURCE until it sees a
143 closing tag for ELEMENT-NAME. Nested occurrences of elements with the
144 same ELEMENT-NAME are also skipped."
146 (lambda (source bindings k
)
148 (multiple-value-bind (type uri lname
)
149 (klacks:consume source
)
150 (declare (ignore uri
))
151 (cond ((and (eql type
:end-element
)
152 (string= lname element-name
))
154 (return (funcall kk source bindings k
))
156 ((and (eql type
:start-element
)
157 (string= lname element-name
))
160 (defun create-bindings-returner ()
161 "Return a function that does nothing but return its BINDINGS,
162 effectively ending matching."
163 (lambda (source bindings k
)
164 (declare (ignore source k
))
165 (nreverse bindings
)))
167 (defmacro catching-xml-errors
(&body body
)
170 (xml-binding-error (c)
173 (defun create-sequence-binder (key forms kk
)
174 "Return a function that creates a list of sub-bindings based on a
175 sub-matcher, with KEY as the key."
176 (let ((binder (create-binder forms
(create-bindings-returner))))
177 (lambda (source bindings k
)
178 (let ((sub-bindings '()))
180 (skip-characters source
)
181 (multiple-value-bind (sub-binding failure
)
183 (funcall binder source nil k
))
188 (nreverse sub-bindings
)
191 (push sub-binding sub-bindings
))))))))
193 (defun create-alist-binder (key kk
)
194 "Return a function that returns the rest of SOURCE as an alist of
195 element-name/element-content data."
196 (lambda (source bindings k
)
198 (acons key
(collect-rest-alist source
) bindings
)
201 (defun create-optional-binder (subforms kk
)
202 (let ((binder (create-binder subforms kk
)))
203 (lambda (source bindings k
)
204 (skip-characters source
)
205 (multiple-value-bind (optional-bindings failure
)
206 (catching-xml-errors (funcall binder source bindings k
))
208 (funcall kk source bindings k
)
209 optional-bindings
)))))
211 (defun create-alternate-binder (subforms kk
)
212 (let ((binders (mapcar (lambda (form) (create-binder form kk
)) subforms
)))
213 (lambda (source bindings k
)
214 ;; FIXME: This xml-binding-error needs :expected and :action
215 ;; ooptions. Can get actual with peeking and expected by getting
216 ;; the cl:cars of subforms...maybe.
217 (dolist (binder binders
(error 'xml-binding-error
))
218 (multiple-value-bind (alt-bindings failure
)
219 (catching-xml-errors (funcall binder source bindings k
))
221 (return alt-bindings
)))))))
223 (defun create-special-processor (operator form k
)
224 "Handle special pattern processing forms like BIND, SKIP-REST, SEQUENCE,
227 (alternate (create-alternate-binder (rest form
) k
))
228 (bind (create-bindings-extender (second form
) k
))
229 (optional (create-optional-binder (second form
) k
))
230 (skip-rest (create-skipper *current-element-name
* k
))
232 (destructuring-bind (key subforms
)
234 (create-sequence-binder key subforms k
)))
236 (create-alist-binder (second form
) k
))))
238 (defun create-binder (form &optional
(k (create-bindings-returner)))
239 "Process FORM as an XML binder pattern and return a closure to
240 process an XML source."
241 (let ((operator (first form
)))
244 (let ((*current-element-name
* operator
))
245 (create-element-start-matcher *current-element-name
*
246 (create-binder (rest form
) k
))))
248 (create-element-end-matcher *current-element-name
*
251 (create-binder operator
(create-binder (rest form
) k
)))
253 (create-special-processor operator form k
)))))
255 (defun xml-source (source)
257 (cxml::cxml-source source
)
258 (t (cxml:make-source source
))))
260 (defun make-binder (form)
261 (let ((binder (create-binder form
(create-bindings-returner))))
263 (let ((source (xml-source source
)))
264 (skip-document-start source
)
268 (create-bindings-returner))))))
270 (defun xml-bind (binder source
)
271 (funcall binder source
))
273 (defun try-to-xml-bind (binder source
)
274 "Like XML-BIND, but catches any XML-BINDING-ERRORs; if any errors
275 are caught, NIL is the primary value and the error object is the
278 (xml-bind binder source
)
279 (xml-binding-error (c)
282 (defun xml-document-element (source)
283 (nth-value 2 (klacks:find-event
(xml-source source
) :start-element
)))
285 (defun bvalue (key bindings
)
286 (cdr (assoc key bindings
)))
290 (bvalue key binding
)))
292 (defmacro alist-bind
(bindings alist
&body body
)
293 (let ((binds (gensym)))
294 (flet ((one-binding (var)
295 (let ((keyword (intern (symbol-name var
) :keyword
)))
296 `(when (eql (caar ,binds
) ,keyword
)
297 (setf ,var
(cdr (pop ,binds
)))))))
299 (let ((,binds
,alist
))
300 ,@(mapcar #'one-binding bindings
)
306 (defgeneric merge-bindings
(object bindings
)
307 (:documentation
"Update OBJECT with the data from BINDINGS."))