47 lines
2.0 KiB
Common Lisp
47 lines
2.0 KiB
Common Lisp
(in-package :dom-impl)
|
|
|
|
(export 'dom-builder)
|
|
|
|
(defclass dom-builder ()
|
|
((document :initform nil :accessor document)
|
|
(element-stack :initform '() :accessor element-stack)))
|
|
|
|
(defmethod sax:start-document ((handler dom-builder))
|
|
(let ((document (make-instance 'dom-impl::document))
|
|
(doctype (make-instance 'dom-impl::document-type
|
|
:notations (make-hash-table :test #'equalp))))
|
|
(setf (slot-value document 'dom-impl::owner) document
|
|
(slot-value document 'dom-impl::doc-type) doctype)
|
|
(setf (document handler) document)
|
|
(push document (element-stack handler))))
|
|
|
|
(defmethod sax:end-document ((handler dom-builder))
|
|
(setf (slot-value (document handler) 'children )
|
|
(nreverse (slot-value (document handler) 'children)))
|
|
(document handler))
|
|
|
|
(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)
|
|
(push element (slot-value parent 'dom-impl::children))
|
|
(push element element-stack))))
|
|
|
|
(defmethod sax:end-element ((handler dom-builder) namespace-uri local-name qname)
|
|
(let ((element (pop (element-stack handler))))
|
|
(setf (slot-value element 'dom-impl::children)
|
|
(nreverse (slot-value element 'dom-impl::children)))))
|
|
|
|
(defmethod sax:characters ((handler dom-builder) data)
|
|
(with-slots (document element-stack) handler
|
|
(let ((node (dom:create-text-node document data)))
|
|
(push node (slot-value (car element-stack) 'dom-impl::children)))))
|
|
|
|
(defmethod sax:processing-instruction ((handler dom-builder) target data)
|
|
(with-slots (document element-stack) handler
|
|
(let ((node (dom:create-processing-instruction document target data)))
|
|
(push node (slot-value (car element-stack) 'dom-impl::children)))))
|