[cxml-cvs] CVS update: cxml/xml/xml-parse.lisp

[David Lichteblau]

Update of /project/cxml/cvsroot/cxml/xml
In directory common-lisp.net:/tmp/cvs-serv30430/xml

Modified Files:
	xml-parse.lisp 
Log Message:
[WFC: No External Entity References]

Date: Sun Nov 27 17:09:19 2005
Author: dlichteblau

Index: cxml/xml/xml-parse.lisp
diff -u cxml/xml/xml-parse.lisp:1.29 cxml/xml/xml-parse.lisp:1.30
--- cxml/xml/xml-parse.lisp:1.29	Sun Nov 27 14:03:01 2005
+++ cxml/xml/xml-parse.lisp	Sun Nov 27 17:09:19 2005
@@ -642,9 +642,13 @@
 
 (define-condition xml-parse-error (simple-error) ())
 (define-condition well-formedness-violation (xml-parse-error) ())
-(define-condition end-of-xstream (well-formedness-violation) ())
 (define-condition validity-error (xml-parse-error) ())
 
+;; We make some effort to signal end of file as a special condition, but we
+;; don't actually try very hard.  Not sure whether we should.  Right now I
+;; would prefer not to document this class.
+(define-condition end-of-xstream (well-formedness-violation) ())
+
 (defun validity-error (x &rest args)
   (error 'validity-error
          :format-control "Document not valid: ~?"
@@ -901,13 +905,11 @@
                       (rod-string entity-name)))
     def))
 
-(defun entity->xstream (entity-name kind &optional zstream)
+(defun entity->xstream (zstream entity-name kind &optional internalp)
   ;; `zstream' is for error messages
   (let ((def (get-entity-definition entity-name kind (dtd *ctx*))))
     (unless def
-      (if zstream
-          (perror zstream "Entity '~A' is not defined." (rod-string entity-name))
-        (wf-error "Entity '~A' is not defined." (rod-string entity-name))))
+      (perror zstream "Entity '~A' is not defined." (rod-string entity-name)))
     (let (r)
       (etypecase def
         (internal-entdef
@@ -917,6 +919,8 @@
                              :entity-kind kind
                              :uri nil)))
         (external-entdef
+         (when internalp
+	   (wf-error "entity not internal: ~A" (rod-string entity-name)))
          (setf r (xstream-open-extid (extid-using-catalog (entdef-extid def))))
          (setf (stream-name-entity-name (xstream-name r)) entity-name
                (stream-name-entity-kind (xstream-name r)) kind)))
@@ -941,9 +945,9 @@
                   :name (make-stream-name :uri sysid)
                   :initial-speed 1)))
 
-(defun call-with-entity-expansion-as-stream (zstream cont name kind)
-  ;; `zstream' is for error messages -- we need something better!
-  (let ((in (entity->xstream name kind zstream)))
+(defun call-with-entity-expansion-as-stream (zstream cont name kind internalp)
+  ;; `zstream' is for error messages
+  (let ((in (entity->xstream zstream name kind internalp)))
     (unwind-protect
         (funcall cont in)
       (close-xstream in))))
@@ -1234,7 +1238,7 @@
     (check-rune input #/\; (read-rune input))
     (cond (*expand-pe-p*
            ;; no external entities here!
-           (let ((i2 (entity->xstream nam :parameter)))
+           (let ((i2 (entity->xstream  zinput nam :parameter)))
              (zstream-push i2 zinput))
            (values :S nil) ;space before inserted PE expansion.
            )
@@ -1443,7 +1447,8 @@
                                        zinput name :general
                                        (lambda (zinput)
                                          (muffle (car (zstream-input-stack zinput))
-                                                 :eof))))
+                                                 :eof))
+				       t))
                                      (:ENT
                                       ;; bypass, but never the less we
                                       ;; need to check for legal
@@ -3052,10 +3057,8 @@
   (push new-xstream (zstream-input-stack zstream))
   zstream)
 
-(defun recurse-on-entity (zstream name kind continuation)
+(defun recurse-on-entity (zstream name kind continuation &optional internalp)
   (assert (not (zstream-token-category zstream)))
-  ;;(sleep .2)
-  ;;(warn "~S / ~S[~S]." (zstream-input-stack zstream) (mu name) kind)
   (call-with-entity-expansion-as-stream
    zstream
    (lambda (new-xstream)
@@ -3069,7 +3072,9 @@
        (assert (eq (pop (zstream-input-stack zstream)) :stop))
        (setf (zstream-token-category zstream) nil)
        '(consume-token zstream)) )
-   name kind))
+   name
+   kind
+   internalp))
 
 #||
 (defmacro read-data-until* ((predicate input res res-start res-end) &body body)