June 2007 - cxml-devel - mailman3.common-lisp.net

[cxml-devel] Patch: casing down some code.
by Marco Monteiro 27 Jun '07

27 Jun '07

The attached patch changes the case of some code that prevents cxml to be used in 'modern mode' Lisp implementations. Please apply. Thanks, Marco

2 1

[cxml-devel] Patch: Support for the Scieneer CL.
by Douglas Crosher 17 Jun '07

17 Jun '07

o Add support for the Scieneer CL. The Scieneer CL has a very fast stream implementation which is comparable in performance to the runes implementation so CXML on the SCL can use CL streams rather than xstreams and ystreams - enabled via the :x&y-streams-are-stream feature. This also enables support for a wider range of encodings. The Scieneer CL also supports http and https URLs for pathnames so can open such external files without the need for an entity resolver. Regards Douglas Crosher o Add support for the Scieneer CL. ? runes/stream-scl.lisp Index: cxml.asd =================================================================== RCS file: /project/cxml/cvsroot/cxml/cxml.asd,v retrieving revision 1.18 diff -u -r1.18 cxml.asd --- cxml.asd 26 May 2007 21:55:57 -0000 1.18 +++ cxml.asd 13 Jun 2007 08:15:02 -0000 @@ -30,7 +30,7 @@ (:file "space-normalizer" :depends-on ("xml-parse")) (:file "catalog" :depends-on ("xml-parse")) (:file "sax-proxy" :depends-on ("xml-parse"))) - :depends-on (:runes :puri :trivial-gray-streams)) + :depends-on (:runes :puri #-scl :trivial-gray-streams)) (defclass utf8dom-file (closure-source-file) ((of))) Index: runes.asd =================================================================== RCS file: /project/cxml/cvsroot/cxml/runes.asd,v retrieving revision 1.1 diff -u -r1.1 runes.asd --- runes.asd 26 May 2007 22:05:13 -0000 1.1 +++ runes.asd 13 Jun 2007 08:15:03 -0000 @@ -52,7 +52,9 @@ #+rune-is-character "characters") #+rune-is-integer (:file "utf8") (:file "syntax") - (:file "encodings") - (:file "encodings-data") - (:file "xstream") - (:file "ystream"))) + #-x&y-streams-are-stream (:file "encodings") + #-x&y-streams-are-stream (:file "encodings-data") + #-x&y-streams-are-stream (:file "xstream") + #-x&y-streams-are-stream (:file "ystream") + #+x&y-streams-are-stream (:file #+scl "stream-scl") + )) Index: xml/package.lisp =================================================================== RCS file: /project/cxml/cvsroot/cxml/xml/package.lisp,v retrieving revision 1.16 diff -u -r1.16 package.lisp --- xml/package.lisp 1 May 2007 20:07:00 -0000 1.16 +++ xml/package.lisp 13 Jun 2007 08:15:04 -0000 @@ -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 Index: xml/unparse.lisp =================================================================== RCS file: /project/cxml/cvsroot/cxml/xml/unparse.lisp,v retrieving revision 1.13 diff -u -r1.13 unparse.lisp --- xml/unparse.lisp 1 May 2007 20:07:00 -0000 1.13 +++ xml/unparse.lisp 13 Jun 2007 08:15:04 -0000 @@ -621,14 +621,22 @@ data) (defun rod-to-utf8-string (rod) + #-scl (let ((out (make-buffer :element-type 'character))) (runes-to-utf8/adjustable-string out rod (length rod)) - out)) + out) + #+scl + (ext:make-string-from-bytes (ext:make-bytes-from-string rod :utf8) + :iso-8859-1)) (defun utf8-string-to-rod (str) + #-scl (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)) + result) + #+scl + (let ((bytes (map '(vector (unsigned-byte 8)) #'char-code str))) + (ext:make-string-from-bytes bytes :utf-8))) 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 @@ -2957,6 +2973,7 @@ ;;;; --------------------------------------------------------------------------- ;;;; User interface ;;;; +#-scl (defun specific-or (component &optional (alternative nil)) (if (eq component :unspecific) alternative @@ -2967,6 +2984,7 @@ alternative str)) +#-scl (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)) +#-scl (defun escape-path (list) (puri::render-parsed-path list t)) +#-scl (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)))))) +#-scl (defun uri-parsed-query (uri) (flet ((unescape (str) (puri::decode-escaped-encoding str t puri::*reserved-characters*))) @@ -3005,9 +3026,11 @@ (t nil))))) +#-scl (defun query-value (name alist) (cdr (assoc name alist :test #'equal))) +#-scl (defun pathname-to-uri (pathname) (let ((path (append (pathname-directory pathname) @@ -3027,6 +3050,11 @@ (specific-or (pathname-device pathname))) :path path)))) +#+scl +(defun pathname-to-uri (pathname) + (puri:parse-uri (namestring pathname))) + +#-scl (defun parse-name.type (str) (if str (let ((i (position #\. str :from-end t))) @@ -3035,6 +3063,7 @@ (values str nil))) (values nil nil))) +#-scl (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)))))) +#+scl +(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))) @@ -3193,15 +3228,18 @@ (defun string->xstream (string) (make-rod-xstream (string-rod string))) +#-scl (defclass octet-input-stream (trivial-gray-stream-mixin fundamental-binary-input-stream) ((octets :initarg :octets) (pos :initform 0))) +#-scl (defmethod close ((stream octet-input-stream) &key abort) (declare (ignore abort)) (open-stream-p stream)) +#-scl (defmethod stream-read-byte ((stream octet-input-stream)) (with-slots (octets pos) stream (if (>= pos (length octets)) @@ -3210,6 +3248,7 @@ (elt octets pos) (incf pos))))) +#-scl (defmethod stream-read-sequence ((stream octet-input-stream) sequence start end &key &allow-other-keys) (with-slots (octets pos) stream @@ -3221,7 +3260,10 @@ end1))) (defun make-octet-input-stream (octets) - (make-instance 'octet-input-stream :octets octets)) + #-scl + (make-instance 'octet-input-stream :octets octets) + #+scl + (ext:make-byte-input-stream octets)) (defun parse-octets (octets handler &rest args) (apply #'parse-stream (make-octet-input-stream octets) handler args)) ;;; -*- Mode: Lisp; Syntax: Common-Lisp; readtable: runes; Encoding: utf-8; -*- ;;; --------------------------------------------------------------------------- ;;; Title: Fast streams ;;; Created: 1999-07-17 ;;; Author: Douglas Crosher ;;; License: Lisp-LGPL (See file COPYING for details). ;;; --------------------------------------------------------------------------- ;;; (c) copyright 2007 by Douglas Crosher ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. (in-package :runes) (eval-when (:compile-toplevel :load-toplevel :execute) (defparameter *fast* '(optimize (speed 3) (safety 3)))) (deftype runes-encoding:encoding-error () 'ext:character-conversion-error) ;;; xstream (eval-when (:compile-toplevel :load-toplevel :execute) (defclass xstream (ext:character-stream) ((name :initarg :name :initform nil :accessor xstream-name) (column :initarg :column :initform 0) (line :initarg :line :initform 1) (unread-column :initarg :unread-column :initform 0))) (defclass eol-conversion-xstream (lisp::eol-conversion-input-stream xstream) ()) ) ; eval-when (defun make-eol-conversion-xstream (source-stream) "Returns a character stream that conversion CR-LF pairs and lone CR characters into single linefeed character." (declare (type stream source-stream)) (let ((stream (ext:make-eol-conversion-stream source-stream :input t :close-stream-p t))) (change-class stream 'eol-conversion-xstream))) (definline xstream-p (stream) (typep stream 'xstream)) (defun close-xstream (input) (close input)) (definline read-rune (input) (declare (type stream input) (inline read-char) #.*fast*) (let ((char (read-char input nil :eof))) (cond ((member char '(#\UFFFE #\UFFFF)) ;; These characters are illegal within XML documents. (simple-error 'ext:character-conversion-error "~@<Illegal XML document character: ~S~:@>" char)) ((eql char #\linefeed) (setf (slot-value input 'unread-column) (slot-value input 'column)) (setf (slot-value input 'column) 0) (incf (the kernel:index (slot-value input 'line)))) (t (incf (the kernel:index (slot-value input 'column))))) char)) (definline peek-rune (input) (declare (type stream input) (inline peek-char) #.*fast*) (peek-char nil input nil :eof)) (definline consume-rune (input) (declare (type stream input) (inline read-rune) #.*fast*) (read-rune input) nil) (definline unread-rune (rune input) (declare (type stream input) (inline unread-char) #.*fast*) (unread-char rune input) (cond ((eql rune #\linefeed) (setf (slot-value input 'column) (slot-value input 'unread-column)) (setf (slot-value input 'unread-column) 0) (decf (the kernel:index (slot-value input 'line)))) (t (decf (the kernel:index (slot-value input 'column))))) nil) (defun fread-rune (input) (read-rune input)) (defun fpeek-rune (input) (peek-rune input)) (defun xstream-position (input) (file-position input)) (defun runes-encoding:find-encoding (encoding) encoding) (defun make-xstream (os-stream &key name (speed 8192) (initial-speed 1) (initial-encoding :guess)) (declare (ignore speed)) (assert (eql initial-speed 1)) (assert (eq initial-encoding :guess)) (let* ((stream (ext:make-xml-character-conversion-stream os-stream :input t :close-stream-p t)) (xstream (make-eol-conversion-xstream stream))) (setf (xstream-name xstream) name) xstream)) (defclass xstream-string-input-stream (lisp::string-input-stream xstream) ()) (defun make-rod-xstream (string &key name) (declare (type string string)) (let ((stream (make-string-input-stream string))) (change-class stream 'xstream-string-input-stream :name name))) ;;; already at 'full speed' so just return the buffer size. (defun set-to-full-speed (stream) (length (ext:stream-in-buffer stream))) (defun xstream-speed (stream) (length (ext:stream-in-buffer stream))) (defun xstream-line-number (stream) (slot-value stream 'line)) (defun xstream-column-number (stream) (slot-value stream 'column)) (defun xstream-encoding (stream) (stream-external-format stream)) ;;; the encoding will have already been detected, but it is checked against the ;;; declared encoding here. (defun (setf xstream-encoding) (declared-encoding stream) (let* ((initial-encoding (xstream-encoding stream)) (canonical-encoding (cond ((and (eq initial-encoding :utf-16le) (member declared-encoding '(:utf-16 :utf16 :utf-16le :utf16le) :test 'string-equal)) :utf-16le) ((and (eq initial-encoding :utf-16be) (member declared-encoding '(:utf-16 :utf16 :utf-16be :utf16be) :test 'string-equal)) :utf-16be) ((and (eq initial-encoding :ucs-4be) (member declared-encoding '(:ucs-4 :ucs4 :ucs-4be :ucs4be) :test 'string-equal)) :ucs4-be) ((and (eq initial-encoding :ucs-4le) (member declared-encoding '(:ucs-4 :ucs4 :ucs-4le :ucs4le) :test 'string-equal)) :ucs4-le) (t declared-encoding)))) (unless (string-equal initial-encoding canonical-encoding) (warn "Unable to change xstream encoding from ~S to ~S (~S)~%" initial-encoding declared-encoding canonical-encoding)) declared-encoding)) ;;; ystream - a run output stream. (deftype ystream () 'stream) (defun ystream-column (stream) (ext:line-column stream)) (definline write-rune (rune stream) (declare (inline write-char)) (write-char rune stream)) (defun write-rod (rod stream) (declare (type rod rod) (type stream stream)) (write-string rod stream)) (defun make-rod-ystream () (make-string-output-stream)) (defun close-ystream (stream) (etypecase stream (ext:string-output-stream (get-output-stream-string stream)) (ext:character-conversion-output-stream (let ((target (slot-value stream 'stream))) (close stream) (if (typep target 'ext:byte-output-stream) (ext:get-output-stream-bytes target) stream))))) ;;;; CHARACTER-STREAM-YSTREAM (defun make-character-stream-ystream (target-stream) target-stream) ;;;; OCTET-VECTOR-YSTREAM (defun make-octet-vector-ystream () (let ((target (ext:make-byte-output-stream))) (ext:make-character-conversion-stream target :output t :external-format :utf-8 :close-stream-p t))) ;;;; OCTET-STREAM-YSTREAM (defun make-octet-stream-ystream (os-stream) (ext:make-character-conversion-stream os-stream :output t :external-format :utf-8 :close-stream-p t))

2 2

[cxml-devel] Patch: Add XMLS support for including the namespace URI in the element and attribute names.
by Douglas Crosher 17 Jun '07

17 Jun '07

o Add support for including the namespace URI in the element and attribute names. o Add support for including the namespace URI in the element and attribute names. Index: xml/xmls-compat.lisp =================================================================== RCS file: /project/cxml/cvsroot/cxml/xml/xmls-compat.lisp,v retrieving revision 1.3 diff -u -r1.3 xmls-compat.lisp --- xml/xmls-compat.lisp 15 May 2006 21:57:47 -0000 1.3 +++ xml/xmls-compat.lisp 13 Jun 2007 08:15:07 -0000 @@ -69,32 +69,56 @@ (root :initform nil :accessor root) (include-default-values :initform t :initarg :include-default-values - :accessor include-default-values))) - -(defun make-xmls-builder (&key (include-default-values t)) - (make-instance 'xmls-builder :include-default-values include-default-values)) + :accessor include-default-values) + (include-namespace-uri :initform nil + :initarg :include-namespace-uri + :accessor include-namespace-uri))) + +(defun make-xmls-builder (&key (include-default-values t) + (include-namespace-uri nil)) + "Make a XMLS style builder. When 'include-namespace-uri is true a modified + XMLS tree is generated that includes the element namespace URI rather than + the qualified name prefix and also includes the namespace URI for attributes." + (make-instance 'xmls-builder :include-default-values include-default-values + :include-namespace-uri include-namespace-uri)) (defmethod sax:end-document ((handler xmls-builder)) (root handler)) (defmethod sax:start-element ((handler xmls-builder) namespace-uri local-name qname attributes) - (declare (ignore namespace-uri)) (setf local-name (or local-name qname)) - (let* ((attributes + (let* ((include-default-values (include-default-values handler)) + (include-namespace-uri (include-namespace-uri handler)) + (attributes (loop for attr in attributes - when (or (sax:attribute-specified-p attr) - (include-default-values handler)) + for attr-namespace-uri = (sax:attribute-namespace-uri attr) + for attr-local-name = (sax:attribute-local-name attr) + when (and (or (sax:attribute-specified-p attr) + include-default-values) + (or (not include-namespace-uri) + (not attr-namespace-uri) + attr-local-name)) collect - (list (sax:attribute-qname attr) + (list (cond (include-namespace-uri + (cond (attr-namespace-uri + (cons attr-local-name attr-namespace-uri)) + (t + (sax:attribute-qname attr)))) + (t + (sax:attribute-qname attr))) (sax:attribute-value attr)))) + (namespace (cond (include-namespace-uri + namespace-uri) + (t + (let ((lq (length qname)) + (ll (length local-name))) + (if (eql lq ll) + nil + (subseq qname 0 (- lq ll 1))))))) (node (make-node :name local-name - :ns (let ((lq (length qname)) - (ll (length local-name))) - (if (eql lq ll) - nil - (subseq qname 0 (- lq ll 1)))) + :ns namespace :attrs attributes)) (parent (car (element-stack handler)))) (if parent

2 2

[cxml-devel] Patch: close zstream input streams.
by Douglas Crosher 16 Jun '07

16 Jun '07

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. 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) ,@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)) ;;;; --------------------------------------------------------------------------- @@ -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)

