1 ;;;; dom-builder.lisp -- DOM-building SAX handler
3 ;;;; This file is part of the CXML parser, released under Lisp-LGPL.
4 ;;;; See file COPYING for details.
6 ;;;; Author: Gilbert Baumann <unk6@rz.uni-karlsruhe.de>
7 ;;;; Author: Henrik Motakef <hmot@henrik-motakef.de>
8 ;;;; Author: David Lichteblau <david@lichteblau.com>
9 ;;;; Author: knowledgeTools Int. GmbH
11 #-cxml-system
::utf8dom-file
12 (in-package :rune-dom
)
14 #+cxml-system
::utf8dom-file
15 (in-package :utf8-dom
)
18 (defclass dom-builder
(sax:content-handler
)
19 ((document :initform nil
:accessor document
)
20 (element-stack :initform
'() :accessor element-stack
)
21 (internal-subset :accessor internal-subset
)
22 (text-buffer :initform nil
:accessor text-buffer
)))
24 #+(and rune-is-integer
(not cxml-system
::utf8dom-file
))
25 (defmethod hax:%want-strings-p
((handler dom-builder
))
28 (defun make-dom-builder ()
29 (make-instance 'dom-builder
))
31 (defun fast-push (new-element vector
)
32 (vector-push-extend new-element vector
(max 1 (array-dimension vector
0))))
34 (defmethod sax:start-document
((handler dom-builder
))
35 (when (and sax
:*namespace-processing
*
36 (not (and sax
:*include-xmlns-attributes
*
37 sax
:*use-xmlns-namespace
*)))
38 (error "SAX configuration is incompatible with DOM: *namespace-processing* is activated, but *include-xmlns-attributes* or *use-xmlns-namespace* are not"))
39 (let ((document (make-instance 'document
)))
40 (setf (slot-value document
'owner
) nil
41 (slot-value document
'doc-type
) nil
)
42 (setf (document handler
) document
)
43 (push document
(element-stack handler
))))
46 (defmethod sax::dtd
((handler dom-builder
) dtd
)
47 (setf (slot-value (document handler
) 'dtd
) dtd
))
49 (defmethod sax:end-document
((handler dom-builder
))
50 (let ((doctype (dom:doctype
(document handler
))))
52 (setf (slot-value (dom:entities doctype
) 'read-only-p
) t
)
53 (setf (slot-value (dom:notations doctype
) 'read-only-p
) t
)))
56 (defmethod sax:entity-resolver
((handler dom-builder
) resolver
)
57 (setf (slot-value (document handler
) 'entity-resolver
) resolver
))
59 (defmethod sax:start-dtd
((handler dom-builder
) name publicid systemid
)
60 (let* ((document (document handler
))
61 (doctype (%create-document-type name publicid systemid
)))
62 (setf (slot-value doctype
'owner
) document
63 (slot-value (dom:notations doctype
) 'owner
) document
64 (slot-value (dom:entities doctype
) 'owner
) document
65 (slot-value document
'doc-type
) doctype
)))
67 (defmethod sax:start-internal-subset
((handler dom-builder
))
68 (setf (internal-subset handler
) nil
))
70 (defmethod sax:end-internal-subset
((handler dom-builder
))
71 (setf (dom::%internal-subset
(slot-value (document handler
) 'doc-type
))
72 (nreverse (internal-subset handler
)))
73 (slot-makunbound handler
'internal-subset
))
75 (macrolet ((defhandler (name &rest args
)
76 `(defmethod ,name
((handler dom-builder
) ,@args
)
77 (when (slot-boundp handler
'internal-subset
)
78 (push (list ',name
,@args
) (internal-subset handler
))))))
79 (defhandler sax
:unparsed-entity-declaration
80 name public-id system-id notation-name
)
81 (defhandler sax
:external-entity-declaration
82 kind name public-id system-id
)
83 (defhandler sax
:internal-entity-declaration
85 (defhandler sax
:notation-declaration
86 name public-id system-id
)
87 (defhandler sax
:element-declaration
89 (defhandler sax
:attribute-declaration
90 element-name attribute-name type default
))
92 (defmethod sax:start-element
93 ((handler dom-builder
) namespace-uri local-name qname attributes
)
94 (check-type qname rod
) ;catch recoder/builder mismatch
95 (flush-characters handler
)
96 (with-slots (document element-stack
) handler
97 (let* ((nsp sax
:*namespace-processing
*)
98 (element (make-instance 'element
101 :namespace-uri
(when nsp namespace-uri
)
102 :local-name
(when nsp local-name
)
103 :prefix
(%rod
(when nsp
(cxml::split-qname
(real-rod qname
))))))
104 (parent (car element-stack
))
106 (dolist (attr attributes
)
109 (dom:create-attribute-ns document
110 (sax:attribute-namespace-uri attr
)
111 (sax:attribute-qname attr
))
112 (dom:create-attribute document
(sax:attribute-qname attr
))))
114 (dom:create-text-node document
(sax:attribute-value attr
))))
115 (setf (slot-value anode
'specified-p
)
116 (sax:attribute-specified-p attr
))
117 (setf (slot-value anode
'owner-element
) element
)
118 (dom:append-child anode text
)
119 (push anode anodes
)))
120 (setf (slot-value element
'parent
) parent
)
121 (fast-push element
(slot-value parent
'children
))
123 (make-instance 'attribute-node-map
125 :element-type
:attribute
128 (setf (slot-value element
'attributes
) map
)
129 (dolist (anode anodes
)
130 (setf (slot-value anode
'map
) map
)))
131 (push element element-stack
))))
133 (defmethod sax:end-element
((handler dom-builder
) namespace-uri local-name qname
)
134 (declare (ignore namespace-uri local-name qname
))
135 (flush-characters handler
)
136 (pop (element-stack handler
)))
138 (defmethod sax:characters
((handler dom-builder
) data
)
139 (with-slots (text-buffer) handler
142 (setf text-buffer data
))
144 (unless (array-has-fill-pointer-p text-buffer
)
145 (setf text-buffer
(make-array (length text-buffer
)
149 :initial-contents text-buffer
)))
150 (let ((n (length text-buffer
))
152 (adjust-vector-exponentially text-buffer
(+ n m
) t
)
153 (move data text-buffer
0 n m
))))))
155 (defun flush-characters (handler)
156 (with-slots (document element-stack text-buffer
) handler
157 (let ((data text-buffer
))
159 (when (array-has-fill-pointer-p data
)
161 (make-array (length data
)
163 :initial-contents data
)))
164 (let ((parent (car element-stack
)))
165 (if (eq (dom:node-type parent
) :cdata-section
)
166 (setf (dom:data parent
) data
)
167 (let ((node (dom:create-text-node document data
)))
168 (setf (slot-value node
'parent
) parent
)
169 (fast-push node
(slot-value (car element-stack
) 'children
)))))
170 (setf text-buffer nil
)))))
172 (defmethod sax:start-cdata
((handler dom-builder
))
173 (flush-characters handler
)
174 (with-slots (document element-stack
) handler
175 (let ((node (dom:create-cdata-section document
#""))
176 (parent (car element-stack
)))
177 (setf (slot-value node
'parent
) parent
)
178 (fast-push node
(slot-value parent
'children
))
179 (push node element-stack
))))
181 (defmethod sax:end-cdata
((handler dom-builder
))
182 (flush-characters handler
)
183 (let ((node (pop (slot-value handler
'element-stack
))))
184 (assert (eq (dom:node-type node
) :cdata-section
))))
186 (defmethod sax:processing-instruction
((handler dom-builder
) target data
)
187 (flush-characters handler
)
188 (with-slots (document element-stack
) handler
189 (let ((node (dom:create-processing-instruction document target data
))
190 (parent (car element-stack
)))
191 (setf (slot-value node
'parent
) parent
)
192 (fast-push node
(slot-value (car element-stack
) 'children
)))))
194 (defmethod sax:comment
((handler dom-builder
) data
)
195 (flush-characters handler
)
196 (with-slots (document element-stack
) handler
197 (let ((node (dom:create-comment document data
))
198 (parent (car element-stack
)))
199 (setf (slot-value node
'parent
) parent
)
200 (fast-push node
(slot-value (car element-stack
) 'children
)))))
202 (defmethod sax:unparsed-entity-declaration
203 ((handler dom-builder
) name public-id system-id notation-name
)
204 (set-entity handler name public-id system-id notation-name
))
206 (defmethod sax:external-entity-declaration
207 ((handler dom-builder
) kind name public-id system-id
)
209 (:general
(set-entity handler name public-id system-id nil
))
212 (defmethod sax:internal-entity-declaration
213 ((handler dom-builder
) kind name value
)
214 (declare (ignore value
))
216 (:general
(set-entity handler name nil nil nil
))
219 (defun set-entity (handler name pid sid notation
)
220 (dom:set-named-item
(dom:entities
(dom:doctype
(document handler
)))
221 (make-instance 'entity
222 :owner
(document handler
)
226 :notation-name notation
)))
228 (defmethod sax:notation-declaration
229 ((handler dom-builder
) name public-id system-id
)
230 (dom:set-named-item
(dom:notations
(dom:doctype
(document handler
)))
231 (make-instance 'notation
232 :owner
(document handler
)
235 :system-id system-id
)))