1 ;;;; dom-impl.lisp -- Implementation of DOM 1 Core -*- package: rune-dom -*-
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: David Lichteblau <david@lichteblau.com>
8 ;;;; Author: knowledgeTools Int. GmbH
10 #-cxml-system
::utf8dom-file
13 #+rune-is-character
(:nicknames
:cxml-dom
)
14 (:export
#:implementation
#:make-dom-builder
#:create-document
))
16 #+cxml-system
::utf8dom-file
18 (:use
:cl
:utf8-runes
)
19 (:nicknames
:cxml-dom
)
20 (:export
#:implementation
#:make-dom-builder
#:create-document
))
22 #-cxml-system
::utf8dom-file
23 (in-package :rune-dom
)
25 #+cxml-system
::utf8dom-file
26 (in-package :utf8-dom
)
31 (define-condition dom-exception
(error)
32 ((key :initarg
:key
:reader dom-exception-key
)
33 (string :initarg
:string
:reader dom-exception-string
)
34 (arguments :initarg
:arguments
:reader dom-exception-arguments
))
37 (format s
"~A (~D):~%~?"
40 (dom-exception-string c
)
41 (dom-exception-arguments c
)))))
43 (defclass node
(dom:node
)
44 ((parent :initarg
:parent
:initform nil
)
45 (children :initarg
:children
:initform
(make-node-list))
46 (owner :initarg
:owner
:initform nil
)
47 (read-only-p :initform nil
:reader read-only-p
)
50 (defmethod dom:prefix
((node node
)) nil
)
51 (defmethod dom:local-name
((node node
)) nil
)
52 (defmethod dom:namespace-uri
((node node
)) nil
)
54 (defclass namespace-mixin
()
55 ((prefix :initarg
:prefix
:reader dom
:prefix
)
56 (local-name :initarg
:local-name
:reader dom
:local-name
)
57 (namespace-uri :initarg
:namespace-uri
:reader dom
:namespace-uri
)))
59 (defmethod (setf dom
:prefix
) (newval (node namespace-mixin
))
60 (assert-writeable node
)
62 (safe-split-qname (concatenate 'rod newval
#":foo")
63 (dom:namespace-uri node
)))
64 (setf (slot-value node
'prefix
) newval
))
66 (defclass document
(node dom
:document
)
67 ((doc-type :initarg
:doc-type
:reader dom
:doctype
)
68 (dtd :initform nil
:reader dtd
)
69 (entity-resolver :initform nil
)))
71 (defclass document-fragment
(node dom
:document-fragment
)
74 (defclass character-data
(node dom
:character-data
)
75 ((value :initarg
:data
:reader dom
:data
)))
77 (defclass attribute
(namespace-mixin node dom
:attr
)
78 ((name :initarg
:name
:reader dom
:name
)
79 (owner-element :initarg
:owner-element
:reader dom
:owner-element
)
80 (specified-p :initarg
:specified-p
:reader dom
:specified
)))
82 (defmethod (setf dom
:prefix
) :before
(newval (node attribute
))
83 (when (rod= (dom:node-name node
) #"xmlns")
84 (dom-error :NAMESPACE_ERR
"must not change xmlns attribute prefix")))
86 (defmethod (setf dom
:prefix
) :after
(newval (node attribute
))
87 (setf (slot-value node
'name
)
88 (concatenate 'rod newval
#":" (dom:local-name node
))))
90 (defmethod print-object ((object attribute
) stream
)
91 (print-unreadable-object (object stream
:type t
:identity t
)
92 (format stream
"~A=~S"
93 (rod-string (dom:name object
))
94 (rod-string (dom:value object
)))))
96 (defclass element
(namespace-mixin node dom
:element
)
97 ((tag-name :initarg
:tag-name
:reader dom
:tag-name
)
98 (attributes :initarg
:attributes
:reader dom
:attributes
)))
100 (defmethod (setf dom
:prefix
) :after
(newval (node element
))
101 (setf (slot-value node
'tag-name
)
102 (concatenate 'rod newval
#":" (dom:local-name node
))))
104 (defmethod print-object ((object element
) stream
)
105 (print-unreadable-object (object stream
:type t
:identity t
)
106 (princ (rod-string (dom:tag-name object
)) stream
)))
108 (defclass text
(character-data dom
:text
)
111 (defclass comment
(character-data dom
:comment
)
114 (defclass cdata-section
(text dom
:cdata-section
)
117 (defclass document-type
(node dom
:document-type
)
118 ((name :initarg
:name
:reader dom
:name
)
119 (public-id :initarg
:public-id
:reader dom
:public-id
)
120 (system-id :initarg
:system-id
:reader dom
:system-id
)
121 (entities :initarg
:entities
:reader dom
:entities
)
122 (notations :initarg
:notations
:reader dom
:notations
)
123 (dom::%internal-subset
:accessor dom
::%internal-subset
)))
125 (defclass notation
(node dom
:notation
)
126 ((name :initarg
:name
:reader dom
:name
)
127 (public-id :initarg
:public-id
:reader dom
:public-id
)
128 (system-id :initarg
:system-id
:reader dom
:system-id
)))
130 (defclass entity
(node dom
:entity
)
131 ((name :initarg
:name
:reader dom
:name
)
132 (public-id :initarg
:public-id
:reader dom
:public-id
)
133 (system-id :initarg
:system-id
:reader dom
:system-id
)
134 (notation-name :initarg
:notation-name
:reader dom
:notation-name
)))
136 (defclass entity-reference
(node dom
:entity-reference
)
137 ((name :initarg
:name
:reader dom
:name
)))
139 (defclass processing-instruction
(node dom
:processing-instruction
)
140 ((target :initarg
:target
:reader dom
:target
)
141 (data :initarg
:data
:reader dom
:data
)))
143 (defclass named-node-map
(dom:named-node-map
)
144 ((items :initarg
:items
:reader dom
:items
146 (owner :initarg
:owner
:reader dom
:owner-document
)
147 (read-only-p :initform nil
:reader read-only-p
)
148 (element-type :initarg
:element-type
)))
150 (defclass attribute-node-map
(named-node-map)
151 ((element :initarg
:element
)))
160 #+cxml-system
::utf8dom-file
(runes::rod
(cxml::rod-to-utf8-string x
))
161 (string (string-rod x
))
164 #-cxml-system
::utf8dom-file
168 #+cxml-system
::utf8dom-file
173 (string (cxml::utf8-string-to-rod x
))))
175 (defun valid-name-p (x)
176 (cxml::valid-name-p
(real-rod x
)))
178 (defun assert-writeable (node)
179 (when (read-only-p node
)
180 (dom-error :NO_MODIFICATION_ALLOWED_ERR
"~S is marked read-only." node
)))
182 (defun dom:map-node-list
(fn nodelist
)
183 (dotimes (i (dom:length nodelist
))
184 (funcall fn
(dom:item nodelist i
))))
186 (defmacro dom
:do-node-list
((var nodelist
&optional resultform
) &body body
)
188 (dom:map-node-list
(lambda (,var
) ,@body
) ,nodelist
)
191 (defun dom:map-node-map
(fn node-map
)
192 (with-slots (items) node-map
195 (defmacro dom
:do-node-map
((var node-map
&optional resultform
) &body body
)
197 (dom:map-node-map
(lambda (,var
) ,@body
) ,node-map
)
200 (defmacro dovector
((var vector
&optional resultform
) &body body
)
202 for
,var across
,vector do
(progn ,@body
)
203 ,@(when resultform
`(finally (return ,resultform
)))))
205 (defun move (from to from-start to-start length
)
206 ;; like (setf (subseq to to-start (+ to-start length))
207 ;; (subseq from from-start (+ from-start length)))
208 ;; but without creating the garbage.
209 ;; Also, this is using AREF not ELT so that fill-pointers are ignored.
210 (if (< to-start from-start
)
213 for i from from-start
215 do
(setf (aref to j
) (aref from i
)))
218 for i downfrom
(+ from-start length -
1)
219 for j downfrom
(+ to-start length -
1)
220 do
(setf (aref to j
) (aref from i
)))))
222 (defun adjust-vector-exponentially (vector new-dimension set-fill-pointer-p
)
223 (let ((d (array-dimension vector
0)))
224 (when (< d new-dimension
)
227 while
(< d new-dimension
))
228 (adjust-array vector d
))
229 (when set-fill-pointer-p
230 (setf (fill-pointer vector
) new-dimension
))))
232 (defun make-space (vector &optional
(n 1))
233 (adjust-vector-exponentially vector
(+ (length vector
) n
) nil
))
235 (defun extension (vector)
236 (max (array-dimension vector
0) 1))
240 (defun dom-error (key fmt
&rest args
)
241 (error 'dom-exception
:key key
:string fmt
:arguments args
))
243 (defmethod dom:code
((self dom-exception
))
244 (ecase (dom-exception-key self
)
246 (:DOMSTRING_SIZE_ERR
2)
247 (:HIERARCHY_REQUEST_ERR
3)
248 (:WRONG_DOCUMENT_ERR
4)
249 (:INVALID_CHARACTER_ERR
5)
250 (:NO_DATA_ALLOWED_ERR
6)
251 (:NO_MODIFICATION_ALLOWED_ERR
7)
253 (:NOT_SUPPORTED_ERR
9)
254 (:INUSE_ATTRIBUTE_ERR
10)
255 (:INVALID_STATE_ERR
11)
257 (:INVALID_MODIFICATION_ERR
13)
259 (:INVALID_ACCESS_ERR
15)))
261 ;; dom-implementation protocol
263 (defmethod dom:has-feature
((factory (eql 'implementation
)) feature version
)
264 (and (or (string-equal (rod-string feature
) "xml")
265 (string-equal (rod-string feature
) "core"))
266 (or (zerop (length version
))
267 (string-equal (rod-string version
) "1.0")
268 (string-equal (rod-string version
) "2.0"))))
270 (defun %create-document-type
(name publicid systemid
)
271 (make-instance 'document-type
273 :notations
(make-instance 'named-node-map
274 :element-type
:notation
276 :entities
(make-instance 'named-node-map
277 :element-type
:entity
280 :system-id systemid
))
282 (defmethod dom:create-document-type
283 ((factory (eql 'implementation
)) name publicid systemid
)
284 (safe-split-qname name
#"")
285 (let ((result (%create-document-type name publicid systemid
)))
286 (setf (slot-value (dom:entities result
) 'read-only-p
) t
)
287 (setf (slot-value (dom:notations result
) 'read-only-p
) t
)
290 (defmethod dom:create-document
291 ((factory (eql 'implementation
)) uri qname doctype
)
292 (let ((document (make-instance 'document
)))
293 (setf (slot-value document
'owner
) nil
294 (slot-value document
'doc-type
) doctype
)
296 (unless (typep doctype
'document-type
)
297 (dom-error :WRONG_DOCUMENT_ERR
298 "doctype was created by a different dom implementation"))
299 (when (dom:owner-document doctype
)
300 (dom-error :WRONG_DOCUMENT_ERR
"doctype already in use"))
301 (setf (slot-value doctype
'owner
) document
302 (slot-value (dom:notations doctype
) 'owner
) document
303 (slot-value (dom:entities doctype
) 'owner
) document
))
305 (dom:append-child document
(dom:create-element-ns document uri qname
)))
308 ;; document-fragment protocol
311 (defmethod dom:implementation
((document document
))
314 (defmethod dom:document-element
((document document
))
315 (dovector (k (dom:child-nodes document
))
316 (cond ((typep k
'element
)
319 (defmethod dom:create-element
((document document
) tag-name
)
320 (setf tag-name
(%rod tag-name
))
321 (unless (valid-name-p tag-name
)
322 (dom-error :INVALID_CHARACTER_ERR
"not a name: ~A" (rod-string tag-name
)))
323 (let ((result (make-instance 'element
329 (setf (slot-value result
'attributes
)
330 (make-instance 'attribute-node-map
331 :element-type
:attribute
334 (add-default-attributes result
)
337 (defun safe-split-qname (qname uri
)
338 (unless (valid-name-p qname
)
339 (dom-error :INVALID_CHARACTER_ERR
"not a name: ~A" (rod-string qname
)))
340 (multiple-value-bind (prefix local-name
)
342 (cxml::split-qname
(real-rod qname
))
343 (cxml:well-formedness-violation
(c)
344 (dom-error :NAMESPACE_ERR
"~A" c
)))
345 (setf local-name
(%rod local-name
))
347 (setf prefix
(%rod prefix
))
349 (dom-error :NAMESPACE_ERR
"prefix specified but no namespace URI"))
350 (when (and (rod= prefix
#"xml")
351 (not (rod= uri
#"http://www.w3.org/XML/1998/namespace")))
352 (dom-error :NAMESPACE_ERR
"invalid uri for prefix `xml'"))
353 (when (and (rod= prefix
#"xmlns")
354 (not (rod= uri
#"http://www.w3.org/2000/xmlns/")))
355 (dom-error :NAMESPACE_ERR
"invalid uri for prefix `xmlns'")))
356 (values prefix local-name
)))
358 (defmethod dom:create-element-ns
((document document
) uri qname
)
359 (setf qname
(%rod qname
))
360 (multiple-value-bind (prefix local-name
)
361 (safe-split-qname qname uri
)
362 (let ((result (make-instance 'element
365 :local-name local-name
368 (setf (slot-value result
'attributes
)
369 (make-instance 'attribute-node-map
370 :element-type
:attribute
373 (add-default-attributes result
)
376 (defmethod dom:create-document-fragment
((document document
))
377 (make-instance 'document-fragment
380 (defmethod dom:create-text-node
((document document
) data
)
381 (setf data
(%rod data
))
386 (defmethod dom:create-comment
((document document
) data
)
387 (setf data
(%rod data
))
388 (make-instance 'comment
392 (defmethod dom:create-cdata-section
((document document
) data
)
393 (setf data
(%rod data
))
394 (make-instance 'cdata-section
398 (defmethod dom:create-processing-instruction
((document document
) target data
)
399 (setf target
(%rod target
))
400 (setf data
(%rod data
))
401 (unless (valid-name-p target
)
402 (dom-error :INVALID_CHARACTER_ERR
"not a name: ~A" (rod-string target
)))
403 (make-instance 'processing-instruction
408 (defmethod dom:create-attribute
((document document
) name
)
409 (setf name
(%rod name
))
410 (unless (valid-name-p name
)
411 (dom-error :INVALID_CHARACTER_ERR
"not a name: ~A" (rod-string name
)))
412 (make-instance 'attribute
421 (defmethod dom:create-attribute-ns
((document document
) uri qname
)
422 (setf uri
(%rod uri
))
423 (setf qname
(%rod qname
))
424 (when (and (rod= qname
#"xmlns")
425 (not (rod= uri
#"http://www.w3.org/2000/xmlns/")))
426 (dom-error :NAMESPACE_ERR
"invalid uri for qname `xmlns'"))
427 (multiple-value-bind (prefix local-name
)
428 (safe-split-qname qname uri
)
429 (make-instance 'attribute
432 :local-name local-name
438 (defmethod dom:create-entity-reference
((document document
) name
)
439 (setf name
(%rod name
))
440 (unless (valid-name-p name
)
441 (dom-error :INVALID_CHARACTER_ERR
"not a name: ~A" (rod-string name
)))
442 (make-instance 'entity-reference
446 (defmethod get-elements-by-tag-name-internal (node tag-name
)
447 (setf tag-name
(%rod tag-name
))
448 (let ((result (make-node-list))
449 (wild-p (rod= tag-name
#"*")))
451 (dovector (c (dom:child-nodes n
))
452 (when (dom:element-p c
)
453 (when (or wild-p
(rod= tag-name
(dom:node-name c
)))
454 (vector-push-extend c result
(extension result
)))
459 (defmethod get-elements-by-tag-name-internal-ns (node uri lname
)
460 (setf uri
(%rod uri
))
461 (setf lname
(%rod lname
))
462 (let ((result (make-node-list))
463 (wild-uri-p (rod= uri
#"*"))
464 (wild-lname-p (rod= lname
#"*")))
466 (dovector (c (dom:child-nodes n
))
467 (when (dom:element-p c
)
468 (when (and (or wild-lname-p
(rod= lname
(dom:local-name c
)))
469 (or wild-uri-p
(rod= uri
(dom:namespace-uri c
))))
470 (vector-push-extend c result
(extension result
)))
475 (defmethod dom:get-elements-by-tag-name
((document document
) tag-name
)
476 (get-elements-by-tag-name-internal document tag-name
))
478 (defmethod dom:get-elements-by-tag-name-ns
((document document
) uri lname
)
479 (get-elements-by-tag-name-internal-ns document uri lname
))
481 (defmethod dom:get-element-by-id
((document document
) id
)
483 (unless (dtd document
)
487 (dovector (c (dom:child-nodes n
))
488 (when (dom:element-p c
)
489 (let ((e (cxml::find-element
490 (real-rod (dom:tag-name c
))
493 (dolist (a (cxml::elmdef-attributes e
))
494 (when (eq :ID
(cxml::attdef-type a
))
495 (let* ((name (%rod
(cxml::attdef-name a
)))
496 (value (dom:get-attribute c name
)))
497 (when (and value
(rod= value id
))
498 (return-from t c
)))))))
505 (defmethod dom:has-attributes
((element node
))
508 (defmethod dom:is-supported
((node node
) feature version
)
509 (dom:has-feature
'implementation feature version
))
511 (defmethod dom:parent-node
((node node
))
512 (slot-value node
'parent
))
514 (defmethod dom:child-nodes
((node node
))
515 (slot-value node
'children
))
517 (defmethod dom:first-child
((node node
))
518 (dom:item
(slot-value node
'children
) 0))
520 (defmethod dom:last-child
((node node
))
521 (with-slots (children) node
522 (if (plusp (length children
))
523 (elt children
(1- (length children
)))
526 (defmethod dom:previous-sibling
((node node
))
527 (with-slots (parent) node
529 (with-slots (children) parent
530 (let ((index (1- (position node children
))))
533 (elt children index
)))))))
535 (defmethod dom:next-sibling
((node node
))
536 (with-slots (parent) node
538 (with-slots (children) parent
539 (let ((index (1+ (position node children
))))
540 (if (eql index
(length children
))
542 (elt children index
)))))))
544 (defmethod dom:owner-document
((node node
))
545 (slot-value node
'owner
))
547 (defun ensure-valid-insertion-request (node new-child
)
548 (assert-writeable node
)
549 (unless (can-adopt-p node new-child
)
550 (dom-error :HIERARCHY_REQUEST_ERR
"~S cannot adopt ~S." node new-child
))
551 #+(or) ;XXX needs to be moved elsewhere
552 (when (eq (dom:node-type node
) :document
)
553 (let ((child-type (dom:node-type new-child
)))
554 (when (and (member child-type
'(:element
:document-type
))
555 (find child-type
(dom:child-nodes node
) :key
#'dom
:node-type
))
556 (dom-error :HIERARCHY_REQUEST_ERR
557 "~S cannot adopt a second child of type ~S."
559 (unless (eq (if (eq (dom:node-type node
) :document
)
561 (dom:owner-document node
))
562 (dom:owner-document new-child
))
563 (dom-error :WRONG_DOCUMENT_ERR
564 "~S cannot adopt ~S, since it was created by a different document."
566 (do ((n node
(dom:parent-node n
)))
568 (when (eq n new-child
)
569 (dom-error :HIERARCHY_REQUEST_ERR
570 "~S cannot adopt ~S, since that would create a cycle"
572 (unless (null (slot-value new-child
'parent
))
573 (dom:remove-child
(slot-value new-child
'parent
) new-child
)))
575 (defmethod dom:insert-before
((node node
) (new-child node
) ref-child
)
576 (ensure-valid-insertion-request node new-child
)
577 (with-slots (children) node
579 (let ((i (position ref-child children
)))
581 (dom-error :NOT_FOUND_ERR
"~S is no child of ~S." ref-child node
))
582 (make-space children
1)
583 (move children children i
(1+ i
) (- (length children
) i
))
584 (incf (fill-pointer children
))
585 (setf (elt children i
) new-child
))
586 (vector-push-extend new-child children
(extension children
)))
587 (setf (slot-value new-child
'parent
) node
)
590 (defmethod dom:insert-before
591 ((node node
) (fragment document-fragment
) ref-child
)
592 (let ((children (dom:child-nodes fragment
)))
593 (cxml::while
(plusp (length children
))
594 (dom:insert-before node
(elt children
0) ref-child
)))
597 (defmethod dom:replace-child
((node node
) (new-child node
) (old-child node
))
598 (ensure-valid-insertion-request node new-child
)
599 (with-slots (children) node
600 (let ((i (position old-child children
)))
602 (dom-error :NOT_FOUND_ERR
"~S is no child of ~S." old-child node
))
603 (setf (elt children i
) new-child
))
604 (setf (slot-value new-child
'parent
) node
)
605 (setf (slot-value old-child
'parent
) nil
)
608 (defmethod dom:replace-child
609 ((node node
) (new-child document-fragment
) (old-child node
))
610 (dom:insert-before node new-child old-child
)
611 (dom:remove-child node old-child
))
613 (defmethod dom:remove-child
((node node
) (old-child node
))
614 (assert-writeable node
)
615 (with-slots (children) node
616 (let ((i (position old-child children
)))
618 (dom-error :NOT_FOUND_ERR
"~A not found in ~A" old-child node
))
619 (move children children
(1+ i
) i
(- (length children
) i
1))
620 (decf (fill-pointer children
)))
621 (setf (slot-value old-child
'parent
) nil
)
624 (defmethod dom:append-child
((node node
) (new-child node
))
625 (ensure-valid-insertion-request node new-child
)
626 (with-slots (children) node
627 (vector-push-extend new-child children
(extension children
))
628 (setf (slot-value new-child
'parent
) node
)
631 (defmethod dom:has-child-nodes
((node node
))
632 (plusp (length (slot-value node
'children
))))
634 (defmethod dom:append-child
((node node
) (new-child document-fragment
))
635 (assert-writeable node
)
636 (let ((children (dom:child-nodes new-child
)))
637 (cxml::while
(plusp (length children
))
638 (dom:append-child node
(elt children
0))))
641 ;; was auf node noch implemetiert werden muss:
650 (defmethod dom:node-name
((self document
))
653 (defmethod dom:node-name
((self document-fragment
))
654 #"#document-fragment")
656 (defmethod dom:node-name
((self text
))
659 (defmethod dom:node-name
((self cdata-section
))
662 (defmethod dom:node-name
((self comment
))
665 (defmethod dom:node-name
((self attribute
))
668 (defmethod dom:node-name
((self element
))
671 (defmethod dom:node-name
((self document-type
))
674 (defmethod dom:node-name
((self notation
))
677 (defmethod dom:node-name
((self entity
))
680 (defmethod dom:node-name
((self entity-reference
))
683 (defmethod dom:node-name
((self processing-instruction
))
688 (defmethod dom:node-type
((self document
)) :document
)
689 (defmethod dom:node-type
((self document-fragment
)) :document-fragment
)
690 (defmethod dom:node-type
((self text
)) :text
)
691 (defmethod dom:node-type
((self comment
)) :comment
)
692 (defmethod dom:node-type
((self cdata-section
)) :cdata-section
)
693 (defmethod dom:node-type
((self attribute
)) :attribute
)
694 (defmethod dom:node-type
((self element
)) :element
)
695 (defmethod dom:node-type
((self document-type
)) :document-type
)
696 (defmethod dom:node-type
((self notation
)) :notation
)
697 (defmethod dom:node-type
((self entity
)) :entity
)
698 (defmethod dom:node-type
((self entity-reference
)) :entity-reference
)
699 (defmethod dom:node-type
((self processing-instruction
)) :processing-instruction
)
703 (defmethod dom:node-value
((self document
)) nil
)
704 (defmethod dom:node-value
((self document-fragment
)) nil
)
705 (defmethod dom:node-value
((self character-data
)) (dom:data self
))
706 (defmethod dom:node-value
((self attribute
)) (dom:value self
))
707 (defmethod dom:node-value
((self element
)) nil
)
708 (defmethod dom:node-value
((self document-type
)) nil
)
709 (defmethod dom:node-value
((self notation
)) nil
)
710 (defmethod dom:node-value
((self entity
)) nil
)
711 (defmethod dom:node-value
((self entity-reference
)) nil
)
712 (defmethod dom:node-value
((self processing-instruction
)) (dom:data self
))
714 ;; (setf node-value), first the meaningful cases...
716 (defmethod (setf dom
:node-value
) (newval (self character-data
))
717 (assert-writeable self
)
718 (setf (dom:data self
) newval
))
720 (defmethod (setf dom
:node-value
) (newval (self attribute
))
721 (assert-writeable self
)
722 (setf (dom:value self
) newval
))
724 (defmethod (setf dom
:node-value
) (newval (self processing-instruction
))
725 (assert-writeable self
)
726 (setf (dom:data self
) newval
))
728 ;; ... and (setf node-value), part II. The DOM Level 1 spec fails to explain
729 ;; this case, but it is covered by the (Level 1) test suite and clarified
731 ;; nodeValue of type DOMString
732 ;; The value of this node, depending on its type; see the
733 ;; table above. When it is defined to be null, setting
736 (defmethod (setf dom
:node-value
) (newval (self element
))
737 (declare (ignore newval
)))
739 (defmethod (setf dom
:node-value
) (newval (self entity-reference
))
740 (declare (ignore newval
)))
742 (defmethod (setf dom
:node-value
) (newval (self entity
))
743 (declare (ignore newval
)))
745 (defmethod (setf dom
:node-value
) (newval (self document
))
746 (declare (ignore newval
)))
748 (defmethod (setf dom
:node-value
) (newval (self document-type
))
749 (declare (ignore newval
)))
751 (defmethod (setf dom
:node-value
) (newval (self document-fragment
))
752 (declare (ignore newval
)))
754 (defmethod (setf dom
:node-value
) (newval (self notation
))
755 (declare (ignore newval
)))
759 ;; (gibt es nur auf element)
761 (defmethod dom:attributes
((self node
))
764 ;; dann fehlt noch can-adopt und attribute conventions fuer adoption
768 (defun make-node-list (&optional initial-contents
)
769 (make-array (length initial-contents
)
771 :fill-pointer
(length initial-contents
)
772 :initial-contents initial-contents
))
774 (defmethod dom:item
((self vector
) index
)
775 (if (< index
(length self
))
779 (defmethod dom:length
((self vector
))
784 (defmethod dom:get-named-item
((self named-node-map
) name
)
785 (setf name
(%rod name
))
786 (with-slots (items) self
787 (dolist (k items nil
)
788 (when (rod= name
(dom:node-name k
))
791 (defmethod dom:get-named-item-ns
((self named-node-map
) uri lname
)
792 (setf uri
(%rod uri
))
793 (setf lname
(%rod lname
))
794 (with-slots (items) self
795 (dolist (k items nil
)
796 (when (and (rod= uri
(dom:namespace-uri k
))
797 (rod= lname
(dom:local-name k
)))
800 (defun %set-named-item
(map arg test
)
801 (assert-writeable map
)
802 (unless (eq (dom:node-type arg
) (slot-value map
'element-type
))
803 (dom-error :HIERARCHY_REQUEST_ERR
804 "~S cannot adopt ~S, since it is not of type ~S."
805 map arg
(slot-value map
'element-type
)))
806 (unless (eq (dom:owner-document map
) (dom:owner-document arg
))
807 (dom-error :WRONG_DOCUMENT_ERR
808 "~S cannot adopt ~S, since it was created by a different document."
810 (let ((old-map (slot-value arg
'map
)))
811 (when (and old-map
(not (eq old-map map
)))
812 (dom-error :INUSE_ATTRIBUTE_ERR
"Attribute node already mapped" arg
)))
813 (setf (slot-value arg
'map
) map
)
814 (with-slots (items) map
815 (dolist (k items
(progn (setf items
(cons arg items
)) nil
))
816 (when (funcall test k
)
817 (setf items
(cons arg
(delete k items
)))
820 (defmethod dom:set-named-item
((self named-node-map
) arg
)
821 (let ((name (dom:node-name arg
)))
822 (%set-named-item self arg
(lambda (k) (rod= name
(dom:node-name k
))))))
824 (defmethod dom:set-named-item-ns
((self named-node-map
) arg
)
825 (let ((uri (dom:namespace-uri arg
))
826 (lname (dom:local-name arg
)))
827 (%set-named-item self
830 (and (rod= lname
(dom:local-name k
))
831 (rod= uri
(dom:namespace-uri k
)))))))
833 (defmethod dom:remove-named-item
((self named-node-map
) name
)
834 (assert-writeable self
)
835 (setf name
(%rod name
))
836 (with-slots (items) self
837 (dolist (k items
(dom-error :NOT_FOUND_ERR
"~A not found in ~A" name self
))
838 (cond ((rod= name
(dom:node-name k
))
839 (setf items
(delete k items
))
842 (defmethod dom:remove-named-item-ns
((self named-node-map
) uri lname
)
843 (assert-writeable self
)
844 (setf uri
(%rod uri
))
845 (setf lname
(%rod lname
))
846 (with-slots (items) self
848 (dom-error :NOT_FOUND_ERR
"~A not found in ~A" lname self
))
849 (when (and (rod= lname
(dom:local-name k
))
850 (rod= uri
(dom:namespace-uri k
)))
851 (setf items
(delete k items
))
854 (defmethod dom:length
((self named-node-map
))
855 (with-slots (items) self
858 (defmethod dom:item
((self named-node-map
) index
)
859 (with-slots (items) self
860 (do ((nthcdr items
(cdr nthcdr
))
862 ((zerop i
) (car nthcdr
)))))
866 (defmethod (setf dom
:data
) (newval (self character-data
))
867 (assert-writeable self
)
868 (setf newval
(%rod newval
))
869 (setf (slot-value self
'value
) newval
))
871 (defmethod dom:length
((node character-data
))
872 (length (slot-value node
'value
)))
874 (defmethod dom:substring-data
((node character-data
) offset count
)
875 (with-slots (value) node
876 (unless (<= 0 offset
(length value
))
877 (dom-error :INDEX_SIZE_ERR
"offset is invalid"))
878 (let ((end (min (length value
) (+ offset count
))))
879 (subseq value offset end
))))
881 (defmethod dom:append-data
((node character-data
) arg
)
882 (assert-writeable node
)
883 (setq arg
(%rod arg
))
884 (with-slots (value) node
885 (setf value
(concatenate 'rod value arg
)))
888 (defmethod dom:delete-data
((node character-data
) offset count
)
889 (assert-writeable node
)
890 (with-slots (value) node
891 (unless (<= 0 offset
(length value
))
892 (dom-error :INDEX_SIZE_ERR
"offset is invalid"))
894 (dom-error :INDEX_SIZE_ERR
"count is negative"))
895 (setf count
(min count
(- (length value
) offset
)))
896 (let ((new (make-array (- (length value
) count
)
897 :element-type
(array-element-type value
))))
899 :start1
0 :end1 offset
900 :start2
0 :end2 offset
)
902 :start1 offset
:end1
(length new
)
903 :start2
(+ offset count
) :end2
(length value
))
907 (defmethod dom:replace-data
((node character-data
) offset count arg
)
908 ;; Although we could implement this by calling DELETE-DATA, then INSERT-DATA,
909 ;; we implement this function directly to avoid creating temporary garbage.
910 (assert-writeable node
)
911 (setf arg
(%rod arg
))
912 (with-slots (value) node
913 (unless (<= 0 offset
(length value
))
914 (dom-error :INDEX_SIZE_ERR
"offset is invalid"))
916 (dom-error :INDEX_SIZE_ERR
"count is negative"))
917 (setf count
(min count
(- (length value
) offset
)))
918 (if (= count
(length arg
))
920 :start1 offset
:end1
(+ offset count
)
921 :start2
0 :end2 count
)
922 (let ((new (make-array (+ (length value
) (length arg
) (- count
))
923 :element-type
(array-element-type value
))))
924 (replace new value
:end1 offset
)
925 (replace new arg
:start1 offset
)
927 :start1
(+ offset
(length arg
))
928 :start2
(+ offset count
))
932 (defmethod dom:insert-data
((node character-data
) offset arg
)
933 (assert-writeable node
)
934 (setf arg
(%rod arg
))
935 (with-slots (value) node
936 (unless (<= 0 offset
(length value
))
937 (dom-error :INDEX_SIZE_ERR
"offset is invalid"))
938 (let ((new (make-array (+ (length value
) (length arg
))
939 :element-type
(array-element-type value
)))
940 (arglen (length arg
)))
941 (replace new value
:end1 offset
)
942 (replace new arg
:start1 offset
)
943 (replace new value
:start1
(+ offset arglen
) :start2 offset
)
949 ;;; An attribute value can be read and set as a string using DOM:VALUE
950 ;;; or frobbed by changing the attribute's children!
952 ;;; We store the value in a TEXT node and read this node's DATA slot
953 ;;; when asked for our VALUE -- until the user changes the child nodes,
954 ;;; in which case we have to compute VALUE by traversing the children.
956 (defmethod dom:value
((node attribute
))
957 (with-slots (children) node
959 ((zerop (length children
))
961 ((and (eql (length children
) 1)
962 (eq (dom:node-type
(elt children
0)) :text
))
963 ;; we have as single TEXT-NODE child, just return its DATA
964 (dom:data
(elt children
0)))
966 ;; traverse children to compute value
967 (attribute-to-string node
)))))
969 (defmethod (setf dom
:value
) (new-value (node attribute
))
970 (assert-writeable node
)
971 (let ((rod (%rod new-value
)))
972 (with-slots (children owner
) node
973 ;; remove children, add new TEXT-NODE child
974 ;; (alas, we must not reuse an old TEXT-NODE)
975 (cxml::while
(plusp (length children
))
976 (dom:remove-child node
(dom:last-child node
)))
977 (dom:append-child node
(dom:create-text-node owner rod
))))
980 (defun attribute-to-string (attribute)
981 (let ((stream (make-rod-stream)))
983 (dovector (child (dom:child-nodes attribute
))
984 (write-attribute-child child stream
))))
986 (initialize-rod-stream stream
)
988 (rod-stream-buf stream
)))
990 (defmethod write-attribute-child ((node node
) stream
)
991 (put-rod (dom:node-value node
) stream
))
993 (defmethod write-attribute-child ((node entity-reference
) stream
)
994 (dovector (child (dom:child-nodes node
))
995 (write-attribute-child child stream
)))
997 ;;; ROD-STREAM als Ersatz fuer MAKE-STRING-OUTPUT-STREAM zu verwenden,
998 ;;; nur dass der Buffer statische Groesse hat. Solange er NIL ist,
999 ;;; zaehlt der Stream nur die Runen. Dann ruft man INITIALIZE-ROD-STREAM
1000 ;;; auf, um den Buffer zu erzeugen und die Position zurueckzusetzen, und
1001 ;;; schreibt alles abermals. Dann ist der Buffer gefuellt.
1002 (defstruct rod-stream
1006 (defun put-rod (rod rod-stream
)
1007 (let ((buf (rod-stream-buf rod-stream
)))
1009 (move rod buf
0 (rod-stream-position rod-stream
) (length rod
)))
1010 (incf (rod-stream-position rod-stream
) (length rod
)))
1013 (defun initialize-rod-stream (stream)
1014 (setf (rod-stream-buf stream
) (make-rod (rod-stream-position stream
)))
1015 (setf (rod-stream-position stream
) 0)
1020 (defmethod dom:has-attributes
((element element
))
1021 (plusp (length (dom:items
(dom:attributes element
)))))
1023 (defmethod dom:has-attribute
((element element
) name
)
1024 (and (dom:get-named-item
(dom:attributes element
) name
) t
))
1026 (defmethod dom:has-attribute-ns
((element element
) uri lname
)
1027 (and (dom:get-named-item-ns
(dom:attributes element
) uri lname
) t
))
1029 (defmethod dom:get-attribute-node
((element element
) name
)
1030 (dom:get-named-item
(dom:attributes element
) name
))
1032 (defmethod dom:set-attribute-node
((element element
) (new-attr attribute
))
1033 (assert-writeable element
)
1034 (dom:set-named-item
(dom:attributes element
) new-attr
))
1036 (defmethod dom:get-attribute-node-ns
((element element
) uri lname
)
1037 (dom:get-named-item-ns
(dom:attributes element
) uri lname
))
1039 (defmethod dom:set-attribute-node-ns
((element element
) (new-attr attribute
))
1040 (assert-writeable element
)
1041 (dom:set-named-item-ns
(dom:attributes element
) new-attr
))
1043 (defmethod dom:get-attribute
((element element
) name
)
1044 (let ((a (dom:get-attribute-node element name
)))
1049 (defmethod dom:get-attribute-ns
((element element
) uri lname
)
1050 (let ((a (dom:get-attribute-node-ns element uri lname
)))
1055 (defmethod dom:set-attribute
((element element
) name value
)
1056 (assert-writeable element
)
1057 (with-slots (owner) element
1058 (let ((attr (dom:create-attribute owner name
)))
1059 (setf (slot-value attr
'owner-element
) element
)
1060 (setf (dom:value attr
) value
)
1061 (dom:set-attribute-node element attr
))
1064 (defmethod dom:set-attribute-ns
((element element
) uri lname value
)
1065 (assert-writeable element
)
1066 (with-slots (owner) element
1067 (let ((attr (dom:create-attribute-ns owner uri lname
)))
1068 (setf (slot-value attr
'owner-element
) element
)
1069 (setf (dom:value attr
) value
)
1070 (dom:set-attribute-node-ns element attr
))
1073 (defmethod dom:remove-attribute
((element element
) name
)
1074 (assert-writeable element
)
1075 (dom:remove-attribute-node element
(dom:get-attribute-node element name
)))
1077 (defmethod dom:remove-attribute-ns
((elt element
) uri lname
)
1078 (assert-writeable elt
)
1079 (dom:remove-attribute-node elt
(dom:get-attribute-node-ns elt uri lname
)))
1081 (defmethod dom:remove-attribute-node
((element element
) (old-attr attribute
))
1082 (assert-writeable element
)
1083 (with-slots (items) (dom:attributes element
)
1084 (unless (find old-attr items
)
1085 (dom-error :NOT_FOUND_ERR
"Attribute not found."))
1086 (setf items
(remove old-attr items
))
1087 (maybe-add-default-attribute element old-attr
)
1092 (defun maybe-add-default-attribute (element old-attr
)
1093 (let* ((qname (dom:name old-attr
))
1094 (dtd (dtd (slot-value element
'owner
)))
1095 (e (when dtd
(cxml::find-element
1096 (real-rod (dom:tag-name element
))
1098 (a (when e
(cxml::find-attribute e
(real-rod qname
)))))
1099 (when (and a
(listp (cxml::attdef-default a
)))
1100 (let ((new (add-default-attribute element a
)))
1101 (setf (slot-value new
'namespace-uri
) (dom:namespace-uri old-attr
))
1102 (setf (slot-value new
'prefix
) (dom:prefix old-attr
))
1103 (setf (slot-value new
'local-name
) (dom:local-name old-attr
))))))
1105 (defun add-default-attributes (element)
1106 (let* ((dtd (dtd (slot-value element
'owner
)))
1107 (e (when dtd
(cxml::find-element
1108 (real-rod (dom:tag-name element
))
1111 (dolist (a (cxml::elmdef-attributes e
))
1113 (listp (cxml::attdef-default a
))
1114 (not (dom:get-attribute-node
1116 (%rod
(cxml::attdef-name a
)))))
1117 (let ((anode (add-default-attribute element a
)))
1118 (multiple-value-bind (prefix local-name
)
1120 (cxml::split-qname
(cxml::attdef-name a
))
1121 (cxml:well-formedness-violation
(c)
1122 (dom-error :NAMESPACE_ERR
"~A" c
)))
1123 (when prefix
(setf prefix
(%rod prefix
)))
1124 (setf local-name
(%rod local-name
))
1125 ;; das ist fuer importnode07.
1126 ;; so richtig ueberzeugend finde ich das ja nicht.
1127 (setf (slot-value anode
'prefix
) prefix
)
1128 (setf (slot-value anode
'local-name
) local-name
))))))))
1130 (defun add-default-attribute (element adef
)
1131 (let* ((value (second (cxml::attdef-default adef
)))
1132 (owner (slot-value element
'owner
))
1133 (anode (dom:create-attribute owner
(cxml::attdef-name adef
)))
1134 (text (dom:create-text-node owner value
)))
1135 (setf (slot-value anode
'specified-p
) nil
)
1136 (setf (slot-value anode
'owner-element
) element
)
1137 (dom:append-child anode text
)
1138 (push anode
(slot-value (dom:attributes element
) 'items
))
1141 (defmethod dom:remove-named-item
((self attribute-node-map
) name
)
1143 (let ((k (call-next-method)))
1144 (maybe-add-default-attribute (slot-value self
'element
) k
)
1147 (defmethod dom:remove-named-item-ns
((self attribute-node-map
) uri lname
)
1149 (let ((k (call-next-method)))
1150 (maybe-add-default-attribute (slot-value self
'element
) k
)
1153 (defmethod dom:get-elements-by-tag-name
((element element
) name
)
1154 (assert-writeable element
)
1155 (get-elements-by-tag-name-internal element name
))
1157 (defmethod dom:get-elements-by-tag-name-ns
((element element
) uri lname
)
1158 (assert-writeable element
)
1159 (get-elements-by-tag-name-internal-ns element uri lname
))
1161 (defmethod dom:set-named-item
:after
((self attribute-node-map
) arg
)
1162 (setf (slot-value arg
'owner-element
)
1163 (slot-value self
'element
)))
1165 (defmethod dom:set-named-item-ns
:after
((self attribute-node-map
) arg
)
1166 (setf (slot-value arg
'owner-element
)
1167 (slot-value self
'element
)))
1169 (defmethod dom:normalize
((node node
))
1170 (assert-writeable node
)
1172 (when (eq (dom:node-type n
) :element
)
1173 (map nil
#'walk
(dom:items
(dom:attributes n
))))
1174 (let ((children (dom:child-nodes n
))
1177 ;; careful here, we're modifying the array we are iterating over
1178 (cxml::while
(< i
(length children
))
1179 (let ((child (elt children i
)))
1181 ((not (eq (dom:node-type child
) :text
))
1184 ((and previous
(eq (dom:node-type previous
) :text
))
1185 (setf (slot-value previous
'value
)
1189 (dom:remove-child n child
)
1192 ((zerop (length (dom:data child
)))
1193 (dom:remove-child n child
)
1197 (setf previous child
)
1199 (map nil
#'walk
(dom:child-nodes n
))))
1205 (defmethod dom:split-text
((text text
) offset
)
1206 (assert-writeable text
)
1207 (with-slots (owner parent value
) text
1208 (unless (<= 0 offset
(length value
))
1209 (dom-error :INDEX_SIZE_ERR
"offset is invalid"))
1211 (dom:insert-before parent
1212 (dom:create-text-node owner
(subseq value offset
))
1213 (dom:next-sibling text
))
1214 (setf value
(subseq value
0 offset
)))))
1217 ;;; CDATA-SECTION -- nix
1221 (defmethod dom:internal-subset
((node document-type
))
1222 ;; FIXME: encoding ist falsch, anderen sink nehmen!
1223 (if (and (slot-boundp node
'dom
::%internal-subset
)
1224 ;; die damen und herren von der test suite sind wohl der meinung,
1225 ;; dass ein leeres internal subset nicht vorhanden ist und
1226 ;; wir daher nil liefern sollen. bittesehr!
1227 (dom::%internal-subset node
))
1229 #+rune-is-character
(cxml:make-string-sink
)
1230 #-rune-is-character
(cxml:make-string-sink
/utf8
)))
1231 (dolist (def (dom::%internal-subset node
))
1232 (apply (car def
) sink
(cdr def
)))
1233 (sax:end-document sink
))
1239 ;;; ENTITY-REFERENCE
1241 (defmethod initialize-instance :after
((instance entity-reference
) &key
)
1242 (let* ((owner (dom:owner-document instance
))
1243 (handler (make-dom-builder))
1244 (resolver (slot-value owner
'entity-resolver
)))
1246 (setf (document handler
) owner
)
1247 (push instance
(element-stack handler
))
1248 #+cxml-system
::utf8dom-file
1249 (setf handler
(cxml:make-recoder handler
#'cxml
:rod-to-utf8-string
))
1250 (funcall resolver
(real-rod (dom:name instance
)) handler
)
1251 (flush-characters handler
)))
1253 (setf (slot-value n
'read-only-p
) t
)
1254 (when (dom:element-p n
)
1255 (setf (slot-value (dom:attributes n
) 'read-only-p
) t
)
1256 (map nil
#'walk
(dom:items
(dom:attributes n
))))
1257 (map nil
#'walk
(dom:child-nodes n
))))
1260 ;;; PROCESSING-INSTRUCTION
1262 (defmethod (setf dom
:data
) (newval (self processing-instruction
))
1263 (assert-writeable self
)
1264 (setf newval
(%rod newval
))
1265 (setf (slot-value self
'data
) newval
))
1267 ;; das koennte man auch mit einer GF machen
1268 (defun can-adopt-p (parent child
)
1269 (member (dom:node-type child
)
1270 (let ((default '(:element
:processing-instruction
:comment
:text
1271 :cdata-section
:entity-reference
)))
1274 '(:element
:processing-instruction
:comment
:document-type
))
1275 (document-fragment default
)
1277 (entity-reference default
)
1279 (attribute '(:text
:entity-reference
))
1280 (processing-instruction nil
)
1290 (defmethod dom:node-p
((object node
)) t
)
1291 (defmethod dom:node-p
((object t
)) nil
)
1293 (defmethod dom:document-p
((object document
)) t
)
1294 (defmethod dom:document-p
((object t
)) nil
)
1296 (defmethod dom:document-fragment-p
((object document-fragment
)) t
)
1297 (defmethod dom:document-fragment-p
((object t
)) nil
)
1299 (defmethod dom:character-data-p
((object character-data
)) t
)
1300 (defmethod dom:character-data-p
((object t
)) nil
)
1302 (defmethod dom:attribute-p
((object attribute
)) t
)
1303 (defmethod dom:attribute-p
((object t
)) nil
)
1305 (defmethod dom:element-p
((object element
)) t
)
1306 (defmethod dom:element-p
((object t
)) nil
)
1308 (defmethod dom:text-node-p
((object text
)) t
)
1309 (defmethod dom:text-node-p
((object t
)) nil
)
1311 (defmethod dom:comment-p
((object comment
)) t
)
1312 (defmethod dom:comment-p
((object t
)) nil
)
1314 (defmethod dom:cdata-section-p
((object cdata-section
)) t
)
1315 (defmethod dom:cdata-section-p
((object t
)) nil
)
1317 (defmethod dom:document-type-p
((object document-type
)) t
)
1318 (defmethod dom:document-type-p
((object t
)) nil
)
1320 (defmethod dom:notation-p
((object notation
)) t
)
1321 (defmethod dom:notation-p
((object t
)) nil
)
1323 (defmethod dom:entity-p
((object entity
)) t
)
1324 (defmethod dom:entity-p
((object t
)) nil
)
1326 (defmethod dom:entity-reference-p
((object entity-reference
)) t
)
1327 (defmethod dom:entity-reference-p
((object t
)) nil
)
1329 (defmethod dom:processing-instruction-p
((object processing-instruction
)) t
)
1330 (defmethod dom:processing-instruction-p
((object t
)) nil
)
1332 (defmethod dom:named-node-map-p
((object named-node-map
)) t
)
1333 (defmethod dom:named-node-map-p
((object t
)) nil
)
1338 (defvar *clone-not-import
* nil
) ;not beautiful, I know. See below.
1340 (defmethod import-node-internal (class document node deep
&rest initargs
)
1341 (let ((result (apply #'make-instance class
:owner document initargs
)))
1343 (dovector (child (dom:child-nodes node
))
1344 (dom:append-child result
(dom:import-node document child t
))))
1347 (defmethod dom:import-node
((document document
) (node t
) deep
)
1348 (declare (ignore deep
))
1349 (dom-error :NOT_SUPPORTED_ERR
"not implemented"))
1351 (defmethod dom:import-node
((document document
) (node attribute
) deep
)
1352 (declare (ignore deep
))
1353 (import-node-internal 'attribute
1356 :specified-p
(dom:specified node
)
1357 :name
(dom:name node
)
1358 :namespace-uri
(dom:namespace-uri node
)
1359 :local-name
(dom:local-name node
)
1360 :prefix
(dom:prefix node
)
1361 :owner-element nil
))
1363 (defmethod dom:import-node
((document document
) (node document-fragment
) deep
)
1364 (import-node-internal 'document-fragment document node deep
))
1366 (defmethod dom:import-node
((document document
) (node element
) deep
)
1367 (let* ((attributes (make-instance 'attribute-node-map
1368 :element-type
:attribute
1370 (result (import-node-internal 'element document node deep
1371 :attributes attributes
1372 :namespace-uri
(dom:namespace-uri node
)
1373 :local-name
(dom:local-name node
)
1374 :prefix
(dom:prefix node
)
1375 :tag-name
(dom:tag-name node
))))
1376 (setf (slot-value attributes
'element
) result
)
1377 (dolist (attribute (dom:items
(dom:attributes node
)))
1378 (when (or (dom:specified attribute
) *clone-not-import
*)
1379 (let ((attr (dom:import-node document attribute t
)))
1380 (if (dom:namespace-uri attribute
)
1381 (dom:set-attribute-node-ns result attr
)
1382 (dom:set-attribute-node result attr
)))))
1383 (add-default-attributes result
)
1386 (defmethod dom:import-node
((document document
) (node entity
) deep
)
1387 (import-node-internal 'entity document node deep
1388 :name
(dom:name node
)
1389 :public-id
(dom:public-id node
)
1390 :system-id
(dom:system-id node
)
1391 :notation-name
(dom:notation-name node
)))
1393 (defmethod dom:import-node
((document document
) (node entity-reference
) deep
)
1394 (declare (ignore deep
))
1395 (import-node-internal 'entity-reference document node nil
1396 :name
(dom:name node
)))
1398 (defmethod dom:import-node
((document document
) (node notation
) deep
)
1399 (import-node-internal 'notation document node deep
1400 :name
(dom:name node
)
1401 :public-id
(dom:public-id node
)
1402 :system-id
(dom:system-id node
)))
1404 (defmethod dom:import-node
1405 ((document document
) (node processing-instruction
) deep
)
1406 (import-node-internal 'processing-instruction document node deep
1407 :target
(dom:target node
)
1408 :data
(dom:data node
)))
1410 ;; TEXT_NODE, CDATA_SECTION_NODE, COMMENT_NODE
1411 (defmethod dom:import-node
1412 ((document document
) (node character-data
) deep
)
1413 (import-node-internal (class-of node
) document node deep
1414 :data
(copy-seq (dom:data node
))))
1418 ;;; As far as I can tell, cloneNode is the same as importNode, except
1419 ;;; for one difference involving element attributes: importNode imports
1420 ;;; only specified attributes, cloneNode copies even default values.
1422 ;;; Since I don't want to reimplement all of importNode here, we run
1423 ;;; importNode with a special flag...
1425 (defmethod dom:clone-node
((node node
) deep
)
1426 (let ((*clone-not-import
* t
))
1427 (dom:import-node
(dom:owner-document node
) node deep
)))
1430 (defmethod dom:clone-node
((node document
) deep
)
1431 (let* ((document (make-instance 'document
))
1432 (original-doctype (dom:doctype node
))
1434 (when original-doctype
1435 (make-instance 'document-type
1437 :name
(dom:name original-doctype
)
1438 :public-id
(dom:public-id original-doctype
)
1439 :system-id
(dom:system-id original-doctype
)
1440 :notations
(make-instance 'named-node-map
1441 :element-type
:notation
1443 :items
(dom:items
(dom:notations original-doctype
)))
1444 :entities
(make-instance 'named-node-map
1445 :element-type
:entity
1448 (dom:entities original-doctype
)))))))
1449 (setf (slot-value document
'owner
) nil
)
1450 (setf (slot-value document
'doc-type
) doctype
)
1451 (setf (slot-value document
'dtd
) (dtd node
))
1452 (setf (slot-value document
'entity-resolver
)
1453 (slot-value node
'entity-resolver
))
1454 (setf (slot-value (dom:entities doctype
) 'read-only-p
) t
)
1455 (setf (slot-value (dom:notations doctype
) 'read-only-p
) t
)
1456 (when (and doctype
(slot-boundp doctype
'dom
::%internal-subset
))
1457 (setf (dom::%internal-subset doctype
)
1458 (dom::%internal-subset original-doctype
)))
1459 (when (and (dom:document-element node
) deep
)
1460 (let* ((*clone-not-import
* t
)
1461 (clone (dom:import-node document
(dom:document-element node
) t
)))
1462 (dom:append-child document clone
)))
1468 (defun create-document (&optional document-element
)
1469 ;; Um ein neues Dokumentenobject zu erzeugen, parsen wir einfach ein
1471 (let* ((handler (make-dom-builder))
1472 (cxml::*ctx
* (cxml::make-context
:handler handler
))
1475 (sax:start-document handler
)
1476 (sax:end-document handler
))))
1477 (when document-element
1478 (dom:append-child result
(dom:import-node result document-element t
)))