2 1

[cxml-devel] Patch: dribble-tests
by Douglas Crosher 16 Jun '07

16 Jun '07

o dribble-tests: 'run-all-tests require the parser function. o dribble-tests: 'run-all-tests require the parser function. Index: test/xmlconf.lisp =================================================================== RCS file: /project/cxml/cvsroot/cxml/test/xmlconf.lisp,v retrieving revision 1.14 diff -u -r1.14 xmlconf.lisp --- test/xmlconf.lisp 18 Feb 2007 14:35:16 -0000 1.14 +++ test/xmlconf.lisp 13 Jun 2007 08:15:04 -0000 @@ -66,14 +71,14 @@ (read-sequence result s ) result))) -(defun dribble-tests (directory) +(defun dribble-tests (parser-fn directory) (let ((base (slot-value (asdf:find-system :cxml) 'asdf::relative-pathname))) (with-open-file (*standard-output* (merge-pathnames "XMLCONF" base) :direction :output :external-format :iso-8859-1 :if-exists :supersede) - (run-all-tests directory)))) + (run-all-tests parser-fn directory)))) (defvar *parser-fn* 'sax-test)

2 1

[cxml-devel] Patch: make-string-sink/utf8 and make-character-stream-sink/utf8 not needed.
by Douglas Crosher 16 Jun '07

16 Jun '07

o make-string-sink/utf8, make-character-stream-sink/utf8: these functions are not needed when compiling with the :rune-is-character feature. o make-string-sink/utf8, make-character-stream-sink/utf8: these functions are not needed when compiling with the :rune-is-character feature. Index: xml/unparse.lisp =================================================================== RCS file: /project/cxml/cvsroot/cxml/xml/unparse.lisp,v retrieving revision 1.13 diff -u -r1.13 unparse.lisp --- xml/unparse.lisp 1 May 2007 20:07:00 -0000 1.13 +++ xml/unparse.lisp 13 Jun 2007 08:15:04 -0000 @@ -110,10 +110,10 @@ #+rune-is-character (define-maker make-character-stream-sink make-character-stream-ystream stream) - ;; #-rune-is-character + #-rune-is-character (define-maker make-string-sink/utf8 make-string-ystream/utf8) - ;; #-rune-is-character + #-rune-is-character (define-maker make-character-stream-sink/utf8 make-character-stream-ystream/utf8 stream))

2 1

[cxml-devel] Patch: extid-using-catalog: make-extid requires a URI object.
by Douglas Crosher 16 Jun '07

16 Jun '07

o extid-using-catalog: convert the URI string returned by 'resolve-extid into the 'uri object required by 'make-extid. o extid-using-catalog: convert the URI string returned by 'resolve-extid into the 'uri object required by 'make-extid. 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 @@ -2481,7 +2496,7 @@ (extid-system extid) *catalog*))) (if sysid - (make-extid nil sysid) + (make-extid nil (safe-parse-uri sysid)) extid)) extid))

