[cxml-cvs] CVS cxml/dom

[dlichteblau]

Update of /project/cxml/cvsroot/cxml/dom
In directory clnet:/tmp/cvs-serv30752/dom

Modified Files:
	dom-impl.lisp 
Log Message:
new feature: clone-node von document
bugfix: entities und notations auch in create-document-type readonly


--- /project/cxml/cvsroot/cxml/dom/dom-impl.lisp	2006/08/20 12:19:01	1.38
+++ /project/cxml/cvsroot/cxml/dom/dom-impl.lisp	2006/08/20 12:55:30	1.39
@@ -282,7 +282,10 @@
 (defmethod dom:create-document-type
     ((factory (eql 'implementation)) name publicid systemid)
   (safe-split-qname name #"")
-  (%create-document-type name publicid systemid))
+  (let ((result (%create-document-type name publicid systemid)))
+    (setf (slot-value (dom:entities result) 'read-only-p) t)
+    (setf (slot-value (dom:notations result) 'read-only-p) t)
+    result))
 
 (defmethod dom:create-document
     ((factory (eql 'implementation)) uri qname doctype)
@@ -1422,6 +1425,42 @@
   (let ((*clone-not-import* t))
     (dom:import-node (dom:owner-document node) node deep)))
 
+;; extension:
+(defmethod dom:clone-node ((node document) deep)
+  (let* ((document (make-instance 'document))
+	 (original-doctype (dom:doctype node))
+	 (doctype 
+	  (when original-doctype
+	    (make-instance 'document-type
+	      :owner document
+	      :name (dom:name original-doctype)
+	      :public-id (dom:public-id original-doctype)
+	      :system-id (dom:system-id original-doctype)
+	      :notations (make-instance 'named-node-map
+			   :element-type :notation
+			   :owner document
+			   :items (dom:items (dom:notations original-doctype)))
+	      :entities (make-instance 'named-node-map
+			  :element-type :entity
+			  :owner document
+			  :items (dom:items
+				  (dom:entities original-doctype)))))))
+    (setf (slot-value document 'owner) nil)
+    (setf (slot-value document 'doc-type) doctype)
+    (setf (slot-value document 'dtd) (dtd node))
+    (setf (slot-value document 'entity-resolver)
+	  (slot-value node 'entity-resolver))
+    (setf (slot-value (dom:entities doctype) 'read-only-p) t)
+    (setf (slot-value (dom:notations doctype) 'read-only-p) t)
+    (when doctype
+      (setf (dom::%internal-subset doctype)
+	    (dom::%internal-subset original-doctype)))
+    (when (and (dom:document-element node) deep)
+      (let* ((*clone-not-import* t)
+	     (clone (dom:import-node document (dom:document-element node) t)))
+	(dom:append-child document clone)))
+    document))
+
 
 ;;; Erweiterung