From 111b5db45ad75a0cb2bf09d717445f501ed6fd95 Mon Sep 17 00:00:00 2001
From: dlichteblau <dlichteblau>
Date: Sun, 20 Aug 2006 13:58:30 +0000
Subject: [PATCH] new function parse-empty-document

---
 README.html        |  2 +-
 doc/using.html     | 12 ++++++++++
 xml/package.lisp   |  1 +
 xml/xml-parse.lisp | 58 ++++++++++++++++++++++++++++++++++++++++++++++
 4 files changed, 72 insertions(+), 1 deletion(-)

diff --git a/README.html b/README.html
index e566c1a..7cf434a 100644
--- a/README.html
+++ b/README.html
@@ -112,7 +112,7 @@
       <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>
+      class hierarchy reworked.  New function parse-empty-document.</li>
     </ul>
     <p class="nomargin"><tt>rel-2006-01-05</tt></p>
     <ul class="nomargin">
diff --git a/doc/using.html b/doc/using.html
index 015f52a..9b4d47b 100644
--- a/doc/using.html
+++ b/doc/using.html
@@ -132,6 +132,18 @@
       specified in the XML declaration, if any.
     </p>
 
+    <p>
+      <div class="def">Function CXML:PARSE-FILE (uri qname handler &key public-id system-id entity-resolver recode)</div>
+    </p>
+    <p>
+      Simulate parsing a document with a document element <tt>qname</tt>
+      having no attributes except for an optional namespace
+      declaration to <tt>uri</tt>.  If an external ID is specified
+      (<tt>system-id</tt>, <tt>public-id</tt>), find, parse, and report
+      this DTD as if with <tt>parse-file</tt>, using the specified
+      entity resolver.
+    </p>
+
     <p>
       <div class="def">Function CXML:PARSE-DTD-FILE (pathname)</div>
       <div class="def">Function CXML:PARSE-DTD-STREAM (stream)</div>
diff --git a/xml/package.lisp b/xml/package.lisp
index c3b358c..15da41e 100644
--- a/xml/package.lisp
+++ b/xml/package.lisp
@@ -36,6 +36,7 @@
    #:parse-stream
    #:parse-rod
    #:parse-octets
+   #:parse-empty-document
 
    #:make-octet-vector-sink
    #:make-octet-stream-sink
diff --git a/xml/xml-parse.lisp b/xml/xml-parse.lisp
index 91d045c..74ea7ed 100644
--- a/xml/xml-parse.lisp
+++ b/xml/xml-parse.lisp
@@ -3005,6 +3005,64 @@
           :initial-speed 1)))
     (apply #'parse-xstream xstream handler args)))
 
+(defun parse-empty-document
+    (uri qname handler &key public-id system-id entity-resolver (recode t))
+  (check-type uri (or null rod))
+  (check-type qname (or null rod))
+  (check-type public-id (or null rod))
+  (check-type system-id (or null puri:uri))
+  (check-type entity-resolver (or null function symbol))
+  (check-type recode boolean)
+  #+rune-is-integer
+  (when recode
+    (setf handler (make-recoder handler #'rod-to-utf8-string)))
+  (let ((*ctx*
+         (make-context :handler handler :entity-resolver entity-resolver))
+        (*validate* nil)
+	(extid
+	 (when (or public-id system-id)
+	   (extid-using-catalog (make-extid public-id system-id)))))
+    (sax:start-document handler)
+    (when extid
+      (sax:start-dtd handler
+                     qname
+                     (and public-id)
+                     (and system-id (uri-rod system-id)))
+      (setf (dtd *ctx*) (getdtd (extid-system extid) *dtd-cache*))
+      (unless (dtd *ctx*)
+	(with-scratch-pads ()
+	  (let ((*data-behaviour* :DTD))
+	    (let* ((xi2 (xstream-open-extid extid))
+		   (zi2 (make-zstream :input-stack (list xi2))))
+	      (ensure-dtd)
+	      (p/ext-subset zi2)))))
+      (sax:end-dtd handler)
+      (let ((dtd (dtd *ctx*)))
+        (sax:entity-resolver handler (lambda (n h) (resolve-entity n h dtd)))
+        (sax::dtd handler dtd)))
+    (ensure-dtd)
+    (when (or uri qname)
+      (let* ((attrs
+	      (when uri
+		(list (sax:make-attribute :qname #"xmlns"
+					  :value (rod uri)
+					  :specified-p t))))
+	     (*namespace-bindings* *namespace-bindings*)
+	     new-namespaces)
+	(when sax:*namespace-processing*
+	  (setf new-namespaces (declare-namespaces attrs))
+	  (mapc #'set-attribute-namespace attrs))
+	(multiple-value-bind (uri prefix local-name)
+	    (if sax:*namespace-processing* (decode-qname qname) nil)
+	  (declare (ignore prefix))
+	  (unless (or sax:*include-xmlns-attributes*
+		      (null sax:*namespace-processing*))
+	    (setf attrs nil)) 
+	  (sax:start-element (handler *ctx*) uri local-name qname attrs)
+	  (sax:end-element (handler *ctx*) uri local-name qname))
+	(undeclare-namespaces new-namespaces)))
+    (sax:end-document handler)))
+
 (defun parse-dtd-file (filename &optional handler)
   (with-open-file (s filename :element-type '(unsigned-byte 8))
     (parse-dtd-stream s handler)))