cxml-cvs

cxml-cvs@common-lisp.net

425 discussions

[cxml-cvs] CVS cxml/xml
by dlichteblau 16 Jun '07

16 Jun '07

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]

1 0

[cxml-cvs] CVS cxml/doc
by dlichteblau 16 Jun '07

16 Jun '07

Update of /project/cxml/cvsroot/cxml/doc In directory clnet:/tmp/cvs-serv20513/doc Modified Files: index.xml 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/doc/index.xml 2007/06/16 11:07:58 1.10 +++ /project/cxml/cvsroot/cxml/doc/index.xml 2007/06/16 11:27:19 1.11 @@ -68,6 +68,12 @@ only. The old behaviour using pairs of prefix and local names was removed. (Thanks to Douglas Crosher.) </li> + <li> + 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). + </li> </ul> <p class="nomargin"><tt>rel-2007-05-26</tt></p> <ul class="nomargin">

1 0

[cxml-cvs] CVS cxml/runes
by dlichteblau 16 Jun '07

16 Jun '07

Update of /project/cxml/cvsroot/cxml/runes In directory clnet:/tmp/cvs-serv20513/runes Modified Files: package.lisp ystream.lisp Added Files: stream-scl.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/runes/package.lisp 2006/12/02 13:21:36 1.7 +++ /project/cxml/cvsroot/cxml/runes/package.lisp 2007/06/16 11:27:19 1.8 @@ -79,7 +79,11 @@ #:make-string-ystream/utf8 ;; #+rune-is-integer #:make-character-stream-ystream/utf8 - #:runes-to-utf8/adjustable-string)) + #:runes-to-utf8/adjustable-string + + #:rod-to-utf8-string + #:utf8-string-to-rod + #:make-octet-input-stream)) (defpackage :utf8-runes (:use :cl) --- /project/cxml/cvsroot/cxml/runes/ystream.lisp 2006/12/02 13:21:36 1.5 +++ /project/cxml/cvsroot/cxml/runes/ystream.lisp 2007/06/16 11:27:19 1.6 @@ -248,3 +248,50 @@ (defmethod close-ystream ((ystream string-ystream/utf8)) (get-output-stream-string (ystream-os-stream ystream)))) + + +;;;; helper functions + +(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 (runes-encoding: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)) + +(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)) + +(defmethod stream-read-byte ((stream octet-input-stream)) + (with-slots (octets pos) stream + (if (>= pos (length octets)) + :eof + (prog1 + (elt octets pos) + (incf pos))))) + +(defmethod stream-read-sequence + ((stream octet-input-stream) sequence start end &key &allow-other-keys) + (with-slots (octets pos) stream + (let* ((length (min (- end start) (- (length octets) pos))) + (end1 (+ start length)) + (end2 (+ pos length))) + (replace sequence octets :start1 start :end1 end1 :start2 pos :end2 end2) + (setf pos end2) + end1))) + +(defun make-octet-input-stream (octets) + (make-instance 'octet-input-stream :octets octets)) --- /project/cxml/cvsroot/cxml/runes/stream-scl.lisp 2007/06/16 11:27:19 NONE +++ /project/cxml/cvsroot/cxml/runes/stream-scl.lisp 2007/06/16 11:27:19 1.1 ;;; -*- 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)) ;;;; helper functions (defun rod-to-utf8-string (rod) (ext:make-string-from-bytes (ext:make-bytes-from-string rod :utf8) :iso-8859-1)) (defun utf8-string-to-rod (str) (let ((bytes (map '(vector (unsigned-byte 8)) #'char-code str))) (ext:make-string-from-bytes bytes :utf-8))) (defun make-octet-input-stream (octets) (ext:make-byte-input-stream octets))

1 0

[cxml-cvs] CVS cxml
by dlichteblau 16 Jun '07

16 Jun '07

Update of /project/cxml/cvsroot/cxml In directory clnet:/tmp/cvs-serv20513 Modified Files: cxml.asd runes.asd 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/cxml.asd 2007/05/26 21:55:57 1.18 +++ /project/cxml/cvsroot/cxml/cxml.asd 2007/06/16 11:27:18 1.19 @@ -4,6 +4,9 @@ (defclass closure-source-file (cl-source-file) ()) +#+scl +(pushnew 'uri-is-namestring *features*) + #+sbcl (defmethod perform :around ((o compile-op) (s closure-source-file)) ;; shut up already. Correctness first. @@ -30,7 +33,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))) --- /project/cxml/cvsroot/cxml/runes.asd 2007/05/26 22:05:13 1.1 +++ /project/cxml/cvsroot/cxml/runes.asd 2007/06/16 11:27:18 1.2 @@ -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") + ))

