[cxml-devel] Patch: close zstream input streams.
Douglas Crosher
dtc at scieneer.com
Wed Jun 13 05:04:55 EDT 2007
o with-zstream: new macro that ensures all the streams in the input stack
are closed even if parsing does not exit normally. Closing stream can also
allow resources to be reused.
-------------- next part --------------
o with-zstream: new macro that ensures all the streams in the input stack
are closed even if parsing does not exit normally. Closing streams can also
allow resources to be reused.
Index: xml/xml-parse.lisp
===================================================================
RCS file: /project/cxml/cvsroot/cxml/xml/xml-parse.lisp,v
retrieving revision 1.67
diff -u -r1.67 xml-parse.lisp
--- xml/xml-parse.lisp 4 Mar 2007 21:04:13 -0000 1.67
+++ xml/xml-parse.lisp 13 Jun 2007 08:15:07 -0000
@@ -1175,6 +1175,21 @@
token-semantic
input-stack)
+(defun call-with-zstream (fn zstream)
+ (unwind-protect
+ (funcall fn zstream)
+ (dolist (input (zstream-input-stack zstream))
+ (cond #-x&y-streams-are-stream
+ ((xstream-p input)
+ (close-xstream input))
+ #+x&y-streams-are-stream
+ ((streamp input)
+ (close input))))))
+
+(defmacro with-zstream ((zstream &rest args) &body body)
+ `(call-with-zstream (lambda (,zstream) , at body)
+ (make-zstream , at args)))
+
(defun read-token (input)
(cond ((zstream-token-category input)
(multiple-value-prog1
@@ -2545,15 +2560,15 @@
(setf (dtd *ctx*) cached-dtd)
(report-cached-dtd cached-dtd))
(t
- (let* ((xi2 (xstream-open-extid effective-extid))
- (zi2 (make-zstream :input-stack (list xi2))))
- (ensure-dtd)
- (p/ext-subset zi2)
- (when (and fresh-dtd-p
- *cache-all-dtds*
- *validate*
- (not (standalone-p *ctx*)))
- (setf (getdtd sysid *dtd-cache*) (dtd *ctx*))))))))
+ (let ((xi2 (xstream-open-extid effective-extid)))
+ (with-zstream (zi2 :input-stack (list xi2))
+ (ensure-dtd)
+ (p/ext-subset zi2)
+ (when (and fresh-dtd-p
+ *cache-all-dtds*
+ *validate*
+ (not (standalone-p *ctx*)))
+ (setf (getdtd sysid *dtd-cache*) (dtd *ctx*)))))))))
(sax:end-dtd (handler *ctx*))
(let ((dtd (dtd *ctx*)))
(sax:entity-resolver
@@ -2657,7 +2672,8 @@
:entity-name "dummy doctype"
:entity-kind :main
:uri (zstream-base-sysid input)))
- (p/doctype-decl (make-zstream :input-stack (list dummy)) dtd)))
+ (with-zstream (zstream :input-stack (list dummy))
+ (p/doctype-decl zstream dtd))))
(defun fix-seen-< (input)
(when (eq (peek-token input) :seen-<)
@@ -2841,106 +2857,106 @@
(defun parse-xml-decl (content)
(let* ((res (make-xml-header))
- (i (make-rod-xstream content))
- (z (make-zstream :input-stack (list i)))
- (atts (read-attribute-list z i t)))
- (unless (eq (peek-rune i) :eof)
- (wf-error i "Garbage at end of XMLDecl."))
- ;; versioninfo muss da sein
- ;; dann ? encodingdecl
- ;; dann ? sddecl
- ;; dann ende
- (unless (eq (caar atts) (intern-name '#.(string-rod "version")))
- (wf-error i "XMLDecl needs version."))
- (unless (and (>= (length (cdar atts)) 1)
- (every (lambda (x)
+ (i (make-rod-xstream content)))
+ (with-zstream (z :input-stack (list i))
+ (let ((atts (read-attribute-list z i t)))
+ (unless (eq (peek-rune i) :eof)
+ (wf-error i "Garbage at end of XMLDecl."))
+ ;; versioninfo muss da sein
+ ;; dann ? encodingdecl
+ ;; dann ? sddecl
+ ;; dann ende
+ (unless (eq (caar atts) (intern-name '#.(string-rod "version")))
+ (wf-error i "XMLDecl needs version."))
+ (unless (and (>= (length (cdar atts)) 1)
+ (every (lambda (x)
+ (or (rune<= #/a x #/z)
+ (rune<= #/A x #/Z)
+ (rune<= #/0 x #/9)
+ (rune= x #/_)
+ (rune= x #/.)
+ (rune= x #/:)
+ (rune= x #/-)))
+ (cdar atts)))
+ (wf-error i"Bad XML version number: ~S." (rod-string (cdar atts))))
+ (setf (xml-header-version res) (rod-string (cdar atts)))
+ (pop atts)
+ (when (eq (caar atts) (intern-name '#.(string-rod "encoding")))
+ (unless (and (>= (length (cdar atts)) 1)
+ (every (lambda (x)
+ (or (rune<= #/a x #/z)
+ (rune<= #/A x #/Z)
+ (rune<= #/0 x #/9)
+ (rune= x #/_)
+ (rune= x #/.)
+ (rune= x #/-)))
+ (cdar atts))
+ ((lambda (x)
(or (rune<= #/a x #/z)
- (rune<= #/A x #/Z)
- (rune<= #/0 x #/9)
- (rune= x #/_)
- (rune= x #/.)
- (rune= x #/:)
- (rune= x #/-)))
- (cdar atts)))
- (wf-error i"Bad XML version number: ~S." (rod-string (cdar atts))))
- (setf (xml-header-version res) (rod-string (cdar atts)))
- (pop atts)
- (when (eq (caar atts) (intern-name '#.(string-rod "encoding")))
- (unless (and (>= (length (cdar atts)) 1)
- (every (lambda (x)
- (or (rune<= #/a x #/z)
- (rune<= #/A x #/Z)
- (rune<= #/0 x #/9)
- (rune= x #/_)
- (rune= x #/.)
- (rune= x #/-)))
- (cdar atts))
- ((lambda (x)
- (or (rune<= #/a x #/z)
- (rune<= #/A x #/Z)))
- (aref (cdar atts) 0)))
- (wf-error i "Bad XML encoding name: ~S." (rod-string (cdar atts))))
- (setf (xml-header-encoding res) (rod-string (cdar atts)))
- (pop atts))
- (when (eq (caar atts) (intern-name '#.(string-rod "standalone")))
- (unless (or (rod= (cdar atts) '#.(string-rod "yes"))
- (rod= (cdar atts) '#.(string-rod "no")))
- (wf-error i "XMLDecl's 'standalone' attribute must be exactly \"yes\" or \"no\" and not ~S."
- (rod-string (cdar atts))))
- (setf (xml-header-standalone-p res)
- (if (rod-equal '#.(string-rod "yes") (cdar atts))
- :yes
- :no))
- (pop atts))
- (when atts
- (wf-error i "Garbage in XMLDecl: ~A" (rod-string content)))
- res))
+ (rune<= #/A x #/Z)))
+ (aref (cdar atts) 0)))
+ (wf-error i "Bad XML encoding name: ~S." (rod-string (cdar atts))))
+ (setf (xml-header-encoding res) (rod-string (cdar atts)))
+ (pop atts))
+ (when (eq (caar atts) (intern-name '#.(string-rod "standalone")))
+ (unless (or (rod= (cdar atts) '#.(string-rod "yes"))
+ (rod= (cdar atts) '#.(string-rod "no")))
+ (wf-error i "XMLDecl's 'standalone' attribute must be exactly \"yes\" or \"no\" and not ~S."
+ (rod-string (cdar atts))))
+ (setf (xml-header-standalone-p res)
+ (if (rod-equal '#.(string-rod "yes") (cdar atts))
+ :yes
+ :no))
+ (pop atts))
+ (when atts
+ (wf-error i "Garbage in XMLDecl: ~A" (rod-string content)))
+ res))))
(defun parse-text-decl (content)
(let* ((res (make-xml-header))
- (i (make-rod-xstream content))
- (z (make-zstream :input-stack (list i)))
- (atts (read-attribute-list z i t)))
- (unless (eq (peek-rune i) :eof)
- (wf-error i "Garbage at end of TextDecl"))
- ;; versioninfo optional
- ;; encodingdecl muss da sein
- ;; dann ende
- (when (eq (caar atts) (intern-name '#.(string-rod "version")))
- (unless (and (>= (length (cdar atts)) 1)
- (every (lambda (x)
- (or (rune<= #/a x #/z)
- (rune<= #/A x #/Z)
- (rune<= #/0 x #/9)
- (rune= x #/_)
- (rune= x #/.)
- (rune= x #/:)
- (rune= x #/-)))
- (cdar atts)))
- (wf-error i "Bad XML version number: ~S." (rod-string (cdar atts))))
- (setf (xml-header-version res) (rod-string (cdar atts)))
- (pop atts))
- (unless (eq (caar atts) (intern-name '#.(string-rod "encoding")))
- (wf-error i "TextDecl needs encoding."))
- (unless (and (>= (length (cdar atts)) 1)
- (every (lambda (x)
- (or (rune<= #/a x #/z)
- (rune<= #/A x #/Z)
- (rune<= #/0 x #/9)
- (rune= x #/_)
- (rune= x #/.)
- (rune= x #/-)))
- (cdar atts))
- ((lambda (x)
- (or (rune<= #/a x #/z)
- (rune<= #/A x #/Z)
- (rune<= #/0 x #/9)))
- (aref (cdar atts) 0)))
- (wf-error i "Bad XML encoding name: ~S." (rod-string (cdar atts))))
- (setf (xml-header-encoding res) (rod-string (cdar atts)))
- (pop atts)
- (when atts
- (wf-error i "Garbage in TextDecl: ~A" (rod-string content)))
+ (i (make-rod-xstream content)))
+ (with-zstream (z :input-stack (list i))
+ (let ((atts (read-attribute-list z i t)))
+ (unless (eq (peek-rune i) :eof)
+ (wf-error i "Garbage at end of TextDecl"))
+ ;; versioninfo optional
+ ;; encodingdecl muss da sein
+ ;; dann ende
+ (when (eq (caar atts) (intern-name '#.(string-rod "version")))
+ (unless (and (>= (length (cdar atts)) 1)
+ (every (lambda (x)
+ (or (rune<= #/a x #/z)
+ (rune<= #/A x #/Z)
+ (rune<= #/0 x #/9)
+ (rune= x #/_)
+ (rune= x #/.)
+ (rune= x #/:)
+ (rune= x #/-)))
+ (cdar atts)))
+ (wf-error i "Bad XML version number: ~S." (rod-string (cdar atts))))
+ (setf (xml-header-version res) (rod-string (cdar atts)))
+ (pop atts))
+ (unless (eq (caar atts) (intern-name '#.(string-rod "encoding")))
+ (wf-error i "TextDecl needs encoding."))
+ (unless (and (>= (length (cdar atts)) 1)
+ (every (lambda (x)
+ (or (rune<= #/a x #/z)
+ (rune<= #/A x #/Z)
+ (rune<= #/0 x #/9)
+ (rune= x #/_)
+ (rune= x #/.)
+ (rune= x #/-)))
+ (cdar atts))
+ ((lambda (x)
+ (or (rune<= #/a x #/z)
+ (rune<= #/A x #/Z)
+ (rune<= #/0 x #/9)))
+ (aref (cdar atts) 0)))
+ (wf-error i "Bad XML encoding name: ~S." (rod-string (cdar atts))))
+ (setf (xml-header-encoding res) (rod-string (cdar atts)))
+ (pop atts)
+ (when atts
+ (wf-error i "Garbage in TextDecl: ~A" (rod-string content)))))
res))
;;;; ---------------------------------------------------------------------------
@@ -3129,10 +3164,10 @@
(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)))))
+ (let ((xi2 (xstream-open-extid extid)))
+ (with-zstream (zi2 :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)))
@@ -3171,15 +3206,15 @@
:entity-name "dtd"
:entity-kind :main
:uri (safe-stream-sysid stream)))
- (let ((zstream (make-zstream :input-stack (list input)))
- (*ctx* (make-context :handler handler))
+ (let ((*ctx* (make-context :handler handler))
(*validate* t)
(*data-behaviour* :DTD))
- (with-scratch-pads ()
- (ensure-dtd)
- (peek-rune input)
- (p/ext-subset zstream)
- (dtd *ctx*)))))
+ (with-zstream (zstream :input-stack (list input))
+ (with-scratch-pads ()
+ (ensure-dtd)
+ (peek-rune input)
+ (p/ext-subset zstream)
+ (dtd *ctx*))))))
(defun parse-rod (string handler &rest args)
(let ((xstream (string->xstream string)))
@@ -3389,63 +3431,63 @@
;; used only by read-att-value-2
(defun find-internal-entity-expansion (name)
- (let ((zinput (make-zstream)))
+ (with-zstream (zinput)
(with-rune-collector-3 (collect)
(labels ((muffle (input)
- (let (c)
- (loop
- (setf c (read-rune input))
- (cond ((eq c :eof)
- (return))
- ((rune= c #/&)
- (setf c (peek-rune input))
- (cond ((eql c :eof)
- (eox input))
- ((rune= c #/#)
- (let ((c (read-character-reference input)))
- (%put-unicode-char c collect)))
- (t
- (unless (name-start-rune-p c)
- (wf-error zinput "Expecting name after &."))
- (let ((name (read-name-token input)))
- (setf c (read-rune input))
- (check-rune input c #/\;)
- (recurse-on-entity
- zinput name :general
- (lambda (zinput)
- (muffle (car (zstream-input-stack zinput)))))))))
- ((rune= c #/<)
- (wf-error zinput "unexpected #\/<"))
- ((space-rune-p c)
- (collect #/space))
- ((not (data-rune-p c))
- (wf-error zinput "illegal char: ~S." c))
- (t
- (collect c)))))))
- (declare (dynamic-extent #'muffle))
- (recurse-on-entity
- zinput name :general
- (lambda (zinput)
- (muffle (car (zstream-input-stack zinput))))) ))))
+ (let (c)
+ (loop
+ (setf c (read-rune input))
+ (cond ((eq c :eof)
+ (return))
+ ((rune= c #/&)
+ (setf c (peek-rune input))
+ (cond ((eql c :eof)
+ (eox input))
+ ((rune= c #/#)
+ (let ((c (read-character-reference input)))
+ (%put-unicode-char c collect)))
+ (t
+ (unless (name-start-rune-p c)
+ (wf-error zinput "Expecting name after &."))
+ (let ((name (read-name-token input)))
+ (setf c (read-rune input))
+ (check-rune input c #/\;)
+ (recurse-on-entity
+ zinput name :general
+ (lambda (zinput)
+ (muffle (car (zstream-input-stack zinput)))))))))
+ ((rune= c #/<)
+ (wf-error zinput "unexpected #\/<"))
+ ((space-rune-p c)
+ (collect #/space))
+ ((not (data-rune-p c))
+ (wf-error zinput "illegal char: ~S." c))
+ (t
+ (collect c)))))))
+ (declare (dynamic-extent #'muffle))
+ (recurse-on-entity
+ zinput name :general
+ (lambda (zinput)
+ (muffle (car (zstream-input-stack zinput)))))))))
;; callback for DOM
(defun resolve-entity (name handler dtd)
(let ((*validate* nil))
(if (get-entity-definition name :general dtd)
(let* ((*ctx* (make-context :handler handler :dtd dtd))
- (input (make-zstream))
(*data-behaviour* :DOC))
- (with-scratch-pads ()
- (recurse-on-entity
- input name :general
- (lambda (input)
- (prog1
- (etypecase (checked-get-entdef name :general)
- (internal-entdef (p/content input))
- (external-entdef (p/ext-parsed-ent input)))
- (unless (eq (peek-token input) :eof)
- (wf-error input "Trailing garbage. - ~S"
- (peek-token input))))))))
+ (with-zstream (input)
+ (with-scratch-pads ()
+ (recurse-on-entity
+ input name :general
+ (lambda (input)
+ (prog1
+ (etypecase (checked-get-entdef name :general)
+ (internal-entdef (p/content input))
+ (external-entdef (p/ext-parsed-ent input)))
+ (unless (eq (peek-token input) :eof)
+ (wf-error input "Trailing garbage. - ~S"
+ (peek-token input)))))))))
nil)))
(defun read-att-value-2 (input)
More information about the cxml-devel
mailing list