[cxml-cvs] CVS cxml/dom

[dlichteblau]

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

Modified Files:
	dom-builder.lisp dom-impl.lisp 
Log Message:
Grow a buffer for string normalization exponentially.

	* dom/dom-builder.lisp (DOM-BUILDER): New slot `text-buffer'.
	(SAX:START-ELEMENT, SAX:END-ELEMENT, SAX:START-CDATA,
	SAX:END-CDATA, SAX:PROCESSING-INSTRUCTION, SAX:COMMENT): Call
	flush-characters.  (SAX:CHARACTERS): Rewritten.
	(FLUSH-CHARACTERS): New, based on the old sax:characters.

	* dom/dom-impl.lisp ((initialize-instance :after entity-reference)):
	Call flush-characters.


--- /project/cxml/cvsroot/cxml/dom/dom-builder.lisp	2007/07/22 19:59:26	1.13
+++ /project/cxml/cvsroot/cxml/dom/dom-builder.lisp	2007/10/03 15:17:08	1.14
@@ -18,7 +18,8 @@
 (defclass dom-builder ()
   ((document      :initform nil :accessor document)
    (element-stack :initform '() :accessor element-stack)
-   (internal-subset             :accessor internal-subset)))
+   (internal-subset             :accessor internal-subset)
+   (text-buffer   :initform nil :accessor text-buffer)))
 
 (defun make-dom-builder ()
   (make-instance 'dom-builder))
@@ -87,6 +88,7 @@
 (defmethod sax:start-element
     ((handler dom-builder) namespace-uri local-name qname attributes)
   (check-type qname rod)		;catch recoder/builder mismatch
+  (flush-characters handler)
   (with-slots (document element-stack) handler
     (let* ((nsp sax:*namespace-processing*)
 	   (element (make-instance 'element 
@@ -126,27 +128,45 @@
 
 (defmethod sax:end-element ((handler dom-builder) namespace-uri local-name qname)
   (declare (ignore namespace-uri local-name qname))
+  (flush-characters handler)
   (pop (element-stack handler)))
 
 (defmethod sax:characters ((handler dom-builder) data)
-  (with-slots (document element-stack) handler
-    (let* ((parent (car element-stack))
-           (last-child (dom:last-child parent)))
-      (cond
-        ((eq (dom:node-type parent) :cdata-section)
-          (setf (dom:data parent) data))
-	((and last-child (eq (dom:node-type last-child) :text))
-          ;; um entities herum wird SAX:CHARACTERS mehrfach aufgerufen fuer
-          ;; den gleichen Textknoten.  Hier muessen wir den bestehenden Knoten
-          ;; erweitern, sonst ist das Dokument nicht normalisiert.
-          ;; (XXX Oder sollte man besser den Parser entsprechend aendern?)
-          (dom:append-data last-child data))
-        (t
-          (let ((node (dom:create-text-node document data)))
-            (setf (slot-value node 'parent) parent)
-            (fast-push node (slot-value (car element-stack) 'children))))))))
+  (with-slots (text-buffer) handler
+    (cond
+      ((null text-buffer)
+       (setf text-buffer data))
+      (t
+       (unless (array-has-fill-pointer-p text-buffer)
+	 (setf text-buffer (make-array (length text-buffer)
+				       :element-type 'rune
+				       :adjustable t
+				       :fill-pointer t
+				       :initial-contents text-buffer)))
+       (let ((n (length text-buffer))
+	     (m (length data)))
+	 (adjust-vector-exponentially text-buffer (+ n m) t)
+	 (move data text-buffer 0 n m))))))
+
+(defun flush-characters (handler)
+  (with-slots (document element-stack text-buffer) handler
+    (let ((data text-buffer))
+      (when data
+	(when (array-has-fill-pointer-p data)
+	  (setf data
+		(make-array (length data)
+			    :element-type 'rune
+			    :initial-contents data)))
+	(let ((parent (car element-stack)))
+	  (if (eq (dom:node-type parent) :cdata-section)
+	      (setf (dom:data parent) data)
+	      (let ((node (dom:create-text-node document data)))
+		(setf (slot-value node 'parent) parent)
+		(fast-push node (slot-value (car element-stack) 'children)))))
+	(setf text-buffer nil)))))
 
 (defmethod sax:start-cdata ((handler dom-builder))
+  (flush-characters handler)
   (with-slots (document element-stack) handler
     (let ((node (dom:create-cdata-section document #""))
           (parent (car element-stack)))
@@ -155,10 +175,12 @@
       (push node element-stack))))
 
 (defmethod sax:end-cdata ((handler dom-builder))
+  (flush-characters handler)
   (let ((node (pop (slot-value handler 'element-stack))))
     (assert (eq (dom:node-type node) :cdata-section))))
 
 (defmethod sax:processing-instruction ((handler dom-builder) target data)
+  (flush-characters handler)
   (with-slots (document element-stack) handler
     (let ((node (dom:create-processing-instruction document target data))
           (parent (car element-stack)))
@@ -166,6 +188,7 @@
       (fast-push node (slot-value (car element-stack) 'children)))))
 
 (defmethod sax:comment ((handler dom-builder) data)
+  (flush-characters handler)
   (with-slots (document element-stack) handler
     (let ((node (dom:create-comment document data))
           (parent (car element-stack)))
--- /project/cxml/cvsroot/cxml/dom/dom-impl.lisp	2006/09/10 14:52:44	1.42
+++ /project/cxml/cvsroot/cxml/dom/dom-impl.lisp	2007/10/03 15:17:08	1.43
@@ -1247,7 +1247,8 @@
       (push instance (element-stack handler))
       #+cxml-system::utf8dom-file
       (setf handler (cxml:make-recoder handler #'cxml:rod-to-utf8-string))
-      (funcall resolver (real-rod (dom:name instance)) handler)))
+      (funcall resolver (real-rod (dom:name instance)) handler)
+      (flush-characters handler)))
   (labels ((walk (n)
              (setf (slot-value n 'read-only-p) t)
              (when (dom:element-p n)