From 6996b0635646a34fd918e89eab10cc7f4195d543 Mon Sep 17 00:00:00 2001
From: dlichteblau <dlichteblau>
Date: Sun, 20 Aug 2006 12:55:30 +0000
Subject: [PATCH] new feature: clone-node von document bugfix: entities und
 notations auch in create-document-type readonly

---
 README.html       |  3 +++
 dom/dom-impl.lisp | 41 ++++++++++++++++++++++++++++++++++++++++-
 2 files changed, 43 insertions(+), 1 deletion(-)

diff --git a/README.html b/README.html
index bcc917f..e566c1a 100644
--- a/README.html
+++ b/README.html
@@ -110,6 +110,9 @@
     <p class="nomargin"><tt>rel-2006-xx-yy</tt></p>
     <ul class="nomargin">
       <li>Serialization fixes (thanks to Nathan Bird, Donavon Keithley).</li>
+      <li>characters.lisp cleanup (thanks to Nathan Bird).</li>
+      <li>Minor changes: clone-node on document as an extension.  DOM
+      class hierarchy reworked.</li>
     </ul>
     <p class="nomargin"><tt>rel-2006-01-05</tt></p>
     <ul class="nomargin">
diff --git a/dom/dom-impl.lisp b/dom/dom-impl.lisp
index e2463f7..b86734c 100644
--- a/dom/dom-impl.lisp
+++ b/dom/dom-impl.lisp
@@ -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