[cxml-cvs] CVS cxml/xml
dlichteblau
dlichteblau at common-lisp.net
Sat Jun 16 11:27:20 UTC 2007
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) , 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))
;;;; ---------------------------------------------------------------------------
@@ -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]
More information about the Cxml-cvs
mailing list