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
()
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 (defun make-dom-builder ()
25 (make-instance 'dom-builder
))
27 (defun fast-push (new-element vector
)
28 (vector-push-extend new-element vector
(max 1 (array-dimension vector
0))))
30 (defmethod sax:start-document
((handler dom-builder
))
31 (when (and sax
:*namespace-processing
*
32 (not (and sax
:*include-xmlns-attributes
*
33 sax
:*use-xmlns-namespace
*)))
34 (error "SAX configuration is incompatible with DOM: *namespace-processing* is activated, but *include-xmlns-attributes* or *use-xmlns-namespace* are not"))
35 (let ((document (make-instance 'document
)))
36 (setf (slot-value document
'owner
) nil
37 (slot-value document
'doc-type
) nil
)
38 (setf (document handler
) document
)
39 (push document
(element-stack handler
))))
42 (defmethod sax::dtd
((handler dom-builder
) dtd
)
43 (setf (slot-value (document handler
) 'dtd
) dtd
))
45 (defmethod sax:end-document
((handler dom-builder
))
46 (let ((doctype (dom:doctype
(document handler
))))
48 (setf (slot-value (dom:entities doctype
) 'read-only-p
) t
)
49 (setf (slot-value (dom:notations doctype
) 'read-only-p
) t
)))
52 (defmethod sax:entity-resolver
((handler dom-builder
) resolver
)
53 (setf (slot-value (document handler
) 'entity-resolver
) resolver
))
55 (defmethod sax:start-dtd
((handler dom-builder
) name publicid systemid
)
56 (let* ((document (document handler
))
57 (doctype (%create-document-type name publicid systemid
)))
58 (setf (slot-value doctype
'owner
) document
59 (slot-value (dom:notations doctype
) 'owner
) document
60 (slot-value (dom:entities doctype
) 'owner
) document
61 (slot-value document
'doc-type
) doctype
)))
63 (defmethod sax:start-internal-subset
((handler dom-builder
))
64 (setf (internal-subset handler
) nil
))
66 (defmethod sax:end-internal-subset
((handler dom-builder
))
67 (setf (dom::%internal-subset
(slot-value (document handler
) 'doc-type
))
68 (nreverse (internal-subset handler
)))
69 (slot-makunbound handler
'internal-subset
))
71 (macrolet ((defhandler (name &rest args
)
72 `(defmethod ,name
((handler dom-builder
) ,@args
)
73 (when (slot-boundp handler
'internal-subset
)
74 (push (list ',name
,@args
) (internal-subset handler
))))))
75 (defhandler sax
:unparsed-entity-declaration
76 name public-id system-id notation-name
)
77 (defhandler sax
:external-entity-declaration
78 kind name public-id system-id
)
79 (defhandler sax
:internal-entity-declaration
81 (defhandler sax
:notation-declaration
82 name public-id system-id
)
83 (defhandler sax
:element-declaration
85 (defhandler sax
:attribute-declaration
86 element-name attribute-name type default
))
88 (defmethod sax:start-element
89 ((handler dom-builder
) namespace-uri local-name qname attributes
)
90 (check-type qname rod
) ;catch recoder/builder mismatch
91 (flush-characters handler
)
92 (with-slots (document element-stack
) handler
93 (let* ((nsp sax
:*namespace-processing
*)
94 (element (make-instance 'element
97 :namespace-uri
(when nsp namespace-uri
)
98 :local-name
(when nsp local-name
)
99 :prefix
(%rod
(when nsp
(cxml::split-qname
(real-rod qname
))))))
100 (parent (car element-stack
))
102 (dolist (attr attributes
)
105 (dom:create-attribute-ns document
106 (sax:attribute-namespace-uri attr
)
107 (sax:attribute-qname attr
))
108 (dom:create-attribute document
(sax:attribute-qname attr
))))
110 (dom:create-text-node document
(sax:attribute-value attr
))))
111 (setf (slot-value anode
'specified-p
)
112 (sax:attribute-specified-p attr
))
113 (setf (slot-value anode
'owner-element
) element
)
114 (dom:append-child anode text
)
115 (push anode anodes
)))
116 (setf (slot-value element
'parent
) parent
)
117 (fast-push element
(slot-value parent
'children
))
119 (make-instance 'attribute-node-map
121 :element-type
:attribute
124 (setf (slot-value element
'attributes
) map
)
125 (dolist (anode anodes
)
126 (setf (slot-value anode
'map
) map
)))
127 (push element element-stack
))))
129 (defmethod sax:end-element
((handler dom-builder
) namespace-uri local-name qname
)
130 (declare (ignore namespace-uri local-name qname
))
131 (flush-characters handler
)
132 (pop (element-stack handler
)))
134 (defmethod sax:characters
((handler dom-builder
) data
)
135 (with-slots (text-buffer) handler
138 (setf text-buffer data
))
140 (unless (array-has-fill-pointer-p text-buffer
)
141 (setf text-buffer
(make-array (length text-buffer
)
145 :initial-contents text-buffer
)))
146 (let ((n (length text-buffer
))
148 (adjust-vector-exponentially text-buffer
(+ n m
) t
)
149 (move data text-buffer
0 n m
))))))
151 (defun flush-characters (handler)
152 (with-slots (document element-stack text-buffer
) handler
153 (let ((data text-buffer
))
155 (when (array-has-fill-pointer-p data
)
157 (make-array (length data
)
159 :initial-contents data
)))
160 (let ((parent (car element-stack
)))
161 (if (eq (dom:node-type parent
) :cdata-section
)
162 (setf (dom:data parent
) data
)
163 (let ((node (dom:create-text-node document data
)))
164 (setf (slot-value node
'parent
) parent
)
165 (fast-push node
(slot-value (car element-stack
) 'children
)))))
166 (setf text-buffer nil
)))))
168 (defmethod sax:start-cdata
((handler dom-builder
))
169 (flush-characters handler
)
170 (with-slots (document element-stack
) handler
171 (let ((node (dom:create-cdata-section document
#""))
172 (parent (car element-stack
)))
173 (setf (slot-value node
'parent
) parent
)
174 (fast-push node
(slot-value parent
'children
))
175 (push node element-stack
))))
177 (defmethod sax:end-cdata
((handler dom-builder
))
178 (flush-characters handler
)
179 (let ((node (pop (slot-value handler
'element-stack
))))
180 (assert (eq (dom:node-type node
) :cdata-section
))))
182 (defmethod sax:processing-instruction
((handler dom-builder
) target data
)
183 (flush-characters handler
)
184 (with-slots (document element-stack
) handler
185 (let ((node (dom:create-processing-instruction document target data
))
186 (parent (car element-stack
)))
187 (setf (slot-value node
'parent
) parent
)
188 (fast-push node
(slot-value (car element-stack
) 'children
)))))
190 (defmethod sax:comment
((handler dom-builder
) data
)
191 (flush-characters handler
)
192 (with-slots (document element-stack
) handler
193 (let ((node (dom:create-comment document data
))
194 (parent (car element-stack
)))
195 (setf (slot-value node
'parent
) parent
)
196 (fast-push node
(slot-value (car element-stack
) 'children
)))))
198 (defmethod sax:unparsed-entity-declaration
199 ((handler dom-builder
) name public-id system-id notation-name
)
200 (set-entity handler name public-id system-id notation-name
))
202 (defmethod sax:external-entity-declaration
203 ((handler dom-builder
) kind name public-id system-id
)
205 (:general
(set-entity handler name public-id system-id nil
))
208 (defmethod sax:internal-entity-declaration
209 ((handler dom-builder
) kind name value
)
210 (declare (ignore value
))
212 (:general
(set-entity handler name nil nil nil
))
215 (defun set-entity (handler name pid sid notation
)
216 (dom:set-named-item
(dom:entities
(dom:doctype
(document handler
)))
217 (make-instance 'entity
218 :owner
(document handler
)
222 :notation-name notation
)))
224 (defmethod sax:notation-declaration
225 ((handler dom-builder
) name public-id system-id
)
226 (dom:set-named-item
(dom:notations
(dom:doctype
(document handler
)))
227 (make-instance 'notation
228 :owner
(document handler
)
231 :system-id system-id
)))