1 0

[cxml-cvs] CVS cxml/xml
by dlichteblau 16 Jun '07

16 Jun '07

Update of /project/cxml/cvsroot/cxml/xml In directory clnet:/tmp/cvs-serv16419/xml Modified Files: xmlns-normalizer.lisp xmls-compat.lisp Log Message: XMLS compatibility is not <i>bug-for-bug</i>-compatible with XMLS any more. There is now a mode using pairs of local name and namespace URI, and a second mode using qualified names only. The old behaviour using pairs of prefix and local names was removed. (Thanks to Douglas Crosher.) --- /project/cxml/cvsroot/cxml/xml/xmlns-normalizer.lisp 2006/08/20 14:59:35 1.3 +++ /project/cxml/cvsroot/cxml/xml/xmlns-normalizer.lisp 2007/06/16 11:07:58 1.4 @@ -34,7 +34,7 @@ (make-instance 'namespace-normalizer :xmlns-stack (list (mapcar (lambda (cons) (make-xmlns-attribute (car cons) (cdr cons))) - *namespace-bindings*)) + *initial-namespace-bindings*)) :chained-handler chained-handler)) (defun normalizer-find-prefix (handler prefix) @@ -74,7 +74,6 @@ (defmethod sax:start-element ((handler namespace-normalizer) uri lname qname attrs) - (declare (ignore qname)) (when (null uri) (setf uri #"")) (let ((normal-attrs '())) @@ -85,8 +84,12 @@ (push a normal-attrs))) (flet ((push-namespace (prefix uri) (let ((new (make-xmlns-attribute prefix uri))) - (push new (car (xmlns-stack handler))) - (push new attrs)))) + (unless (find (sax:attribute-qname new) + attrs + :test #'rod= + :key #'sax:attribute-qname) + (push new (car (xmlns-stack handler))) + (push new attrs))))) (multiple-value-bind (prefix local-name) (split-qname qname) (setf lname local-name) (let ((binding (normalizer-find-prefix handler prefix))) --- /project/cxml/cvsroot/cxml/xml/xmls-compat.lisp 2006/05/15 21:57:47 1.3 +++ /project/cxml/cvsroot/cxml/xml/xmls-compat.lisp 2007/06/16 11:07:58 1.4 @@ -69,32 +69,50 @@ (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 t + :initarg :include-namespace-uri + :accessor include-namespace-uri))) + +(defun make-xmls-builder (&key (include-default-values t) + (include-namespace-uri t)) + "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) + (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 (when include-namespace-uri namespace-uri)) (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 @@ -129,34 +147,100 @@ (defun map-node (handler node - &key (include-xmlns-attributes sax:*include-xmlns-attributes*)) + &key (include-xmlns-attributes sax:*include-xmlns-attributes*) + (include-namespace-uri t)) + (if include-namespace-uri + (map-node/lnames (cxml:make-namespace-normalizer handler) + node + include-xmlns-attributes) + (map-node/qnames handler node include-xmlns-attributes))) + +(defun map-node/lnames (handler node include-xmlns-attributes) + (sax:start-document handler) + (labels ((walk (node) + (unless (node-ns node) + (error "serializing with :INCLUDE-NAMESPACE-URI, but node ~ + was created without namespace URI")) + (let* ((attlist + (compute-attributes/lnames node include-xmlns-attributes)) + (uri (node-ns node)) + (lname (node-name node)) + (qname lname) ;let the normalizer fix it + ) + (sax:start-element handler uri lname qname attlist) + (dolist (child (node-children node)) + (typecase child + (list (walk child)) + ((or string rod) + (sax:characters handler (string-rod child))))) + (sax:end-element handler uri lname qname)))) + (walk node)) + (sax:end-document handler)) + +(defun map-node/qnames (handler node include-xmlns-attributes) (sax:start-document handler) (labels ((walk (node) + (when (node-ns node) + (error "serializing without :INCLUDE-NAMESPACE-URI, but node ~ + was created with a namespace URI")) (let* ((attlist - (compute-attributes node include-xmlns-attributes)) - (lname (rod (node-name node))) - (qname (if (node-ns node) - (concatenate 'rod - (rod (node-ns node)) - (rod ":") - lname) - lname))) + (compute-attributes/qnames node include-xmlns-attributes)) + (qname (string-rod (node-name node))) + (lname (nth-value 1 (cxml::split-qname qname)))) (sax:start-element handler nil lname qname attlist) (dolist (child (node-children node)) (typecase child (list (walk child)) - ((or string rod) (sax:characters handler (rod child))))) + ((or string rod) + (sax:characters handler (string-rod child))))) (sax:end-element handler nil lname qname)))) (walk node)) (sax:end-document handler)) -(defun compute-attributes (node xmlnsp) +(defun compute-attributes/lnames (node xmlnsp) + (remove nil + (mapcar (lambda (a) + (destructuring-bind (name value) a + (unless (listp name) + (setf name (cons name nil))) + (destructuring-bind (lname &rest uri) name + (cond + ((not (equal uri "http://www.w3.org/2000/xmlns/")) + (sax:make-attribute + ;; let the normalizer fix the qname + :qname (if uri + (string-rod (concatenate 'string + "dummy:" + lname)) + (string-rod lname)) + :local-name (string-rod lname) + :namespace-uri uri + :value (string-rod value) + :specified-p t)) + (xmlnsp + (sax:make-attribute + :qname (string-rod + (if lname + (concatenate 'string "xmlns:" lname) + "xmlns")) + :local-name (string-rod lname) + :namespace-uri uri + :value (string-rod value) + :specified-p t)))))) + (node-attrs node)))) + +(defun compute-attributes/qnames (node xmlnsp) (remove nil (mapcar (lambda (a) (destructuring-bind (name value) a - (if (or xmlnsp (not (cxml::xmlns-attr-p (rod name)))) - (sax:make-attribute :qname (rod name) - :value (rod value) + (when (listp name) + (error "serializing without :INCLUDE-NAMESPACE-URI, ~ + but attribute was created with a namespace ~ + URI")) + (if (or xmlnsp + (not (cxml::xmlns-attr-p (string-rod name)))) + (sax:make-attribute :qname (string-rod name) + :value (string-rod value) :specified-p t) nil))) (node-attrs node))))

1 0

[cxml-cvs] CVS cxml/doc
by dlichteblau 16 Jun '07

16 Jun '07

Update of /project/cxml/cvsroot/cxml/doc In directory clnet:/tmp/cvs-serv16419/doc Modified Files: index.xml xmls-compat.xml Log Message: XMLS compatibility is not <i>bug-for-bug</i>-compatible with XMLS any more. There is now a mode using pairs of local name and namespace URI, and a second mode using qualified names only. The old behaviour using pairs of prefix and local names was removed. (Thanks to Douglas Crosher.) --- /project/cxml/cvsroot/cxml/doc/index.xml 2007/06/16 09:42:06 1.9 +++ /project/cxml/cvsroot/cxml/doc/index.xml 2007/06/16 11:07:58 1.10 @@ -61,6 +61,13 @@ <ul class="nomargin"> <li>Serialization no longer defaults to canonical form.</li> <li>Fixed octet array argument to make-source.</li> + <li> + XMLS compatibility is not <i>bug-for-bug</i>-compatible with + XMLS any more. There is now a mode using pairs of local name + and namespace URI, and a second mode using qualified names + only. The old behaviour using pairs of prefix and local names + was removed. (Thanks to Douglas Crosher.) + </li> </ul> <p class="nomargin"><tt>rel-2007-05-26</tt></p> <ul class="nomargin"> --- /project/cxml/cvsroot/cxml/doc/xmls-compat.xml 2007/02/18 12:35:50 1.1 +++ /project/cxml/cvsroot/cxml/doc/xmls-compat.xml 2007/06/16 11:07:58 1.2 @@ -16,7 +16,28 @@ DOM functions cannot be implemented on them. </p> <p> - <div class="def">Function CXML-XMLS:MAKE-XMLS-BUILDER (&key include-default-values)</div> + <b>New namespace handling:</b> + XMLS compatibility is not <i>bug-for-bug</i>-compatible with + XMLS any more. There is now a mode using pairs of local name + and namespace URI, and a second mode using qualified names + only. The old behaviour using pairs of prefix and local names + was removed. + </p> + <p> + <strike> + fixme: It is unclear to me how namespaces are meant to + work in xmls, since xmls documentation differs from how xmls + actually works in current releases. Usually applications need to + know both the namespace prefix <em>and</em> the namespace URI. We + currently follow the xmls <em>implementation</em> and use the + namespace prefix instead of following its <em>documentation</em> which + shows the URI. We do not follow xmls in munging xmlns attribute + values. Attributes themselves have namespaces and it is not clear + to me how that works in xmls. + </strike> + </p> + <p> + <div class="def">Function CXML-XMLS:MAKE-XMLS-BUILDER (&key include-default-values include-namespace-uri)</div> Create a SAX handler which builds XMLS list structures.  If <tt>include-default-values</tt> is true, default values for attributes declared in a DTD are included as attributes in the @@ -25,11 +46,18 @@ values. </p> <p> + If <tt>include-namespace-uri</tt> is true (the default), node + names and attribute names are pairs of local name and namespace + URI. (Except for attributes without a namespace, which are named + using a string.) Otherwise, nodes and attributes are named by + their qualified name. + </p> + <p> Example: </p> <pre>(cxml:parse-file "test.xml" (cxml-xmls:make-xmls-builder))</pre> <p> - <div class="def">Function CXML-XMLS:MAP-NODE (handler node &key include-xmlns-attributes)</div> + <div class="def">Function CXML-XMLS:MAP-NODE (handler node &key include-xmlns-attributes include-namespace-uri)</div> Traverse an XMLS document/node and call SAX functions as if an XML representation of the document were processed by a SAX parser. </p> @@ -52,17 +80,6 @@ and namespace prefix <tt>ns</tt>. </p> <p> - <em>fixme:</em> It is unclear to me how namespaces are meant to - work in xmls, since xmls documentation differs from how xmls - actually works in current releases. Usually applications need to - know both the namespace prefix <em>and</em> the namespace URI. We - currently follow the xmls <em>implementation</em> and use the - namespace prefix instead of following its <em>documentation</em> which - shows the URI. We do not follow xmls in munging xmlns attribute - values. Attributes themselves have namespaces and it is not clear - to me how that works in xmls. - </p> - <p> <div class="def">Accessor CXML-XMLS:NODE-NAME (node)</div> <div class="def">Accessor CXML-XMLS:NODE-NS (node)</div> <div class="def">Accessor CXML-XMLS:NODE-ATTRS (node)</div>

1 0

[cxml-cvs] CVS cxml/test
by dlichteblau 16 Jun '07

16 Jun '07

Update of /project/cxml/cvsroot/cxml/test In directory clnet:/tmp/cvs-serv2457 Modified Files: xmlconf.lisp Log Message: DTC patch-xmlconf o dribble-tests: 'run-all-tests require the parser function. --- /project/cxml/cvsroot/cxml/test/xmlconf.lisp 2007/02/18 14:35:16 1.14 +++ /project/cxml/cvsroot/cxml/test/xmlconf.lisp 2007/06/16 10:03:11 1.15 @@ -66,14 +66,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)

1 0

[cxml-cvs] CVS cxml/xml
by dlichteblau 16 Jun '07

16 Jun '07

Update of /project/cxml/cvsroot/cxml/xml In directory clnet:/tmp/cvs-serv2346 Modified Files: unparse.lisp Log Message: DTC patch-rune o make-string-sink/utf8, make-character-stream-sink/utf8: these functions are not needed when compiling with the :rune-is-character feature. --- /project/cxml/cvsroot/cxml/xml/unparse.lisp 2007/06/16 09:42:06 1.14 +++ /project/cxml/cvsroot/cxml/xml/unparse.lisp 2007/06/16 10:02:43 1.15 @@ -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))

1 0

[cxml-cvs] CVS cxml/test
by dlichteblau 16 Jun '07

16 Jun '07

Update of /project/cxml/cvsroot/cxml/test In directory clnet:/tmp/cvs-serv30886/test Modified Files: domtest.lisp Log Message: DTC patch-dom o translate-uri-equals: should work on all CL implementations, not just the Allegro CL because 'puri' is used for compatibility. --- /project/cxml/cvsroot/cxml/test/domtest.lisp 2006/08/20 11:48:58 1.17 +++ /project/cxml/cvsroot/cxml/test/domtest.lisp 2007/06/16 09:52:15 1.18 @@ -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|

1 0

[cxml-cvs] CVS cxml/xml
by dlichteblau 16 Jun '07

16 Jun '07

Update of /project/cxml/cvsroot/cxml/xml In directory clnet:/tmp/cvs-serv29603/xml Modified Files: unparse.lisp Log Message: <li>Serialization no longer defaults to canonical form.</li> --- /project/cxml/cvsroot/cxml/xml/unparse.lisp 2007/05/01 20:07:00 1.13 +++ /project/cxml/cvsroot/cxml/xml/unparse.lisp 2007/06/16 09:42:06 1.14 @@ -72,7 +72,7 @@ (defclass sink () ((ystream :initarg :ystream :accessor sink-ystream) (width :initform 79 :initarg :width :accessor width) - (canonical :initform t :initarg :canonical :accessor canonical) + (canonical :initform nil :initarg :canonical :accessor canonical) (indentation :initform nil :initarg :indentation :accessor indentation) (current-indentation :initform 0 :accessor current-indentation) (notations :initform (make-buffer :element-type t) :accessor notations)

1 0

← Newer
1
...
6
7
8
9
10
11
12
...
43
Older →

Jump to page:

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

2005

cxml-cvs