[cxml-cvs] CVS update: cxml/dom/dom-builder.lisp cxml/dom/dom-impl.lisp cxml/dom/dom-sax.lisp cxml/dom/package.lisp cxml/dom/unparse.lisp cxml/dom/simple-dom.lisp cxml/dom/string-dom.lisp
David Lichteblau
dlichteblau at common-lisp.net
Sun Dec 4 18:44:00 UTC 2005
Update of /project/cxml/cvsroot/cxml/dom
In directory common-lisp.net:/tmp/cvs-serv22921/dom
Modified Files:
dom-builder.lisp dom-impl.lisp dom-sax.lisp package.lisp
unparse.lisp
Removed Files:
simple-dom.lisp string-dom.lisp
Log Message:
DOM 2 Core. Ungetestet, aber die 1er tests laufen wieder, daher rein damit.
Date: Sun Dec 4 19:43:56 2005
Author: dlichteblau
Index: cxml/dom/dom-builder.lisp
diff -u cxml/dom/dom-builder.lisp:1.3 cxml/dom/dom-builder.lisp:1.4
--- cxml/dom/dom-builder.lisp:1.3 Mon Nov 28 23:33:33 2005
+++ cxml/dom/dom-builder.lisp Sun Dec 4 19:43:54 2005
@@ -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) , at args)
+ (when (slot-boundp handler 'internal-subset)
+ (push (list ',name , at 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)
Index: cxml/dom/dom-impl.lisp
diff -u cxml/dom/dom-impl.lisp:1.4 cxml/dom/dom-impl.lisp:1.5
--- cxml/dom/dom-impl.lisp:1.4 Mon Nov 28 23:33:33 2005
+++ cxml/dom/dom-impl.lisp Sun Dec 4 19:43:56 2005
@@ -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))
Index: cxml/dom/dom-sax.lisp
diff -u cxml/dom/dom-sax.lisp:1.2 cxml/dom/dom-sax.lisp:1.3
--- cxml/dom/dom-sax.lisp:1.2 Mon Nov 28 23:33:33 2005
+++ cxml/dom/dom-sax.lisp Sun Dec 4 19:43:56 2005
@@ -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)
Index: cxml/dom/package.lisp
diff -u cxml/dom/package.lisp:1.2 cxml/dom/package.lisp:1.3
--- cxml/dom/package.lisp:1.2 Mon Nov 28 23:33:33 2005
+++ cxml/dom/package.lisp Sun Dec 4 19:43:56 2005
@@ -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
Index: cxml/dom/unparse.lisp
diff -u cxml/dom/unparse.lisp:1.1.1.1 cxml/dom/unparse.lisp:1.2
--- cxml/dom/unparse.lisp:1.1.1.1 Sun Mar 13 19:02:47 2005
+++ cxml/dom/unparse.lisp Sun Dec 4 19:43:56 2005
@@ -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))
More information about the Cxml-cvs
mailing list