140 lines
6.1 KiB
Common Lisp
140 lines
6.1 KiB
Common Lisp
;;; XXX this DOM builder knows too much about the specifics of the DOM
|
|
;;; implementation for my taste. While document creation is not specified
|
|
;;; by the DOM Level 1 spec, we shouldn't really be manually setting slots
|
|
;;; in other nodes IMHO.
|
|
;;;
|
|
;;; As a follow-up to that, the children list is created in the wrong order
|
|
;;; and then reversed. Is it really worth the improved speed to do this?
|
|
;;; Calling APPEND-NODE would be portable.
|
|
;;;
|
|
;;; In particular, that design choice has lead to other bugs, for example the
|
|
;;; PARENT slot has to be set manually, too. A DOM test finally showed
|
|
;;; that this had been forgotten for Text nodes and PIs.
|
|
;;;
|
|
;;; Opinions?
|
|
;;;
|
|
;;; -- David
|
|
|
|
;;; Now at least the children list isn't reversed anymore, because I changed
|
|
;;; the representation to be an extensible vector. Still its not clear to
|
|
;;; me whether the DOM Builder should be affected by such changes at all.
|
|
;;;
|
|
;;; -- David
|
|
|
|
(in-package :dom-impl)
|
|
|
|
(defclass dom-builder ()
|
|
((document :initform nil :accessor document)
|
|
(element-stack :initform '() :accessor element-stack)))
|
|
|
|
(defun dom:make-dom-builder ()
|
|
(make-instance 'dom-builder))
|
|
|
|
(defun fast-push (new-element vector)
|
|
(vector-push-extend new-element vector (max 1 (array-dimension vector 0))))
|
|
|
|
(defmethod sax:start-document ((handler dom-builder))
|
|
(let ((document (make-instance 'dom-impl::document)))
|
|
(setf (slot-value document 'dom-impl::owner) nil
|
|
(slot-value document 'dom-impl::doc-type) nil)
|
|
(setf (document handler) document)
|
|
(push document (element-stack handler))))
|
|
|
|
(defmethod sax:end-document ((handler dom-builder))
|
|
(setf (slot-value (document handler) 'entities) xml::*entities*)
|
|
(let ((doctype (dom:doctype (document handler))))
|
|
(when doctype
|
|
(setf (slot-value (dom:entities doctype) 'read-only-p) t)
|
|
(setf (slot-value (dom:notations doctype) 'read-only-p) t)))
|
|
(document handler))
|
|
|
|
(defmethod sax:start-dtd ((handler dom-builder) name publicid systemid)
|
|
(declare (ignore publicid systemid))
|
|
(let* ((document (document handler))
|
|
(doctype (make-instance 'dom-impl::document-type
|
|
:name name
|
|
:notations (make-instance 'dom-impl::named-node-map
|
|
:element-type :notation
|
|
:owner document)
|
|
:entities (make-instance 'dom-impl::named-node-map
|
|
:element-type :entity
|
|
:owner document))))
|
|
(setf (slot-value doctype 'dom-impl::owner) document
|
|
(slot-value document 'dom-impl::doc-type) doctype)))
|
|
|
|
(defmethod sax:start-element ((handler dom-builder) namespace-uri local-name qname attributes)
|
|
(with-slots (document element-stack) handler
|
|
(let ((element (dom:create-element document qname))
|
|
(parent (car element-stack)))
|
|
(dolist (attr attributes)
|
|
(dom:set-attribute element (xml::attribute-qname attr) (xml::attribute-value attr)))
|
|
(setf (slot-value element 'dom-impl::parent) parent)
|
|
(fast-push element (slot-value parent 'dom-impl::children))
|
|
(push element element-stack))))
|
|
|
|
(defmethod sax:end-element ((handler dom-builder) namespace-uri local-name qname)
|
|
(pop (element-stack handler)))
|
|
|
|
(defmethod sax:characters ((handler dom-builder) data)
|
|
(with-slots (document element-stack) handler
|
|
(let* ((parent (car element-stack))
|
|
(last-child (dom:last-child parent)))
|
|
(cond
|
|
((eq (dom:node-type parent) :cdata-section)
|
|
(setf (dom:data parent) data))
|
|
((and last-child (eq (dom:node-type last-child) :text))
|
|
;; um entities herum wird SAX:CHARACTERS mehrfach aufgerufen fuer
|
|
;; den gleichen Textknoten. Hier muessen wir den bestehenden Knoten
|
|
;; erweitern, sonst ist das Dokument nicht normalisiert.
|
|
;; (XXX Oder sollte man besser den Parser entsprechend aendern?)
|
|
(dom:append-data last-child data))
|
|
(t
|
|
(let ((node (dom:create-text-node document data)))
|
|
(setf (slot-value node 'dom-impl::parent) parent)
|
|
(fast-push node (slot-value (car element-stack) 'dom-impl::children))))))))
|
|
|
|
(defmethod sax:start-cdata ((handler dom-builder))
|
|
(with-slots (document element-stack) handler
|
|
(let ((node (dom:create-cdata-section document #""))
|
|
(parent (car element-stack)))
|
|
(setf (slot-value node 'dom-impl::parent) parent)
|
|
(fast-push node (slot-value parent 'dom-impl::children))
|
|
(push node element-stack))))
|
|
|
|
(defmethod sax:end-cdata ((handler dom-builder))
|
|
(let ((node (pop (slot-value handler 'element-stack))))
|
|
(assert (eq (dom:node-type node) :cdata-section))))
|
|
|
|
(defmethod sax:processing-instruction ((handler dom-builder) target data)
|
|
(with-slots (document element-stack) handler
|
|
(let ((node (dom:create-processing-instruction document target data))
|
|
(parent (car element-stack)))
|
|
(setf (slot-value node 'dom-impl::parent) parent)
|
|
(fast-push node (slot-value (car element-stack) 'dom-impl::children)))))
|
|
|
|
(defmethod sax:comment ((handler dom-builder) data)
|
|
(with-slots (document element-stack) handler
|
|
(let ((node (dom:create-comment document data))
|
|
(parent (car element-stack)))
|
|
(setf (slot-value node 'dom-impl::parent) parent)
|
|
(fast-push node (slot-value (car element-stack) 'dom-impl::children)))))
|
|
|
|
(defmethod sax:unparsed-entity-declaration
|
|
((handler dom-builder) name public-id system-id notation-name)
|
|
(dom:set-named-item (dom:entities (dom:doctype (document handler)))
|
|
(make-instance 'dom-impl::entity
|
|
:owner (document handler)
|
|
:name name
|
|
:public-id public-id
|
|
:system-id system-id
|
|
:notation-name notation-name)))
|
|
|
|
(defmethod sax:notation-declaration
|
|
((handler dom-builder) name public-id system-id)
|
|
(dom:set-named-item (dom:notations (dom:doctype (document handler)))
|
|
(make-instance 'dom-impl::notation
|
|
:owner (document handler)
|
|
:name name
|
|
:public-id public-id
|
|
:system-id system-id)))
|