Update of /project/cxml/cvsroot/cxml/xml In directory clnet:/tmp/cvs-serv20513/xml
Modified Files: package.lisp unparse.lisp xml-parse.lisp Log Message: SCL support (thanks to Douglas Crosher). Includes support for implementations where URIs are valid namestrings, and a mode where normal streams are used instead of xstreams and ystreams (albeit both SCL-specific at this point).
--- /project/cxml/cvsroot/cxml/xml/package.lisp 2007/05/01 20:07:00 1.16 +++ /project/cxml/cvsroot/cxml/xml/package.lisp 2007/06/16 11:27:19 1.17 @@ -6,7 +6,7 @@ (in-package :cl-user)
(defpackage :cxml - (:use :cl :runes :runes-encoding :trivial-gray-streams) + (:use :cl :runes :runes-encoding #-scl :trivial-gray-streams) (:export ;; xstreams #:make-xstream --- /project/cxml/cvsroot/cxml/xml/unparse.lisp 2007/06/16 10:02:43 1.15 +++ /project/cxml/cvsroot/cxml/xml/unparse.lisp 2007/06/16 11:27:19 1.16 @@ -619,16 +619,3 @@ (maybe-emit-start-tag) (sax:characters *sink* (rod data)) data) - -(defun rod-to-utf8-string (rod) - (let ((out (make-buffer :element-type 'character))) - (runes-to-utf8/adjustable-string out rod (length rod)) - out)) - -(defun utf8-string-to-rod (str) - (let* ((bytes (map '(vector (unsigned-byte 8)) #'char-code str)) - (buffer (make-array (length bytes) :element-type '(unsigned-byte 16))) - (n (decode-sequence :utf-8 bytes 0 (length bytes) buffer 0 0 nil)) - (result (make-array n :element-type 'rune))) - (map-into result #'code-rune buffer) - result)) --- /project/cxml/cvsroot/cxml/xml/xml-parse.lisp 2007/03/04 21:04:13 1.67 +++ /project/cxml/cvsroot/cxml/xml/xml-parse.lisp 2007/06/16 11:27:19 1.68 @@ -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) ,@body) + (make-zstream ,@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))
;;;; --------------------------------------------------------------------------- @@ -2957,6 +2973,7 @@ ;;;; --------------------------------------------------------------------------- ;;;; User interface ;;;;
+#-cxml-system::uri-is-namestring (defun specific-or (component &optional (alternative nil)) (if (eq component :unspecific) alternative @@ -2967,6 +2984,7 @@ alternative str))
+#-cxml-system::uri-is-namestring (defun make-uri (&rest initargs &key path query &allow-other-keys) (apply #'make-instance 'puri:uri @@ -2974,9 +2992,11 @@ :query (and query (escape-query query)) initargs))
+#-cxml-system::uri-is-namestring (defun escape-path (list) (puri::render-parsed-path list t))
+#-cxml-system::uri-is-namestring (defun escape-query (pairs) (flet ((escape (str) (puri::encode-escaped-encoding str puri::*reserved-characters* t))) @@ -2990,6 +3010,7 @@ (write-char #= s) (write-string (escape (cdr pair)) s))))))
+#-cxml-system::uri-is-namestring (defun uri-parsed-query (uri) (flet ((unescape (str) (puri::decode-escaped-encoding str t puri::*reserved-characters*))) @@ -3005,9 +3026,11 @@ (t nil)))))
+#-cxml-system::uri-is-namestring (defun query-value (name alist) (cdr (assoc name alist :test #'equal)))
+#-cxml-system::uri-is-namestring (defun pathname-to-uri (pathname) (let ((path (append (pathname-directory pathname) @@ -3027,6 +3050,11 @@ (specific-or (pathname-device pathname))) :path path))))
+#+cxml-system::uri-is-namestring +(defun pathname-to-uri (pathname) + (puri:parse-uri (namestring pathname))) + +#-cxml-system::uri-is-namestring (defun parse-name.type (str) (if str (let ((i (position #. str :from-end t))) @@ -3035,6 +3063,7 @@ (values str nil))) (values nil nil)))
+#-cxml-system::uri-is-namestring (defun uri-to-pathname (uri) (let ((scheme (puri:uri-scheme uri)) (path (puri:uri-parsed-path uri))) @@ -3058,11 +3087,17 @@ :directory (cons :absolute (butlast (cdr path))) :name name :type type)))))) +#+cxml-system::uri-is-namestring +(defun uri-to-pathname (uri) + (let ((pathname (puri:render-uri uri nil))) + (when (equalp (pathname-host pathname) "+") + (setf (slot-value pathname 'lisp::host) "localhost")) + pathname))
(defun parse-xstream (xstream handler &rest args) (let ((*ctx* nil)) (handler-case - (let ((zstream (make-zstream :input-stack (list xstream)))) + (with-zstream (zstream :input-stack (list xstream)) (peek-rune xstream) (with-scratch-pads () (apply #'p/document zstream handler args))) @@ -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))) @@ -3193,36 +3228,6 @@ (defun string->xstream (string) (make-rod-xstream (string-rod string)))
-(defclass octet-input-stream - (trivial-gray-stream-mixin fundamental-binary-input-stream) - ((octets :initarg :octets) - (pos :initform 0))) - -(defmethod close ((stream octet-input-stream) &key abort) - (declare (ignore abort)) - (open-stream-p stream)) -
[136 lines skipped]