OSCL/CXML
2
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

DOM 2 Core. Ungetestet, aber die 1er tests laufen wieder, daher rein damit.

Browse Source
This commit is contained in:
dlichteblau
2005-12-04 18:43:49 +00:00
parent 0e994ba607
commit 74cb5b7f8c
15 changed files with 1299 additions and 811 deletions
Download Patch File Download Diff File Expand all files Collapse all files

48
dom/dom-builder.lisp
View File

@ -12,7 +12,8 @@
(defclass dom-builder ()
((document :initform nil :accessor document)
(element-stack :initform '() :accessor element-stack)))
(element-stack :initform '() :accessor element-stack)
(internal-subset :accessor internal-subset)))
(defun dom:make-dom-builder ()
(make-instance 'dom-builder))
@ -39,26 +40,48 @@
(setf (slot-value (document handler) 'entity-resolver) resolver))
(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))))
(doctype
(dom:create-document-type 'implementation name publicid systemid)))
(setf (slot-value doctype 'dom-impl::owner) document
(slot-value (dom:notations doctype) 'dom-impl::owner) document
(slot-value (dom:entities doctype) 'dom-impl::owner) document
(slot-value document 'dom-impl::doc-type) doctype)))
(defmethod sax:start-internal-subset ((handler dom-builder))
(setf (internal-subset handler) nil))
(defmethod sax:end-internal-subset ((handler dom-builder))
(setf (internal-subset (slot-value (document handler) 'dom-impl::doc-type))
(nreverse (internal-subset handler)))
(slot-makunbound handler 'internal-subset))
(macrolet ((defhandler (name &rest args)
`(defmethod ,name ((handler dom-builder) ,@args)
(when (slot-boundp handler 'internal-subset)
(push (list ',name ,@args) (internal-subset handler))))))
(defhandler sax:unparsed-entity-declaration
name public-id system-id notation-name)
(defhandler sax:external-entity-declaration
kind name public-id system-id)
(defhandler sax:internal-entity-declaration
kind name value)
(defhandler sax:notation-declaration
name public-id system-id)
(defhandler sax:element-declaration
name model)
(defhandler sax:attribute-declaration
element-name attribute-name type default))
(defmethod sax:start-element
((handler dom-builder) namespace-uri local-name qname attributes)
(declare (ignore namespace-uri local-name))
(with-slots (document element-stack) handler
(let ((element (make-instance 'element
:tag-name qname
:owner document))
:owner document
:namespace-uri namespace-uri
:local-name local-name
:prefix (cxml::split-qname (cxml::rod qname))))
(parent (car element-stack))
(anodes '()))
(dolist (attr attributes)
@ -68,6 +91,7 @@
(dom:create-text-node document (sax:attribute-value attr))))
(setf (slot-value anode 'dom-impl::specified-p)
(sax:attribute-specified-p attr))
(setf (slot-value anode 'dom-impl::owner-element) element)
(dom:append-child anode text)
(push anode anodes)))
(setf (slot-value element 'dom-impl::parent) parent)

319
dom/dom-impl.lisp
View File

@ -8,7 +8,8 @@
;;;; Author: knowledgeTools Int. GmbH
(defpackage :dom-impl
(:use :cl :runes))
(:use :cl :runes)
(:export #:create-document))
(in-package :dom-impl)
@ -33,6 +34,15 @@
(read-only-p :initform nil :reader read-only-p)
(map :initform nil)))
(defmethod dom:prefix ((node node)) nil)
(defmethod dom:local-name ((node node)) nil)
(defmethod dom:namespace-uri ((node node)) nil)
(defclass namespace-mixin ()
((prefix :initarg :prefix :reader dom:prefix)
(local-name :initarg :local-name :reader dom:local-name)
(namespace-uri :initarg :namespace-uri :reader dom:namespace-uri)))
(defclass document (node)
((doc-type :initarg :doc-type :reader dom:doctype)
(dtd :initform nil :reader dtd)
@ -44,8 +54,9 @@
(defclass character-data (node)
((value :initarg :data :reader dom:data)))
(defclass attribute (node)
(defclass attribute (namespace-mixin node)
((name :initarg :name :reader dom:name)
(owner-element :initarg :owner-element :reader dom:owner-element)
(specified-p :initarg :specified-p :reader dom:specified)))
(defmethod print-object ((object attribute) stream)
@ -54,7 +65,7 @@
(rod-string (dom:name object))
(rod-string (dom:value object)))))
(defclass element (node)
(defclass element (namespace-mixin node)
((tag-name :initarg :tag-name :reader dom:tag-name)
(attributes :initarg :attributes :reader dom:attributes)))
@ -73,8 +84,11 @@
(defclass document-type (node)
((name :initarg :name :reader dom:name)
(public-id :initarg :public-id :reader dom:public-id)
(system-id :initarg :system-id :reader dom:system-id)
(entities :initarg :entities :reader dom:entities)
(notations :initarg :notations :reader dom:notations)))
(notations :initarg :notations :reader dom:notations)
(internal-subset :accessor internal-subset)))
(defclass notation (node)
((name :initarg :name :reader dom:name)
@ -176,6 +190,45 @@
(:NOT_SUPPORTED_ERR 9)
(:INUSE_ATTRIBUTE_ERR 10)))
;; dom-implementation protocol
(defmethod dom:has-feature ((factory (eql 'implementation)) feature version)
(and (or (string-equal (rod-string feature) "xml")
(string-equal (rod-string feature) "core"))
(or (string-equal (rod-string version) "1.0")
(string-equal (rod-string version) "2.0"))))
(defmethod dom:create-document-type
((factory (eql 'implementation)) name publicid systemid)
(make-instance 'dom-impl::document-type
:name name
:notations (make-instance 'dom-impl::named-node-map
:element-type :notation
:owner nil)
:entities (make-instance 'dom-impl::named-node-map
:element-type :entity
:owner nil)
:public-id publicid
:system-id systemid))
(defmethod dom:create-document
((factory (eql 'implementation)) uri qname doctype)
(let ((document (make-instance 'dom-impl::document)))
(setf (slot-value document 'owner) nil
(slot-value document 'doc-type) doctype
(slot-value document 'namespace-uri) uri)
(setf (values (slot-value document 'prefix)
(slot-value document 'local-name))
(safe-split-qname qname uri))
(when doctype
(unless (typep doctype 'document-type)
(dom-error :WRONG_DOCUMENT_ERR
"doctype was created by a different dom implementation"))
(setf (slot-value doctype 'dom-impl::owner) document
(slot-value (dom:notations doctype) 'dom-impl::owner) document
(slot-value (dom:entities doctype) 'dom-impl::owner) document))
document))
;; document-fragment protocol
;; document protocol
@ -191,8 +244,11 @@
(setf tag-name (rod tag-name))
(unless (cxml::valid-name-p tag-name)
(dom-error :INVALID_CHARACTER_ERR "not a name: ~A" (rod-string tag-name)))
(let ((result (make-instance 'element
(let ((result (make-instance 'element
:tag-name tag-name
:namespace-uri nil
:local-name nil
:prefix nil
:owner document)))
(setf (slot-value result 'attributes)
(make-instance 'attribute-node-map
@ -202,6 +258,41 @@
(add-default-attributes result)
result))
(defun safe-split-qname (qname uri)
(unless (cxml::valid-name-p qname)
(dom-error :INVALID_CHARACTER_ERR "not a name: ~A" (rod-string qname)))
(multiple-value-bind (prefix local-name)
(handler-case
(cxml::split-qname qname)
(cxml:well-formedness-violation (c)
(dom-error :NAMESPACE_ERR "~A" c)))
(when prefix
(when (and (rod= prefix "xml")
(not (rod= uri "http://www.w3.org/XML/1998/namespace")))
(dom-error :NAMESPACE_ERR "invalid uri for prefix `xml'"))
(when (and (rod= prefix "xmlns")
(not (rod= uri "http://www.w3.org/2000/xmlns/")))
(dom-error :NAMESPACE_ERR "invalid uri for prefix `xmlns'")))
(values prefix local-name)))
(defmethod dom:create-element-ns ((document document) uri qname)
(setf qname (rod qname))
(multiple-value-bind (prefix local-name)
(safe-split-qname qname uri)
(let ((result (make-instance 'element
:tag-name qname
:namespace-uri uri
:local-name local-name
:prefix prefix
:owner document)))
(setf (slot-value result 'attributes)
(make-instance 'attribute-node-map
:element-type :attribute
:owner document
:element result))
(add-default-attributes result)
result)))
(defmethod dom:create-document-fragment ((document document))
(make-instance 'document-fragment
:owner document))
@ -240,9 +331,25 @@
(dom-error :INVALID_CHARACTER_ERR "not a name: ~A" (rod-string name)))
(make-instance 'attribute
:name name
:local-name nil
:prefix nil
:namespace-uri nil
:specified-p t
:owner document))
(defmethod dom:create-attribute-ns ((document document) uri qname)
(setf uri (rod uri))
(setf qname (rod qname))
(multiple-value-bind (prefix local-name)
(safe-split-qname qname uri)
(make-instance 'attribute
:name qname
:namespace-uri uri
:local-name local-name
:prefix prefix
:specified-p t
:owner document)))
(defmethod dom:create-entity-reference ((document document) name)
(setf name (rod name))
(unless (cxml::valid-name-p name)
@ -253,23 +360,66 @@
(defmethod get-elements-by-tag-name-internal (node tag-name)
(setf tag-name (rod tag-name))
(let ((result (make-node-list)))
(setf tag-name (rod tag-name))
(let ((wild-p (rod= tag-name '#.(string-rod "*"))))
(labels ((walk (n)
(dovector (c (dom:child-nodes n))
(when (dom:element-p c)
(when (or wild-p (rod= tag-name (dom:node-name c)))
(vector-push-extend c result (extension result)))
(walk c)))))
(walk node)))
(let ((result (make-node-list))
(wild-p (rod= tag-name '#.(string-rod "*"))))
(labels ((walk (n)
(dovector (c (dom:child-nodes n))
(when (dom:element-p c)
(when (or wild-p (rod= tag-name (dom:node-name c)))
(vector-push-extend c result (extension result)))
(walk c)))))
(walk node))
result))
(defmethod get-elements-by-tag-name-internal-ns (node uri lname)
(setf uri (rod uri))
(setf lname (rod lname))
(let ((result (make-node-list))
(wild-uri-p (rod= uri '#.(string-rod "*")))
(wild-lname-p (rod= lname '#.(string-rod "*"))))
(labels ((walk (n)
(dovector (c (dom:child-nodes n))
(when (dom:element-p c)
(when (and (or wild-lname-p (rod= lname (dom:local-name c)))
(or wild-uri-p (rod= uri (dom:namespace-uri c))))
(vector-push-extend c result (extension result)))
(walk c)))))
(walk node))
result))
(defmethod dom:get-elements-by-tag-name ((document document) tag-name)
(get-elements-by-tag-name-internal document tag-name))
(defmethod dom:get-elements-by-tag-name-ns ((document document) uri lname)
(get-elements-by-tag-name-internal-ns document uri lname))
(defmethod dom:get-element-by-id ((document document) id)
(block nil
(unless (dtd document)
(return nil))
(setf id (rod id))
(labels ((walk (n)
(dovector (c (dom:child-nodes n))
(when (dom:element-p c)
(let ((e (cxml::find-element
(cxml::rod (dom:tag-name c))
(dtd document))))
(when e
(dolist (a (cxml::elmdef-attributes e))
(when (eq :ID (cxml::attdef-type a))
(let* ((name (rod (cxml::attdef-name a)))
(value (dom:get-attribute c name)))
(when (and value (rod= value id))
(return c)))))))
(walk c)))))
(walk document))))
;;; Node
(defmethod dom:is-supported ((node node) feature version)
(dom:has-feature 'implementation feature version))
(defmethod dom:parent-node ((node node))
(slot-value node 'parent))
@ -544,29 +694,50 @@
(setf name (rod name))
(with-slots (items) self
(dolist (k items nil)
(cond ((rod= name (dom:node-name k))
(return k))))))
(when (rod= name (dom:node-name k))
(return k)))))
(defmethod dom:set-named-item ((self named-node-map) arg)
(assert-writeable self)
(unless (eq (dom:node-type arg) (slot-value self 'element-type))
(defmethod dom:get-named-item-ns ((self named-node-map) uri lname)
(setf uri (rod uri))
(setf lname (rod lname))
(with-slots (items) self
(dolist (k items nil)
(when (and (equal uri (dom:namespace-uri k))
(equal lname (dom:local-name k)))
(return k)))))
(defun %set-named-item (map arg test)
(assert-writeable map)
(unless (eq (dom:node-type arg) (slot-value map 'element-type))
(dom-error :HIERARCHY_REQUEST_ERR
"~S cannot adopt ~S, since it is not of type ~S."
self arg (slot-value self 'element-type)))
(unless (eq (dom:owner-document self) (dom:owner-document arg))
map arg (slot-value map 'element-type)))
(unless (eq (dom:owner-document map) (dom:owner-document arg))
(dom-error :WRONG_DOCUMENT_ERR
"~S cannot adopt ~S, since it was created by a different document."
self arg))
map arg))
(let ((old-map (slot-value arg 'map)))
(when (and old-map (not (eq old-map self)))
(when (and old-map (not (eq old-map map)))
(dom-error :INUSE_ATTRIBUTE_ERR "Attribute node already mapped" arg)))
(setf (slot-value arg 'map) self)
(setf (slot-value arg 'map) map)
(with-slots (items) map
(dolist (k items (progn (setf items (cons arg items)) nil))
(when (funcall test k)
(setf items (cons arg (delete k items)))
(return k)))))
(defmethod dom:set-named-item ((self named-node-map) arg)
(let ((name (dom:node-name arg)))
(with-slots (items) self
(dolist (k items (progn (setf items (cons arg items))nil))
(cond ((rod= name (dom:node-name k))
(setf items (cons arg (delete k items)))
(return k)))))))
(%set-named-item self arg (lambda (k) (rod= name (dom:node-name k))))))
(defmethod dom:set-named-item-ns ((self named-node-map) arg)
(let ((uri (dom:namespace-uri arg))
(lname (dom:local-name arg)))
(%set-named-item self
arg
(lambda (k)
(and (rod= lname (dom:local-name k))
(rod= uri (dom:namespace-uri k)))))))
(defmethod dom:remove-named-item ((self named-node-map) name)
(assert-writeable self)
@ -577,6 +748,18 @@
(setf items (delete k items))
(return k))))))
(defmethod dom:remove-named-item-ns ((self named-node-map) uri lname)
(assert-writeable self)
(setf uri (rod uri))
(setf lname (rod lname))
(with-slots (items) self
(dolist (k items
(dom-error :NOT_FOUND_ERR "~A not found in ~A" lname self))
(when (and (rod= lname (dom:local-name k))
(rod= uri (dom:namespace-uri k)))
(setf items (delete k items))
(return k)))))
(defmethod dom:length ((self named-node-map))
(with-slots (items) self
(length items)))
@ -743,6 +926,15 @@
;;; ELEMENT
(defmethod dom:has-attributes ((element element))
(plusp (length (dom:items (dom:attributes element)))))
(defmethod dom:has-attribute ((element element) name)
(and (dom:get-named-item (dom:attributes element) name) t))
(defmethod dom:has-attribute-ns ((element element) uri lname)
(and (dom:get-named-item-ns (dom:attributes element) uri lname) t))
(defmethod dom:get-attribute-node ((element element) name)
(dom:get-named-item (dom:attributes element) name))
@ -750,24 +942,51 @@
(assert-writeable element)
(dom:set-named-item (dom:attributes element) new-attr))
(defmethod dom:get-attribute-node-ns ((element element) uri lname)
(dom:get-named-item-ns (dom:attributes element) uri lname))
(defmethod dom:set-attribute-node-ns ((element element) (new-attr attribute))
(assert-writeable element)
(dom:set-named-item-ns (dom:attributes element) new-attr))
(defmethod dom:get-attribute ((element element) name)
(let ((a (dom:get-attribute-node element name)))
(if a
(dom:value a)
#.(string-rod ""))))
(defmethod dom:get-attribute-ns ((element element) uri lname)
(let ((a (dom:get-attribute-node-ns element uri lname)))
(if a
(dom:value a)
#.(string-rod ""))))
(defmethod dom:set-attribute ((element element) name value)
(assert-writeable element)
(with-slots (owner) element
(let ((attr (dom:create-attribute owner name)))
(setf (slot-value attr 'owner-element) element)
(setf (dom:value attr) value)
(dom:set-attribute-node element attr))
(values)))
(defmethod dom:set-attribute-ns ((element element) uri lname value)
(assert-writeable element)
(with-slots (owner) element
(let ((attr (dom:create-attribute-ns owner uri lname)))
(setf (slot-value attr 'owner-element) element)
(setf (dom:value attr) value)
(dom:set-attribute-node-ns element attr))
(values)))
(defmethod dom:remove-attribute ((element element) name)
(assert-writeable element)
(dom:remove-attribute-node element (dom:get-attribute-node element name)))
(defmethod dom:remove-attribute-ns ((elt element) uri lname)
(assert-writeable elt)
(dom:remove-attribute-node elt (dom:get-attribute-node-ns elt uri lname)))
(defmethod dom:remove-attribute-node ((element element) (old-attr attribute))
(assert-writeable element)
(with-slots (items) (dom:attributes element)
@ -781,14 +1000,18 @@
(defun maybe-add-default-attribute (element name)
(let* ((dtd (dtd (slot-value element 'owner)))
(e (when dtd (cxml::find-element (dom:tag-name element) dtd)))
(e (when dtd (cxml::find-element
(cxml::rod (dom:tag-name element))
dtd)))
(a (when e (cxml::find-attribute e name))))
(when (and a (listp (cxml::attdef-default a)))
(add-default-attribute element a))))
(defun add-default-attributes (element)
(let* ((dtd (dtd (slot-value element 'owner)))
(e (when dtd (cxml::find-element (dom:tag-name element) dtd))))
(e (when dtd (cxml::find-element
(cxml::rod (dom:tag-name element))
dtd))))
(when e
(dolist (a (cxml::elmdef-attributes e))
(when (and a (listp (cxml::attdef-default a)))
@ -799,7 +1022,8 @@
(owner (slot-value element 'owner))
(anode (dom:create-attribute owner (cxml::attdef-name adef)))
(text (dom:create-text-node owner value)))
(setf (slot-value anode 'dom-impl::specified-p) nil)
(setf (slot-value anode 'specified-p) nil)
(setf (slot-value anode 'owner-element) element)
(dom:append-child anode text)
(push anode (slot-value (dom:attributes element) 'items))))
@ -810,8 +1034,16 @@
(assert-writeable element)
(get-elements-by-tag-name-internal element name))
(defmethod dom:normalize ((element element))
(defmethod dom:get-elements-by-tag-name-ns ((element element) uri lname)
(assert-writeable element)
(get-elements-by-tag-name-internal-ns element uri lname))
(defmethod dom:set-named-item :after ((self attribute-node-map) arg)
(setf (slot-value arg 'owner-element)
(slot-value self 'element)))
(defmethod dom:normalize ((node node))
(assert-writeable node)
(labels ((walk (n)
(when (eq (dom:node-type n) :element)
(map nil #'walk (dom:items (dom:attributes n))))
@ -837,7 +1069,7 @@
(setf previous child)
(incf i))))))
(map nil #'walk (dom:child-nodes n))))
(walk element))
(walk node))
(values))
;;; TEXT
@ -856,7 +1088,17 @@
;;; COMMENT -- nix
;;; CDATA-SECTION -- nix
;;; DOCUMENT-TYPE -- missing
;;; DOCUMENT-TYPE
(defmethod dom:internal-subset ((node document-type))
;; FIXME: encoding ist falsch, anderen sink nehmen!
(if (slot-boundp node 'internal-subset)
(with-output-to-string (stream)
(let ((sink (cxml:make-character-stream-sink stream)))
(dolist (def (internal-subset node))
(apply (car def) sink (cdr def)))))
nil))
;;; NOTATION -- nix
;;; ENTITY -- nix
@ -978,6 +1220,9 @@
:owner document))
(result (import-node-internal 'element document node deep
:attributes attributes
:namespace-uri (dom:namespace-uri node)
:local-name (dom:local-name node)
:prefix (dom:prefix node)
:tag-name (dom:tag-name node))))
(setf (slot-value attributes 'element) result)
(dolist (attribute (dom:items (dom:attributes node)))
@ -1034,7 +1279,7 @@
;;; Erweiterung
(defun dom:create-document (&optional document-element)
(defun dom-impl:create-document (&optional document-element)
;; Um ein neues Dokumentenobject zu erzeugen, parsen wir einfach ein
;; Dummydokument.
(let* ((handler (dom:make-dom-builder))

51
dom/dom-sax.lisp
View File

@ -11,26 +11,41 @@
(defun dom:map-document
(handler document
&key (include-xmlns-attributes sax:*include-xmlns-attributes*)
include-doctype
include-default-values)
(sax:start-document handler)
(let ((doctype (dom:doctype document)))
(when doctype
(sax:start-dtd handler (dom:name doctype) nil nil)
;; need notations for canonical mode 2
(let* ((ns (dom:notations doctype))
(a (make-array (dom:length ns))))
;; get them
(dotimes (k (dom:length ns))
(setf (elt a k) (dom:item ns k)))
;; sort them
(setf a (sort a #'rod< :key #'dom:name))
(loop for n across a do
(sax:notation-declaration handler
(dom:name n)
(dom:public-id n)
(dom:system-id n)))
;; fixme: entities!
(sax:end-dtd handler))))
(when include-doctype
(let ((doctype (dom:doctype document)))
(when doctype
(sax:start-dtd handler
(dom:name doctype)
(dom:public-id doctype)
(dom:system-id doctype))
(ecase include-doctype
(:full-internal-subset
(when (slot-boundp doctype 'internal-subset)
(sax:start-internal-subset handler)
(dolist (def (internal-subset doctype))
(apply (car def) handler (cdr def)))
(sax:end-internal-subset handler)))
(:canonical-notations
;; need notations for canonical mode 2
(let* ((ns (dom:notations doctype))
(a (make-array (dom:length ns))))
(when (plusp (dom:length ns))
(sax:start-internal-subset handler)
;; get them
(dotimes (k (dom:length ns))
(setf (elt a k) (dom:item ns k)))
;; sort them
(setf a (sort a #'rod< :key #'dom:name))
(loop for n across a do
(sax:notation-declaration handler
(dom:name n)
(dom:public-id n)
(dom:system-id n)))
(sax:end-internal-subset handler)))))
(sax:end-dtd handler))))
(labels ((walk (node)
(dom:do-node-list (child (dom:child-nodes node))
(ecase (dom:node-type child)

29
dom/package.lisp
View File

@ -12,7 +12,33 @@
;; lisp-specific extensions
#:make-dom-builder
;; methods
;; DOM 2 functions
#:owner-element
#:import-node
#:create-element-ns
#:create-attribute-ns
#:get-elements-by-tag-name-ns
#:get-element-by-id
#:get-named-item-ns
#:set-named-item-ns
#:remove-named-item-ns
#:is-supported
#:has-attributes
#:namespace-uri
#:prefix
#:local-name
#:internal-subset
#:create-document-type
#:create-document
#:get-attribute-ns
#:set-attribute-ns
#:remove-attribute-ns
#:get-attribute-node-ns
#:set-attribute-node-ns
#:has-attribute
#:has-attribute-ns
;; DOM 1 functions
#:has-feature
#:doctype
#:implementation
@ -72,7 +98,6 @@
#:system-id
#:notation-name
#:target
#:import-node
#:code
;; protocol classes

46
dom/simple-dom.lisp
View File

@ -1,46 +0,0 @@
(in-package :xml)
;;; Implementation of a simple but faster DOM.
(defclass simple-document ()
((children :initform nil :accessor simple-document-children)))
(defstruct node
parent)
(defstruct (processing-instruction (:include node))
target
data)
(defstruct (text (:include node)
(:constructor make-text-boa (parent data)))
data)
(defstruct (element (:include node))
gi
attributes
children)
(defmethod dom:create-processing-instruction ((document simple-document) target data)
(make-processing-instruction :target target :data data))
(defmethod dom:append-child ((node element) child)
(setf (node-parent child) node)
(push child (element-children node)))
(defmethod dom:append-child ((node simple-document) child)
(push child (simple-document-children node))
nil)
(defmethod dom:create-element ((document simple-document) name)
(make-element :gi name))
(defmethod dom:set-attribute ((node element) name value)
(push (cons name value)
(element-attributes node)))
(defmethod dom:create-text-node ((document simple-document) data)
(make-text-boa nil data))
(defmethod dom:create-cdata-section ((document simple-document) data)
(make-text-boa nil data))

66
dom/string-dom.lisp
View File

@ -1,66 +0,0 @@
;;; A wrapper package STRING-DOM around the ordinary DOM presents
;;; DOMString as Lisp STRING. This was a workaround until
;;; RUNE-IS-CHARACTER was implemented, but might still be useful on
;;; Lisps without Unicode support.
(defpackage :string-dom
(:use))
(eval-when (:compile-toplevel :load-toplevel :execute)
(do-external-symbols (var :dom)
(let* ((home-package
(if (member var '(dom:data dom:name dom:value dom:tag-name
dom:node-name dom:node-value
dom:substring-data dom:get-attribute
dom:set-attribute dom:public-id dom:system-id
dom:notation-name dom:target))
:string-dom
:dom))
(symbol (intern (symbol-name var) home-package)))
(import symbol :string-dom)
(export (list symbol) :string-dom))))
(defpackage :string-dom-impl (:use :cl))
(in-package :string-dom-impl)
(defun rod-to-string (frob)
(if (null frob)
nil
(map 'string #'code-char frob)))
(defun string-dom:data (node) (rod-to-string (dom:data node)))
(defun string-dom:name (node) (rod-to-string (dom:name node)))
(defun string-dom:value (node) (rod-to-string (dom:value node)))
(defun string-dom:tag-name (node) (rod-to-string (dom:tag-name node)))
(defun string-dom:node-name (node) (rod-to-string (dom:node-name node)))
(defun string-dom:node-value (node) (rod-to-string (dom:node-value node)))
(defun (setf string-dom:data) (newval node)
(setf (dom:data node) newval))
(defun (setf string-dom:value) (newval node)
(setf (dom:value node) newval))
(defun (setf string-dom:node-value) (newval node)
(setf (dom:node-value node) newval))
(defun string-dom:substring-data (node offset count)
(rod-to-string (dom:substring-data node offset count)))
(defun string-dom:get-attribute (elt name)
(rod-to-string (dom:get-attribute elt name)))
(defun string-dom:set-attribute (elt name value)
(dom:set-attribute elt (runes:rod name) (runes:rod value)))
(defun string-dom:public-id (node)
(rod-to-string (dom:public-id node)))
(defun string-dom:system-id (node)
(rod-to-string (dom:system-id node)))
(defun string-dom:notation-name (node)
(rod-to-string (dom:notation-name node)))
(defun string-dom:target (node)
(rod-to-string (dom:target node)))

23
dom/unparse.lisp
View File

@ -1,9 +1,20 @@
(in-package :cxml)
(defun unparse-document-to-octets (doc &rest initargs)
(let ((sink (apply #'make-octet-vector-sink initargs)))
(dom:map-document sink doc :include-default-values t)))
(defun %unparse-document (sink doc canonical)
(dom:map-document sink
doc
:include-doctype (if (and canonical (>= canonical 2))
:canonical-notations
nil)
:include-default-values t))
(defun unparse-document (doc character-stream &rest initargs)
(let ((sink (apply #'make-character-stream-sink character-stream initargs)))
(dom:map-document sink doc :include-default-values t)))
(defun unparse-document-to-octets (doc &rest initargs &key canonical)
(%unparse-document (apply #'make-octet-vector-sink initargs)
doc
canonical))
(defun unparse-document (doc character-stream &rest initargs &key canonical)
(%unparse-document
(apply #'make-character-stream-sink character-stream initargs)
doc
canonical))