1 ;;; -*- Mode: Lisp; readtable: runes; -*-
2 ;;; (c) copyright 2007 David Lichteblau
4 ;;; This library is free software; you can redistribute it and/or
5 ;;; modify it under the terms of the GNU Library General Public
6 ;;; License as published by the Free Software Foundation; either
7 ;;; version 2 of the License, or (at your option) any later version.
9 ;;; This library is distributed in the hope that it will be useful,
10 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
11 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
12 ;;; Library General Public License for more details.
14 ;;; You should have received a copy of the GNU Library General Public
15 ;;; License along with this library; if not, write to the
16 ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
17 ;;; Boston, MA 02111-1307 USA.
21 (defclass klacks
:source
()
23 ;; fixme, terrible DTD kludges
24 (internal-declarations)
25 (external-declarations :initform nil
)
26 (dom-impl-dtd :initform nil
)
27 (dom-impl-entity-resolver :initform nil
)))
29 (defgeneric klacks
:close-source
(source))
31 (defgeneric klacks
:peek
(source))
32 (defgeneric klacks
:peek-value
(source))
33 (defgeneric klacks
:consume
(source))
35 (defgeneric klacks
:map-attributes
(fn source
))
36 (defgeneric klacks
:list-attributes
(source))
37 (defgeneric klacks
:get-attribute
(source lname
&optional uri
))
38 ;;;(defgeneric klacks:current-uri (source))
39 ;;;(defgeneric klacks:current-lname (source))
40 ;;;(defgeneric klacks:current-qname (source))
41 ;;;(defgeneric klacks:current-characters (source))
42 (defgeneric klacks
:current-cdata-section-p
(source))
43 (defgeneric klacks
:map-current-namespace-declarations
(fn source
))
45 (defgeneric klacks
:current-line-number
(source))
46 (defgeneric klacks
:current-column-number
(source))
47 (defgeneric klacks
:current-system-id
(source))
48 (defgeneric klacks
:current-xml-base
(source))
50 (defgeneric klacks
:find-namespace-binding
(prefix source
))
51 (defgeneric klacks
:decode-qname
(qname source
))
53 (defmacro klacks
:with-open-source
((var source
) &body body
)
54 `(let ((,var
,source
))
57 (klacks:close-source
,var
))))
59 (defun klacks:current-uri
(source)
60 (multiple-value-bind (key uri lname qname
) (klacks:peek source
)
61 (declare (ignore lname qname
))
62 (check-type key
(member :start-element
:end-element
))
65 (defun klacks:current-lname
(source)
66 (multiple-value-bind (key uri lname qname
) (klacks:peek source
)
67 (declare (ignore uri qname
))
68 (check-type key
(member :start-element
:end-element
))
71 (defun klacks:current-qname
(source)
72 (multiple-value-bind (key uri lname qname
) (klacks:peek source
)
73 (declare (ignore uri lname
))
74 (check-type key
(member :start-element
:end-element
))
77 (defun klacks:current-characters
(source)
78 (multiple-value-bind (key characters
) (klacks:peek source
)
79 (check-type key
(member :characters
))
82 (defun klacks:consume-characters
(source)
83 (with-output-to-string (s)
84 (while (eq (klacks:peek source
) :characters
)
85 (write-string (klacks:current-characters source
) s
)
86 (klacks:consume source
))))
88 (defun klacks:serialize-event
(source handler
&key
(consume t
))
89 (multiple-value-bind (key a b c
) (klacks:peek source
)
93 (sax:start-document handler
)
94 (loop for
(prefix . uri
) in
*initial-namespace-bindings
* do
95 (sax:start-prefix-mapping handler prefix uri
)))
98 ((klacks:current-cdata-section-p source
)
99 (sax:start-cdata handler
)
100 (sax:characters handler a
)
101 (sax:end-cdata handler
))
103 (sax:characters handler a
))))
104 (:processing-instruction
105 (sax:processing-instruction handler a b
))
107 (sax:comment handler a
))
109 (sax:start-dtd handler a b
(and c
(uri-rod c
)))
110 (when (slot-boundp source
'internal-declarations
)
111 (sax:start-internal-subset handler
)
112 (serialize-declaration-kludge
113 (slot-value source
'internal-declarations
)
115 (sax:end-internal-subset handler
))
116 (serialize-declaration-kludge
117 (slot-value source
'external-declarations
)
119 (sax:end-dtd handler
)
120 (sax:entity-resolver handler
121 (slot-value source
'dom-impl-entity-resolver
))
122 (sax::dtd handler
(slot-value source
'dom-impl-dtd
)))
124 (klacks:map-current-namespace-declarations
126 (sax:start-prefix-mapping handler prefix uri
))
128 (sax:start-element handler a b c
(klacks:list-attributes source
)))
130 (sax:end-element handler a b c
)
131 (klacks:map-current-namespace-declarations
133 (declare (ignore uri
))
134 (sax:end-prefix-mapping handler prefix
))
137 (loop for
(prefix . nil
) in
*initial-namespace-bindings
* do
138 (sax:end-prefix-mapping handler prefix
))
139 (setf result
(sax:end-document handler
)))
141 (error "serialize-event read past end of document"))
143 (error "unexpected klacks key: ~A" key
)))
145 (klacks:consume source
))
148 (defun serialize-declaration-kludge (list handler
)
150 for
(fn . args
) in list
151 do
(apply fn handler args
)))
153 (defun klacks:serialize-source
(source handler
)
155 (let ((document (klacks:serialize-event source handler
)))
157 (return document
)))))
159 (defclass klacksax
(sax:sax-parser
)
160 ((source :initarg
:source
)))
162 (defmethod sax:line-number
((parser klacksax
))
163 (klacks:current-line-number
(slot-value parser
'source
)))
165 (defmethod sax:column-number
((parser klacksax
))
166 (klacks:current-column-number
(slot-value parser
'source
)))
168 (defmethod sax:system-id
((parser klacksax
))
169 (klacks:current-system-id
(slot-value parser
'source
)))
171 (defmethod sax:xml-base
((parser klacksax
))
172 (klacks:current-xml-base
(slot-value parser
'source
)))
174 (defun klacks:serialize-element
(source handler
&key
(document-events t
))
175 (unless (eq (klacks:peek source
) :start-element
)
176 (error "not at start of element"))
177 (sax:register-sax-parser handler
(make-instance 'klacksax
:source source
))
178 (when document-events
179 (sax:start-document handler
))
181 (klacks:serialize-event source handler
)
183 (let ((key (klacks:peek source
)))
185 (:start-element
(recurse))
186 (:end-element
(return))
187 ((:characters
:comment
:processing-instruction
)
188 (klacks:serialize-event source handler
)))))
189 (klacks:serialize-event source handler
)))
191 (when document-events
192 (sax:end-document handler
)))
194 (defun klacks:find-element
(source &optional lname uri
)
196 (multiple-value-bind (key current-uri current-lname current-qname
)
202 (when (and (eq key
:start-element
)
204 (equal lname
(klacks:current-lname source
)))
206 (equal uri
(klacks:current-uri source
))))
208 (values key current-uri current-lname current-qname
)))))
209 (klacks:consume source
))))
211 (defun klacks:find-event
(source key
)
213 (multiple-value-bind (this a b c
)
219 (return (values this a b c
))))
220 (klacks:consume source
))))
222 (define-condition klacks
:klacks-error
(xml-parse-error) ())
224 (defun klacks-error (fmt &rest args
)
225 (%error
'klacks
:klacks-error
227 (format nil
"Klacks assertion failed: ~?" fmt args
)))
229 (defun klacks:expect
(source key
&optional u v w
)
230 (multiple-value-bind (this a b c
)
232 (unless (eq this key
) (klacks-error "expected ~A but got ~A" key this
))
233 (when (and u
(not (equal a u
)))
234 (klacks-error "expected ~A but got ~A" u a
))
235 (when (and v
(not (equal b v
)))
236 (klacks-error "expected ~A but got ~A" v b
))
237 (when (and w
(not (equal c w
)))
238 (klacks-error "expected ~A but got ~A" w c
))
239 (values this a b c
)))
241 (defun klacks:skip
(source key
&optional a b c
)
242 (klacks:expect source key a b c
)
243 (klacks:consume source
))
245 (defun invoke-expecting-element (fn source
&optional lname uri
)
246 (multiple-value-bind (key a b
)
248 (unless (eq key
:start-element
)
249 (klacks-error "expected ~A but got ~A" (or lname
"element") key
))
250 (when (and uri
(not (equal a uri
)))
251 (klacks-error "expected ~A but got ~A" uri a
))
252 (when (and lname
(not (equal b lname
)))
253 (klacks-error "expected ~A but got ~A" lname b
))
254 (multiple-value-prog1
256 (klacks:skip source
:end-element a b
))))
258 (defmacro klacks
:expecting-element
((source &optional lname uri
) &body body
)
259 `(invoke-expecting-element (lambda () ,@body
) ,source
,lname
,uri
))