2 1

[cxml-devel] Patch: translate-uri-equals work with puri.
by Douglas Crosher 16 Jun '07

16 Jun '07

o translate-uri-equals: should work on all CL implementations, not just the Allegro CL because 'puri' is used for compatibility. o translate-uri-equals: should work on all CL implementations, not just the Allegro CL because 'puri' is used for compatibility. Index: test/domtest.lisp =================================================================== RCS file: /project/cxml/cvsroot/cxml/test/domtest.lisp,v retrieving revision 1.17 diff -u -r1.17 domtest.lisp --- test/domtest.lisp 20 Aug 2006 11:48:58 -0000 1.17 +++ test/domtest.lisp 13 Jun 2007 08:15:04 -0000 @@ -274,13 +274,6 @@ (with-attributes (|type|) element `(equal ,|type| "text/xml"))) -#-allegro -(defun translate-uri-equals (element) - (declare (ignore element)) - (warn "oops, assert-uri-equals needs Franz' URI package") - (throw 'give-up nil)) - -#+allegro (defun translate-uri-equals (element) (with-attributes (|actual|

2 1

[cxml-devel] Patch: downcase symbol names.
by Douglas Crosher 13 Jun '07

13 Jun '07

o Downcase symbol names for compatibility with CL variants with lower case symbol names such the Scieneer CL and ACL 'modern' mode. o Downcase symbol names for compatibility with CL variants with lower case symbol names such the Scieneer CL and ACL 'modern' mode. Index: klacks/klacks.lisp =================================================================== RCS file: /project/cxml/cvsroot/cxml/klacks/klacks.lisp,v retrieving revision 1.8 diff -u -r1.8 klacks.lisp --- klacks/klacks.lisp 1 May 2007 18:21:41 -0000 1.8 +++ klacks/klacks.lisp 13 Jun 2007 08:15:03 -0000 @@ -93,7 +93,7 @@ (sax:start-cdata source) (sax:characters handler a) (sax:end-cdata source)) - (T + (t (sax:characters handler a)))) (:processing-instruction (sax:processing-instruction handler a b)) Index: runes/ystream.lisp =================================================================== RCS file: /project/cxml/cvsroot/cxml/runes/ystream.lisp,v retrieving revision 1.5 diff -u -r1.5 ystream.lisp --- runes/ystream.lisp 2 Dec 2006 13:21:36 -0000 1.5 +++ runes/ystream.lisp 13 Jun 2007 08:15:03 -0000 @@ -42,11 +42,11 @@ (defstruct (utf8-ystream (:include ystream) - (:conc-name "YSTREAM-")) + (:conc-name #:ystream-)) (out-buffer (make-ub8-array (* 6 +ystream-bufsize+)) :type (simple-array (unsigned-byte 8) (*)))) -(defstruct (%stream-ystream (:include utf8-ystream) (:conc-name "YSTREAM-")) +(defstruct (%stream-ystream (:include utf8-ystream) (:conc-name #:ystream-)) (os-stream nil)) (definline write-rune (rune ystream) @@ -176,7 +176,7 @@ (defstruct (character-stream-ystream (:constructor make-character-stream-ystream (target-stream)) (:include ystream) - (:conc-name "YSTREAM-")) + (:conc-name #:ystream-)) (target-stream nil)) (defmethod flush-ystream ((ystream character-stream-ystream)) @@ -193,7 +193,7 @@ (defstruct (octet-vector-ystream (:include utf8-ystream) - (:conc-name "YSTREAM-")) + (:conc-name #:ystream-)) (result (make-buffer))) (defmethod ystream-device-write ((ystream octet-vector-ystream) buf nbytes) @@ -214,7 +214,7 @@ (defstruct (octet-stream-ystream (:include %stream-ystream) (:constructor make-octet-stream-ystream (os-stream)) - (:conc-name "YSTREAM-"))) + (:conc-name #:ystream-))) (defmethod ystream-device-write ((ystream octet-stream-ystream) buf nbytes) (write-sequence buf (ystream-os-stream ystream) :end nbytes)) @@ -227,7 +227,7 @@ (defstruct (character-stream-ystream/utf8 (:constructor make-character-stream-ystream/utf8 (os-stream)) (:include %stream-ystream) - (:conc-name "YSTREAM-"))) + (:conc-name #:ystream-))) (defmethod ystream-device-write ((ystream character-stream-ystream/utf8) buf nbytes) @@ -244,7 +244,7 @@ (defstruct (string-ystream/utf8 (:include character-stream-ystream/utf8 (os-stream (make-string-output-stream))) - (:conc-name "YSTREAM-"))) + (:conc-name #:ystream-))) (defmethod close-ystream ((ystream string-ystream/utf8)) (get-output-stream-string (ystream-os-stream ystream)))) Index: xml/xml-name-rune-p.lisp =================================================================== RCS file: /project/cxml/cvsroot/cxml/xml/xml-name-rune-p.lisp,v retrieving revision 1.8 diff -u -r1.8 xml-name-rune-p.lisp --- xml/xml-name-rune-p.lisp 10 Sep 2006 14:52:44 -0000 1.8 +++ xml/xml-name-rune-p.lisp 13 Jun 2007 08:15:04 -0000 @@ -162,20 +162,20 @@ (setf (aref r i) 1))))) ) `(progn - (DEFINLINE NAME-RUNE-P (RUNE) - (SETF RUNE (RUNE-CODE RUNE)) - (LOCALLY (DECLARE (OPTIMIZE (SAFETY 0) (SPEED 3)) + (definline name-rune-p (rune) + (setf rune (rune-code rune)) + (locally (declare (optimize (safety 0) (speed 3)) (type fixnum rune)) - (AND (<= 0 RUNE ,+max+) - (= 1 (SBIT ',(predicate-to-bv #'name-rune-p) - RUNE))))) - (DEFINLINE NAME-START-RUNE-P (RUNE) - (SETF RUNE (RUNE-CODE RUNE)) - (LOCALLY (DECLARE (OPTIMIZE (SAFETY 0) (SPEED 3)) + (and (<= 0 rune ,+max+) + (= 1 (sbit ',(predicate-to-bv #'name-rune-p) + rune))))) + (definline name-start-rune-p (rune) + (setf rune (rune-code rune)) + (locally (declare (optimize (safety 0) (speed 3)) (type fixnum rune)) - (AND (<= 0 RUNE ,+MAX+) - (= 1 (SBIT ',(predicate-to-bv #'name-start-rune-p) - RUNE))))) + (and (<= 0 rune ,+max+) + (= 1 (sbit ',(predicate-to-bv #'name-start-rune-p) + rune))))) (definline valid-name-p (rod) (and (plusp (length rod)) (name-start-rune-p (elt rod 0)) 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 @@ -3326,20 +3368,20 @@ (let ((input-var (gensym)) (collect (gensym)) (c (gensym))) - `(LET ((,input-var ,input)) - (MULTIPLE-VALUE-BIND (,res ,res-start ,res-end) - (WITH-RUNE-COLLECTOR/RAW (,collect) - (LOOP - (LET ((,c (PEEK-RUNE ,input-var))) - (COND ((EQ ,c :EOF) + `(let ((,input-var ,input)) + (multiple-value-bind (,res ,res-start ,res-end) + (with-rune-collector/raw (,collect) + (loop + (let ((,c (peek-rune ,input-var))) + (cond ((eq ,c :eof) ;; xxx error message - (RETURN)) - ((FUNCALL ,predicate ,c) - (RETURN)) + (return)) + ((funcall ,predicate ,c) + (return)) (t (,collect ,c) - (CONSUME-RUNE ,input-var)))))) - (LOCALLY + (consume-rune ,input-var)))))) + (locally ,@body))))) (defun read-name-token (input)

1 0

[cxml-devel] cxml-rng patch.
by Marco Monteiro 04 Jun '07

04 Jun '07

Hi. Names created for define/ref nodes (when simplifying) are symbols. This causes problems with cxml:unparse-attribute when serializing the grammar. Adding a call to #'STRING on the generated symbol solves the problem. Patch attached. Marco

1 0