From bknr at bknr.net Fri Dec 1 10:37:34 2006 From: bknr at bknr.net (bknr at bknr.net) Date: Fri, 1 Dec 2006 05:37:34 -0500 (EST) Subject: [bknr-cvs] r2093 - branches Message-ID: <20061201103734.97D5056006@common-lisp.net> Author: hhubner Date: 2006-12-01 05:37:34 -0500 (Fri, 01 Dec 2006) New Revision: 2093 Added: branches/grin-neu/ Log: Add branch for GRiN development, moving to SBCL Copied: branches/grin-neu (from rev 2092, trunk) From bknr at bknr.net Fri Dec 1 10:39:53 2006 From: bknr at bknr.net (bknr at bknr.net) Date: Fri, 1 Dec 2006 05:39:53 -0500 (EST) Subject: [bknr-cvs] r2094 - in branches/grin-neu: bknr/src bknr/src/utils bknr/src/web bknr/src/xml-impex projects/bos/payment-website/templates/da projects/bos/worldpay-test projects/mah-jongg/src projects/mah-jongg/website site thirdparty thirdparty/cl-ppcre thirdparty/cl-ppcre/doc thirdparty/cxml thirdparty/cxml/contrib thirdparty/cxml/doc thirdparty/cxml/dom thirdparty/cxml/runes thirdparty/cxml/test thirdparty/cxml/xml thirdparty/cxml/xml/sax-tests thirdparty/emacs/slime thirdparty/kmrcl-1.72 thirdparty/net-telent-date thirdparty/net.post-office thirdparty/portableaserve/acl-compat/sbcl thirdparty/portableaserve/aserve thirdparty/puri thirdparty/trivial-gray-streams thirdparty/trivial-gray-streams/CVS thirdparty/uffi/src/corman thirdparty/uffi/tests tools Message-ID: <20061201103953.C6DB656006@common-lisp.net> Author: hhubner Date: 2006-12-01 05:39:49 -0500 (Fri, 01 Dec 2006) New Revision: 2094 Added: branches/grin-neu/thirdparty/cxml/COPYING branches/grin-neu/thirdparty/cxml/DOMTEST branches/grin-neu/thirdparty/cxml/GNUmakefile branches/grin-neu/thirdparty/cxml/OLDNEWS branches/grin-neu/thirdparty/cxml/XMLCONF branches/grin-neu/thirdparty/cxml/XMLS-SYMBOLS.diff branches/grin-neu/thirdparty/cxml/contrib/ branches/grin-neu/thirdparty/cxml/contrib/xhtmlgen.lisp branches/grin-neu/thirdparty/cxml/doc/ branches/grin-neu/thirdparty/cxml/doc/bg.png branches/grin-neu/thirdparty/cxml/doc/cxml.css branches/grin-neu/thirdparty/cxml/doc/dom.html branches/grin-neu/thirdparty/cxml/doc/installation.html branches/grin-neu/thirdparty/cxml/doc/quickstart.html branches/grin-neu/thirdparty/cxml/doc/using.html branches/grin-neu/thirdparty/cxml/doc/xmls-compat.html branches/grin-neu/thirdparty/cxml/glisp/ branches/grin-neu/thirdparty/cxml/runes/definline.lisp branches/grin-neu/thirdparty/cxml/runes/definline.x86f branches/grin-neu/thirdparty/cxml/runes/utf8.lisp branches/grin-neu/thirdparty/cxml/runes/ystream.lisp branches/grin-neu/thirdparty/cxml/test/utf8domtest.diff branches/grin-neu/thirdparty/cxml/xml/sax-proxy.lisp branches/grin-neu/thirdparty/cxml/xml/space-normalizer.lisp branches/grin-neu/thirdparty/cxml/xml/util.lisp branches/grin-neu/thirdparty/cxml/xml/xmlns-normalizer.lisp branches/grin-neu/thirdparty/net-telent-date/ branches/grin-neu/thirdparty/net-telent-date/CVS/ branches/grin-neu/thirdparty/net-telent-date/INSTALL.asdf branches/grin-neu/thirdparty/net-telent-date/README branches/grin-neu/thirdparty/net-telent-date/date.lisp branches/grin-neu/thirdparty/net-telent-date/defpackage.lisp branches/grin-neu/thirdparty/net-telent-date/maintainer-Makefile branches/grin-neu/thirdparty/net-telent-date/make-makefile.lisp branches/grin-neu/thirdparty/net-telent-date/net-telent-date.asd branches/grin-neu/thirdparty/net-telent-date/net-telent-date.system branches/grin-neu/thirdparty/net-telent-date/parse-time.lisp branches/grin-neu/thirdparty/net-telent-date/tests.lisp branches/grin-neu/thirdparty/puri/ branches/grin-neu/thirdparty/puri/LICENSE branches/grin-neu/thirdparty/puri/README branches/grin-neu/thirdparty/puri/puri.asd branches/grin-neu/thirdparty/puri/src.lisp branches/grin-neu/thirdparty/puri/tests.lisp branches/grin-neu/thirdparty/puri/uri.html branches/grin-neu/thirdparty/trivial-gray-streams/ branches/grin-neu/thirdparty/trivial-gray-streams/COPYING branches/grin-neu/thirdparty/trivial-gray-streams/CVS/ branches/grin-neu/thirdparty/trivial-gray-streams/CVS/Entries branches/grin-neu/thirdparty/trivial-gray-streams/CVS/Repository branches/grin-neu/thirdparty/trivial-gray-streams/CVS/Root branches/grin-neu/thirdparty/trivial-gray-streams/CVS/Template branches/grin-neu/thirdparty/trivial-gray-streams/Makefile branches/grin-neu/thirdparty/trivial-gray-streams/README branches/grin-neu/thirdparty/trivial-gray-streams/mixin.lisp branches/grin-neu/thirdparty/trivial-gray-streams/package.lisp branches/grin-neu/thirdparty/trivial-gray-streams/trivial-gray-streams.asd Removed: branches/grin-neu/thirdparty/cl-ppcre/testdata branches/grin-neu/thirdparty/cl-ppcre/testinput Modified: branches/grin-neu/bknr/src/bknr-utils.asd branches/grin-neu/bknr/src/bknr.asd branches/grin-neu/bknr/src/packages.lisp branches/grin-neu/bknr/src/utils/package.lisp branches/grin-neu/bknr/src/web/handlers.lisp branches/grin-neu/bknr/src/web/templates.lisp branches/grin-neu/bknr/src/xml-impex/package.lisp branches/grin-neu/bknr/src/xml-impex/xml-export.lisp branches/grin-neu/bknr/src/xml-impex/xml-import.lisp branches/grin-neu/projects/bos/payment-website/templates/da/bestellung.xml branches/grin-neu/projects/bos/worldpay-test/tags.lisp branches/grin-neu/projects/mah-jongg/src/game.lisp branches/grin-neu/projects/mah-jongg/website/game.xsl branches/grin-neu/site/svn-config branches/grin-neu/thirdparty/cl-ppcre/CHANGELOG branches/grin-neu/thirdparty/cl-ppcre/api.lisp branches/grin-neu/thirdparty/cl-ppcre/cl-ppcre-test.asd branches/grin-neu/thirdparty/cl-ppcre/cl-ppcre-test.system branches/grin-neu/thirdparty/cl-ppcre/cl-ppcre.asd branches/grin-neu/thirdparty/cl-ppcre/cl-ppcre.system branches/grin-neu/thirdparty/cl-ppcre/closures.lisp branches/grin-neu/thirdparty/cl-ppcre/convert.lisp branches/grin-neu/thirdparty/cl-ppcre/doc/index.html branches/grin-neu/thirdparty/cl-ppcre/errors.lisp branches/grin-neu/thirdparty/cl-ppcre/lexer.lisp branches/grin-neu/thirdparty/cl-ppcre/lispworks-defsystem.lisp branches/grin-neu/thirdparty/cl-ppcre/load.lisp branches/grin-neu/thirdparty/cl-ppcre/optimize.lisp branches/grin-neu/thirdparty/cl-ppcre/packages.lisp branches/grin-neu/thirdparty/cl-ppcre/parser.lisp branches/grin-neu/thirdparty/cl-ppcre/ppcre-tests.lisp branches/grin-neu/thirdparty/cl-ppcre/regex-class.lisp branches/grin-neu/thirdparty/cl-ppcre/repetition-closures.lisp branches/grin-neu/thirdparty/cl-ppcre/scanner.lisp branches/grin-neu/thirdparty/cl-ppcre/specials.lisp branches/grin-neu/thirdparty/cl-ppcre/util.lisp branches/grin-neu/thirdparty/cxml/README.html branches/grin-neu/thirdparty/cxml/catalog.dtd branches/grin-neu/thirdparty/cxml/cxml.asd branches/grin-neu/thirdparty/cxml/dom/dom-builder.lisp branches/grin-neu/thirdparty/cxml/dom/dom-impl.lisp branches/grin-neu/thirdparty/cxml/dom/dom-sax.lisp branches/grin-neu/thirdparty/cxml/dom/package.lisp branches/grin-neu/thirdparty/cxml/mlisp-patch.diff branches/grin-neu/thirdparty/cxml/runes/characters.lisp branches/grin-neu/thirdparty/cxml/runes/encodings-data.lisp branches/grin-neu/thirdparty/cxml/runes/encodings.lisp branches/grin-neu/thirdparty/cxml/runes/package.lisp branches/grin-neu/thirdparty/cxml/runes/runes.lisp branches/grin-neu/thirdparty/cxml/runes/syntax.lisp branches/grin-neu/thirdparty/cxml/runes/xstream.lisp branches/grin-neu/thirdparty/cxml/test/domtest.lisp branches/grin-neu/thirdparty/cxml/test/xmlconf.lisp branches/grin-neu/thirdparty/cxml/xml/catalog.lisp branches/grin-neu/thirdparty/cxml/xml/package.lisp branches/grin-neu/thirdparty/cxml/xml/recoder.lisp branches/grin-neu/thirdparty/cxml/xml/sax-handler.lisp branches/grin-neu/thirdparty/cxml/xml/sax-tests/tests.lisp branches/grin-neu/thirdparty/cxml/xml/unparse.lisp branches/grin-neu/thirdparty/cxml/xml/xml-name-rune-p.lisp branches/grin-neu/thirdparty/cxml/xml/xml-parse.lisp branches/grin-neu/thirdparty/cxml/xml/xmls-compat.lisp branches/grin-neu/thirdparty/emacs/slime/swank-loader.x86f branches/grin-neu/thirdparty/kmrcl-1.72/byte-stream.lisp branches/grin-neu/thirdparty/kmrcl-1.72/kmrcl.asd branches/grin-neu/thirdparty/net.post-office/net.post-office.asd branches/grin-neu/thirdparty/net.post-office/packages.lisp branches/grin-neu/thirdparty/portableaserve/acl-compat/sbcl/acl-excl.lisp branches/grin-neu/thirdparty/portableaserve/acl-compat/sbcl/acl-mp.lisp branches/grin-neu/thirdparty/portableaserve/acl-compat/sbcl/acl-socket.lisp branches/grin-neu/thirdparty/portableaserve/aserve/main.cl branches/grin-neu/thirdparty/uffi/src/corman/getenv-ccl.lisp branches/grin-neu/thirdparty/uffi/tests/package.lisp branches/grin-neu/tools/make-core.lisp Log: SBCL-1.0 compatibility changes and package updates. Modified: branches/grin-neu/bknr/src/bknr-utils.asd =================================================================== --- branches/grin-neu/bknr/src/bknr-utils.asd 2006-12-01 10:37:34 UTC (rev 2093) +++ branches/grin-neu/bknr/src/bknr-utils.asd 2006-12-01 10:39:49 UTC (rev 2094) @@ -18,7 +18,8 @@ :depends-on (:cl-interpol :cl-ppcre :cxml - :md5 + #-sbcl :md5 + #+sbcl :sb-md5 #+(not allegro) :acl-compat :iconv) Modified: branches/grin-neu/bknr/src/bknr.asd =================================================================== --- branches/grin-neu/bknr/src/bknr.asd 2006-12-01 10:37:34 UTC (rev 2093) +++ branches/grin-neu/bknr/src/bknr.asd 2006-12-01 10:39:49 UTC (rev 2094) @@ -24,7 +24,8 @@ :cl-gd :aserve ;:net.post-office - :md5 + #-sbcl :md5 + #+sbcl :sb-md5 :cxml :unit-test :bknr-utils Modified: branches/grin-neu/bknr/src/packages.lisp =================================================================== --- branches/grin-neu/bknr/src/packages.lisp 2006-12-01 10:37:34 UTC (rev 2093) +++ branches/grin-neu/bknr/src/packages.lisp 2006-12-01 10:39:49 UTC (rev 2094) @@ -113,7 +113,8 @@ :cl-user :cl-interpol :cl-ppcre - :md5 + #+cmu :md5 + #+sbcl :sb-md5 :bknr.datastore :bknr.indices :bknr.utils @@ -183,7 +184,8 @@ :cxml-xmls :xhtml-generator :puri - :md5 + #+cmu :md5 + #+sbcl :sb-md5 :js :bknr.datastore :bknr.indices Modified: branches/grin-neu/bknr/src/utils/package.lisp =================================================================== --- branches/grin-neu/bknr/src/utils/package.lisp 2006-12-01 10:37:34 UTC (rev 2093) +++ branches/grin-neu/bknr/src/utils/package.lisp 2006-12-01 10:39:49 UTC (rev 2094) @@ -5,7 +5,8 @@ :cl-ppcre :cl-interpol :cxml-xmls - :md5 + #+cmu :md5 + #+sbcl :sb-md5 #+cmu :extensions ; #+sbcl :sb-ext #+(not allegro) :acl-compat.mp Modified: branches/grin-neu/bknr/src/web/handlers.lisp =================================================================== --- branches/grin-neu/bknr/src/web/handlers.lisp 2006-12-01 10:37:34 UTC (rev 2093) +++ branches/grin-neu/bknr/src/web/handlers.lisp 2006-12-01 10:39:49 UTC (rev 2094) @@ -449,8 +449,7 @@ (defgeneric xml-object-handler-show-object (handler object req)) (defmethod xml-object-handler-show-object ((handler xml-object-handler) object req) - (write-to-xml object - :string-rod-fn #'cxml::utf8-string-to-rod)) + (write-to-xml object)) (defmethod handle-object ((handler xml-object-handler) object req) (xml-object-handler-show-object handler object req)) Modified: branches/grin-neu/bknr/src/web/templates.lisp =================================================================== --- branches/grin-neu/bknr/src/web/templates.lisp 2006-12-01 10:37:34 UTC (rev 2093) +++ branches/grin-neu/bknr/src/web/templates.lisp 2006-12-01 10:39:49 UTC (rev 2094) @@ -11,6 +11,7 @@ ;; FreeBSD "/usr/local/share/xml/catalog.ports")) +#-sbcl (eval-when (:load-toplevel :execute) (let ((env-catalog (assoc :xmlcatalog ext:*environment-list*))) (when env-catalog Modified: branches/grin-neu/bknr/src/xml-impex/package.lisp =================================================================== --- branches/grin-neu/bknr/src/xml-impex/package.lisp 2006-12-01 10:37:34 UTC (rev 2093) +++ branches/grin-neu/bknr/src/xml-impex/package.lisp 2006-12-01 10:39:49 UTC (rev 2094) @@ -24,5 +24,7 @@ #:with-xml-export* #:write-to-xml + #:set-string-rod-fn + #:create-instance #:set-slot-value)) Modified: branches/grin-neu/bknr/src/xml-impex/xml-export.lisp =================================================================== --- branches/grin-neu/bknr/src/xml-impex/xml-export.lisp 2006-12-01 10:37:34 UTC (rev 2093) +++ branches/grin-neu/bknr/src/xml-impex/xml-export.lisp 2006-12-01 10:39:49 UTC (rev 2094) @@ -1,5 +1,10 @@ (in-package :bknr.impex) +(defvar *string-rod-fn* #'cxml::string-rod) + +(defun set-string-rod-fn (function) + (setf *string-rod-fn* function)) + (defmethod slot-serialize-value ((slot xml-effective-slot-definition) value) (with-slots (serializer object-to-id) slot (when object-to-id @@ -12,7 +17,7 @@ (defmacro with-xml-export* ((&key output indentation canonical) &body body) `(let ((*objects-written* (make-hash-table :test #'equal)) (cxml::*sink* (cxml:make-character-stream-sink ,output - :indentation ,indentation :canonical ,canonical))) + :indentation ,indentation :canonical ,canonical))) , at body)) (defmacro with-xml-export (nil &body body) @@ -26,23 +31,23 @@ (declare (ignore name))) (defmethod write-to-xml ((object list) &key (name (error "Can not serialize list to XML without an element name~%")) no-recurse) - (sax:start-element cxml::*sink* nil nil (cxml::string-rod name) nil) + (sax:start-element cxml::*sink* nil nil (funcall *string-rod-fn* name) nil) (dolist (obj object) (write-to-xml obj)) - (sax:end-element cxml::*sink* nil nil (cxml::string-rod name))) + (sax:end-element cxml::*sink* nil nil (funcall *string-rod-fn* name))) (defmethod write-to-xml ((object string) &key (name (error "Can not serialize string ~A to XML without an element name." object)) no-recurse) - (sax:start-element cxml::*sink* nil nil (cxml::string-rod name) nil) - (sax:characters cxml::*sink* (cxml::string-rod object)) - (sax:end-element cxml::*sink* nil nil (cxml::string-rod name))) + (sax:start-element cxml::*sink* nil nil (funcall *string-rod-fn* name) nil) + (sax:characters cxml::*sink* (funcall *string-rod-fn* object)) + (sax:end-element cxml::*sink* nil nil (funcall *string-rod-fn* name))) (defun write-object-reference (class object unique-id-slot-name name) (let ((slotdef (find unique-id-slot-name (class-slots class) :key #'slot-definition-name))) (unless (xml-effective-slot-definition-attribute slotdef) (error "Slot ~A is not defined as :attribute slot and cannot be used as unique-id slot for class ~A" unique-id-slot-name (class-name class))) (sax:start-element cxml::*sink* nil nil name - (list (sax:make-attribute :qname (cxml::string-rod (xml-effective-slot-definition-attribute slotdef)) - :value (cxml::string-rod (slot-serialize-value slotdef (slot-value object unique-id-slot-name)))))) + (list (sax:make-attribute :qname (funcall *string-rod-fn* (xml-effective-slot-definition-attribute slotdef)) + :value (funcall *string-rod-fn* (slot-serialize-value slotdef (slot-value object unique-id-slot-name)))))) (sax:end-element cxml::*sink* nil nil name))) (defmethod write-to-xml ((object t) &key name no-recurse) @@ -50,7 +55,7 @@ (cond ((typep class 'xml-class) (xml-object-check-validity object) - (let ((qname (cxml::string-rod (or name (xml-class-element class))))) + (let ((qname (funcall *string-rod-fn* (or name (xml-class-element class))))) ;; If this object has been serialized to the XML stream, ;; write a reference to the object and return. @@ -72,13 +77,13 @@ ;; attributes (attributes (loop for slot in attr-slots for name = (slot-definition-name slot) - for attdef = (cxml::string-rod (xml-effective-slot-definition-attribute slot)) + for attdef = (funcall *string-rod-fn* (xml-effective-slot-definition-attribute slot)) when (and (slot-boundp object name) (slot-value object name)) collect (sax:make-attribute :qname attdef :value - (cxml::string-rod + (funcall *string-rod-fn* (slot-serialize-value slot (slot-value object name))))))) (sax:start-element cxml::*sink* nil nil qname attributes) @@ -104,9 +109,9 @@ (when (slot-boundp object name) (sax:characters cxml::*sink* - (cxml::string-rod + (funcall *string-rod-fn* (funcall (xml-effective-slot-definition-serializer body-slot) (slot-value object name))))))) (sax:end-element cxml::*sink* nil nil qname)))) - (t nil))))) + (t nil)))) Modified: branches/grin-neu/bknr/src/xml-impex/xml-import.lisp =================================================================== --- branches/grin-neu/bknr/src/xml-impex/xml-import.lisp 2006-12-01 10:37:34 UTC (rev 2093) +++ branches/grin-neu/bknr/src/xml-impex/xml-import.lisp 2006-12-01 10:39:49 UTC (rev 2094) @@ -185,3 +185,14 @@ :class-hash class-hash))) (cxml:parse-file xml-file (cxml:make-recoder importer recoder)) (importer-root-elt importer)))) + +(defun parse-xml-string (string classes &key (recoder #'cxml::rod-string) + (importer-class 'xml-class-importer)) + (with-input-from-string (stream string) + (let ((class-hash (make-hash-table :test #'equal))) + (dolist (class classes) + (setf (gethash (xml-class-element class) class-hash) class)) + (let ((importer (make-instance importer-class + :class-hash class-hash))) + (cxml:parse-stream stream (cxml:make-recoder importer recoder)) + (importer-root-elt importer))))) \ No newline at end of file Modified: branches/grin-neu/projects/bos/payment-website/templates/da/bestellung.xml =================================================================== --- branches/grin-neu/projects/bos/payment-website/templates/da/bestellung.xml 2006-12-01 10:37:34 UTC (rev 2093) +++ branches/grin-neu/projects/bos/payment-website/templates/da/bestellung.xml 2006-12-01 10:39:49 UTC (rev 2094) @@ -19,7 +19,7 @@ Plant regnskov -

for kun 3,- Euro/24,- Kroner per m?? +

for kun 24,- Kroner per m??




@@ -58,6 +58,7 @@
+ Modified: branches/grin-neu/projects/bos/worldpay-test/tags.lisp =================================================================== --- branches/grin-neu/projects/bos/worldpay-test/tags.lisp 2006-12-01 10:37:34 UTC (rev 2093) +++ branches/grin-neu/projects/bos/worldpay-test/tags.lisp 2006-12-01 10:39:49 UTC (rev 2094) @@ -56,8 +56,13 @@ (not (equal "" href))) (html ((:base "href" href))))) +(defun get-sqm-price (currency) + (ecase (make-keyword-from-string currency) + (:eur 3) + (:dkk 24))) + (define-bknr-tag buy-sqm (&key children) - (with-template-vars (numsqm numsqm1 action gift donationcert-yearly download-only) + (with-template-vars (currency numsqm numsqm1 action gift donationcert-yearly download-only) (let* ((numsqm (parse-integer (or numsqm numsqm1))) ;; Wer ueber dieses Formular bestellt, ist ein neuer Sponsor, ;; also ein neues Sponsorenobjekt anlegen. Eine Profil-ID @@ -70,7 +75,8 @@ (manual-transfer (or (scan #?r"rweisen" action) (scan #?r"rweisung" action))) (sponsor (make-sponsor)) - (price (* numsqm 3)) + (currency (or currency "EUR")) + (price (* numsqm (get-sqm-price currency))) (contract (make-contract sponsor numsqm :download-only download-only :expires (+ (if manual-transfer @@ -80,15 +86,17 @@ (language (session-variable :language))) (setf (get-template-var :worldpay-url) (if manual-transfer - (format nil "ueberweisung?contract-id=~A&amount=~A&numsqm=~A~@[&donationcert-yearly=1~]" + (format nil "ueberweisung?contract-id=~A¤cy=~A&amount=~A&numsqm=~A~@[&donationcert-yearly=1~]" (store-object-id contract) + currency price numsqm donationcert-yearly) - (format nil "https://select.worldpay.com/wcc/purchase?instId=~A&cartId=~A&amount=~A¤cy=EUR&lang=~A&desc=~A&MC_sponsorid=~A&MC_password=~A&MC_donationcert-yearly=~A&MC_gift=~A~@[~A~]" + (format nil "https://select.worldpay.com/wcc/purchase?instId=~A&cartId=~A&amount=~A¤cy=~A&lang=~A&desc=~A&MC_sponsorid=~A&MC_password=~A&MC_donationcert-yearly=~A&MC_gift=~A~@[~A~]" *worldpay-installation-id* (store-object-id contract) price + currency language (encode-urlencoded (format nil "~A ~A in Samboja Lestari" numsqm Modified: branches/grin-neu/projects/mah-jongg/src/game.lisp =================================================================== --- branches/grin-neu/projects/mah-jongg/src/game.lisp 2006-12-01 10:37:34 UTC (rev 2093) +++ branches/grin-neu/projects/mah-jongg/src/game.lisp 2006-12-01 10:39:49 UTC (rev 2094) @@ -142,5 +142,6 @@ (make-instance 'store :directory "../datastore/") (publish :path "/game" :function 'handle-game) - (publish-directory :prefix "/" :destination "../website/") + (publish-directory :prefix "/" + :destination #-sbcl "../website/" #+sbcl (namestring (merge-pathnames "../website/" *default-pathname-defaults*))) (start :port port)) \ No newline at end of file Modified: branches/grin-neu/projects/mah-jongg/website/game.xsl =================================================================== --- branches/grin-neu/projects/mah-jongg/website/game.xsl 2006-12-01 10:37:34 UTC (rev 2093) +++ branches/grin-neu/projects/mah-jongg/website/game.xsl 2006-12-01 10:39:49 UTC (rev 2094) @@ -79,7 +79,7 @@
@@ -72,21 +73,21 @@
- 1 m?? regnskov [3 Euro/24 Kroner], + 1 m?? regnskov [24 Kroner],

- 5 m?? regnskov [15 Euro/120 Kroner], + 5 m?? regnskov [120 Kroner],

- 10 m?? regnskov [30 Euro/240 Kroner], + 10 m?? regnskov [240 Kroner],

- 30 m?? regnskov [90 Euro/720 Kroner], + 30 m?? regnskov [720 Kroner],

or - m?? [3 Euro/24 Kroner stk]. + m?? [24 Kroner stk].

- + Modified: branches/grin-neu/site/svn-config =================================================================== --- branches/grin-neu/site/svn-config 2006-12-01 10:37:34 UTC (rev 2093) +++ branches/grin-neu/site/svn-config 2006-12-01 10:39:49 UTC (rev 2094) @@ -61,7 +61,7 @@ [miscellany] ### Set global-ignores to a set of whitespace-delimited globs ### which Subversion will ignore in its 'status' output. -global-ignores = *.o *.lo *.la #*# .*.rej *.rej .*~ *~ .#* .DS_Store *.x86f datastore *.core datastore +global-ignores = *.o *.lo *.la #*# .*.rej *.rej .*~ *~ .#* .DS_Store *.x86f datastore *.core datastore *.fasl ### Set log-encoding to the default encoding for log messages log-encoding = latin1 ### Set use-commit-times to make checkout/update/switch/revert Modified: branches/grin-neu/thirdparty/cl-ppcre/CHANGELOG =================================================================== --- branches/grin-neu/thirdparty/cl-ppcre/CHANGELOG 2006-12-01 10:37:34 UTC (rev 2093) +++ branches/grin-neu/thirdparty/cl-ppcre/CHANGELOG 2006-12-01 10:39:49 UTC (rev 2094) @@ -1,3 +1,30 @@ +Version 1.2.18 +2006-10-12 +Changed default element type for LispWorks +Fixed documentation for REGEX-REPLACE-ALL + +Version 1.2.17 +2006-10-11 +Fixed bug in DO-SCANS which affected anchors (caught by RegexCoach user Laurent Taupiac) +Update link for 'man perlre' (thanks to Ricardo Boccato Alves) + +Version 1.2.16 +2006-07-16 +Added :ELEMENT-TYPE to REGEX-REPLACE(-ALL) + +Version 1.2.15 +2006-07-03 +Added :REGEX tag to parse tree syntax (thanks to Fr?d?ric Jolliton) + +Version 1.2.14 +2006-05-24 +Added missing tag in docs (thanks to Wojciech Kaczmarek) +Fixed IMPORT statement for LW + +Version 1.2.13 +2005-12-06 +Fixed bug involving *REAL-START-POS* (caught by "tichy") + Version 1.2.12 2005-11-01 REGEX-APROPOS-AUX now also uses :INHERITED Modified: branches/grin-neu/thirdparty/cl-ppcre/api.lisp =================================================================== --- branches/grin-neu/thirdparty/cl-ppcre/api.lisp 2006-12-01 10:37:34 UTC (rev 2093) +++ branches/grin-neu/thirdparty/cl-ppcre/api.lisp 2006-12-01 10:39:49 UTC (rev 2094) @@ -1,9 +1,9 @@ ;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-PPCRE; Base: 10 -*- -;;; $Header: /usr/local/cvsrep/cl-ppcre/api.lisp,v 1.60 2005/11/01 09:51:01 edi Exp $ +;;; $Header: /usr/local/cvsrep/cl-ppcre/api.lisp,v 1.70 2006/10/12 06:24:41 edi Exp $ ;;; The external API for creating and using scanners. -;;; Copyright (c) 2002-2005, Dr. Edmund Weitz. All rights reserved. +;;; Copyright (c) 2002-2006, Dr. Edmund Weitz. All rights reserved. ;;; Redistribution and use in source and binary forms, with or without ;;; modification, are permitted provided that the following conditions @@ -185,6 +185,7 @@ single-line-mode extended-mode destructive) + (declare #.*standard-optimize-settings*) (declare (ignore destructive)) (when (or case-insensitive-mode multi-line-mode single-line-mode extended-mode) (signal-ppcre-invocation-error @@ -197,6 +198,7 @@ single-line-mode extended-mode destructive) + (declare #.*standard-optimize-settings*) (declare (ignore destructive)) (excl:compile-re parse-tree :case-fold case-insensitive-mode @@ -205,19 +207,22 @@ :single-line single-line-mode :return :index)) -(defgeneric scan (regex target-string &key start end) +(defgeneric scan (regex target-string &key start end real-start-pos) (:documentation "Searches TARGET-STRING from START to END and tries -to match REGEX. On success returns four values - the start of the +to match REGEX. On success returns four values - the start of the match, the end of the match, and two arrays denoting the beginnings -and ends of register matches. On failure returns NIL. REGEX can be a +and ends of register matches. On failure returns NIL. REGEX can be a string which will be parsed according to Perl syntax, a parse tree, or -a pre-compiled scanner created by CREATE-SCANNER. TARGET-STRING will -be coerced to a simple string if it isn't one already.")) +a pre-compiled scanner created by CREATE-SCANNER. TARGET-STRING will +be coerced to a simple string if it isn't one already. The +REAL-START-POS parameter should be ignored - it exists only for +internal purposes.")) #-:use-acl-regexp2-engine (defmethod scan ((regex-string string) target-string &key (start 0) - (end (length target-string))) + (end (length target-string)) + ((:real-start-pos *real-start-pos*) nil)) (declare #.*standard-optimize-settings*) ;; note that the scanners are optimized for simple strings so we ;; have to coerce TARGET-STRING into one if it isn't already @@ -228,7 +233,8 @@ #-:use-acl-regexp2-engine (defmethod scan ((scanner function) target-string &key (start 0) - (end (length target-string))) + (end (length target-string)) + ((:real-start-pos *real-start-pos*) nil)) (declare #.*standard-optimize-settings*) (funcall scanner (maybe-coerce-to-simple-string target-string) @@ -237,7 +243,8 @@ #-:use-acl-regexp2-engine (defmethod scan ((parse-tree t) target-string &key (start 0) - (end (length target-string))) + (end (length target-string)) + ((:real-start-pos *real-start-pos*) nil)) (declare #.*standard-optimize-settings*) (funcall (create-scanner parse-tree) (maybe-coerce-to-simple-string target-string) @@ -249,7 +256,9 @@ #+:use-acl-regexp2-engine (defmethod scan ((parse-tree t) target-string &key (start 0) - (end (length target-string))) + (end (length target-string)) + ((:real-start-pos *real-start-pos*) nil)) + (declare #.*standard-optimize-settings*) (when (< end start) (return-from scan nil)) (let ((results (multiple-value-list (excl:match-re parse-tree target-string @@ -274,9 +283,8 @@ (define-compiler-macro scan (&whole form &environment env regex target-string &rest rest) "Make sure that constant forms are compiled into scanners at compile time." (cond ((constantp regex env) - `(scan (load-time-value - (create-scanner ,regex)) - ,target-string , at rest)) + `(scan (load-time-value (create-scanner ,regex)) + ,target-string , at rest)) (t form))) (defun scan-to-strings (regex target-string &key (start 0) @@ -309,8 +317,7 @@ (&whole form &environment env regex target-string &rest rest) "Make sure that constant forms are compiled into scanners at compile time." (cond ((constantp regex env) - `(scan-to-strings (load-time-value - (create-scanner ,regex)) + `(scan-to-strings (load-time-value (create-scanner ,regex)) ,target-string , at rest)) (t form))) @@ -371,7 +378,6 @@ ;; the NIL BLOCK to enable exits via (RETURN ...) `(block nil (let* ((,%start (or ,start 0)) - (*real-start-pos* ,%start) (,%end (or ,end (length ,target-string))) ,@(unless (constantp regex env) ;; leave constant regular expressions as they are - @@ -397,7 +403,8 @@ (,match-start ,match-end ,reg-starts ,reg-ends) (scan ,(cond ((constantp regex env) regex) (t scanner)) - ,target-string :start ,%start :end ,%end) + ,target-string :start ,%start :end ,%end + :real-start-pos (or ,start 0)) ;; declare the variables to be IGNORABLE to prevent the ;; compiler from issuing warnings (declare @@ -523,8 +530,7 @@ "Make sure that constant forms are compiled into scanners at compile time." (cond ((constantp regex env) - `(all-matches (load-time-value - (create-scanner ,regex)) + `(all-matches (load-time-value (create-scanner ,regex)) , at rest)) (t form))) @@ -548,9 +554,8 @@ compile time." (cond ((constantp regex env) `(all-matches-as-strings - (load-time-value - (create-scanner ,regex)) - , at rest)) + (load-time-value (create-scanner ,regex)) + , at rest)) (t form))) (defun split (regex target-string @@ -628,8 +633,7 @@ (define-compiler-macro split (&whole form &environment env regex target-string &rest rest) "Make sure that constant forms are compiled into scanners at compile time." (cond ((constantp regex env) - `(split (load-time-value - (create-scanner ,regex)) + `(split (load-time-value (create-scanner ,regex)) ,target-string , at rest)) (t form))) @@ -751,14 +755,17 @@ #-:cormanlisp (defmethod build-replacement-template ((replacement-function function)) + (declare #.*standard-optimize-settings*) (list replacement-function)) #-:cormanlisp (defmethod build-replacement-template ((replacement-function-symbol symbol)) + (declare #.*standard-optimize-settings*) (list replacement-function-symbol)) #-:cormanlisp (defmethod build-replacement-template ((replacement-list list)) + (declare #.*standard-optimize-settings*) replacement-list) ;;; Corman Lisp's methods can't be closures... :( @@ -816,17 +823,18 @@ start end match-start match-end reg-starts reg-ends - simple-calls) + simple-calls + element-type) (declare #.*standard-optimize-settings*) "Accepts a replacement template and the current values from the matching process in REGEX-REPLACE or REGEX-REPLACE-ALL and returns the -corresponding template." +corresponding string." ;; the upper exclusive bound of the register numbers in the regular ;; expression (let ((reg-bound (if reg-starts (array-dimension reg-starts 0) 0))) - (with-output-to-string (s) + (with-output-to-string (s nil :element-type element-type) (loop for token in replacement-template do (typecase token (string @@ -901,8 +909,8 @@ reg-starts reg-ends))) s))))))))) -(defun replace-aux (target-string replacement pos-list reg-list - start end preserve-case simple-calls) +(defun replace-aux (target-string replacement pos-list reg-list start end + preserve-case simple-calls element-type) (declare #.*standard-optimize-settings*) "Auxiliary function used by REGEX-REPLACE and REGEX-REPLACE-ALL. POS-LIST contains a list with the start and end @@ -910,7 +918,7 @@ representing the corresponding register start and end positions." ;; build the template once before we start the loop (let ((replacement-template (build-replacement-template replacement))) - (with-output-to-string (s) + (with-output-to-string (s nil :element-type element-type) ;; loop through all matches and take the start and end of the ;; whole string into account (loop for (from to) on (append (list start) pos-list (list end)) @@ -925,7 +933,8 @@ start end from to reg-starts reg-ends - simple-calls) + simple-calls + element-type) nil) while to if replace @@ -946,7 +955,8 @@ &key (start 0) (end (length target-string)) preserve-case - simple-calls) + simple-calls + (element-type #+:lispworks 'lw:simple-char #-:lispworks 'character)) (declare #.*standard-optimize-settings*) "Try to match TARGET-STRING between START and END against REGEX and replace the first match with REPLACEMENT. @@ -973,14 +983,17 @@ If PRESERVE-CASE is true, the replacement will try to preserve the case (all upper case, all lower case, or capitalized) of the match. The result will always be a fresh string, even if REGEX doesn't -match." +match. + + ELEMENT-TYPE is the element type of the resulting string." (multiple-value-bind (match-start match-end reg-starts reg-ends) (scan regex target-string :start start :end end) (if match-start (replace-aux target-string replacement (list match-start match-end) (list reg-starts reg-ends) - start end preserve-case simple-calls) + start end preserve-case + simple-calls element-type) (subseq target-string start end)))) #-:cormanlisp @@ -988,8 +1001,7 @@ (&whole form &environment env regex target-string replacement &rest rest) "Make sure that constant forms are compiled into scanners at compile time." (cond ((constantp regex env) - `(regex-replace (load-time-value - (create-scanner ,regex)) + `(regex-replace (load-time-value (create-scanner ,regex)) ,target-string ,replacement , at rest)) (t form))) @@ -997,7 +1009,8 @@ &key (start 0) (end (length target-string)) preserve-case - simple-calls) + simple-calls + (element-type #+:lispworks 'lw:simple-char #-:lispworks 'character)) (declare #.*standard-optimize-settings*) "Try to match TARGET-STRING between START and END against REGEX and replace all matches with REPLACEMENT. @@ -1024,7 +1037,9 @@ If PRESERVE-CASE is true, the replacement will try to preserve the case (all upper case, all lower case, or capitalized) of the match. The result will always be a fresh string, even if REGEX doesn't -match." +match. + + ELEMENT-TYPE is the element type of the resulting string." (let ((pos-list '()) (reg-list '())) (do-scans (match-start match-end reg-starts reg-ends regex target-string @@ -1038,7 +1053,8 @@ (replace-aux target-string replacement (nreverse pos-list) (nreverse reg-list) - start end preserve-case simple-calls) + start end preserve-case + simple-calls element-type) (subseq target-string start end)))) #-:cormanlisp @@ -1046,8 +1062,7 @@ (&whole form &environment env regex target-string replacement &rest rest) "Make sure that constant forms are compiled into scanners at compile time." (cond ((constantp regex env) - `(regex-replace-all (load-time-value - (create-scanner ,regex)) + `(regex-replace-all (load-time-value (create-scanner ,regex)) ,target-string ,replacement , at rest)) (t form))) @@ -1148,8 +1163,8 @@ (push (format nil "[constant]~:[~; value: ~S~]" (boundp symbol) (symbol-value symbol)) output-list)) ((boundp symbol) - (push #+(or LispWorks CLISP) "[variable]" - #-(or LispWorks CLISP) (format nil "[variable] value: ~S" + (push #+(or :lispworks :clisp) "[variable]" + #-(or :lispworks :clisp) (format nil "[variable] value: ~S" (symbol-value symbol)) output-list))) #-(or :cormanlisp :clisp) Modified: branches/grin-neu/thirdparty/cl-ppcre/cl-ppcre-test.asd =================================================================== --- branches/grin-neu/thirdparty/cl-ppcre/cl-ppcre-test.asd 2006-12-01 10:37:34 UTC (rev 2093) +++ branches/grin-neu/thirdparty/cl-ppcre/cl-ppcre-test.asd 2006-12-01 10:39:49 UTC (rev 2094) @@ -1,9 +1,9 @@ ;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- -;;; $Header: /usr/local/cvsrep/cl-ppcre/cl-ppcre-test.asd,v 1.8 2005/11/01 09:51:01 edi Exp $ +;;; $Header: /usr/local/cvsrep/cl-ppcre/cl-ppcre-test.asd,v 1.12 2006/10/11 15:41:42 edi Exp $ ;;; This ASDF system definition was kindly provided by Marco Baringer. -;;; Copyright (c) 2002-2005, Dr. Edmund Weitz. All rights reserved. +;;; Copyright (c) 2002-2006, Dr. Edmund Weitz. All rights reserved. ;;; Redistribution and use in source and binary forms, with or without ;;; modification, are permitted provided that the following conditions @@ -29,13 +29,6 @@ ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -(defpackage #:cl-ppcre-test.system - (:use #:cl - #:asdf)) - -(in-package #:cl-ppcre-test.system) - -(defsystem #:cl-ppcre-test - :version "1.2.12" - :depends-on (#:cl-ppcre) +(asdf:defsystem :cl-ppcre-test + :depends-on (:cl-ppcre) :components ((:file "ppcre-tests"))) Modified: branches/grin-neu/thirdparty/cl-ppcre/cl-ppcre-test.system =================================================================== --- branches/grin-neu/thirdparty/cl-ppcre/cl-ppcre-test.system 2006-12-01 10:37:34 UTC (rev 2093) +++ branches/grin-neu/thirdparty/cl-ppcre/cl-ppcre-test.system 2006-12-01 10:39:49 UTC (rev 2094) @@ -1,7 +1,7 @@ ;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- -;;; $Header: /usr/local/cvsrep/cl-ppcre/cl-ppcre-test.system,v 1.9 2005/04/01 21:29:09 edi Exp $ +;;; $Header: /usr/local/cvsrep/cl-ppcre/cl-ppcre-test.system,v 1.10 2006/01/03 18:38:55 edi Exp $ -;;; Copyright (c) 2002-2005, Dr. Edmund Weitz. All rights reserved. +;;; Copyright (c) 2002-2006, Dr. Edmund Weitz. All rights reserved. ;;; Redistribution and use in source and binary forms, with or without ;;; modification, are permitted provided that the following conditions Modified: branches/grin-neu/thirdparty/cl-ppcre/cl-ppcre.asd =================================================================== --- branches/grin-neu/thirdparty/cl-ppcre/cl-ppcre.asd 2006-12-01 10:37:34 UTC (rev 2093) +++ branches/grin-neu/thirdparty/cl-ppcre/cl-ppcre.asd 2006-12-01 10:39:49 UTC (rev 2094) @@ -1,9 +1,9 @@ ;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- -;;; $Header: /usr/local/cvsrep/cl-ppcre/cl-ppcre.asd,v 1.12 2005/11/01 09:51:01 edi Exp $ +;;; $Header: /usr/local/cvsrep/cl-ppcre/cl-ppcre.asd,v 1.21 2006/10/12 06:24:41 edi Exp $ ;;; This ASDF system definition was kindly provided by Marco Baringer. -;;; Copyright (c) 2002-2005, Dr. Edmund Weitz. All rights reserved. +;;; Copyright (c) 2002-2006, Dr. Edmund Weitz. All rights reserved. ;;; Redistribution and use in source and binary forms, with or without ;;; modification, are permitted provided that the following conditions @@ -29,14 +29,8 @@ ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -(defpackage #:cl-ppcre.system - (:use #:cl - #:asdf)) - -(in-package #:cl-ppcre.system) - -(defsystem #:cl-ppcre - :version "1.2.12" +(asdf:defsystem :cl-ppcre + :version "1.2.18" :serial t :components ((:file "packages") (:file "specials") Modified: branches/grin-neu/thirdparty/cl-ppcre/cl-ppcre.system =================================================================== --- branches/grin-neu/thirdparty/cl-ppcre/cl-ppcre.system 2006-12-01 10:37:34 UTC (rev 2093) +++ branches/grin-neu/thirdparty/cl-ppcre/cl-ppcre.system 2006-12-01 10:39:49 UTC (rev 2094) @@ -1,7 +1,7 @@ ;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- -;;; $Header: /usr/local/cvsrep/cl-ppcre/cl-ppcre.system,v 1.11 2005/04/01 21:29:09 edi Exp $ +;;; $Header: /usr/local/cvsrep/cl-ppcre/cl-ppcre.system,v 1.12 2006/01/03 18:38:55 edi Exp $ -;;; Copyright (c) 2002-2005, Dr. Edmund Weitz. All rights reserved. +;;; Copyright (c) 2002-2006, Dr. Edmund Weitz. All rights reserved. ;;; Redistribution and use in source and binary forms, with or without ;;; modification, are permitted provided that the following conditions Modified: branches/grin-neu/thirdparty/cl-ppcre/closures.lisp =================================================================== --- branches/grin-neu/thirdparty/cl-ppcre/closures.lisp 2006-12-01 10:37:34 UTC (rev 2093) +++ branches/grin-neu/thirdparty/cl-ppcre/closures.lisp 2006-12-01 10:39:49 UTC (rev 2094) @@ -1,10 +1,10 @@ ;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-PPCRE; Base: 10 -*- -;;; $Header: /usr/local/cvsrep/cl-ppcre/closures.lisp,v 1.29 2005/05/16 16:29:23 edi Exp $ +;;; $Header: /usr/local/cvsrep/cl-ppcre/closures.lisp,v 1.32 2006/10/11 15:41:42 edi Exp $ ;;; Here we create the closures which together build the final ;;; scanner. -;;; Copyright (c) 2002-2005, Dr. Edmund Weitz. All rights reserved. +;;; Copyright (c) 2002-2006, Dr. Edmund Weitz. All rights reserved. ;;; Redistribution and use in source and binary forms, with or without ;;; modification, are permitted provided that the following conditions @@ -63,6 +63,7 @@ such that the call to NEXT-FN after the match would succeed.")) (defmethod create-matcher-aux ((seq seq) next-fn) + (declare #.*standard-optimize-settings*) ;; the closure for a SEQ is a chain of closures for the elements of ;; this sequence which call each other in turn; the last closure ;; calls NEXT-FN @@ -72,6 +73,7 @@ finally (return next-matcher))) (defmethod create-matcher-aux ((alternation alternation) next-fn) + (declare #.*standard-optimize-settings*) ;; first create closures for all alternations of ALTERNATION (let ((all-matchers (mapcar #'(lambda (choice) (create-matcher-aux choice next-fn)) @@ -84,6 +86,7 @@ thereis (funcall (the function matcher) start-pos))))) (defmethod create-matcher-aux ((register register) next-fn) + (declare #.*standard-optimize-settings*) ;; the position of this REGISTER within the whole regex; we start to ;; count at 0 (let ((num (num register))) @@ -122,6 +125,7 @@ next-pos))))))) (defmethod create-matcher-aux ((lookahead lookahead) next-fn) + (declare #.*standard-optimize-settings*) ;; create a closure which just checks for the inner regex and ;; doesn't care about NEXT-FN (let ((test-matcher (create-matcher-aux (regex lookahead) #'identity))) @@ -139,6 +143,7 @@ (funcall next-fn start-pos)))))) (defmethod create-matcher-aux ((lookbehind lookbehind) next-fn) + (declare #.*standard-optimize-settings*) (let ((len (len lookbehind)) ;; create a closure which just checks for the inner regex and ;; doesn't care about NEXT-FN @@ -275,6 +280,7 @@ `(gethash ,chr-expr hash))))))))) (defmethod create-matcher-aux ((char-class char-class) next-fn) + (declare #.*standard-optimize-settings*) (declare (type function next-fn)) ;; insert a test against the current character within *STRING* (insert-char-class-tester (char-class (schar *string* start-pos)) @@ -291,6 +297,7 @@ (funcall next-fn (1+ start-pos))))))) (defmethod create-matcher-aux ((str str) next-fn) + (declare #.*standard-optimize-settings*) (declare (type fixnum *end-string-pos*) (type function next-fn) ;; this special value is set by CREATE-SCANNER when the @@ -405,6 +412,7 @@ (word-char-p (schar *string* start-pos))))))) (defmethod create-matcher-aux ((word-boundary word-boundary) next-fn) + (declare #.*standard-optimize-settings*) (declare (type function next-fn)) (if (negatedp word-boundary) (lambda (start-pos) @@ -415,6 +423,7 @@ (funcall next-fn start-pos))))) (defmethod create-matcher-aux ((everything everything) next-fn) + (declare #.*standard-optimize-settings*) (declare (type function next-fn)) (if (single-line-p everything) ;; closure for single-line-mode: we really match everything, so we @@ -432,11 +441,12 @@ (funcall next-fn (1+ start-pos)))))) (defmethod create-matcher-aux ((anchor anchor) next-fn) + (declare #.*standard-optimize-settings*) (declare (type function next-fn)) (let ((startp (startp anchor)) (multi-line-p (multi-line-p anchor))) (cond ((no-newline-p anchor) - ;; this must be and end-anchor and it must be modeless, so + ;; this must be an end-anchor and it must be modeless, so ;; we just have to check whether START-POS equals ;; *END-POS* (lambda (start-pos) @@ -486,6 +496,7 @@ (funcall next-fn start-pos))))))) (defmethod create-matcher-aux ((back-reference back-reference) next-fn) + (declare #.*standard-optimize-settings*) (declare (type function next-fn)) ;; the position of the corresponding REGISTER within the whole ;; regex; we start to count at 0 @@ -525,6 +536,7 @@ (funcall next-fn next-pos))))))))) (defmethod create-matcher-aux ((branch branch) next-fn) + (declare #.*standard-optimize-settings*) (let* ((test (test branch)) (then-matcher (create-matcher-aux (then-regex branch) next-fn)) (else-matcher (create-matcher-aux (else-regex branch) next-fn))) @@ -545,6 +557,7 @@ (funcall else-matcher start-pos)))))))) (defmethod create-matcher-aux ((standalone standalone) next-fn) + (declare #.*standard-optimize-settings*) (let ((inner-matcher (create-matcher-aux (regex standalone) #'identity))) (declare (type function next-fn inner-matcher)) (lambda (start-pos) @@ -553,6 +566,7 @@ (funcall next-fn next-pos)))))) (defmethod create-matcher-aux ((filter filter) next-fn) + (declare #.*standard-optimize-settings*) (let ((fn (fn filter))) (lambda (start-pos) (let ((next-pos (funcall fn start-pos))) @@ -560,5 +574,6 @@ (funcall next-fn next-pos)))))) (defmethod create-matcher-aux ((void void) next-fn) + (declare #.*standard-optimize-settings*) ;; optimize away VOIDs: don't create a closure, just return NEXT-FN next-fn) Modified: branches/grin-neu/thirdparty/cl-ppcre/convert.lisp =================================================================== --- branches/grin-neu/thirdparty/cl-ppcre/convert.lisp 2006-12-01 10:37:34 UTC (rev 2093) +++ branches/grin-neu/thirdparty/cl-ppcre/convert.lisp 2006-12-01 10:39:49 UTC (rev 2094) @@ -1,11 +1,11 @@ ;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-PPCRE; Base: 10 -*- -;;; $Header: /usr/local/cvsrep/cl-ppcre/convert.lisp,v 1.22 2005/04/01 21:29:09 edi Exp $ +;;; $Header: /usr/local/cvsrep/cl-ppcre/convert.lisp,v 1.24 2006/07/03 11:16:48 edi Exp $ ;;; Here the parse tree is converted into its internal representation ;;; using REGEX objects. At the same time some optimizations are ;;; already applied. -;;; Copyright (c) 2002-2005, Dr. Edmund Weitz. All rights reserved. +;;; Copyright (c) 2002-2006, Dr. Edmund Weitz. All rights reserved. ;;; Redistribution and use in source and binary forms, with or without ;;; modification, are permitted provided that the following conditions @@ -544,6 +544,10 @@ :num (1- backref-number) :case-insensitive-p (case-insensitive-mode-p flags)))) + ;; (:REGEX ) + ((:regex) + (let ((regex (second parse-tree))) + (convert-aux (parse-string regex)))) ;; (:CHAR-CLASS|:INVERTED-CHAR-CLASS {}*) ;; where item is one of ;; - a character Modified: branches/grin-neu/thirdparty/cl-ppcre/doc/index.html =================================================================== --- branches/grin-neu/thirdparty/cl-ppcre/doc/index.html 2006-12-01 10:37:34 UTC (rev 2093) +++ branches/grin-neu/thirdparty/cl-ppcre/doc/index.html 2006-12-01 10:39:49 UTC (rev 2094) @@ -3,7 +3,7 @@ - CL-PPCRE - portable Perl-compatible regular expressions for Common Lisp + CL-PPCRE - Portable Perl-compatible regular expressions for Common Lisp + + +

Closure XML Parser

An XML parser written in Common Lisp.

@@ -47,62 +74,79 @@ (SAX layer; namespace support)
  • - David Lichteblau at knowledgeTools (david at knowledgetools.de)
    + David Lichteblau for knowledgeTools (conversion into an independent package; DOM bug fixing; validation) + and headcraft + (most september/october 2004 changes) and privately (changes + since then).
  • - Mailing list cxml-devel - is hosted on common-lisp.net. + CXML implements a namespace-aware, + validating SAX-like XML 1.0 + parser as well as the DOM Level 2 Core + interfaces.

    -

    Download

    - Get a tarball. + CXML is licensed under Lisp-LGPL.

    +

    - David's tla archive is at http://www.common-lisp.net/project/cxml/david at knowledgetools.de--cxml/. - (Brief tla usage instructions: Unpack the cxml tarball.  - Enter tla register-archive URL to turn it into a working - copy.  tla update is similar to cvs up.) + Send bug reports to cxml-devel at common-lisp.net + (list + information).

    -

    Contents

    - -

    Recent Changes

    -

    patch-xyz (2004-xx-yy)

    +

    rel-2006-xx-yy

      +
    • Serialization fixes (thanks to Nathan Bird, Donavon Keithley).
    • +
    • characters.lisp cleanup (thanks to Nathan Bird).
    • +
    • Namespace normalizer bugfixes.
    • +
    • Minor changes: clone-node on document as an extension. DOM + class hierarchy reworked. New function parse-empty-document. + Fixed the DOM serializer to not throw away local names. + Fixed a long-standing bug in the parser for documents without a + doctype. ANSI conformance fixes.
    • +
    +

    rel-2006-01-05

    +
      +
    • Implemented DOM 2 Core.
    • +
    • Error handling overhaul.
    • +
    • UTF-8 string support in DOM on Lisps without Unicode characters.
    • +
    • Sink API has been changed.
    • +
    • Support internal subset serialization.
    • +
    • Whitespace normalizer.
    • +
    • Gilbert Baumann has clarified the license as Lisp-LGPL.
    • +
    • Use trivial-gray-streams.
    • +
    +

    rel-2005-06-25

    +
      +
    • Port to OpenMCL (thanks to Rudi Schlatte).
    • +
    • Port to LispWorks (thanks to Edi Weitz).
    • +
    • Minor new features: include-default-values argument to + make-xmls-builder; handler argument + to parse-dtd-stream; SAX proxy class
    • +
    • Various bugfixes.
    • +
    +

    patch-357 (2004-10-10)

    +
    • Auto-detect unicode support for better asdf-installability.
    • Use the puri library for Sys-ID handling.
    • Semi-automatic caching of DTD instances.
    • Support user-defined entity resolvers.
    • Support for Oasis XML Catalogs.
    • +
    • xhtmlgen version of Franz htmlgen.
    • +
    • Fixes for SBCL's unicode support.

    patch-306 (2004-09-03)

      @@ -125,111 +169,14 @@
    • Initial release.
    -
    -

    CXML Modules

    -

    CXML provides three packages:

    -
    - - -

    Installation

    -

    - CXML should be portable to all Common Lisp implementations - supporting gray streams.  Currently assumed to work are ACL, - SBCL, CMUCL, and CLISP.  (CLISP needs to be run with an - option like -E iso-8869-1 teaching it to accept cxml's - non-ASCII source files.) -

    - -

    - Optional configuration (skip this unless you know better): CXML - has full Unicode code support -- even on Lisps without Unicode - strings. On non-unicode aware Lisps, DOMString is - implemented as an array of character codes. CXML will auto-detect - at compile-time which string representation to use. To override - the auto-detection, you can set one of the features - :rune-is-character and :rune-is-octet before - loading cxml.asd. -

    - -

    - ASDF is used for - compilation. The following instructions assume that ASDF has - already been loaded. -

    - -

    - Prerequisites. - CXML needs the puri library. -

    - -

    - Compiling and loading CXML. - Register the .asd file, e.g. by symlinking it: -

    -
    $ ln -sf `pwd`/cxml.asd /path/to/your/registry/
    -

    Then compile CXML using:

    -
    * (asdf:operate 'asdf:load-op :cxml)
    - -

    - You can then try the quick-start example. -

    - - -

    Tests

    -

    Check out the XML and DOM testsuites:

    -
    $ export CVSROOT=:pserver:anonymous at dev.w3.org:/sources/public
    -$ cvs login    # password is "anonymous"
    -$ cvs co 2001/XML-Test-Suite/xmlconf
    -$ cvs co 2001/DOM-Test-Suite
    -

    Usage and expected output:

    -
    * (xmlconf:run-all-tests "/path/to/2001/XML-Test-Suite/xmlconf/")
    -0/556 tests failed; 1606 tests were skipped
    -* (domtest:run-all-tests "/path/to/2001/DOM-Test-Suite/")
    -0/450 tests failed; 71 tests were skipped
    - -

    - fixme: Add an explanation of xml/sax-tests here. -

    - -

    - fixme My parser does not understand the current testsuite - anymore.  To fix this problem, revert the affected files - manually after check-out: -

    - -
    $ cd 2001/XML-Test-Suite/xmlconf/
    -xmltest$ patch -p0 -R </path/to/cxml/test/xmlconf-base.diff
    - -

    - The log message for the changes reads "Removed unnecessary - xml:base attribute".  If I understand correctly, only - DOM 3 parsers provide the baseURI attribute necessary for - understanding xmlconf.xml now.  We don't have that - yet. -

    - + -
    -

    Using CXML

    - -
    -

    Quick-Start Example

    - -

    - Make sure to install and load cxml first. -

    - -

    Create a test file called example.xml:

    -
    * (with-open-file (s "example.xml" :direction :output)
    -    (write-string "<test a='b'><child/></test>" s))
    - -

    Parse example.xml into a DOM tree (read - more):

    -
    * (cxml:parse-file "example.xml" (dom:make-dom-builder))
    -#<DOM-IMPL::DOCUMENT @ #x72206172>
    -;; save result for later:
    -* (defparameter *example* *)
    -*EXAMPLE*
    - -

    Inspect the DOM tree (read more):

    -
    * (dom:document-element *example*)
    -#<DOM-IMPL::ELEMENT test @ #x722b6ba2>
    -* (dom:tag-name (dom:document-element *example*))
    -"test"
    -* (dom:child-nodes (dom:document-element *example*))
    -#(#<DOM-IMPL::ELEMENT child @ #x722b6d8a>)
    -* (dom:get-attribute (dom:document-element *example*) "a")
    -"b"
    - -

    Serialize the DOM document back into a stream (read more):

    -
    (cxml:unparse-document *example* *standard-output*)
    -<test a="b"><child></child></test>
    - -

    As an alternative to DOM, parse into xmls-compatible list - structure (read more):

    -
    * (cxml:parse-file "example.xml" (cxml-xmls:make-xmls-builder))
    -("test" (("a" "b")) ("child" NIL))
    - - -

    Parsing and Validating

    -

    -

    Function CXML:PARSE-FILE (pathname handler &key ...)
    -
    Function CXML:PARSE-STREAM (stream handler &key ...)
    -
    Function CXML:PARSE-OCTETS (octets handler &key ...)
    - Parse an XML document.  - Return values from this function depend on the SAX handler used.
    - Arguments: -

    -
      -
    • pathname -- a Common Lisp pathname
    • -
    • stream -- a Common Lisp stream with element-type - (unsigned-byte 8)
    • -
    • octets -- an (unsigned-byte 8) array
    • -
    • handler -- a SAX handler
    • -
    -

    - Common keyword arguments: -

    -
      -
    • - validate -- A boolean.  Defaults to - nil. If true, parse in validating mode, i.e. assert that - the document contains a DOCTYPE declaration and conforms to the - DTD declared. -
    • -
    • - dtd -- unless nil, an extid instance - specifying the external subset to load. This options overrides - the extid specified in the document type declaration, if any. - See below for make-extid. This option is useful - for verification purposes together with the root - and disallow-internal-subset arguments. -
    • -
    • root -- the expected root element - name, or nil (the default). -
    • -
    • - entity-resolver -- nil or a function of two - arguments which is invoked for every entity referenced by the - document with the entity's Public ID (a rod) and System ID (an - URI object) as arguments. The function may either return - nil, CXML will then try to resolve the entity as usual. - Alternatively it may return a Common Lisp stream specialized on - (unsigned-byte 8) which will be used instead. (It may - also signal an error, of course, which can be useful to prohibit - parsed XML documents from including arbitrary files readable by - the parser.) -
    • -
    • - disallow-internal-subset -- a boolean. If true, signal - an error if the document contains an internal subset. -
    • -
    - -

    -

    Function CXML:PARSE-DTD-FILE (pathname)
    -
    Function CXML:PARSE-DTD-STREAM (stream)
    - Parse
    declarations - from a stand-alone file and return an object representing the DTD, - suitable as an argument to validate. -

    -
      -
    • pathname -- a Common Lisp pathname
    • -
    • stream -- a Common Lisp stream with element-type - (unsigned-byte 8)
    • -
    - -

    -

    Function CXML:MAKE-EXTID (publicid systemid)
    - Create an object representing the External ID composed - of the specified Public ID, a rod or nil, and System ID - (an URI object). -

    - -

    -

    Function DOM:MAKE-DOM-BUILDER ()
    - Create a SAX handler which builds a DOM document.  Example: -

    -
    (cxml:parse-file "test.xml" (dom:make-dom-builder))
    - - -

    Serialization

    -

    -

    Function CXML:UNPARSE-DOCUMENT (document stream &rest keys)
    -
    Function CXML:UNPARSE-DOCUMENT-TO-OCTETS (document &rest keys) => vector
    - Serialize a DOM document object. -

    -
      -
    • document -- a DOM document object
    • -
    • stream -- a Common Lisp stream with element-type - character
    • -
    -

    Keyword arguments:

    -
      -
    • - canonical -- canonical form, one of NIL, T, 1, 2 -
    • -
    • - indentation -- indentation level. An integer or nil. -
    • -
    -

    - The following canonical values are allowed: -

    -
    -

    - With an indentation level, pretty-print the XML by - inserting additional whitespace.  Note that indentation - changes the document model and should only be used if whitespace - does not matter to the application. -

    -

    - unparse-document-to-octets returns an (unsigned-byte - 8) array, whereas unparse-document writes - characters.  unparse-document is useful together - with with-output-to-string.  However, note that the - resulting document in both cases is UTF-8 encoded, so the - characters written by unparse-document are really UTF-8 - bytes encoded as characters. -

    - -

    -

    Function CXML:MAKE-CHARACTER-STREAM-SINK (stream &rest keys) => sink
    -
    Function CXML:MAKE-OCTET-VECTOR-SINK (&rest keys) => sink
    - Return a handle suitable for event-based XML serialization. -

    -

    - These function provide the low-level mechanism used by the DOM - serialization functions. To serialize a document without building - its DOM tree first, create a sink handle and call SAX functions on that - handle. sax:end-document returns the serialized form of - the document described by the SAX events. -

    - -

    -

    Macro CXML:WITH-XML-OUTPUT (sink &body body) => vector
    -
    Macro CXML:WITH-ELEMENT (qname &body body) => result
    -
    Function CXML:ATTRIBUTE (name value) => value
    -
    Function CXML:TEXT (data) => data
    -
    Function CXML:CDATA (data) => data
    - Convenience syntax for event-based serialization. -

    -

    - Example: -

    -
    (with-xml-output (make-octet-stream-sink stream :indentation 2 :canonical nil)
    -  (with-element "foo"
    -    (attribute "xyz" "abc")
    -    (with-element "bar"
    -      (attribute "blub" "bla"))
    -    (text "Hi there.")))
    -

    - Prints this to stream, which must be an - (unsigned-byte 8) stream: -

    -
    <foo xyz="abc">
    -  <bar blub="bla"></bar>
    -  Hi there.
    -</foo>
    -

    - (Note that these functions accept both strings and rods, so we - could write "foo" instead of #"foo" above.) -

    - - -

    Miscellaneous Utility Functions

    -

    -

    Function CXML:MAKE-VALIDATOR (dtd root)
    - Create a SAX handler which validates against a DTD instance.  - The document's root element must be named root.  - Used with dom:map-document, this validates a document - object as if by re-reading it with a validating parser, except - that declarations recorded in the document instance are completely - ignored.
    - Example: -

    -
    (let ((d (parse-file "~/test.xml" (dom:make-dom-builder)))
    -      (x (parse-dtd-file "~/test.dtd")))
    -  (dom:map-document (cxml:make-validator x #"foo") d))
    - -

    -

    Function DOM:MAP-DOCUMENT (handler document &key include-xmlns-attributes include-default-values)
    - Traverse a DOM document and call SAX functions as if an XML - representation of the document were processed by a SAX parser. -

    - -
    -

    XMLS Compatibility

    -

    - Like other XML parsers written in Lisp, CXML can work with - documents represented as list structures. The specific model - implemented by cxml is compatible with the xmls parser. Xmls - list structures are a simpler and faster alternative to full DOM - document trees. They also serve as an example showing how to - implement user-defined document models as an independent layer - over the the base parser (c.f. xml/xmls-compat.lisp in - the cxml distribution). However, note that the list structures do - not include all information available in DOM documents and are - sometimes more difficult to work wth since many DOM functions - cannot be implemented on them. -

    -

    -

    Function CXML-XMLS:MAKE-XMLS-BUILDER ()
    - Create a SAX handler which builds XMLS list structures.  - Example: -

    -
    (cxml:parse-file "test.xml" (cxml-xmls:make-xmls-builder))
    -

    -

    Function CXML-XMLS:MAP-NODE (handler node &key include-xmlns-attributes)
    - Traverse an XMLS document/node and call SAX functions as if an XML - representation of the document were processed by a SAX parser. -

    -

    - Use this function to serialize XMLS data. For example, we could - define a replacement for xmls:write-xml like this: -

    -
    (defun write-xml (stream node &key indent)
    -  (let ((sink (cxml:make-character-stream-sink
    -               stream :canonical nil :indentation indent)))
    -    (cxml-xmls:map-node sink node)))
    -

    -

    Function CXML-XMLS:MAKE-NODE (&key name ns attrs - children) => xmls node
    - Build a list node of the form - (name ((name value)*child*). -

    -

    - The node list's car can also be a cons of local name - and namespace prefix ns. - 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 and the namespace URI. We - currently follow the xmls implementation and use the - namespace prefix instead of following its documentation 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. -

    -

    -

    Accessor CXML-XMLS:NODE-NAME (node)
    -
    Accessor CXML-XMLS:NODE-NS (node)
    -
    Accessor CXML-XMLS:NODE-ATTRS (node)
    -
    Accessor CXML-XMLS:NODE-CHILDREN (node)
    - Accessors for xmls node data. -

    -

    -

    - - -

    Dealing with Rods

    -

    - As explained above, the XML parser handles character encoding and - uses 16bit strings internally. Instead of using characters and strings - it uses runes and rods. This is seen as a - feature, but can be inconvenient. -

    -
      -
    • - If your Lisp supports 16 bit unicode strings, use feature - :rune-is-character and forget about runes and rods. - CXML will use ordinary Lisp characters and strings both - internally and externally. -
    • -
    • - If your Lisp does not support such strings and your application - needs Unicode support, use functions defined in the - runes package instead of ordinary string operators. -
    • -
    • - If your Lisp does not support such strings and your application - does not need Unicode support anyway, it will probably be more - convenient to let CXML convert rods into strings automatically. - To do that, use cxml:make-recoder to chain a special - sax handler between the parser and your application handler. - The recoder translates all rods using an application defined - function, which defaults to runes:rod-string. Although - the actual XML parser still uses rods internally, you SAX - handler will only see ordinary Lisp strings. -
    • -
    -

    - Note that the recoder approach does not work with the DOM - builder, since DOM is specified to use UTF-16. -

    -

    -

    Function CXML:MAKE-RECODER (chained-handler &optional recoder-fn)
    - Return a SAX handler which passes all events on to - chained-handler after converting all strings and rods - using recoder-fn, a function of one argument which - defaults to runes:rod-string. -

    -

    - Example. In a Lisp which ordinarily would use octet vector rods: -

    -
    CL-USER(14): (cxml:parse-string "<test/>" (cxml-xmls:make-xmls-builder))
    -(#(116 101 115 116) NIL)
    -

    - Use a SAX recoder to get strings instead:: -

    -
    CL-USER(17): (parse-string "<test/>" (cxml:make-recoder (cxml-xmls:make-xmls-builder)))
    -("test" NIL)
    - -
    -

    Caching of DTD Objects

    -

    - To avoid spending time parsing the same DTD over and over again, - CXML can cache DTD objects. The parser consults - cxml:*dtd-cache* whenever it is looking for an external - subset in a document which does not have an internal subset and - uses the cached DTD instance if one is present in the cache for - the System ID in question. -

    -

    - Note that DTDs do not expire from the cache automatically. - (Future versions of CXML might introduce automatic checks for - outdated DTDs.) -

    -

    -

    Variable CXML:*DTD-CACHE*
    - The DTD cache object consulted by the parser when it needs a DTD. -

    -

    -

    Function CXML:MAKE-DTD-CACHE ()
    - Return a new, empty DTD cache object. -

    -

    -

    Variable CXML:*CACHE-ALL-DTDS*
    - If true, instructs the parser to enter all DTDs that could have - been cached into *dtd-cache* if they were not cached - already. Defaults to nil. -

    -

    -

    Reader CXML:GETDTD (uri dtd-cache)
    - Return a cached instance of the DTD at uri, if present in - the cache, or nil. -

    -

    -

    Writer CXML:GETDTD (uri dtd-cache)
    - Enter a new value for uri into dtd-cache. -

    -

    -

    Function CXML:REMDTD (uri dtd-cache)
    - Ensure that no DTD is recorded for uri in the cache and - return true if such a DTD was present. -

    -

    -

    Function CXML:CLEAR-DTD-CACHE (dtd-cache)
    - Remove all entries from dtd-cache. -

    -

    - fixme: thread-safety -

    - -
    -

    XML Catalogs

    -

    - External entities (for example, DTDs) are referred to using their - Public and System IDs. Usually the System ID, a URI, is used to - locate the entity. CXML itself handles only file://-URIs, but - many System IDs in practical use are http://-URIs. There are two - different mechanims applications can use to allow CXML to locate - entities using arbitrary Public ID or System ID: -

    -
    -

    - This section describes XML Catalogs, the second solution. CXML - implements Oasis - XML Catalogs. -

    -

    -

    Variable CXML:*CATALOG*
    - The XML Catalog object consulted by the parser before trying to - open an entity. Initially nil. -

    -

    -

    Variable CXML:*PREFER*
    - The default "prefer" mode from the Catalog specification, one - of :public or :system. Defaults - to :public. -

    -

    -

    Function CXML:MAKE-CATALOG (&optional uris)
    - Return a catalog object for the catalog files specified. -

    -

    -

    Function CXML:RESOLVE-URI (uri catalog)
    - Look up uri in catalog and return the - resulting URI, or nil if no match was found. -

    -

    -

    Function CXML:RESOLVE-EXTID (publicid systemid catalog)
    - Look up the External ID (publicid, systemid) - in catalog and return the resulting URI, or nil - if no match was found. -

    -

    - Example: -

    -
    * (setf cxml:*catalog* nil)
    -* (cxml:parse-file "test.xhtml" nil)
    -=> Error: URI scheme :HTTP not supported
    -
    -* (setf cxml:*catalog* (cxml:make-catalog))
    -* (cxml:parse-file "test.xhtml" nil)
    -;; no error!
    -NIL
    -

    - Note that parsed catalog files are cached in the catalog object. - Catalog files cached do not expire automatically. To ensure that - all catalog files are parsed again, create a new catalog object. -

    - - -

    SAX Interface

    -

    - A SAX handler is an arbitrary objects that implements some of the - generic functions in the SAX package.  Note that no default - handler class is necessary, because all generic functions have default - methods which do nothing.  SAX functions are: -

    Function SAX:START-DOCUMENT (handler)
    -
    Function SAX:END-DOCUMENT (handler)
    -
    -
    Function SAX:START-ELEMENT (handler namespace-uri local-name qname attributes)
    -
    Function SAX:END-ELEMENT (handler namespace-uri local-name qname)
    -
    Function SAX:START-PREFIX-MAPPING (handler prefix uri)
    -
    Function SAX:END-PREFIX-MAPPING (handler prefix)
    -
    Function SAX:PROCESSING-INSTRUCTION (handler target data)
    -
    Function SAX:COMMENT (handler data)
    -
    Function SAX:START-CDATA (handler)
    -
    Function SAX:END-CDATA (handler)
    -
    Function SAX:CHARACTERS (handler data)
    -
    -
    Function SAX:START-DTD (handler name public-id system-id)
    -
    Function SAX:END-DTD (handler)
    -
    Function SAX:UNPARSED-ENTITY-DECLARATION (handler name public-id system-id notation-name)
    -
    Function SAX:EXTERNAL-ENTITY-DECLARATION (handler kind name public-id system-id)
    -
    Function SAX:INTERNAL-ENTITY-DECLARATION (handler kind name value)
    -
    Function SAX:NOTATION-DECLARATION (handler name public-id system-id)
    -
    Function SAX:ELEMENT-DECLARATION (handler name model)
    -
    Function SAX:ATTRIBUTE-DECLARATION (handler ename aname type default)
    -
    -
    Accessor SAX:ATTRIBUTE-PREFIX (attribute)
    -
    Accessor SAX:ATTRIBUTE-NAMESPACE-URI (attribute)
    -
    Accessor SAX:ATTRIBUTE-LOCAL-NAME (attribute)
    -
    Accessor SAX:ATTRIBUTE-VALUE (attribute)
    -
    Accessor SAX:ATTRIBUTE-QNAME (attribute)
    -
    Accessor SAX:ATTRIBUTE-SPECIFIED-P (attribute)
    -

    -

    - The entity declaration methods are similar to Java SAX - definitions, but parameter entities are distinguished from - general entities not by a % prefix to the name, but by - the kind argument, either :parameter or - :general. -

    -

    - The arguments to sax:element-declaration and - sax:attribute-declaration differ significantly from their - Java counterparts. -

    -

    - fixme: For more information on these functions refer to the docstrings. -

    - - -
    -

    DOM Notes

    -

    - CXML implements the DOM Level 1 Core interfaces.  Explaining - DOM is better left to the specification, - so please refer to the official W3C documents for DOM. -

    -

    - However, there is no "standard" DOM mapping for Lisp.  DOM - is specified - in CORBA IDL, but it refrains from using object-oriented IDL - features, allowing for a much more natural Lisp implemenation than - the the ordinary IDL/Lisp mapping would. -

    -

    - Differences between CXML's DOM and the direct IDL/Lisp mapping: -

    -
      -
    • - DOM function names are symbols in the DOM package (not - the OP package). -
    • -
    • - DOM functions have proper required arguments, not a huge - &rest lambda list. -
    • -
    • - Although most IDL interfaces are implemented as CLOS classes by - CXML, the Lisp types of DOM objects is not documented and cannot - be relied upon.  A node's type can be determined using - dom:node-type instead. -
    • -
    • - DOMString is mapped to rod, which is either - an (unsigned-byte 16) array type or a string type. -
    • -
    • - The IDL/Lisp mapping maps CORBA enums to Lisp keywords.  - Unfortunately, the DOM IDL does not use enums.  Instead, - both exception types and node types are defined integer - constants.  CXML chooses to ignore this definition and uses - keywords instead. -
    • -
    • - DOM uses StudlyCaps.  Lisp programmers don't.  We - insert #\- before every upper case letter preceded by a - lower case letter and before every upper case letter which is - followed by a lower case letter, but preceded by a capital - letter.  This algorithms leads to the natural Lisp spelling - of DOM function names. -
    • -
    • - Implementation note: DOM's NodeList does not - necessarily map to a native "sequence" type.  (For example, - node lists are objects in Java, not arrays.)  - NodeList is specified to reflect changes done after a - node list was created, so node lists cannot be Lisp lists.  - (A node list could be implemented as a CLOS object pointing to - said list though.)  Instead, CXML currently implements node - lists as adjustable vectors.  Note that code which relies on - this implementation and uses Lisp sequence functions - instead of sticking to dom:item and dom:length - is not portable.  As a compromise, you can use our - extensions dom:map-node-list or - dom:do-node-list, which can be implemented portably. -
    • -
    -

    Example:

    -
    XML(97): (dom:node-type
    -          (dom:document-element
    -           (cxml:parse-file "~/test.xml" (dom:make-dom-builder))))
    -:ELEMENT
    Added: branches/grin-neu/thirdparty/cxml/XMLCONF =================================================================== --- branches/grin-neu/thirdparty/cxml/XMLCONF 2006-12-01 10:37:34 UTC (rev 2093) +++ branches/grin-neu/thirdparty/cxml/XMLCONF 2006-12-01 10:39:49 UTC (rev 2094) @@ -0,0 +1,1834 @@ +xmltest/not-wf/sa/001.xml [not validating:] not-wf [validating:] invalid +xmltest/not-wf/sa/002.xml [not validating:] not-wf [validating:] invalid +xmltest/not-wf/sa/003.xml [not validating:] not-wf [validating:] invalid +xmltest/not-wf/sa/004.xml [not validating:] not-wf [validating:] invalid +xmltest/not-wf/sa/005.xml [not validating:] not-wf [validating:] invalid +xmltest/not-wf/sa/006.xml [not validating:] not-wf [validating:] invalid +xmltest/not-wf/sa/007.xml [not validating:] not-wf [validating:] invalid +xmltest/not-wf/sa/008.xml [not validating:] not-wf [validating:] invalid +xmltest/not-wf/sa/009.xml [not validating:] not-wf [validating:] invalid +xmltest/not-wf/sa/010.xml [not validating:] not-wf [validating:] invalid +xmltest/not-wf/sa/011.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/012.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/013.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/014.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/015.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/016.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/017.xml [not validating:] not-wf [validating:] invalid +xmltest/not-wf/sa/018.xml [not validating:] not-wf [validating:] invalid +xmltest/not-wf/sa/019.xml [not validating:] not-wf [validating:] invalid +xmltest/not-wf/sa/020.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/021.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/022.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/023.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/024.xml [not validating:] not-wf [validating:] invalid +xmltest/not-wf/sa/025.xml [not validating:] not-wf [validating:] invalid +xmltest/not-wf/sa/026.xml [not validating:] not-wf [validating:] invalid +xmltest/not-wf/sa/027.xml [not validating:] not-wf [validating:] invalid +xmltest/not-wf/sa/028.xml [not validating:] not-wf [validating:] invalid +xmltest/not-wf/sa/029.xml [not validating:] not-wf [validating:] invalid +xmltest/not-wf/sa/030.xml [not validating:] not-wf [validating:] invalid +xmltest/not-wf/sa/031.xml [not validating:] not-wf [validating:] invalid +xmltest/not-wf/sa/032.xml [not validating:] not-wf [validating:] invalid +xmltest/not-wf/sa/033.xml [not validating:] not-wf [validating:] invalid +xmltest/not-wf/sa/034.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/035.xml [not validating:] not-wf [validating:] invalid +xmltest/not-wf/sa/036.xml [not validating:] not-wf [validating:] invalid +xmltest/not-wf/sa/037.xml [not validating:] not-wf [validating:] invalid +xmltest/not-wf/sa/038.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/039.xml [not validating:] not-wf [validating:] invalid +xmltest/not-wf/sa/040.xml [not validating:] not-wf [validating:] invalid +xmltest/not-wf/sa/041.xml [not validating:] not-wf [validating:] invalid +xmltest/not-wf/sa/042.xml [not validating:] not-wf [validating:] invalid +xmltest/not-wf/sa/043.xml [not validating:] not-wf [validating:] invalid +xmltest/not-wf/sa/044.xml [not validating:] not-wf [validating:] invalid +xmltest/not-wf/sa/045.xml [not validating:] not-wf [validating:] invalid +xmltest/not-wf/sa/046.xml [not validating:] not-wf [validating:] invalid +xmltest/not-wf/sa/047.xml [not validating:] not-wf [validating:] invalid +xmltest/not-wf/sa/048.xml [not validating:] not-wf [validating:] invalid +xmltest/not-wf/sa/049.xml [not validating:] not-wf [validating:] invalid +xmltest/not-wf/sa/050.xml [not validating:] not-wf [validating:] invalid +xmltest/not-wf/sa/051.xml [not validating:] not-wf [validating:] invalid +xmltest/not-wf/sa/052.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/053.xml [not validating:] not-wf [validating:] invalid +xmltest/not-wf/sa/054.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/055.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/056.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/057.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/058.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/059.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/060.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/061.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/062.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/063.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/064.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/065.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/066.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/067.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/068.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/069.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/070.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/071.xml [not validating:] not-wf [validating:] invalid +xmltest/not-wf/sa/072.xml [not validating:] not-wf [validating:] invalid +xmltest/not-wf/sa/073.xml [not validating:] not-wf [validating:] invalid +xmltest/not-wf/sa/074.xml [not validating:] not-wf [validating:] invalid +xmltest/not-wf/sa/075.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/076.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/077.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/078.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/079.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/080.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/081.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/082.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/083.xml [not validating:] not-wf [validating:] invalid +xmltest/not-wf/sa/084.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/085.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/086.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/087.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/088.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/089.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/090.xml [not validating:] not-wf [validating:] invalid +xmltest/not-wf/sa/091.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/092.xml [not validating:] not-wf [validating:] invalid +xmltest/not-wf/sa/093.xml [not validating:] not-wf [validating:] invalid +xmltest/not-wf/sa/094.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/095.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/096.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/097.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/098.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/099.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/100.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/101.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/102.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/103.xml [not validating:] not-wf [validating:] invalid +xmltest/not-wf/sa/104.xml [not validating:] not-wf [validating:] invalid +xmltest/not-wf/sa/105.xml [not validating:] not-wf [validating:] invalid +xmltest/not-wf/sa/106.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/107.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/108.xml [not validating:] not-wf [validating:] invalid +xmltest/not-wf/sa/109.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/110.xml [not validating:] not-wf [validating:] invalid +xmltest/not-wf/sa/111.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/112.xml [not validating:] not-wf [validating:] invalid +xmltest/not-wf/sa/113.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/114.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/115.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/116.xml [not validating:] not-wf [validating:] invalid +xmltest/not-wf/sa/117.xml [not validating:] not-wf [validating:] invalid +xmltest/not-wf/sa/118.xml [not validating:] not-wf [validating:] invalid +xmltest/not-wf/sa/119.xml [not validating:] not-wf [validating:] invalid +xmltest/not-wf/sa/120.xml [not validating:] not-wf [validating:] invalid +xmltest/not-wf/sa/121.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/122.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/123.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/124.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/125.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/126.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/127.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/128.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/129.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/130.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/131.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/132.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/133.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/134.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/135.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/136.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/137.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/138.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/139.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/140.xml [not validating:] not-wf [validating:] invalid +xmltest/not-wf/sa/141.xml [not validating:] not-wf [validating:] invalid +xmltest/not-wf/sa/142.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/143.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/144.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/145.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/146.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/147.xml [not validating:] not-wf [validating:] invalid +xmltest/not-wf/sa/148.xml [not validating:] not-wf [validating:] invalid +xmltest/not-wf/sa/149.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/150.xml [not validating:] not-wf [validating:] invalid +xmltest/not-wf/sa/151.xml [not validating:] not-wf [validating:] invalid +xmltest/not-wf/sa/152.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/153.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/154.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/155.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/156.xml [not validating:] not-wf [validating:] invalid +xmltest/not-wf/sa/157.xml [not validating:] not-wf [validating:] invalid +xmltest/not-wf/sa/158.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/159.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/160.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/161.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/162.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/163.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/164.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/165.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/166.xml [not validating:] not-wf [validating:] invalid +xmltest/not-wf/sa/167.xml [not validating:] not-wf [validating:] invalid +xmltest/not-wf/sa/168.xml [not validating:] not-wf [validating:] invalid +xmltest/not-wf/sa/169.xml [not validating:] not-wf [validating:] invalid +xmltest/not-wf/sa/170.xml [not validating:] not-wf [validating:] invalid +xmltest/not-wf/sa/171.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/172.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/173.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/174.xml [not validating:] not-wf [validating:] invalid +xmltest/not-wf/sa/175.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/176.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/177.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/178.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/179.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/180.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/181.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/182.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/183.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/184.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/185.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/186.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/not-sa/001.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/not-sa/002.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/not-sa/003.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/not-sa/004.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/not-sa/006.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/not-sa/007.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/not-sa/008.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/not-sa/009.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/ext-sa/001.xml [not validating:] not-wf [validating:] invalid +xmltest/not-wf/ext-sa/002.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/ext-sa/003.xml [not validating:] not-wf [validating:] not-wf +xmltest/invalid/002.xml [not validating:] input [validating:] invalid +xmltest/invalid/005.xml [not validating:] input [validating:] invalid +xmltest/invalid/006.xml [not validating:] input [validating:] invalid +xmltest/invalid/not-sa/022.xml [not validating:] input/output [validating:] invalid +xmltest/valid/sa/001.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/002.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/003.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/004.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/005.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/006.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/007.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/008.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/009.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/010.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/011.xml [not validating:] input/output [validating:] input/output +valid/sa/012.xml: test applies to parsers without namespace support, skipping +xmltest/valid/sa/013.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/014.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/015.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/016.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/017.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/018.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/019.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/020.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/021.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/022.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/023.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/024.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/025.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/026.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/027.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/028.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/029.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/030.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/031.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/032.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/033.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/034.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/035.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/036.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/037.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/038.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/039.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/040.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/041.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/042.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/043.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/044.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/045.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/046.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/047.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/048.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/049.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/050.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/051.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/052.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/053.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/054.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/055.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/056.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/057.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/058.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/059.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/060.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/061.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/062.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/063.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/064.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/065.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/066.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/067.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/068.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/069.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/070.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/071.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/072.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/073.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/074.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/075.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/076.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/077.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/078.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/079.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/080.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/081.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/082.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/083.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/084.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/085.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/086.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/087.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/088.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/089.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/090.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/091.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/092.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/093.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/094.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/095.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/096.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/097.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/098.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/099.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/100.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/101.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/102.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/103.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/104.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/105.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/106.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/107.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/108.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/109.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/110.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/111.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/112.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/113.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/114.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/115.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/116.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/117.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/118.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/119.xml [not validating:] input/output [validating:] input/output +xmltest/valid/not-sa/001.xml [not validating:] input/output [validating:] input/output +xmltest/valid/not-sa/002.xml [not validating:] input/output [validating:] input/output +xmltest/valid/not-sa/003.xml [not validating:] input/output [validating:] input/output +xmltest/valid/not-sa/004.xml [not validating:] input/output [validating:] input/output +xmltest/valid/not-sa/005.xml [not validating:] input/output [validating:] input/output +xmltest/valid/not-sa/006.xml [not validating:] input/output [validating:] input/output +xmltest/valid/not-sa/007.xml [not validating:] input/output [validating:] input/output +xmltest/valid/not-sa/008.xml [not validating:] input/output [validating:] input/output +xmltest/valid/not-sa/009.xml [not validating:] input/output [validating:] input/output +xmltest/valid/not-sa/010.xml [not validating:] input/output [validating:] input/output +xmltest/valid/not-sa/011.xml [not validating:] input/output [validating:] input/output +xmltest/valid/not-sa/012.xml [not validating:] input/output [validating:] input/output +xmltest/valid/not-sa/013.xml [not validating:] input/output [validating:] input/output +xmltest/valid/not-sa/014.xml [not validating:] input/output [validating:] input/output +xmltest/valid/not-sa/015.xml [not validating:] input/output [validating:] input/output +xmltest/valid/not-sa/016.xml [not validating:] input/output [validating:] input/output +xmltest/valid/not-sa/017.xml [not validating:] input/output [validating:] input/output +xmltest/valid/not-sa/018.xml [not validating:] input/output [validating:] input/output +xmltest/valid/not-sa/019.xml [not validating:] input/output [validating:] input/output +xmltest/valid/not-sa/020.xml [not validating:] input/output [validating:] input/output +xmltest/valid/not-sa/021.xml [not validating:] input/output [validating:] input/output +xmltest/valid/not-sa/023.xml [not validating:] input/output [validating:] input/output +xmltest/valid/not-sa/024.xml [not validating:] input/output [validating:] input/output +xmltest/valid/not-sa/025.xml [not validating:] input/output [validating:] input/output +xmltest/valid/not-sa/026.xml [not validating:] input/output [validating:] input/output +xmltest/valid/not-sa/027.xml [not validating:] input/output [validating:] input/output +xmltest/valid/not-sa/028.xml [not validating:] input/output [validating:] input/output +xmltest/valid/not-sa/029.xml [not validating:] input/output [validating:] input/output +xmltest/valid/not-sa/030.xml [not validating:] input/output [validating:] input/output +xmltest/valid/not-sa/031.xml [not validating:] input/output [validating:] input/output +xmltest/valid/ext-sa/001.xml [not validating:] input/output [validating:] input/output +xmltest/valid/ext-sa/002.xml [not validating:] input/output [validating:] input/output +xmltest/valid/ext-sa/003.xml [not validating:] input/output [validating:] input/output +xmltest/valid/ext-sa/004.xml [not validating:] input/output [validating:] input/output +xmltest/valid/ext-sa/005.xml [not validating:] input/output [validating:] input/output +xmltest/valid/ext-sa/006.xml [not validating:] input/output [validating:] input/output +xmltest/valid/ext-sa/007.xml [not validating:] input/output [validating:] input/output +xmltest/valid/ext-sa/008.xml [not validating:] input/output [validating:] input/output +xmltest/valid/ext-sa/009.xml [not validating:] input/output [validating:] input/output +xmltest/valid/ext-sa/011.xml [not validating:] input/output [validating:] input/output +xmltest/valid/ext-sa/012.xml [not validating:] input/output [validating:] input/output +xmltest/valid/ext-sa/013.xml [not validating:] input/output [validating:] input/output +xmltest/valid/ext-sa/014.xml [not validating:] input/output [validating:] input/output +japanese/pr-xml-little-endian.xml [not validating:] input [validating:] input +japanese/pr-xml-utf-16.xml [not validating:] input [validating:] input +japanese/pr-xml-utf-8.xml [not validating:] input [validating:] input +japanese/weekly-little-endian.xml [not validating:] input [validating:] input +japanese/weekly-utf-16.xml [not validating:] input [validating:] input +japanese/weekly-utf-8.xml [not validating:] input [validating:] input +sun/valid/pe01.xml [not validating:] input [validating:] input +sun/valid/dtd00.xml [not validating:] input/output [validating:] input/output +sun/valid/dtd01.xml [not validating:] input/output [validating:] input/output +sun/valid/element.xml [not validating:] input/output [validating:] input/output +sun/valid/ext01.xml [not validating:] input/output [validating:] input/output +sun/valid/ext02.xml [not validating:] input/output [validating:] input/output +sun/valid/not-sa01.xml [not validating:] input/output [validating:] input/output +sun/valid/not-sa02.xml [not validating:] input/output [validating:] input/output +sun/valid/not-sa03.xml [not validating:] input/output [validating:] input/output +sun/valid/not-sa04.xml [not validating:] input/output [validating:] input/output +sun/valid/notation01.xml [not validating:] input/output [validating:] input/output +sun/valid/optional.xml [not validating:] input/output [validating:] input/output +sun/valid/required00.xml [not validating:] input/output [validating:] input/output +sun/valid/sa01.xml [not validating:] input/output [validating:] input/output +sun/valid/sa02.xml [not validating:] input/output [validating:] input/output +sun/valid/sa03.xml [not validating:] input/output [validating:] input/output +sun/valid/sa04.xml [not validating:] input/output [validating:] input/output +sun/valid/sa05.xml [not validating:] input/output [validating:] input/output +sun/valid/sgml01.xml [not validating:] input/output [validating:] input/output +sun/valid/v-lang01.xml [not validating:] input/output [validating:] input/output +sun/valid/v-lang02.xml [not validating:] input/output [validating:] input/output +sun/valid/v-lang03.xml [not validating:] input/output [validating:] input/output +sun/valid/v-lang04.xml [not validating:] input/output [validating:] input/output +sun/valid/v-lang05.xml [not validating:] input/output [validating:] input/output +sun/valid/v-lang06.xml [not validating:] input/output [validating:] input/output +sun/valid/pe00.xml [not validating:] input/output [validating:] input/output +sun/valid/pe03.xml [not validating:] input/output [validating:] input/output +sun/valid/pe02.xml [not validating:] input/output [validating:] input/output +sun/invalid/dtd01.xml [not validating:] input [validating:] invalid +sun/invalid/dtd02.xml [not validating:] input [validating:] invalid +sun/invalid/dtd03.xml [not validating:] input [validating:] invalid +sun/invalid/el01.xml [not validating:] input [validating:] invalid +sun/invalid/el02.xml [not validating:] input [validating:] invalid +sun/invalid/el03.xml [not validating:] input [validating:] invalid +sun/invalid/el04.xml [not validating:] input [validating:] invalid +sun/invalid/el05.xml [not validating:] input [validating:] invalid +sun/invalid/el06.xml [not validating:] input [validating:] invalid +sun/invalid/id01.xml [not validating:] input [validating:] invalid +sun/invalid/id02.xml [not validating:] input [validating:] invalid +sun/invalid/id03.xml [not validating:] input [validating:] invalid +sun/invalid/id04.xml [not validating:] input [validating:] invalid +sun/invalid/id05.xml [not validating:] input [validating:] invalid +sun/invalid/id06.xml [not validating:] input [validating:] invalid +sun/invalid/id07.xml [not validating:] input [validating:] invalid +sun/invalid/id08.xml [not validating:] input [validating:] invalid +sun/invalid/id09.xml [not validating:] input [validating:] invalid +sun/invalid/not-sa01.xml [not validating:] input [validating:] invalid +sun/invalid/not-sa02.xml [not validating:] input [validating:] invalid +sun/invalid/not-sa04.xml [not validating:] input [validating:] invalid +sun/invalid/not-sa05.xml [not validating:] input [validating:] invalid +sun/invalid/not-sa06.xml [not validating:] input [validating:] invalid +sun/invalid/not-sa07.xml [not validating:] input [validating:] invalid +sun/invalid/not-sa08.xml [not validating:] input [validating:] invalid +sun/invalid/not-sa09.xml [not validating:] input [validating:] invalid +sun/invalid/not-sa10.xml [not validating:] input [validating:] invalid +sun/invalid/not-sa11.xml [not validating:] input [validating:] invalid +sun/invalid/not-sa12.xml [not validating:] input [validating:] invalid +sun/invalid/not-sa13.xml [not validating:] input [validating:] invalid +sun/invalid/not-sa14.xml [not validating:] input [validating:] invalid +sun/invalid/optional01.xml [not validating:] input [validating:] invalid +sun/invalid/optional02.xml [not validating:] input [validating:] invalid +sun/invalid/optional03.xml [not validating:] input [validating:] invalid +sun/invalid/optional04.xml [not validating:] input [validating:] invalid +sun/invalid/optional05.xml [not validating:] input [validating:] invalid +sun/invalid/optional06.xml [not validating:] input [validating:] invalid +sun/invalid/optional07.xml [not validating:] input [validating:] invalid +sun/invalid/optional08.xml [not validating:] input [validating:] invalid +sun/invalid/optional09.xml [not validating:] input [validating:] invalid +sun/invalid/optional10.xml [not validating:] input [validating:] invalid +sun/invalid/optional11.xml [not validating:] input [validating:] invalid +sun/invalid/optional12.xml [not validating:] input [validating:] invalid +sun/invalid/optional13.xml [not validating:] input [validating:] invalid +sun/invalid/optional14.xml [not validating:] input [validating:] invalid +sun/invalid/optional20.xml [not validating:] input [validating:] invalid +sun/invalid/optional21.xml [not validating:] input [validating:] invalid +sun/invalid/optional22.xml [not validating:] input [validating:] invalid +sun/invalid/optional23.xml [not validating:] input [validating:] invalid +sun/invalid/optional24.xml [not validating:] input [validating:] invalid +sun/invalid/optional25.xml [not validating:] input [validating:] invalid +sun/invalid/required00.xml [not validating:] input [validating:] invalid +sun/invalid/required01.xml [not validating:] input [validating:] invalid +sun/invalid/required02.xml [not validating:] input [validating:] invalid +sun/invalid/root.xml [not validating:] input [validating:] invalid +sun/invalid/attr01.xml [not validating:] input [validating:] invalid +sun/invalid/attr02.xml [not validating:] input [validating:] invalid +sun/invalid/attr03.xml [not validating:] input [validating:] invalid +sun/invalid/attr04.xml [not validating:] input [validating:] invalid +sun/invalid/attr05.xml [not validating:] input [validating:] invalid +sun/invalid/attr06.xml [not validating:] input [validating:] invalid +sun/invalid/attr07.xml [not validating:] input [validating:] invalid +sun/invalid/attr08.xml [not validating:] input [validating:] invalid +sun/invalid/attr09.xml [not validating:] input [validating:] invalid +sun/invalid/attr10.xml [not validating:] input [validating:] invalid +sun/invalid/attr11.xml [not validating:] input [validating:] invalid +sun/invalid/attr12.xml [not validating:] input [validating:] invalid +sun/invalid/attr13.xml [not validating:] input [validating:] invalid +sun/invalid/attr14.xml [not validating:] input [validating:] invalid +sun/invalid/attr15.xml [not validating:] input [validating:] invalid +sun/invalid/attr16.xml [not validating:] input [validating:] invalid +sun/invalid/utf16b.xml [not validating:] input [validating:] invalid +sun/invalid/utf16l.xml [not validating:] input [validating:] invalid +sun/invalid/empty.xml [not validating:] input [validating:] invalid +sun/not-wf/not-sa03.xml [not validating:] not-wf [validating:] invalid +sun/not-wf/attlist01.xml [not validating:] not-wf [validating:] not-wf +sun/not-wf/attlist02.xml [not validating:] not-wf [validating:] not-wf +sun/not-wf/attlist03.xml [not validating:] not-wf [validating:] not-wf +sun/not-wf/attlist04.xml [not validating:] not-wf [validating:] not-wf +sun/not-wf/attlist05.xml [not validating:] not-wf [validating:] not-wf +sun/not-wf/attlist06.xml [not validating:] not-wf [validating:] not-wf +sun/not-wf/attlist07.xml [not validating:] not-wf [validating:] not-wf +sun/not-wf/attlist08.xml [not validating:] not-wf [validating:] not-wf +sun/not-wf/attlist09.xml [not validating:] not-wf [validating:] not-wf +sun/not-wf/attlist10.xml [not validating:] not-wf [validating:] not-wf +sun/not-wf/attlist11.xml [not validating:] not-wf [validating:] not-wf +sun/not-wf/cond01.xml [not validating:] not-wf [validating:] not-wf +sun/not-wf/cond02.xml [not validating:] not-wf [validating:] not-wf +sun/not-wf/content01.xml [not validating:] not-wf [validating:] not-wf +sun/not-wf/content02.xml [not validating:] not-wf [validating:] not-wf +sun/not-wf/content03.xml [not validating:] not-wf [validating:] not-wf +sun/not-wf/decl01.xml [not validating:] not-wf [validating:] not-wf +sun/not-wf/dtd00.xml [not validating:] not-wf [validating:] not-wf +sun/not-wf/dtd01.xml [not validating:] not-wf [validating:] not-wf +sun/not-wf/dtd02.xml [not validating:] not-wf [validating:] not-wf +sun/not-wf/dtd03.xml [not validating:] not-wf [validating:] not-wf +sun/not-wf/dtd04.xml [not validating:] not-wf [validating:] not-wf +sun/not-wf/dtd05.xml [not validating:] not-wf [validating:] not-wf +sun/not-wf/dtd07.xml [not validating:] not-wf [validating:] not-wf +sun/not-wf/element00.xml [not validating:] not-wf [validating:] invalid +sun/not-wf/element01.xml [not validating:] not-wf [validating:] invalid +sun/not-wf/element02.xml [not validating:] not-wf [validating:] not-wf +sun/not-wf/element03.xml [not validating:] not-wf [validating:] not-wf +sun/not-wf/element04.xml [not validating:] not-wf [validating:] not-wf +sun/not-wf/encoding01.xml [not validating:] not-wf [validating:] not-wf +sun/not-wf/encoding02.xml [not validating:] not-wf [validating:] not-wf +sun/not-wf/encoding03.xml [not validating:] not-wf [validating:] not-wf +sun/not-wf/encoding04.xml [not validating:] not-wf [validating:] not-wf +sun/not-wf/encoding05.xml [not validating:] not-wf [validating:] not-wf +sun/not-wf/encoding06.xml [not validating:] not-wf [validating:] not-wf +sun/not-wf/encoding07.xml [not validating:] not-wf [validating:] not-wf +sun/not-wf/pi.xml [not validating:] not-wf [validating:] not-wf +sun/not-wf/pubid01.xml [not validating:] not-wf [validating:] not-wf +sun/not-wf/pubid02.xml [not validating:] not-wf [validating:] not-wf +sun/not-wf/pubid03.xml [not validating:] not-wf [validating:] not-wf +sun/not-wf/pubid04.xml [not validating:] not-wf [validating:] not-wf +sun/not-wf/pubid05.xml [not validating:] not-wf [validating:] not-wf +sun/not-wf/sgml01.xml [not validating:] not-wf [validating:] invalid +sun/not-wf/sgml02.xml [not validating:] not-wf [validating:] invalid +sun/not-wf/sgml03.xml [not validating:] not-wf [validating:] not-wf +sun/not-wf/sgml04.xml [not validating:] not-wf [validating:] not-wf +sun/not-wf/sgml05.xml [not validating:] not-wf [validating:] not-wf +sun/not-wf/sgml06.xml [not validating:] not-wf [validating:] not-wf +sun/not-wf/sgml07.xml [not validating:] not-wf [validating:] not-wf +sun/not-wf/sgml08.xml [not validating:] not-wf [validating:] not-wf +sun/not-wf/sgml09.xml [not validating:] not-wf [validating:] not-wf +sun/not-wf/sgml10.xml [not validating:] not-wf [validating:] not-wf +sun/not-wf/sgml11.xml [not validating:] not-wf [validating:] not-wf +sun/not-wf/sgml12.xml [not validating:] not-wf [validating:] not-wf +sun/not-wf/sgml13.xml [not validating:] not-wf [validating:] not-wf +oasis/p01pass2.xml [not validating:] input [validating:] input +oasis/p06pass1.xml [not validating:] input [validating:] input +oasis/p07pass1.xml [not validating:] input [validating:] input +p08pass1.xml: test applies to parsers without namespace support, skipping +oasis/p09pass1.xml [not validating:] input [validating:] input +oasis/p12pass1.xml [not validating:] input [validating:] input +oasis/p22pass4.xml [not validating:] input [validating:] input +oasis/p22pass5.xml [not validating:] input [validating:] input +oasis/p22pass6.xml [not validating:] input [validating:] input +oasis/p28pass1.xml [not validating:] input [validating:] input +oasis/p28pass3.xml [not validating:] input [validating:] input +oasis/p28pass4.xml [not validating:] input [validating:] input +oasis/p28pass5.xml [not validating:] input [validating:] input +oasis/p29pass1.xml [not validating:] input [validating:] input +oasis/p30pass1.xml [not validating:] input [validating:] input +oasis/p30pass2.xml [not validating:] input [validating:] input +oasis/p31pass1.xml [not validating:] input [validating:] input +oasis/p31pass2.xml [not validating:] input [validating:] input +oasis/p43pass1.xml [not validating:] input [validating:] input +oasis/p45pass1.xml [not validating:] input [validating:] input +oasis/p46pass1.xml [not validating:] input [validating:] input +oasis/p47pass1.xml [not validating:] input [validating:] input +oasis/p48pass1.xml [not validating:] input [validating:] input +oasis/p49pass1.xml [not validating:] input [validating:] input +oasis/p50pass1.xml [not validating:] input [validating:] input +oasis/p51pass1.xml [not validating:] input [validating:] input +oasis/p52pass1.xml [not validating:] input [validating:] input +oasis/p53pass1.xml [not validating:] input [validating:] input +oasis/p54pass1.xml [not validating:] input [validating:] input +oasis/p55pass1.xml [not validating:] input [validating:] input +oasis/p56pass1.xml [not validating:] input [validating:] input +oasis/p57pass1.xml [not validating:] input [validating:] input +oasis/p58pass1.xml [not validating:] input [validating:] input +oasis/p59pass1.xml [not validating:] input [validating:] input +oasis/p60pass1.xml [not validating:] input [validating:] input +oasis/p61pass1.xml [not validating:] input [validating:] input +oasis/p62pass1.xml [not validating:] input [validating:] input +oasis/p63pass1.xml [not validating:] input [validating:] input +oasis/p64pass1.xml [not validating:] input [validating:] input +oasis/p68pass1.xml [not validating:] input [validating:] input +oasis/p69pass1.xml [not validating:] input [validating:] input +oasis/p70pass1.xml [not validating:] input [validating:] input +oasis/p71pass1.xml [not validating:] input [validating:] input +oasis/p72pass1.xml [not validating:] input [validating:] input +oasis/p73pass1.xml [not validating:] input [validating:] input +oasis/p76pass1.xml [not validating:] input [validating:] input +oasis/p01pass1.xml [not validating:] input [validating:] invalid +oasis/p01pass3.xml [not validating:] input [validating:] invalid +oasis/p03pass1.xml [not validating:] input [validating:] invalid +p04pass1.xml: test applies to parsers without namespace support, skipping +p05pass1.xml: test applies to parsers without namespace support, skipping +oasis/p06fail1.xml [not validating:] input [validating:] invalid +oasis/p08fail1.xml [not validating:] input [validating:] invalid +oasis/p08fail2.xml [not validating:] input [validating:] invalid +oasis/p10pass1.xml [not validating:] input [validating:] invalid +oasis/p14pass1.xml [not validating:] input [validating:] invalid +oasis/p15pass1.xml [not validating:] input [validating:] invalid +oasis/p16pass1.xml [not validating:] input [validating:] invalid +oasis/p16pass2.xml [not validating:] input [validating:] invalid +oasis/p16pass3.xml [not validating:] input [validating:] invalid +oasis/p18pass1.xml [not validating:] input [validating:] invalid +oasis/p22pass1.xml [not validating:] input [validating:] invalid +oasis/p22pass2.xml [not validating:] input [validating:] invalid +oasis/p22pass3.xml [not validating:] input [validating:] invalid +oasis/p23pass1.xml [not validating:] input [validating:] invalid +oasis/p23pass2.xml [not validating:] input [validating:] invalid +oasis/p23pass3.xml [not validating:] input [validating:] invalid +oasis/p23pass4.xml [not validating:] input [validating:] invalid +oasis/p24pass1.xml [not validating:] input [validating:] invalid +oasis/p24pass2.xml [not validating:] input [validating:] invalid +oasis/p24pass3.xml [not validating:] input [validating:] invalid +oasis/p24pass4.xml [not validating:] input [validating:] invalid +oasis/p25pass1.xml [not validating:] input [validating:] invalid +oasis/p25pass2.xml [not validating:] input [validating:] invalid +oasis/p26pass1.xml [not validating:] input [validating:] invalid +oasis/p27pass1.xml [not validating:] input [validating:] invalid +oasis/p27pass2.xml [not validating:] input [validating:] invalid +oasis/p27pass3.xml [not validating:] input [validating:] invalid +oasis/p27pass4.xml [not validating:] input [validating:] invalid +oasis/p32pass1.xml [not validating:] input [validating:] invalid +oasis/p32pass2.xml [not validating:] input [validating:] invalid +oasis/p39pass1.xml [not validating:] input [validating:] invalid +oasis/p39pass2.xml [not validating:] input [validating:] invalid +oasis/p40pass1.xml [not validating:] input [validating:] invalid +oasis/p40pass2.xml [not validating:] input [validating:] invalid +oasis/p40pass3.xml [not validating:] input [validating:] invalid +oasis/p40pass4.xml [not validating:] input [validating:] invalid +oasis/p41pass1.xml [not validating:] input [validating:] invalid +oasis/p41pass2.xml [not validating:] input [validating:] invalid +oasis/p42pass1.xml [not validating:] input [validating:] invalid +oasis/p42pass2.xml [not validating:] input [validating:] invalid +oasis/p44pass1.xml [not validating:] input [validating:] invalid +oasis/p44pass2.xml [not validating:] input [validating:] invalid +oasis/p44pass3.xml [not validating:] input [validating:] invalid +oasis/p44pass4.xml [not validating:] input [validating:] invalid +oasis/p44pass5.xml [not validating:] input [validating:] invalid +oasis/p66pass1.xml [not validating:] input [validating:] invalid +oasis/p74pass1.xml [not validating:] input [validating:] invalid +oasis/p75pass1.xml [not validating:] input [validating:] invalid +oasis/e2.xml [not validating:] input [validating:] invalid +oasis/p01fail1.xml [not validating:] not-wf [validating:] invalid +oasis/p01fail2.xml [not validating:] not-wf [validating:] invalid +oasis/p01fail3.xml [not validating:] not-wf [validating:] invalid +oasis/p01fail4.xml [not validating:] not-wf [validating:] invalid +oasis/p02fail1.xml [not validating:] not-wf [validating:] invalid +oasis/p02fail10.xml [not validating:] not-wf [validating:] invalid +oasis/p02fail11.xml [not validating:] not-wf [validating:] invalid +oasis/p02fail12.xml [not validating:] not-wf [validating:] invalid +oasis/p02fail13.xml [not validating:] not-wf [validating:] invalid +oasis/p02fail14.xml [not validating:] not-wf [validating:] invalid +oasis/p02fail15.xml [not validating:] not-wf [validating:] invalid +oasis/p02fail16.xml [not validating:] not-wf [validating:] invalid +oasis/p02fail17.xml [not validating:] not-wf [validating:] invalid +oasis/p02fail18.xml [not validating:] not-wf [validating:] invalid +oasis/p02fail19.xml [not validating:] not-wf [validating:] invalid +oasis/p02fail2.xml [not validating:] not-wf [validating:] invalid +oasis/p02fail20.xml [not validating:] not-wf [validating:] invalid +oasis/p02fail21.xml [not validating:] not-wf [validating:] invalid +oasis/p02fail22.xml [not validating:] not-wf [validating:] invalid +oasis/p02fail23.xml [not validating:] not-wf [validating:] invalid +oasis/p02fail24.xml [not validating:] not-wf [validating:] invalid +oasis/p02fail25.xml [not validating:] not-wf [validating:] invalid +oasis/p02fail26.xml [not validating:] not-wf [validating:] invalid +oasis/p02fail27.xml [not validating:] not-wf [validating:] invalid +oasis/p02fail28.xml [not validating:] not-wf [validating:] invalid +oasis/p02fail29.xml [not validating:] not-wf [validating:] invalid +oasis/p02fail3.xml [not validating:] not-wf [validating:] invalid +oasis/p02fail30.xml [not validating:] not-wf [validating:] invalid +oasis/p02fail31.xml [not validating:] not-wf [validating:] invalid +oasis/p02fail4.xml [not validating:] not-wf [validating:] invalid +oasis/p02fail5.xml [not validating:] not-wf [validating:] invalid +oasis/p02fail6.xml [not validating:] not-wf [validating:] invalid +oasis/p02fail7.xml [not validating:] not-wf [validating:] invalid +oasis/p02fail8.xml [not validating:] not-wf [validating:] invalid +oasis/p02fail9.xml [not validating:] not-wf [validating:] invalid +oasis/p03fail1.xml [not validating:] not-wf [validating:] not-wf +oasis/p03fail10.xml [not validating:] not-wf [validating:] not-wf +oasis/p03fail11.xml [not validating:] not-wf [validating:] not-wf +oasis/p03fail12.xml [not validating:] not-wf [validating:] not-wf +oasis/p03fail13.xml [not validating:] not-wf [validating:] not-wf +oasis/p03fail14.xml [not validating:] not-wf [validating:] not-wf +oasis/p03fail15.xml [not validating:] not-wf [validating:] not-wf +oasis/p03fail16.xml [not validating:] not-wf [validating:] not-wf +oasis/p03fail17.xml [not validating:] not-wf [validating:] not-wf +oasis/p03fail18.xml [not validating:] not-wf [validating:] not-wf +oasis/p03fail19.xml [not validating:] not-wf [validating:] not-wf +oasis/p03fail2.xml [not validating:] not-wf [validating:] not-wf +oasis/p03fail20.xml [not validating:] not-wf [validating:] not-wf +oasis/p03fail21.xml [not validating:] not-wf [validating:] not-wf +oasis/p03fail22.xml [not validating:] not-wf [validating:] not-wf +oasis/p03fail23.xml [not validating:] not-wf [validating:] not-wf +oasis/p03fail24.xml [not validating:] not-wf [validating:] not-wf +oasis/p03fail25.xml [not validating:] not-wf [validating:] not-wf +oasis/p03fail26.xml [not validating:] not-wf [validating:] not-wf +oasis/p03fail27.xml [not validating:] not-wf [validating:] not-wf +oasis/p03fail28.xml [not validating:] not-wf [validating:] not-wf +oasis/p03fail29.xml [not validating:] not-wf [validating:] not-wf +oasis/p03fail3.xml [not validating:] not-wf [validating:] not-wf +oasis/p03fail4.xml [not validating:] not-wf [validating:] not-wf +oasis/p03fail5.xml [not validating:] not-wf [validating:] not-wf +oasis/p03fail7.xml [not validating:] not-wf [validating:] not-wf +oasis/p03fail8.xml [not validating:] not-wf [validating:] not-wf +oasis/p03fail9.xml [not validating:] not-wf [validating:] not-wf +oasis/p04fail1.xml [not validating:] not-wf [validating:] not-wf +oasis/p04fail2.xml [not validating:] not-wf [validating:] not-wf +oasis/p04fail3.xml [not validating:] not-wf [validating:] not-wf +oasis/p05fail1.xml [not validating:] not-wf [validating:] not-wf +oasis/p05fail2.xml [not validating:] not-wf [validating:] not-wf +oasis/p05fail3.xml [not validating:] not-wf [validating:] not-wf +oasis/p05fail4.xml [not validating:] not-wf [validating:] not-wf +oasis/p05fail5.xml [not validating:] not-wf [validating:] not-wf +oasis/p09fail1.xml [not validating:] not-wf [validating:] not-wf +oasis/p09fail2.xml [not validating:] not-wf [validating:] not-wf +oasis/p09fail3.xml [not validating:] not-wf [validating:] not-wf +oasis/p09fail4.xml [not validating:] not-wf [validating:] not-wf +oasis/p09fail5.xml [not validating:] not-wf [validating:] not-wf +oasis/p10fail1.xml [not validating:] not-wf [validating:] not-wf +oasis/p10fail2.xml [not validating:] not-wf [validating:] not-wf +oasis/p10fail3.xml [not validating:] not-wf [validating:] not-wf +oasis/p11fail1.xml [not validating:] not-wf [validating:] not-wf +oasis/p11fail2.xml [not validating:] not-wf [validating:] not-wf +oasis/p12fail1.xml [not validating:] not-wf [validating:] not-wf +oasis/p12fail2.xml [not validating:] not-wf [validating:] not-wf +oasis/p12fail3.xml [not validating:] not-wf [validating:] not-wf +oasis/p12fail4.xml [not validating:] not-wf [validating:] not-wf +oasis/p12fail5.xml [not validating:] not-wf [validating:] not-wf +oasis/p12fail6.xml [not validating:] not-wf [validating:] not-wf +oasis/p12fail7.xml [not validating:] not-wf [validating:] not-wf +oasis/p14fail1.xml [not validating:] not-wf [validating:] invalid +oasis/p14fail2.xml [not validating:] not-wf [validating:] invalid +oasis/p14fail3.xml [not validating:] not-wf [validating:] invalid +oasis/p15fail1.xml [not validating:] not-wf [validating:] not-wf +oasis/p15fail2.xml [not validating:] not-wf [validating:] not-wf +oasis/p15fail3.xml [not validating:] not-wf [validating:] not-wf +oasis/p16fail1.xml [not validating:] not-wf [validating:] invalid +oasis/p16fail2.xml [not validating:] not-wf [validating:] not-wf +oasis/p16fail3.xml [not validating:] not-wf [validating:] not-wf +oasis/p18fail1.xml [not validating:] not-wf [validating:] invalid +oasis/p18fail2.xml [not validating:] not-wf [validating:] invalid +oasis/p18fail3.xml [not validating:] not-wf [validating:] invalid +oasis/p22fail1.xml [not validating:] not-wf [validating:] invalid +oasis/p22fail2.xml [not validating:] not-wf [validating:] not-wf +oasis/p23fail1.xml [not validating:] not-wf [validating:] not-wf +oasis/p23fail2.xml [not validating:] not-wf [validating:] not-wf +oasis/p23fail3.xml [not validating:] not-wf [validating:] not-wf +oasis/p23fail4.xml [not validating:] not-wf [validating:] not-wf +oasis/p23fail5.xml [not validating:] not-wf [validating:] not-wf +oasis/p24fail1.xml [not validating:] not-wf [validating:] not-wf +oasis/p24fail2.xml [not validating:] not-wf [validating:] not-wf +oasis/p25fail1.xml [not validating:] not-wf [validating:] not-wf +oasis/p26fail1.xml [not validating:] not-wf [validating:] not-wf +oasis/p26fail2.xml [not validating:] not-wf [validating:] not-wf +oasis/p27fail1.xml [not validating:] not-wf [validating:] not-wf +oasis/p28fail1.xml [not validating:] not-wf [validating:] not-wf +oasis/p29fail1.xml [not validating:] not-wf [validating:] not-wf +oasis/p30fail1.xml [not validating:] not-wf [validating:] not-wf +oasis/p31fail1.xml [not validating:] not-wf [validating:] not-wf +oasis/p32fail1.xml [not validating:] not-wf [validating:] not-wf +oasis/p32fail2.xml [not validating:] not-wf [validating:] not-wf +oasis/p32fail3.xml [not validating:] not-wf [validating:] not-wf +oasis/p32fail4.xml [not validating:] not-wf [validating:] not-wf +oasis/p32fail5.xml [not validating:] not-wf [validating:] not-wf +oasis/p39fail1.xml [not validating:] not-wf [validating:] invalid +oasis/p39fail2.xml [not validating:] not-wf [validating:] invalid +oasis/p39fail3.xml [not validating:] not-wf [validating:] invalid +oasis/p39fail4.xml [not validating:] not-wf [validating:] not-wf +oasis/p39fail5.xml [not validating:] not-wf [validating:] not-wf +oasis/p40fail1.xml [not validating:] not-wf [validating:] not-wf +oasis/p40fail2.xml [not validating:] not-wf [validating:] not-wf +oasis/p40fail3.xml [not validating:] not-wf [validating:] not-wf +oasis/p40fail4.xml [not validating:] not-wf [validating:] not-wf +oasis/p41fail1.xml [not validating:] not-wf [validating:] not-wf +oasis/p41fail2.xml [not validating:] not-wf [validating:] not-wf +oasis/p41fail3.xml [not validating:] not-wf [validating:] not-wf +oasis/p42fail1.xml [not validating:] not-wf [validating:] invalid +oasis/p42fail2.xml [not validating:] not-wf [validating:] invalid +oasis/p42fail3.xml [not validating:] not-wf [validating:] not-wf +oasis/p43fail1.xml [not validating:] not-wf [validating:] not-wf +oasis/p43fail2.xml [not validating:] not-wf [validating:] not-wf +oasis/p43fail3.xml [not validating:] not-wf [validating:] not-wf +oasis/p44fail1.xml [not validating:] not-wf [validating:] not-wf +oasis/p44fail2.xml [not validating:] not-wf [validating:] not-wf +oasis/p44fail3.xml [not validating:] not-wf [validating:] not-wf +oasis/p44fail4.xml [not validating:] not-wf [validating:] not-wf +oasis/p44fail5.xml [not validating:] not-wf [validating:] not-wf +oasis/p45fail1.xml [not validating:] not-wf [validating:] not-wf +oasis/p45fail2.xml [not validating:] not-wf [validating:] not-wf +oasis/p45fail3.xml [not validating:] not-wf [validating:] not-wf +oasis/p45fail4.xml [not validating:] not-wf [validating:] not-wf +oasis/p46fail1.xml [not validating:] not-wf [validating:] not-wf +oasis/p46fail2.xml [not validating:] not-wf [validating:] not-wf +oasis/p46fail3.xml [not validating:] not-wf [validating:] not-wf +oasis/p46fail4.xml [not validating:] not-wf [validating:] not-wf +oasis/p46fail5.xml [not validating:] not-wf [validating:] not-wf +oasis/p46fail6.xml [not validating:] not-wf [validating:] not-wf +oasis/p47fail1.xml [not validating:] not-wf [validating:] not-wf +oasis/p47fail2.xml [not validating:] not-wf [validating:] not-wf +oasis/p47fail3.xml [not validating:] not-wf [validating:] not-wf +oasis/p47fail4.xml [not validating:] not-wf [validating:] not-wf +oasis/p48fail1.xml [not validating:] not-wf [validating:] not-wf +oasis/p48fail2.xml [not validating:] not-wf [validating:] not-wf +oasis/p49fail1.xml [not validating:] not-wf [validating:] not-wf +oasis/p50fail1.xml [not validating:] not-wf [validating:] not-wf +oasis/p51fail1.xml [not validating:] not-wf [validating:] not-wf +oasis/p51fail2.xml [not validating:] not-wf [validating:] not-wf +oasis/p51fail3.xml [not validating:] not-wf [validating:] not-wf +oasis/p51fail4.xml [not validating:] not-wf [validating:] not-wf +oasis/p51fail5.xml [not validating:] not-wf [validating:] not-wf +oasis/p51fail6.xml [not validating:] not-wf [validating:] not-wf +oasis/p51fail7.xml [not validating:] not-wf [validating:] not-wf +oasis/p52fail1.xml [not validating:] not-wf [validating:] not-wf +oasis/p52fail2.xml [not validating:] not-wf [validating:] not-wf +oasis/p53fail1.xml [not validating:] not-wf [validating:] not-wf +oasis/p53fail2.xml [not validating:] not-wf [validating:] not-wf +oasis/p53fail3.xml [not validating:] not-wf [validating:] not-wf +oasis/p53fail4.xml [not validating:] not-wf [validating:] not-wf +oasis/p53fail5.xml [not validating:] not-wf [validating:] not-wf +oasis/p54fail1.xml [not validating:] not-wf [validating:] not-wf +oasis/p55fail1.xml [not validating:] not-wf [validating:] not-wf +oasis/p56fail1.xml [not validating:] not-wf [validating:] not-wf +oasis/p56fail2.xml [not validating:] not-wf [validating:] not-wf +oasis/p56fail3.xml [not validating:] not-wf [validating:] not-wf +oasis/p56fail4.xml [not validating:] not-wf [validating:] not-wf +oasis/p56fail5.xml [not validating:] not-wf [validating:] not-wf +oasis/p57fail1.xml [not validating:] not-wf [validating:] not-wf +oasis/p58fail1.xml [not validating:] not-wf [validating:] not-wf +oasis/p58fail2.xml [not validating:] not-wf [validating:] not-wf +oasis/p58fail3.xml [not validating:] not-wf [validating:] invalid +oasis/p58fail4.xml [not validating:] not-wf [validating:] not-wf +oasis/p58fail5.xml [not validating:] not-wf [validating:] not-wf +oasis/p58fail6.xml [not validating:] not-wf [validating:] not-wf +oasis/p58fail7.xml [not validating:] not-wf [validating:] not-wf +oasis/p58fail8.xml [not validating:] not-wf [validating:] not-wf +oasis/p59fail1.xml [not validating:] not-wf [validating:] not-wf +oasis/p59fail2.xml [not validating:] not-wf [validating:] not-wf +oasis/p59fail3.xml [not validating:] not-wf [validating:] not-wf +oasis/p60fail1.xml [not validating:] not-wf [validating:] not-wf +oasis/p60fail2.xml [not validating:] not-wf [validating:] not-wf +oasis/p60fail3.xml [not validating:] not-wf [validating:] not-wf +oasis/p60fail4.xml [not validating:] not-wf [validating:] not-wf +oasis/p60fail5.xml [not validating:] not-wf [validating:] not-wf +oasis/p61fail1.xml [not validating:] not-wf [validating:] not-wf +oasis/p62fail1.xml [not validating:] not-wf [validating:] not-wf +oasis/p62fail2.xml [not validating:] not-wf [validating:] not-wf +oasis/p63fail1.xml [not validating:] not-wf [validating:] not-wf +oasis/p63fail2.xml [not validating:] not-wf [validating:] not-wf +oasis/p64fail1.xml [not validating:] not-wf [validating:] not-wf +oasis/p64fail2.xml [not validating:] not-wf [validating:] not-wf +oasis/p66fail1.xml [not validating:] not-wf [validating:] invalid +oasis/p66fail2.xml [not validating:] not-wf [validating:] invalid +oasis/p66fail3.xml [not validating:] not-wf [validating:] invalid +oasis/p66fail4.xml [not validating:] not-wf [validating:] invalid +oasis/p66fail5.xml [not validating:] not-wf [validating:] invalid +oasis/p66fail6.xml [not validating:] not-wf [validating:] invalid +oasis/p68fail1.xml [not validating:] not-wf [validating:] not-wf +oasis/p68fail2.xml [not validating:] not-wf [validating:] not-wf +oasis/p68fail3.xml [not validating:] not-wf [validating:] not-wf +oasis/p69fail1.xml [not validating:] not-wf [validating:] not-wf +oasis/p69fail2.xml [not validating:] not-wf [validating:] not-wf +oasis/p69fail3.xml [not validating:] not-wf [validating:] not-wf +oasis/p70fail1.xml [not validating:] not-wf [validating:] not-wf +oasis/p71fail1.xml [not validating:] not-wf [validating:] not-wf +oasis/p71fail2.xml [not validating:] not-wf [validating:] not-wf +oasis/p71fail3.xml [not validating:] not-wf [validating:] not-wf +oasis/p71fail4.xml [not validating:] not-wf [validating:] not-wf +oasis/p72fail1.xml [not validating:] not-wf [validating:] not-wf +oasis/p72fail2.xml [not validating:] not-wf [validating:] not-wf +oasis/p72fail3.xml [not validating:] not-wf [validating:] not-wf +oasis/p72fail4.xml [not validating:] not-wf [validating:] not-wf +oasis/p73fail1.xml [not validating:] not-wf [validating:] not-wf +oasis/p73fail2.xml [not validating:] not-wf [validating:] not-wf +oasis/p73fail3.xml [not validating:] not-wf [validating:] not-wf +oasis/p73fail4.xml [not validating:] not-wf [validating:] not-wf +oasis/p73fail5.xml [not validating:] not-wf [validating:] not-wf +oasis/p74fail1.xml [not validating:] not-wf [validating:] not-wf +oasis/p74fail2.xml [not validating:] not-wf [validating:] not-wf +oasis/p74fail3.xml [not validating:] not-wf [validating:] not-wf +oasis/p75fail1.xml [not validating:] not-wf [validating:] not-wf +oasis/p75fail2.xml [not validating:] not-wf [validating:] not-wf +oasis/p75fail3.xml [not validating:] not-wf [validating:] not-wf +oasis/p75fail4.xml [not validating:] not-wf [validating:] not-wf +oasis/p75fail5.xml [not validating:] not-wf [validating:] not-wf +oasis/p75fail6.xml [not validating:] not-wf [validating:] not-wf +oasis/p76fail1.xml [not validating:] not-wf [validating:] not-wf +oasis/p76fail2.xml [not validating:] not-wf [validating:] not-wf +oasis/p76fail3.xml [not validating:] not-wf [validating:] not-wf +oasis/p76fail4.xml [not validating:] not-wf [validating:] not-wf +ibm/invalid/P28/ibm28i01.xml [not validating:] input/output [validating:] invalid +ibm/invalid/P32/ibm32i01.xml [not validating:] input/output [validating:] invalid +ibm/invalid/P32/ibm32i03.xml [not validating:] input/output [validating:] invalid +ibm/invalid/P32/ibm32i04.xml [not validating:] input/output [validating:] invalid +ibm/invalid/P39/ibm39i01.xml [not validating:] input/output [validating:] invalid +ibm/invalid/P39/ibm39i02.xml [not validating:] input/output [validating:] invalid +ibm/invalid/P39/ibm39i03.xml [not validating:] input/output [validating:] invalid +ibm/invalid/P39/ibm39i04.xml [not validating:] input/output [validating:] invalid +ibm/invalid/P41/ibm41i01.xml [not validating:] input/output [validating:] invalid +ibm/invalid/P41/ibm41i02.xml [not validating:] input/output [validating:] invalid +ibm/invalid/P45/ibm45i01.xml [not validating:] input/output [validating:] invalid +ibm/invalid/P49/ibm49i01.xml [not validating:] input/output [validating:] invalid +ibm/invalid/P50/ibm50i01.xml [not validating:] input/output [validating:] invalid +ibm/invalid/P51/ibm51i01.xml [not validating:] input/output [validating:] invalid +ibm/invalid/P51/ibm51i03.xml [not validating:] input/output [validating:] invalid +ibm/invalid/P56/ibm56i01.xml [not validating:] input/output [validating:] invalid +ibm/invalid/P56/ibm56i02.xml [not validating:] input/output [validating:] invalid +ibm/invalid/P56/ibm56i03.xml [not validating:] input/output [validating:] invalid +ibm/invalid/P56/ibm56i05.xml [not validating:] input/output [validating:] invalid +ibm/invalid/P56/ibm56i06.xml [not validating:] input/output [validating:] invalid +ibm/invalid/P56/ibm56i07.xml [not validating:] input/output [validating:] invalid +ibm/invalid/P56/ibm56i08.xml [not validating:] input/output [validating:] invalid +ibm/invalid/P56/ibm56i09.xml [not validating:] input/output [validating:] invalid +ibm/invalid/P56/ibm56i10.xml [not validating:] input/output [validating:] invalid +ibm/invalid/P56/ibm56i11.xml [not validating:] input/output [validating:] invalid +ibm/invalid/P56/ibm56i12.xml [not validating:] input/output [validating:] invalid +ibm/invalid/P56/ibm56i13.xml [not validating:] input/output [validating:] invalid +ibm/invalid/P56/ibm56i14.xml [not validating:] input/output [validating:] invalid +ibm/invalid/P56/ibm56i15.xml [not validating:] input/output [validating:] invalid +ibm/invalid/P56/ibm56i16.xml [not validating:] input/output [validating:] invalid +ibm/invalid/P56/ibm56i17.xml [not validating:] input/output [validating:] invalid +ibm/invalid/P56/ibm56i18.xml [not validating:] input/output [validating:] invalid +ibm/invalid/P58/ibm58i01.xml [not validating:] input/output [validating:] invalid +ibm/invalid/P58/ibm58i02.xml [not validating:] input/output [validating:] invalid +ibm/invalid/P59/ibm59i01.xml [not validating:] input/output [validating:] invalid +ibm/invalid/P60/ibm60i01.xml [not validating:] input/output [validating:] invalid +ibm/invalid/P60/ibm60i02.xml [not validating:] input/output [validating:] invalid +ibm/invalid/P60/ibm60i03.xml [not validating:] input/output [validating:] invalid +ibm/invalid/P60/ibm60i04.xml [not validating:] input/output [validating:] invalid +ibm/invalid/P76/ibm76i01.xml [not validating:] input/output [validating:] invalid +ibm/not-wf/P01/ibm01n01.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P01/ibm01n02.xml [not validating:] not-wf [validating:] invalid +ibm/not-wf/P01/ibm01n03.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P02/ibm02n01.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P02/ibm02n02.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P02/ibm02n03.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P02/ibm02n04.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P02/ibm02n05.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P02/ibm02n06.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P02/ibm02n07.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P02/ibm02n08.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P02/ibm02n09.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P02/ibm02n10.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P02/ibm02n11.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P02/ibm02n12.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P02/ibm02n13.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P02/ibm02n14.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P02/ibm02n15.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P02/ibm02n16.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P02/ibm02n17.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P02/ibm02n18.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P02/ibm02n19.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P02/ibm02n20.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P02/ibm02n21.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P02/ibm02n22.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P02/ibm02n23.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P02/ibm02n24.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P02/ibm02n25.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P02/ibm02n26.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P02/ibm02n27.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P02/ibm02n28.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P02/ibm02n29.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P02/ibm02n30.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P02/ibm02n31.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P02/ibm02n32.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P02/ibm02n33.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P03/ibm03n01.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P04/ibm04n01.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P04/ibm04n02.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P04/ibm04n03.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P04/ibm04n04.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P04/ibm04n05.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P04/ibm04n06.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P04/ibm04n07.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P04/ibm04n08.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P04/ibm04n09.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P04/ibm04n10.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P04/ibm04n11.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P04/ibm04n12.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P04/ibm04n13.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P04/ibm04n14.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P04/ibm04n15.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P04/ibm04n16.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P04/ibm04n17.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P04/ibm04n18.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P05/ibm05n01.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P05/ibm05n02.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P05/ibm05n03.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P09/ibm09n01.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P09/ibm09n02.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P09/ibm09n03.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P09/ibm09n04.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P10/ibm10n01.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P10/ibm10n02.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P10/ibm10n03.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P10/ibm10n04.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P10/ibm10n05.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P10/ibm10n06.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P10/ibm10n07.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P10/ibm10n08.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P11/ibm11n01.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P11/ibm11n02.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P11/ibm11n03.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P11/ibm11n04.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P12/ibm12n01.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P12/ibm12n02.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P12/ibm12n03.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P13/ibm13n01.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P13/ibm13n02.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P13/ibm13n03.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P14/ibm14n01.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P14/ibm14n02.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P14/ibm14n03.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P15/ibm15n01.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P15/ibm15n02.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P15/ibm15n03.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P15/ibm15n04.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P16/ibm16n01.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P16/ibm16n02.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P16/ibm16n03.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P16/ibm16n04.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P17/ibm17n01.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P17/ibm17n02.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P17/ibm17n03.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P17/ibm17n04.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P18/ibm18n01.xml [not validating:] not-wf [validating:] invalid +ibm/not-wf/P18/ibm18n02.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P19/ibm19n01.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P19/ibm19n02.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P19/ibm19n03.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P20/ibm20n01.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P21/ibm21n01.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P21/ibm21n02.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P21/ibm21n03.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P22/ibm22n01.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P22/ibm22n02.xml [not validating:] not-wf [validating:] invalid +ibm/not-wf/P22/ibm22n03.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P23/ibm23n01.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P23/ibm23n02.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P23/ibm23n03.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P23/ibm23n04.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P23/ibm23n05.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P23/ibm23n06.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P24/ibm24n01.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P24/ibm24n02.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P24/ibm24n03.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P24/ibm24n04.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P24/ibm24n05.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P24/ibm24n06.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P24/ibm24n07.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P24/ibm24n08.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P24/ibm24n09.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P25/ibm25n01.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P25/ibm25n02.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P26/ibm26n01.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P27/ibm27n01.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P28/ibm28n01.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P28/ibm28n02.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P28/ibm28n03.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P28/ibm28n04.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P28/ibm28n05.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P28/ibm28n06.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P28/ibm28n07.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P28/ibm28n08.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/p28a/ibm28an01.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P29/ibm29n01.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P29/ibm29n02.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P29/ibm29n03.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P29/ibm29n04.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P29/ibm29n05.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P29/ibm29n06.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P29/ibm29n07.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P30/ibm30n01.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P31/ibm31n01.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P32/ibm32n01.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P32/ibm32n02.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P32/ibm32n03.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P32/ibm32n04.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P32/ibm32n05.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P32/ibm32n06.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P32/ibm32n07.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P32/ibm32n08.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P32/ibm32n09.xml [not validating:] not-wf [validating:] invalid +ibm/not-wf/P39/ibm39n01.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P39/ibm39n02.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P39/ibm39n03.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P39/ibm39n04.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P39/ibm39n05.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P39/ibm39n06.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P40/ibm40n01.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P40/ibm40n02.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P40/ibm40n03.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P40/ibm40n04.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P40/ibm40n05.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P41/ibm41n01.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P41/ibm41n02.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P41/ibm41n03.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P41/ibm41n04.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P41/ibm41n05.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P41/ibm41n06.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P41/ibm41n07.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P41/ibm41n08.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P41/ibm41n09.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P41/ibm41n10.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P41/ibm41n11.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P41/ibm41n12.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P41/ibm41n13.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P41/ibm41n14.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P42/ibm42n01.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P42/ibm42n02.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P42/ibm42n03.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P42/ibm42n04.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P42/ibm42n05.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P43/ibm43n01.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P43/ibm43n02.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P43/ibm43n04.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P43/ibm43n05.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P44/ibm44n01.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P44/ibm44n02.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P44/ibm44n03.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P44/ibm44n04.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P45/ibm45n01.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P45/ibm45n02.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P45/ibm45n03.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P45/ibm45n04.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P45/ibm45n05.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P45/ibm45n06.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P45/ibm45n07.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P45/ibm45n08.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P45/ibm45n09.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P46/ibm46n01.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P46/ibm46n02.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P46/ibm46n03.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P46/ibm46n04.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P46/ibm46n05.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P47/ibm47n01.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P47/ibm47n02.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P47/ibm47n03.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P47/ibm47n04.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P47/ibm47n05.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P47/ibm47n06.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P48/ibm48n01.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P48/ibm48n02.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P48/ibm48n03.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P48/ibm48n04.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P48/ibm48n05.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P48/ibm48n06.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P48/ibm48n07.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P49/ibm49n01.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P49/ibm49n02.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P49/ibm49n03.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P49/ibm49n04.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P49/ibm49n05.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P49/ibm49n06.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P50/ibm50n01.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P50/ibm50n02.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P50/ibm50n03.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P50/ibm50n04.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P50/ibm50n05.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P50/ibm50n06.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P50/ibm50n07.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P51/ibm51n01.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P51/ibm51n02.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P51/ibm51n03.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P51/ibm51n04.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P51/ibm51n05.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P51/ibm51n06.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P51/ibm51n07.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P52/ibm52n01.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P52/ibm52n02.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P52/ibm52n03.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P52/ibm52n04.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P52/ibm52n05.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P52/ibm52n06.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P53/ibm53n01.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P53/ibm53n02.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P53/ibm53n03.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P53/ibm53n04.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P53/ibm53n05.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P53/ibm53n06.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P53/ibm53n07.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P53/ibm53n08.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P54/ibm54n01.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P54/ibm54n02.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P55/ibm55n01.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P55/ibm55n02.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P55/ibm55n03.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P56/ibm56n01.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P56/ibm56n02.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P56/ibm56n03.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P56/ibm56n04.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P56/ibm56n05.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P56/ibm56n06.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P56/ibm56n07.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P57/ibm57n01.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P58/ibm58n01.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P58/ibm58n02.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P58/ibm58n03.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P58/ibm58n04.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P58/ibm58n05.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P58/ibm58n06.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P58/ibm58n07.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P58/ibm58n08.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P59/ibm59n01.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P59/ibm59n02.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P59/ibm59n03.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P59/ibm59n04.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P59/ibm59n05.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P59/ibm59n06.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P60/ibm60n01.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P60/ibm60n02.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P60/ibm60n03.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P60/ibm60n04.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P60/ibm60n05.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P60/ibm60n06.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P60/ibm60n07.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P60/ibm60n08.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P61/ibm61n01.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P62/ibm62n01.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P62/ibm62n02.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P62/ibm62n03.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P62/ibm62n04.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P62/ibm62n05.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P62/ibm62n06.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P62/ibm62n07.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P62/ibm62n08.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P63/ibm63n01.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P63/ibm63n02.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P63/ibm63n03.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P63/ibm63n04.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P63/ibm63n05.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P63/ibm63n06.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P63/ibm63n07.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P64/ibm64n01.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P64/ibm64n02.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P64/ibm64n03.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P65/ibm65n01.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P65/ibm65n02.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P66/ibm66n01.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P66/ibm66n02.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P66/ibm66n03.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P66/ibm66n04.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P66/ibm66n05.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P66/ibm66n06.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P66/ibm66n07.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P66/ibm66n08.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P66/ibm66n09.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P66/ibm66n10.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P66/ibm66n11.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P66/ibm66n12.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P66/ibm66n13.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P66/ibm66n14.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P66/ibm66n15.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P68/ibm68n01.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P68/ibm68n02.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P68/ibm68n03.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P68/ibm68n04.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P68/ibm68n05.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P68/ibm68n06.xml [not validating:] not-wf [validating:] invalid +ibm/not-wf/P68/ibm68n07.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P68/ibm68n08.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P68/ibm68n09.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P68/ibm68n10.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P69/ibm69n01.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P69/ibm69n02.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P69/ibm69n03.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P69/ibm69n04.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P69/ibm69n06.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P69/ibm69n07.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P71/ibm70n01.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P71/ibm71n01.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P71/ibm71n02.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P71/ibm71n03.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P71/ibm71n04.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P71/ibm71n05.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P71/ibm71n06.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P71/ibm71n07.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P71/ibm71n08.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P72/ibm72n01.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P72/ibm72n02.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P72/ibm72n03.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P72/ibm72n04.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P72/ibm72n05.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P72/ibm72n06.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P72/ibm72n07.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P72/ibm72n08.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P72/ibm72n09.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P73/ibm73n01.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P73/ibm73n03.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P74/ibm74n01.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P75/ibm75n01.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P75/ibm75n02.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P75/ibm75n03.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P75/ibm75n04.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P75/ibm75n05.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P75/ibm75n06.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P75/ibm75n07.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P75/ibm75n08.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P75/ibm75n09.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P75/ibm75n10.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P75/ibm75n11.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P75/ibm75n12.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P75/ibm75n13.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P76/ibm76n01.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P76/ibm76n02.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P76/ibm76n03.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P76/ibm76n04.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P76/ibm76n05.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P76/ibm76n06.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P76/ibm76n07.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P77/ibm77n01.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P77/ibm77n02.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P77/ibm77n03.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P77/ibm77n04.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P78/ibm78n01.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P78/ibm78n02.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P79/ibm79n01.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P79/ibm79n02.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P80/ibm80n01.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P80/ibm80n02.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P80/ibm80n03.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P80/ibm80n04.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P80/ibm80n05.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P80/ibm80n06.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P81/ibm81n01.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P81/ibm81n02.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P81/ibm81n03.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P81/ibm81n04.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P81/ibm81n05.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P81/ibm81n06.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P81/ibm81n07.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P81/ibm81n08.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P81/ibm81n09.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P82/ibm82n01.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P82/ibm82n02.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P82/ibm82n03.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P82/ibm82n04.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P82/ibm82n05.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P82/ibm82n06.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P82/ibm82n07.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P82/ibm82n08.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P83/ibm83n01.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P83/ibm83n02.xml [not validating:] not-wf [validating:] invalid +ibm/not-wf/P83/ibm83n03.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P83/ibm83n04.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P83/ibm83n05.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P83/ibm83n06.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n01.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n02.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n03.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n04.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n05.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n06.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n07.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n08.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n09.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n10.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n100.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n101.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n102.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n103.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n104.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n105.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n106.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n107.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n108.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n109.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n11.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n110.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n111.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n112.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n113.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n114.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n115.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n116.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n117.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n118.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n119.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n12.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n120.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n121.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n122.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n123.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n124.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n125.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n126.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n127.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n128.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n129.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n13.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n130.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n131.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n132.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n133.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n134.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n135.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n136.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n137.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n138.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n139.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n14.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n140.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n141.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n142.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n143.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n144.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n145.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n146.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n147.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n148.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n149.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n15.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n150.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n151.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n152.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n153.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n154.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n155.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n156.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n157.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n158.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n159.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n16.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n160.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n161.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n162.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n163.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n164.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n165.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n166.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n167.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n168.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n169.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n17.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n170.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n171.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n172.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n173.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n174.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n175.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n176.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n177.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n178.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n179.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n18.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n180.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n181.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n182.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n183.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n184.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n185.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n186.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n187.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n188.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n189.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n19.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n190.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n191.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n192.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n193.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n194.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n195.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n196.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n197.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n198.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n20.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n21.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n22.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n23.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n24.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n25.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n26.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n27.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n28.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n29.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n30.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n31.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n32.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n33.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n34.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n35.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n36.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n37.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n38.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n39.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n40.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n41.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n42.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n43.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n44.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n45.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n46.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n47.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n48.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n49.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n50.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n51.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n52.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n53.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n54.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n55.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n56.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n57.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n58.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n59.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n60.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n61.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n62.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n63.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n64.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n65.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n66.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n67.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n68.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n69.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n70.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n71.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n72.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n73.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n74.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n75.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n76.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n77.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n78.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n79.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n80.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n81.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n82.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n83.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n84.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n85.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n86.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n87.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n88.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n89.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n90.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n91.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n92.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n93.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n94.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n95.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n96.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n97.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n98.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n99.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P86/ibm86n01.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P86/ibm86n02.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P86/ibm86n03.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P86/ibm86n04.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P87/ibm87n01.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P87/ibm87n02.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P87/ibm87n03.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P87/ibm87n04.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P87/ibm87n05.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P87/ibm87n06.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P87/ibm87n07.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P87/ibm87n08.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P87/ibm87n09.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P87/ibm87n10.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P87/ibm87n11.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P87/ibm87n12.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P87/ibm87n13.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P87/ibm87n14.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P87/ibm87n15.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P87/ibm87n16.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P87/ibm87n17.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P87/ibm87n18.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P87/ibm87n19.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P87/ibm87n20.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P87/ibm87n21.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P87/ibm87n22.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P87/ibm87n23.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P87/ibm87n24.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P87/ibm87n25.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P87/ibm87n26.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P87/ibm87n27.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P87/ibm87n28.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P87/ibm87n29.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P87/ibm87n30.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P87/ibm87n31.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P87/ibm87n32.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P87/ibm87n33.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P87/ibm87n34.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P87/ibm87n35.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P87/ibm87n36.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P87/ibm87n37.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P87/ibm87n38.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P87/ibm87n39.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P87/ibm87n40.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P87/ibm87n41.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P87/ibm87n42.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P87/ibm87n43.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P87/ibm87n44.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P87/ibm87n45.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P87/ibm87n46.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P87/ibm87n47.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P87/ibm87n48.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P87/ibm87n49.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P87/ibm87n50.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P87/ibm87n51.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P87/ibm87n52.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P87/ibm87n53.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P87/ibm87n54.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P87/ibm87n55.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P87/ibm87n56.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P87/ibm87n57.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P87/ibm87n58.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P87/ibm87n59.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P87/ibm87n60.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P87/ibm87n61.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P87/ibm87n62.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P87/ibm87n63.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P87/ibm87n64.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P87/ibm87n66.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P87/ibm87n67.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P87/ibm87n68.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P87/ibm87n69.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P87/ibm87n70.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P87/ibm87n71.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P87/ibm87n72.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P87/ibm87n73.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P87/ibm87n74.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P87/ibm87n75.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P87/ibm87n76.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P87/ibm87n77.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P87/ibm87n78.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P87/ibm87n79.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P87/ibm87n80.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P87/ibm87n81.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P87/ibm87n82.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P87/ibm87n83.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P87/ibm87n84.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P87/ibm87n85.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P88/ibm88n01.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P88/ibm88n02.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P88/ibm88n03.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P88/ibm88n04.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P88/ibm88n05.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P88/ibm88n06.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P88/ibm88n08.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P88/ibm88n09.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P88/ibm88n10.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P88/ibm88n11.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P88/ibm88n12.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P88/ibm88n13.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P88/ibm88n14.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P88/ibm88n15.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P88/ibm88n16.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P89/ibm89n01.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P89/ibm89n02.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P89/ibm89n03.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P89/ibm89n04.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P89/ibm89n05.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P89/ibm89n06.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P89/ibm89n07.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P89/ibm89n08.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P89/ibm89n09.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P89/ibm89n10.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P89/ibm89n11.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P89/ibm89n12.xml [not validating:] not-wf [validating:] not-wf +ibm/valid/P01/ibm01v01.xml [not validating:] input/output [validating:] input/output +ibm/valid/P02/ibm02v01.xml [not validating:] input [validating:] input +ibm/valid/P03/ibm03v01.xml [not validating:] input [validating:] input +ibm/valid/P09/ibm09v01.xml [not validating:] input/output [validating:] input/output +ibm/valid/P09/ibm09v02.xml [not validating:] input/output [validating:] input/output +ibm/valid/P09/ibm09v03.xml [not validating:] input/output [validating:] input/output +ibm/valid/P09/ibm09v04.xml [not validating:] input/output [validating:] input/output +ibm/valid/P09/ibm09v05.xml [not validating:] input/output [validating:] input/output +ibm/valid/P10/ibm10v01.xml [not validating:] input/output [validating:] input/output +ibm/valid/P10/ibm10v02.xml [not validating:] input/output [validating:] input/output +ibm/valid/P10/ibm10v03.xml [not validating:] input/output [validating:] input/output +ibm/valid/P10/ibm10v04.xml [not validating:] input/output [validating:] input/output +ibm/valid/P10/ibm10v05.xml [not validating:] input/output [validating:] input/output +ibm/valid/P10/ibm10v06.xml [not validating:] input/output [validating:] input/output +ibm/valid/P10/ibm10v07.xml [not validating:] input/output [validating:] input/output +ibm/valid/P10/ibm10v08.xml [not validating:] input/output [validating:] input/output +ibm/valid/P11/ibm11v01.xml [not validating:] input/output [validating:] input/output +ibm/valid/P11/ibm11v02.xml [not validating:] input/output [validating:] input/output +ibm/valid/P11/ibm11v03.xml [not validating:] input/output [validating:] input/output +ibm/valid/P11/ibm11v04.xml [not validating:] input/output [validating:] input/output +ibm/valid/P12/ibm12v01.xml [not validating:] input/output [validating:] input/output +ibm/valid/P12/ibm12v02.xml [not validating:] input/output [validating:] input/output +ibm/valid/P12/ibm12v03.xml [not validating:] input/output [validating:] input/output +ibm/valid/P12/ibm12v04.xml [not validating:] input/output [validating:] input/output +ibm/valid/P13/ibm13v01.xml [not validating:] input/output [validating:] input/output +ibm/valid/P14/ibm14v01.xml [not validating:] input/output [validating:] input/output +ibm/valid/P14/ibm14v02.xml [not validating:] input/output [validating:] input/output +ibm/valid/P14/ibm14v03.xml [not validating:] input/output [validating:] input/output +ibm/valid/P15/ibm15v01.xml [not validating:] input/output [validating:] input/output +ibm/valid/P15/ibm15v02.xml [not validating:] input/output [validating:] input/output +ibm/valid/P15/ibm15v03.xml [not validating:] input/output [validating:] input/output +ibm/valid/P15/ibm15v04.xml [not validating:] input/output [validating:] input/output +ibm/valid/P16/ibm16v01.xml [not validating:] input/output [validating:] input/output +ibm/valid/P16/ibm16v02.xml [not validating:] input/output [validating:] input/output +ibm/valid/P16/ibm16v03.xml [not validating:] input/output [validating:] input/output +ibm/valid/P17/ibm17v01.xml [not validating:] input/output [validating:] input/output +ibm/valid/P18/ibm18v01.xml [not validating:] input/output [validating:] input/output +ibm/valid/P19/ibm19v01.xml [not validating:] input/output [validating:] input/output +ibm/valid/P20/ibm20v01.xml [not validating:] input/output [validating:] input/output +ibm/valid/P20/ibm20v02.xml [not validating:] input/output [validating:] input/output +ibm/valid/P21/ibm21v01.xml [not validating:] input/output [validating:] input/output +ibm/valid/P22/ibm22v01.xml [not validating:] input/output [validating:] input/output +ibm/valid/P22/ibm22v02.xml [not validating:] input/output [validating:] input/output +ibm/valid/P22/ibm22v03.xml [not validating:] input/output [validating:] input/output +ibm/valid/P22/ibm22v04.xml [not validating:] input/output [validating:] input/output +ibm/valid/P22/ibm22v05.xml [not validating:] input/output [validating:] input/output +ibm/valid/P22/ibm22v06.xml [not validating:] input/output [validating:] input/output +ibm/valid/P22/ibm22v07.xml [not validating:] input/output [validating:] input/output +ibm/valid/P23/ibm23v01.xml [not validating:] input/output [validating:] input/output +ibm/valid/P23/ibm23v02.xml [not validating:] input/output [validating:] input/output +ibm/valid/P23/ibm23v03.xml [not validating:] input/output [validating:] input/output +ibm/valid/P23/ibm23v04.xml [not validating:] input/output [validating:] input/output +ibm/valid/P23/ibm23v05.xml [not validating:] input/output [validating:] input/output +ibm/valid/P23/ibm23v06.xml [not validating:] input/output [validating:] input/output +ibm/valid/P24/ibm24v01.xml [not validating:] input/output [validating:] input/output +ibm/valid/P24/ibm24v02.xml [not validating:] input/output [validating:] input/output +ibm/valid/P25/ibm25v01.xml [not validating:] input/output [validating:] input/output +ibm/valid/P25/ibm25v02.xml [not validating:] input/output [validating:] input/output +ibm/valid/P25/ibm25v03.xml [not validating:] input/output [validating:] input/output +ibm/valid/P25/ibm25v04.xml [not validating:] input/output [validating:] input/output +ibm/valid/P26/ibm26v01.xml [not validating:] input/output [validating:] input/output +ibm/valid/P27/ibm27v01.xml [not validating:] input/output [validating:] input/output +ibm/valid/P27/ibm27v02.xml [not validating:] input/output [validating:] input/output +ibm/valid/P27/ibm27v03.xml [not validating:] input/output [validating:] input/output +ibm/valid/P28/ibm28v01.xml [not validating:] input/output [validating:] input/output +ibm/valid/P30/ibm30v01.xml [not validating:] input/output [validating:] input/output +ibm/valid/P30/ibm30v02.xml [not validating:] input/output [validating:] input/output +ibm/valid/P31/ibm31v01.xml [not validating:] input/output [validating:] input/output +ibm/valid/P32/ibm32v01.xml [not validating:] input/output [validating:] input/output +ibm/valid/P32/ibm32v02.xml [not validating:] input/output [validating:] input/output +ibm/valid/P32/ibm32v03.xml [not validating:] input/output [validating:] input/output +ibm/valid/P32/ibm32v04.xml [not validating:] input/output [validating:] input/output +ibm/valid/P33/ibm33v01.xml [not validating:] input/output [validating:] input/output +ibm/valid/P34/ibm34v01.xml [not validating:] input/output [validating:] input/output +ibm/valid/P35/ibm35v01.xml [not validating:] input/output [validating:] input/output +ibm/valid/P36/ibm36v01.xml [not validating:] input/output [validating:] input/output +ibm/valid/P37/ibm37v01.xml [not validating:] input/output [validating:] input/output +ibm/valid/P38/ibm38v01.xml [not validating:] input/output [validating:] input/output +ibm/valid/P39/ibm39v01.xml [not validating:] input/output [validating:] input/output +ibm/valid/P40/ibm40v01.xml [not validating:] input/output [validating:] input/output +ibm/valid/P41/ibm41v01.xml [not validating:] input/output [validating:] input/output +ibm/valid/P42/ibm42v01.xml [not validating:] input/output [validating:] input/output +ibm/valid/P43/ibm43v01.xml [not validating:] input/output [validating:] input/output +ibm/valid/P44/ibm44v01.xml [not validating:] input/output [validating:] input/output +ibm/valid/P45/ibm45v01.xml [not validating:] input/output [validating:] input/output +ibm/valid/P47/ibm47v01.xml [not validating:] input/output [validating:] input/output +ibm/valid/P49/ibm49v01.xml [not validating:] input/output [validating:] input/output +ibm/valid/P50/ibm50v01.xml [not validating:] input/output [validating:] input/output +ibm/valid/P51/ibm51v01.xml [not validating:] input/output [validating:] input/output +ibm/valid/P51/ibm51v02.xml [not validating:] input/output [validating:] input/output +ibm/valid/P52/ibm52v01.xml [not validating:] input/output [validating:] input/output +ibm/valid/P54/ibm54v01.xml [not validating:] input [validating:] input +ibm/valid/P54/ibm54v02.xml [not validating:] input/output [validating:] input/output +ibm/valid/P54/ibm54v03.xml [not validating:] input/output [validating:] input/output +ibm/valid/P55/ibm55v01.xml [not validating:] input/output [validating:] input/output +ibm/valid/P56/ibm56v01.xml [not validating:] input/output [validating:] input/output +ibm/valid/P56/ibm56v02.xml [not validating:] input/output [validating:] input/output +ibm/valid/P56/ibm56v03.xml [not validating:] input/output [validating:] input/output +ibm/valid/P56/ibm56v04.xml [not validating:] input/output [validating:] input/output +ibm/valid/P56/ibm56v05.xml [not validating:] input/output [validating:] input/output +ibm/valid/P56/ibm56v06.xml [not validating:] input/output [validating:] input/output +ibm/valid/P56/ibm56v07.xml [not validating:] input/output [validating:] input/output +ibm/valid/P56/ibm56v08.xml [not validating:] input/output [validating:] input/output +ibm/valid/P56/ibm56v09.xml [not validating:] input/output [validating:] input/output +ibm/valid/P56/ibm56v10.xml [not validating:] input/output [validating:] input/output +ibm/valid/P57/ibm57v01.xml [not validating:] input/output [validating:] input/output +ibm/valid/P58/ibm58v01.xml [not validating:] input/output [validating:] input/output +ibm/valid/P58/ibm58v02.xml [not validating:] input/output [validating:] input/output +ibm/valid/P59/ibm59v01.xml [not validating:] input/output [validating:] input/output +ibm/valid/P59/ibm59v02.xml [not validating:] input/output [validating:] input/output +ibm/valid/P60/ibm60v01.xml [not validating:] input/output [validating:] input/output +ibm/valid/P60/ibm60v02.xml [not validating:] input/output [validating:] input/output +ibm/valid/P60/ibm60v03.xml [not validating:] input/output [validating:] input/output +ibm/valid/P60/ibm60v04.xml [not validating:] input/output [validating:] input/output +ibm/valid/P61/ibm61v01.xml [not validating:] input/output [validating:] input/output +ibm/valid/P61/ibm61v02.xml [not validating:] input/output [validating:] input/output +ibm/valid/P62/ibm62v01.xml [not validating:] input/output [validating:] input/output +ibm/valid/P62/ibm62v02.xml [not validating:] input/output [validating:] input/output +ibm/valid/P62/ibm62v03.xml [not validating:] input/output [validating:] input/output +ibm/valid/P62/ibm62v04.xml [not validating:] input/output [validating:] input/output +ibm/valid/P62/ibm62v05.xml [not validating:] input/output [validating:] input/output +ibm/valid/P63/ibm63v01.xml [not validating:] input/output [validating:] input/output +ibm/valid/P63/ibm63v02.xml [not validating:] input/output [validating:] input/output +ibm/valid/P63/ibm63v03.xml [not validating:] input/output [validating:] input/output +ibm/valid/P63/ibm63v04.xml [not validating:] input/output [validating:] input/output +ibm/valid/P63/ibm63v05.xml [not validating:] input/output [validating:] input/output +ibm/valid/P64/ibm64v01.xml [not validating:] input/output [validating:] input/output +ibm/valid/P64/ibm64v02.xml [not validating:] input/output [validating:] input/output +ibm/valid/P64/ibm64v03.xml [not validating:] input/output [validating:] input/output +ibm/valid/P65/ibm65v01.xml [not validating:] input/output [validating:] input/output +ibm/valid/P65/ibm65v02.xml [not validating:] input/output [validating:] input/output +ibm/valid/P66/ibm66v01.xml [not validating:] input/output [validating:] input/output +ibm/valid/P67/ibm67v01.xml [not validating:] input/output [validating:] input/output +ibm/valid/P68/ibm68v01.xml [not validating:] input/output [validating:] input/output +ibm/valid/P68/ibm68v02.xml [not validating:] input/output [validating:] input/output +ibm/valid/P69/ibm69v01.xml [not validating:] input/output [validating:] input/output +ibm/valid/P69/ibm69v02.xml [not validating:] input/output [validating:] input/output +ibm/valid/P70/ibm70v01.xml [not validating:] input/output [validating:] input/output +ibm/valid/P78/ibm78v01.xml [not validating:] input/output [validating:] input/output +ibm/valid/P79/ibm79v01.xml [not validating:] input [validating:] input +ibm/valid/P82/ibm82v01.xml [not validating:] input/output [validating:] input/output +ibm/valid/P85/ibm85v01.xml [not validating:] input [validating:] input +ibm/valid/P86/ibm86v01.xml [not validating:] input [validating:] input +ibm/valid/P87/ibm87v01.xml [not validating:] input [validating:] input +ibm/valid/P88/ibm88v01.xml [not validating:] input [validating:] input +ibm/valid/P89/ibm89v01.xml [not validating:] input [validating:] input +eduni/namespaces/1.0/001.xml [not validating:] input [validating:] input +eduni/namespaces/1.0/002.xml [not validating:] input [validating:] input +eduni/namespaces/1.0/003.xml [not validating:] input [validating:] input +eduni/namespaces/1.0/007.xml [not validating:] input [validating:] input +eduni/namespaces/1.0/008.xml [not validating:] input [validating:] input +eduni/namespaces/1.0/009.xml [not validating:] not-wf [validating:] not-wf +eduni/namespaces/1.0/010.xml [not validating:] not-wf [validating:] not-wf +eduni/namespaces/1.0/011.xml [not validating:] not-wf [validating:] not-wf +eduni/namespaces/1.0/012.xml [not validating:] not-wf [validating:] not-wf +eduni/namespaces/1.0/013.xml [not validating:] not-wf [validating:] invalid +eduni/namespaces/1.0/014.xml [not validating:] not-wf [validating:] invalid +eduni/namespaces/1.0/015.xml [not validating:] not-wf [validating:] invalid +eduni/namespaces/1.0/016.xml [not validating:] not-wf [validating:] invalid +eduni/namespaces/1.0/017.xml [not validating:] input [validating:] invalid +eduni/namespaces/1.0/018.xml [not validating:] input [validating:] invalid +eduni/namespaces/1.0/019.xml [not validating:] input [validating:] invalid +eduni/namespaces/1.0/020.xml [not validating:] input [validating:] invalid +eduni/namespaces/1.0/021.xml [not validating:] input [validating:] invalid +eduni/namespaces/1.0/022.xml [not validating:] input [validating:] invalid +eduni/namespaces/1.0/023.xml [not validating:] not-wf [validating:] invalid +eduni/namespaces/1.0/024.xml [not validating:] input [validating:] invalid +eduni/namespaces/1.0/025.xml [not validating:] not-wf [validating:] invalid +eduni/namespaces/1.0/026.xml [not validating:] not-wf [validating:] invalid +eduni/namespaces/1.0/027.xml [not validating:] input [validating:] invalid +eduni/namespaces/1.0/028.xml [not validating:] input [validating:] invalid +eduni/namespaces/1.0/029.xml [not validating:] not-wf [validating:] invalid +eduni/namespaces/1.0/030.xml [not validating:] not-wf [validating:] invalid +eduni/namespaces/1.0/031.xml [not validating:] not-wf [validating:] invalid +eduni/namespaces/1.0/032.xml [not validating:] not-wf [validating:] invalid +eduni/namespaces/1.0/033.xml [not validating:] not-wf [validating:] invalid +eduni/namespaces/1.0/034.xml [not validating:] input [validating:] invalid +eduni/namespaces/1.0/035.xml [not validating:] not-wf [validating:] invalid +eduni/namespaces/1.0/036.xml [not validating:] not-wf [validating:] invalid +eduni/namespaces/1.0/037.xml [not validating:] input [validating:] invalid +eduni/namespaces/1.0/038.xml [not validating:] input [validating:] invalid +eduni/namespaces/1.0/039.xml [not validating:] input [validating:] invalid +eduni/namespaces/1.0/040.xml [not validating:] input [validating:] invalid +eduni/namespaces/1.0/041.xml [not validating:] input [validating:] invalid +eduni/namespaces/1.0/042.xml [not validating:] not-wf [validating:] not-wf +eduni/namespaces/1.0/043.xml [not validating:] not-wf [validating:] not-wf +eduni/namespaces/1.0/044.xml [not validating:] not-wf [validating:] not-wf +eduni/namespaces/1.0/045.xml [not validating:] input [validating:] invalid +eduni/namespaces/1.0/046.xml [not validating:] input [validating:] invalid +0/1829 tests failed; 333 tests were skipped \ No newline at end of file Added: branches/grin-neu/thirdparty/cxml/XMLS-SYMBOLS.diff =================================================================== --- branches/grin-neu/thirdparty/cxml/XMLS-SYMBOLS.diff 2006-12-01 10:37:34 UTC (rev 2093) +++ branches/grin-neu/thirdparty/cxml/XMLS-SYMBOLS.diff 2006-12-01 10:39:49 UTC (rev 2094) @@ -0,0 +1,98 @@ +* looking for david at knowledgetools.de--cxml/cxml--devel--1.0--patch-309 to compare with +* comparing to david at knowledgetools.de--cxml/cxml--devel--1.0--patch-309 +M xml/xmls-compat.lisp + +* modified files + +--- orig/xml/xmls-compat.lisp ++++ mod/xml/xmls-compat.lisp +@@ -12,7 +12,8 @@ + (defpackage cxml-xmls + (:use :cl :runes) + (:export #:make-node #:node-name #:node-ns #:node-attrs #:node-children +- #:make-xmls-builder #:map-node)) ++ #:make-xmls-builder #:map-node ++ #:*identifier-case*)) + + (in-package :cxml-xmls) + +@@ -64,6 +65,10 @@ + + ;;;; SAX-Handler (Parser) + ++(defvar *identifier-case* nil ++ "One of NIL (don't intern names), :PRESERVE, :UPCASE, :DOWNCASE, or :INVERT ++ (intern name into the keyword package after adjusting case).") ++ + (defclass xmls-builder () + ((element-stack :initform nil :accessor element-stack) + (root :initform nil :accessor root))) +@@ -74,16 +79,46 @@ + (defmethod sax:end-document ((handler xmls-builder)) + (root handler)) + ++(defun string-invert-case (str) ++ (map 'string ++ (lambda (c) ++ (cond ++ ((upper-case-p c) (char-downcase c)) ++ ((lower-case-p c) (char-upcase c)) ++ (t c))) ++ str)) ++ ++(defun maybe-intern (name) ++ (if *identifier-case* ++ (let ((str (if (stringp name) name (rod-string name)))) ++ (intern (ecase *identifier-case* ++ (:preserve str) ++ (:upcase (string-upcase str)) ++ (:downcase (string-downcase str)) ++ (:invert (string-invert-case str))) ++ :keyword)) ++ name)) ++ ++(defun maybe-stringify (name) ++ (if (symbolp name) ++ (let ((str (symbol-name name))) ++ (ecase *identifier-case* ++ (:preserve str) ++ (:upcase (string-downcase str)) ++ (:downcase (string-upcase str)) ++ (:invert (string-invert-case str)))) ++ name)) ++ + (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 + (mapcar (lambda (attr) +- (list (sax:attribute-qname attr) ++ (list (maybe-intern (sax:attribute-qname attr)) + (sax:attribute-value attr))) + attributes)) +- (node (make-node :name local-name ++ (node (make-node :name (maybe-intern local-name) + :ns (let ((lq (length qname)) + (ll (length local-name))) + (if (eql lq ll) +@@ -124,7 +159,7 @@ + (labels ((walk (node) + (let* ((attlist + (compute-attributes node include-xmlns-attributes)) +- (lname (rod (node-name node))) ++ (lname (rod (maybe-stringify (node-name node)))) + (ns (rod (node-ns node))) + (qname (concatenate 'rod ns (rod ":") lname))) + ;; fixme: namespaces +@@ -141,6 +176,7 @@ + (remove nil + (mapcar (lambda (a) + (destructuring-bind (name value) a ++ (setf name (maybe-stringify name)) + (if (or xmlnsp (not (cxml::xmlns-attr-p (rod name)))) + (sax:make-attribute :qname (rod name) + :value (rod value) + + + Modified: branches/grin-neu/thirdparty/cxml/catalog.dtd =================================================================== --- branches/grin-neu/thirdparty/cxml/catalog.dtd 2006-12-01 10:37:34 UTC (rev 2093) +++ branches/grin-neu/thirdparty/cxml/catalog.dtd 2006-12-01 10:39:49 UTC (rev 2094) @@ -1,4 +1,4 @@ - + Added: branches/grin-neu/thirdparty/cxml/contrib/xhtmlgen.lisp =================================================================== --- branches/grin-neu/thirdparty/cxml/contrib/xhtmlgen.lisp 2006-12-01 10:37:34 UTC (rev 2093) +++ branches/grin-neu/thirdparty/cxml/contrib/xhtmlgen.lisp 2006-12-01 10:39:49 UTC (rev 2094) @@ -0,0 +1,352 @@ +;; xhtmlgen.lisp +;; This version by david at lichteblau.com for headcraft (http://headcraft.de/) +;; +;; Derived from htmlgen.cl: +;; copyright (c) 1986-2000 Franz Inc, Berkeley, CA +;; +;; This code is free software; you can redistribute it and/or +;; modify it under the terms of the version 2.1 of +;; the GNU Lesser General Public License as published by +;; the Free Software Foundation, as clarified by the AllegroServe +;; prequel found in license-allegroserve.txt. +;; +;; This code 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 +;; Lesser General Public License for more details. +;; +;; Version 2.1 of the GNU Lesser General Public License is in the file +;; license-lgpl.txt that was distributed with this file. +;; If it is not present, you can access it from +;; http://www.gnu.org/copyleft/lesser.txt (until superseded by a newer +;; version) or write to the Free Software Foundation, Inc., 59 Temple Place, +;; Suite 330, Boston, MA 02111-1307 USA + +(defpackage :xhtml-generator + (:use :common-lisp) + (:export #:with-html #:write-doctype)) + +(in-package :xhtml-generator) + +;; html generation + +(defstruct (html-process (:type list) (:constructor + make-html-process (key macro special + name-attr + ))) + key ; keyword naming this tag + macro ; the macro to define this + special ; if true then call this to process the keyword and return + ; the macroexpansion + name-attr ; attribute symbols which can name this object for subst purposes + ) + + +(defparameter *html-process-table* + (make-hash-table :test #'equal) ; #'eq is accurate but want to avoid rehashes + ) + +(defvar *html-sink*) + +(defun write-doctype (sink) + (sax:start-dtd sink + "html" + "-//W3C//DTD XHTML 1.0 Transitional//EN" + "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd") + (sax:end-dtd sink)) + +(defmacro with-html (sink &rest forms &environment env) + `(let ((*html-sink* ,sink)) + ,(process-html-forms forms env))) + +(defun get-process (form) + (let ((ent (gethash form *html-process-table*))) + (unless ent + (error "unknown html keyword ~s" form)) + ent)) + +(defun process-html-forms (forms env) + (let (res) + (flet ((do-ent (ent args argsp body) + ;; ent is an html-process object associated with the + ;; html tag we're processing + ;; args is the list of values after the tag in the form + ;; ((:tag &rest args) ....) + ;; argsp is true if this isn't a singleton tag (i.e. it has + ;; a body) .. (:tag ...) or ((:tag ...) ...) + ;; body is the body if any of the form + ;; + (let ((special (html-process-special ent))) + (push (if special + (funcall special ent args argsp body) + `(,(html-process-macro ent) + ,args + ,(process-html-forms body env))) + res)))) + (do* ((xforms forms (cdr xforms)) + (form (car xforms) (car xforms))) + ((null xforms)) + + (setq form (macroexpand form env)) + + (if (atom form) + (typecase form + (keyword (do-ent (get-process form) nil nil nil)) + (string (push `(sax:characters *html-sink* ,form) res)) + (t (push form res))) + (let ((first (car form))) + (cond + ((keywordp first) + ;; (:xxx . body) form + (do-ent (get-process (car form)) nil t (cdr form))) + ((and (consp first) (keywordp (car first))) + ;; ((:xxx args ) . body) + (do-ent (get-process (caar form)) (cdr first) t (cdr form))) + (t + (push form res))))))) + `(progn ,@(nreverse res)))) + +(defun html-body-key-form (string-code args body) + (unless (evenp (length args)) + (error "attribute list ~S isn't even" args)) + `(let ((.tagname. ,string-code)) + (sax:start-element *html-sink* nil nil .tagname. + (list + ,@(loop + for (name value) on args by #'cddr + collect + `(sax:make-attribute + :qname ,(etypecase name + (symbol (symbol-name name)) + (string name)) + :value ,value + :specified-p t)))) + , at body + (sax:end-element *html-sink* nil nil .tagname.))) + +(defun emit-without-quoting (str) + (let ((s (cxml::chained-handler *html-sink*))) + (cxml::maybe-close-tag s) + (map nil (lambda (c) (cxml::write-rune (char-code c) s)) str))) + +(defun princ-http (val) + (warn "use of deprecated :PRINC (use :PRINC-SAFE instead?)") + (emit-without-quoting (princ-to-string val))) + +(defun prin1-http (val) + (warn "use of deprecated :PRIN1 (use :PRIN1-SAFE instead?)") + (emit-without-quoting (prin1-to-string val))) + +(defun princ-safe-http (val) + (sax:characters *html-sink* (princ-to-string val))) + +(defun prin1-safe-http (val) + (sax:characters *html-sink* (prin1-to-string val))) + + +;; -- defining how html tags are handled. -- +;; +;; most tags are handled in a standard way and the def-std-html +;; macro is used to define such tags +;; +;; Some tags need special treatment and def-special-html defines +;; how these are handled. The tags requiring special treatment +;; are the pseudo tags we added to control operations +;; in the html generator. +;; +;; +;; tags can be found in three ways: +;; :br - singleton, no attributes, no body +;; (:b "foo") - no attributes but with a body +;; ((:a href="foo") "balh") - attributes and body +;; + +(defmacro def-special-html (kwd fcn) + ;; kwd - the tag we're defining behavior for. + ;; fcn - function to compute the macroexpansion of a use of this + ;; tag. args to fcn are: + ;; ent - html-process object holding info on this tag + ;; args - list of attribute-values following tag + ;; argsp - true if there is a body in this use of the tag + ;; body - list of body forms. + `(setf (gethash ,kwd *html-process-table*) + (make-html-process ,kwd nil ,fcn nil))) + +(def-special-html :newline + #'(lambda (ent args argsp body) + (declare (ignore ent args argsp)) + (when body + (error "can't have a body with :newline -- body is ~s" body)) + (emit-without-quoting (string #\newline)))) + +(def-special-html :princ + #'(lambda (ent args argsp body) + (declare (ignore ent args argsp)) + `(progn ,@(mapcar #'(lambda (bod) + `(princ-http ,bod)) + body)))) + +(def-special-html :princ-safe + #'(lambda (ent args argsp body) + (declare (ignore ent args argsp)) + `(progn ,@(mapcar #'(lambda (bod) + `(princ-safe-http ,bod)) + body)))) + +(def-special-html :prin1 + #'(lambda (ent args argsp body) + (declare (ignore ent args argsp)) + `(progn ,@(mapcar #'(lambda (bod) + `(prin1-http ,bod)) + body)))) + +(def-special-html :prin1-safe + #'(lambda (ent args argsp body) + (declare (ignore ent args argsp)) + `(progn ,@(mapcar #'(lambda (bod) + `(prin1-safe-http ,bod)) + body)))) + +(def-special-html :comment + #'(lambda (ent args argsp body) + (declare (ignore ent args argsp body)) + `(warn ":COMMENT in html macro not supported yet"))) + +(defmacro def-std-html (kwd name-attrs) + (let ((mac-name (intern (format nil "~a-~a" :with-html kwd))) + (string-code (string-downcase (string kwd)))) + `(progn (setf (gethash ,kwd *html-process-table*) + (make-html-process ,kwd + ',mac-name + nil + ',name-attrs)) + (defmacro ,mac-name (args &rest body) + (html-body-key-form ,string-code args body))))) + +(def-std-html :a nil) +(def-std-html :abbr nil) +(def-std-html :acronym nil) +(def-std-html :address nil) +(def-std-html :applet nil) +(def-std-html :area nil) + +(def-std-html :b nil) +(def-std-html :base nil) +(def-std-html :basefont nil) +(def-std-html :bdo nil) +(def-std-html :bgsound nil) +(def-std-html :big nil) +(def-std-html :blink nil) +(def-std-html :blockquote nil) +(def-std-html :body nil) +(def-std-html :br nil) +(def-std-html :button nil) + +(def-std-html :caption nil) +(def-std-html :center nil) +(def-std-html :cite nil) +(def-std-html :code nil) +(def-std-html :col nil) +(def-std-html :colgroup nil) + +(def-std-html :dd nil) +(def-std-html :del nil) +(def-std-html :dfn nil) +(def-std-html :dir nil) +(def-std-html :div nil) +(def-std-html :dl nil) +(def-std-html :dt nil) + +(def-std-html :em nil) +(def-std-html :embed nil) + +(def-std-html :fieldset nil) +(def-std-html :font nil) +(def-std-html :form :name) +(def-std-html :frame nil) +(def-std-html :frameset nil) + +(def-std-html :h1 nil) +(def-std-html :h2 nil) +(def-std-html :h3 nil) +(def-std-html :h4 nil) +(def-std-html :h5 nil) +(def-std-html :h6 nil) +(def-std-html :head nil) +(def-std-html :hr nil) +(def-std-html :html nil) + +(def-std-html :i nil) +(def-std-html :iframe nil) +(def-std-html :ilayer nil) +(def-std-html :img :id) +(def-std-html :input nil) +(def-std-html :ins nil) +(def-std-html :isindex nil) + +(def-std-html :kbd nil) +(def-std-html :keygen nil) + +(def-std-html :label nil) +(def-std-html :layer nil) +(def-std-html :legend nil) +(def-std-html :li nil) +(def-std-html :link nil) +(def-std-html :listing nil) + +(def-std-html :map nil) +(def-std-html :marquee nil) +(def-std-html :menu nil) +(def-std-html :meta nil) +(def-std-html :multicol nil) + +(def-std-html :nobr nil) +(def-std-html :noembed nil) +(def-std-html :noframes nil) +(def-std-html :noscript nil) + +(def-std-html :object nil) +(def-std-html :ol nil) +(def-std-html :optgroup nil) +(def-std-html :option nil) + +(def-std-html :p nil) +(def-std-html :param nil) +(def-std-html :plaintext nil) +(def-std-html :pre nil) + +(def-std-html :q nil) + +(def-std-html :s nil) +(def-std-html :samp nil) +(def-std-html :script nil) +(def-std-html :select nil) +(def-std-html :server nil) +(def-std-html :small nil) +(def-std-html :spacer nil) +(def-std-html :span :id) +(def-std-html :strike nil) +(def-std-html :strong nil) +(def-std-html :style nil) +(def-std-html :sub nil) +(def-std-html :sup nil) + +(def-std-html :table :name) +(def-std-html :tbody nil) +(def-std-html :td nil) +(def-std-html :textarea nil) +(def-std-html :tfoot nil) +(def-std-html :th nil) +(def-std-html :thead nil) +(def-std-html :title nil) +(def-std-html :tr nil) +(def-std-html :tt nil) + +(def-std-html :u nil) +(def-std-html :ul nil) + +(def-std-html :var nil) + +(def-std-html :wbr nil) + +(def-std-html :xmp nil) Modified: branches/grin-neu/thirdparty/cxml/cxml.asd =================================================================== --- branches/grin-neu/thirdparty/cxml/cxml.asd 2006-12-01 10:37:34 UTC (rev 2093) +++ branches/grin-neu/thirdparty/cxml/cxml.asd 2006-12-01 10:39:49 UTC (rev 2094) @@ -5,10 +5,6 @@ (:use :asdf :cl)) (in-package :cxml-system) -;; XXX das sollte natuerlich erst beim laden stattfinden -#+cmu -(require :gray-streams) - (defclass closure-source-file (cl-source-file) ()) #+sbcl @@ -18,7 +14,7 @@ (let (#+sbcl (*compile-print* nil)) (call-next-method)))) -#-(or rune-is-character rune-is-octet) +#-(or rune-is-character rune-is-integer) (progn (format t "~&;;; Checking for wide character support...") (force-output) @@ -28,7 +24,7 @@ :rune-is-character)) (unless (and (< x char-code-limit) (code-char x)) (format t " no, reverting to octet strings.~%") - (return :rune-is-octet))) + (return :rune-is-integer))) *features*)) #-rune-is-character @@ -37,67 +33,81 @@ #+rune-is-character (format t "~&;;; Building cxml with CHARACTER RUNES~%") -(defsystem runes +(defsystem :cxml-runes :default-component-class closure-source-file :pathname (merge-pathnames "runes/" (make-pathname :name nil :type nil :defaults *load-truename*)) + :serial t :components ((:file "package") - (:file dependent - :pathname - #+CLISP "dep-clisp" - #+(AND :CMU (NOT :PTHREAD)) "dep-cmucl" - #+sbcl "dep-sbcl" - #+(AND :CMU :PTHREAD) "dep-cmucl-dtc" - #+(and allegro-version>= (version>= 5.0)) "dep-acl5" - #+(and allegro-version>= (not (version>= 5.0))) "dep-acl" - #-(or sbcl CLISP CMU allegro) #.(error "Configure!") - :depends-on ("package")) + (:file "definline") (:file runes :pathname #-rune-is-character "runes" - #+rune-is-character "characters" - :depends-on ("package" dependent)) - (:file "syntax" :depends-on ("package" dependent runes)) - (:file "util" :depends-on ("package" dependent)) - (:file "encodings" :depends-on ("package")) - (:file "encodings-data" :depends-on ("package" "encodings")) - (:file "xstream" - :depends-on ("package" dependent "syntax" "encodings-data")))) + #+rune-is-character "characters") + #+rune-is-integer (:file "utf8") + (:file "syntax") + (:file "encodings") + (:file "encodings-data") + (:file "xstream") + (:file "ystream"))) -(asdf:defsystem :xml +(asdf:defsystem :cxml-xml :default-component-class closure-source-file :pathname (merge-pathnames "xml/" (make-pathname :name nil :type nil :defaults *load-truename*)) :components ((:file "package") + (:file "util" :depends-on ("package")) (:file "sax-handler") - (:file "characters" :depends-on ("package")) - (:file "xml-name-rune-p" :depends-on ("package")) + (:file "xml-name-rune-p" :depends-on ("package" "util")) (:file "split-sequence" :depends-on ("package")) - (:file "xml-parse" :depends-on ("package" "sax-handler" "split-sequence" "xml-name-rune-p" "characters")) - (:file "characters" :depends-on ("package")) + (:file "xml-parse" :depends-on ("package" "util" "sax-handler" "split-sequence" "xml-name-rune-p")) (:file "unparse" :depends-on ("xml-parse")) (:file "xmls-compat" :depends-on ("xml-parse")) (:file "recoder" :depends-on ("xml-parse")) - (:file "catalog" :depends-on ("xml-parse"))) - :depends-on (:runes :puri)) + (:file "xmlns-normalizer" :depends-on ("xml-parse")) + (:file "space-normalizer" :depends-on ("xml-parse")) + (:file "catalog" :depends-on ("xml-parse")) + (:file "sax-proxy" :depends-on ("xml-parse"))) + :depends-on (:cxml-runes :puri :trivial-gray-streams)) -(asdf:defsystem :dom +(defclass utf8dom-file (closure-source-file) ((of))) + +(defmethod output-files ((operation compile-op) (c utf8dom-file)) + (let* ((normal (car (call-next-method))) + (name (concatenate 'string (pathname-name normal) "-utf8")) + (of (make-pathname :name name :defaults normal))) + (setf (slot-value c 'of) of) + (list of))) + +(defmethod perform ((o load-op) (c utf8dom-file)) + (load (slot-value c 'of))) + +(defvar *utf8-runes-readtable*) + +(defmethod perform ((operation compile-op) (c utf8dom-file)) + (let ((*features* (cons 'utf8dom-file *features*)) + (*readtable* *utf8-runes-readtable*)) + (call-next-method))) + +(asdf:defsystem :cxml-dom :default-component-class closure-source-file :pathname (merge-pathnames "dom/" (make-pathname :name nil :type nil :defaults *load-truename*)) :components ((:file "package") - (:file "dom-impl" :depends-on ("package")) - (:file "dom-builder" :depends-on ("dom-impl")) - (:file "unparse" :depends-on ("package")) - (:file "simple-dom" :depends-on ("package")) + (:file rune-impl :pathname "dom-impl" :depends-on ("package")) + (:file rune-builder :pathname "dom-builder" :depends-on (rune-impl)) + #+rune-is-integer + (utf8dom-file utf8-impl :pathname "dom-impl" :depends-on ("package")) + #+rune-is-integer + (utf8dom-file utf8-builder :pathname "dom-builder" :depends-on (utf8-impl)) (:file "dom-sax" :depends-on ("package"))) - :depends-on (:xml)) + :depends-on (:cxml-xml)) (asdf:defsystem :cxml-test :default-component-class closure-source-file @@ -105,6 +115,6 @@ "test/" (make-pathname :name nil :type nil :defaults *load-truename*)) :components ((:file "domtest") (:file "xmlconf")) - :depends-on (:xml :dom)) + :depends-on (:cxml-xml :cxml-dom)) -(asdf:defsystem :cxml :components () :depends-on (:dom :cxml-test)) +(asdf:defsystem :cxml :components () :depends-on (:cxml-dom :cxml-test)) Added: branches/grin-neu/thirdparty/cxml/doc/bg.png =================================================================== (Binary files differ) Property changes on: branches/grin-neu/thirdparty/cxml/doc/bg.png ___________________________________________________________________ Name: svn:mime-type + image/png Added: branches/grin-neu/thirdparty/cxml/doc/cxml.css =================================================================== --- branches/grin-neu/thirdparty/cxml/doc/cxml.css 2006-12-01 10:37:34 UTC (rev 2093) +++ branches/grin-neu/thirdparty/cxml/doc/cxml.css 2006-12-01 10:39:49 UTC (rev 2094) @@ -0,0 +1,85 @@ +div.sidebar { + float: right; + min-width: 15%; + padding: 0pt 5pt 5pt 5pt; + font-family: verdana, arial; +} + +div.sidebar-title { + font-weight: bold; + background-color: #9c0000; + border: solid #9c0000; + border-top-width: 1px; + border-bottom-width: 0px; + border-left-width: 4px; + border-right-width: 0px; + margin: 0em 2pt 1px 2em; +} + +div.sidebar-title a { + color: #ffffff; +} + +div.sidebar-main { + background-color: #eeeeee; + border: solid #9c0000; + border-top-width: 0px; + border-bottom-width: 0px; + border-left-width: 4px; + border-right-width: 0px; + margin: 0em 2pt 1em 2em; + padding-top: 2px; + padding-left: 2px; +} + +div.sidebar ul.main { + padding: 0pt 0pt 0pt 1em; + margin: 0 0 1em; +} + +div.sidebar ul.sub { + list-style-type: square; + padding: 0pt 0pt 0pt 1em; + margin: 0 0 1em; +} + +div.sidebar ul.hack { + padding: 0 0 0 0; + margin: 0 0 1em; + list-style-type: none; +} + +body { + color: #000000; + background-color: #ffffff; + margin-right: 0pt; + margin-bottom: 10%; + margin-left: 40px; + padding-left: 30px; + font-family: verdana, arial; + background-image: url(bg.png); + background-position: top left; + background-attachment: fixed; + background-repeat: no-repeat; +} + +h1,h2,h3 { + margin-left: -30px; +} + +pre { + background-color: #eeeeee; + border: solid 1px #d0d0d0; + padding: 1em; + margin-right: 10%; +} + +.def { + background-color: #ddddff; + font-weight: bold; +} + +.nomargin { + margin-bottom: 0; + margin-top: 0; +} Added: branches/grin-neu/thirdparty/cxml/doc/dom.html =================================================================== --- branches/grin-neu/thirdparty/cxml/doc/dom.html 2006-12-01 10:37:34 UTC (rev 2093) +++ branches/grin-neu/thirdparty/cxml/doc/dom.html 2006-12-01 10:39:49 UTC (rev 2094) @@ -0,0 +1,209 @@ + + + + + Closure XML + + + + + +

    The DOM implementation

    +

    + CXML implements the DOM Level 2 Core interfaces.  For details + on DOM, please refer to the specification. +

    + + +

    Parsing into DOM

    +

    + To parse an XML document into a DOM tree, use the SAX parser with a + DOM builder as the SAX handler. Example: +

    +
    (cxml:parse-file "test.xml" (cxml-dom:make-dom-builder))
    +

    +

    Function CXML-DOM:MAKE-DOM-BUILDER ()
    + Create a SAX handler which builds a DOM document. +

    +

    + This functions returns a DOM builder that will work with the default + configuration of the SAX parser and is guaranteed to use + characters/strings instead of runes/rods, if that makes a + difference on the Lisp in question. +

    +

    + This is the same as rune-dom:make-dom-builder on Lisps + with Unicode support, and the same as + utf8-dom:make-dom-builder otherwise. +

    + +

    +

    Function RUNE-DOM:MAKE-DOM-BUILDER ()
    + Create a SAX handler which builds a DOM document using runes and rods. +

    + +

    +

    Function UTF8-DOM:MAKE-DOM-BUILDER ()
    + (Only on Lisps without Unicode support:) + Create a SAX handler which builds a DOM document using + UTF-8-encoded strings. +

    + +
    +

    Serializing DOM

    +

    + To serialize a DOM document, use a SAX serialization sink as the + argument to dom:map-document, which generates SAX events + for the DOM tree. +

    +

    + Applications dealing with namespaces might want to inject a + namespace normalizer into the + sink chain. +

    +

    +

    Function DOM:MAP-DOCUMENT (handler document &key include-xmlns-attributes include-default-values include-doctype)
    + Traverse a DOM document and call SAX functions as if an XML + representation of the document was processed by a SAX parser. +

    +

    Keyword arguments:

    +
      +
    • + include-xmlns-attributes -- defaults to + sax:*include-xmlns-attributes* +
    • +
    • + include-doctype -- One of nil (no doctype + declaration), :full-internal-subset (include a doctype + declaration and the full internal subset), or + :canonical-notations (write a doctype declaration + with an internal subset including only notations, as required + for canonical serialization). +
    • +
    • + include-default-values -- include attribute nodes with nil + dom:specified. +
    • +
    • + recode -- (ignored on Lisps with Unicode support.) If + true, recode UTF-8 strings to rods. Defaults to true if used + with a UTF-8 DOM document. It can be set to false manually to + suppress recoding in this case. +
    • +
    + + +

    DOM/Lisp mapping

    +

    + Note that there is no "standard" DOM mapping for Lisp. +

    +

    + DOM is specified + in CORBA IDL, but it refrains from using object-oriented IDL + features, allowing for a much more natural Lisp implemenation than + the the ordinary IDL/Lisp mapping would.  + Differences between CXML's DOM and the direct IDL/Lisp mapping: +

    +
      +
    • + DOM function names are symbols in the DOM package (not + the OP package). +
    • +
    • + DOM functions have proper required arguments, not a huge + &rest lambda list. +
    • +
    • + Although most IDL interfaces are implemented as CLOS classes by + CXML, the Lisp types of DOM objects is not documented and cannot + be relied upon.  A node's type can be determined using + dom:node-type instead. +
    • +
    • + DOMString is mapped to rod, which is either + an (unsigned-byte 16) array type or a string type. +
    • +
    • + The IDL/Lisp mapping maps CORBA enums to Lisp keywords.  + Unfortunately, the DOM IDL does not use enums.  Instead, + both exception types and node types are defined integer + constants.  CXML chooses to ignore this definition and uses + keywords instead. +
    • +
    • + DOM uses StudlyCaps.  Lisp programmers don't.  We + insert #\- before every upper case letter preceded by a + lower case letter and before every upper case letter which is + followed by a lower case letter, but preceded by a capital + letter.  This algorithms leads to the natural Lisp spelling + of DOM function names. +
    • +
    • + Implementation note: DOM's NodeList does not + necessarily map to a native "sequence" type.  (For example, + node lists are objects in Java, not arrays.)  + NodeList is specified to reflect changes done after a + node list was created, so node lists cannot be Lisp lists.  + (A node list could be implemented as a CLOS object pointing to + said list though.)  Instead, CXML currently implements node + lists as adjustable vectors.  Note that code which relies on + this implementation and uses Lisp sequence functions + instead of sticking to dom:item and dom:length + is not portable.  As a compromise, you can use our + extensions dom:map-node-list or + dom:do-node-list, which can be implemented portably. +
    • +
    + + Added: branches/grin-neu/thirdparty/cxml/doc/installation.html =================================================================== --- branches/grin-neu/thirdparty/cxml/doc/installation.html 2006-12-01 10:37:34 UTC (rev 2093) +++ branches/grin-neu/thirdparty/cxml/doc/installation.html 2006-12-01 10:39:49 UTC (rev 2094) @@ -0,0 +1,162 @@ + + + + + Closure XML + + + + +

    Installation of Closure XML

    + + +

    Download

    +
      +
    • + +
    • +
    • +
      + Anoncvs (browse): +
      $ export CVSROOT=:pserver:anonymous at common-lisp.net:/project/cxml/cvsroot
      +$ cvs login
      +Logging in to :pserver:anonymous at common-lisp.net:2401/project/cxml/cvsroot
      +CVS password: anonymous
      +$ cvs co cxml
      +
      +
    • +
    + + +

    Implementation-specific notes

    +

    + CXML should be portable to all Common Lisp implementations + supported by trivial-gray-streams. +

    +
      +
    • + The SBCL port uses 16 bit surrogate characters instead of taking + advantage of SBCL's full 21 bit character support. +
    • +
    + + +

    Compilation

    +

    + ASDF is used for + compilation. The following instructions assume that ASDF has + already been loaded. +

    + +

    + Prerequisites. + CXML needs the puri library + as well as trivial-gray-streams. +

    + +

    + Compiling and loading CXML. + Register the .asd file, e.g. by symlinking it: +

    +
    $ ln -sf `pwd`/cxml.asd /path/to/your/registry/
    +

    Then compile CXML using:

    +
    * (asdf:operate 'asdf:load-op :cxml)
    + +

    + You can then try the quick-start example. +

    + + +

    Tests

    +

    Check out the XML and DOM testsuites:

    +
    $ export CVSROOT=:pserver:anonymous at dev.w3.org:/sources/public
    +$ cvs login    # password is "anonymous"
    +$ cvs co 2001/XML-Test-Suite/xmlconf
    +$ cvs co -D '2005-05-06 23:00' 2001/DOM-Test-Suite
    +$ cd 2001/DOM-Test-Suite && ant dom1-dtd dom2-dtd
    +

    + Omit -D to get the latest version, which may not work + with cxml yet. The ant step is necessary to run the DOM + tests. +

    +

    Usage:

    +
    * (xmlconf:run-all-tests "/path/to/2001/XML-Test-Suite/xmlconf/")
    +* (domtest:run-all-tests "/path/to/2001/DOM-Test-Suite/")
    +
    +

    + To compare your results with known output, refer to the files + XMLCONF and DOMTEST in the cxml distribution. +

    + +

    + fixme: Add an explanation of xml/sax-tests here. +

    + +

    + fixme domtest.lisp does not understand the current + testsuite driver anymore.  To fix this problem, revert the + affected files manually after check-out: +

    + +
    $ cd 2001/XML-Test-Suite/xmlconf/
    +xmltest$ patch -p0 -R </path/to/cxml/test/xmlconf-base.diff
    + +

    + The log message for the changes reads "Removed unnecessary + xml:base attribute".  If I understand correctly, only + DOM 3 parsers provide the baseURI attribute necessary for + understanding xmlconf.xml now.  We don't have that + yet. +

    + + Added: branches/grin-neu/thirdparty/cxml/doc/quickstart.html =================================================================== --- branches/grin-neu/thirdparty/cxml/doc/quickstart.html 2006-12-01 10:37:34 UTC (rev 2093) +++ branches/grin-neu/thirdparty/cxml/doc/quickstart.html 2006-12-01 10:39:49 UTC (rev 2094) @@ -0,0 +1,98 @@ + + + + + Closure XML + + + +
    + +

    Quick-Start Example

    + +

    + Make sure to install and load cxml first. +

    + +

    Create a test file called example.xml:

    +
    * (with-open-file (s "example.xml" :direction :output)
    +    (write-string "<test a='b'><child/></test>" s))
    + +

    Parse example.xml into a DOM tree (read + more):

    +
    * (cxml:parse-file "example.xml" (cxml-dom:make-dom-builder))
    +#<DOM-IMPL::DOCUMENT @ #x72206172>
    +;; save result for later:
    +* (defparameter *example* *)
    +*EXAMPLE*
    + +

    Inspect the DOM tree (read more):

    +
    * (dom:document-element *example*)
    +#<DOM-IMPL::ELEMENT test @ #x722b6ba2>
    +* (dom:tag-name (dom:document-element *example*))
    +"test"
    +* (dom:child-nodes (dom:document-element *example*))
    +#(#<DOM-IMPL::ELEMENT child @ #x722b6d8a>)
    +* (dom:get-attribute (dom:document-element *example*) "a")
    +"b"
    + +

    Serialize the DOM document back into a file (read more):

    +
    (with-open-file (out "example.out" :direction :output :element-type '(unsigned-byte 8))
    +  (dom:map-document (cxml:make-octet-stream-sink out) *example*))
    + +

    As an alternative to DOM, parse into xmls-compatible list + structure (read more):

    +
    * (cxml:parse-file "example.xml" (cxml-xmls:make-xmls-builder))
    +("test" (("a" "b")) ("child" NIL))
    + + Added: branches/grin-neu/thirdparty/cxml/doc/using.html =================================================================== --- branches/grin-neu/thirdparty/cxml/doc/using.html 2006-12-01 10:37:34 UTC (rev 2093) +++ branches/grin-neu/thirdparty/cxml/doc/using.html 2006-12-01 10:39:49 UTC (rev 2094) @@ -0,0 +1,635 @@ + + + + + Closure XML + + + + +

    Using the SAX parser

    + + +

    Parsing and Validating

    +

    + CXML is implemented as a SAX parser. (Refer to make-dom-builder for information about + DOM.) +

    +

    +

    Function CXML:PARSE-FILE (pathname handler &key ...)
    +
    Function CXML:PARSE-STREAM (stream handler &key ...)
    +
    Function CXML:PARSE-OCTETS (octets handler &key ...)
    +
    Function CXML:PARSE-ROD (rod handler &key ...)
    + Parse an XML document.  + Return values from this function depend on the SAX handler used.
    + Arguments: +

    +
      +
    • pathname -- a Common Lisp pathname
    • +
    • stream -- a Common Lisp stream with element-type + (unsigned-byte 8)
    • +
    • octets -- an (unsigned-byte 8) array
    • +
    • handler -- a SAX handler
    • +
    +

    + Common keyword arguments: +

    +
      +
    • + validate -- A boolean.  Defaults to + nil. If true, parse in validating mode, i.e. assert that + the document contains a DOCTYPE declaration and conforms to the + DTD declared. +
    • +
    • + dtd -- unless nil, an extid instance + specifying the external subset to load. This options overrides + the extid specified in the document type declaration, if any. + See below for make-extid. This option is useful + for verification purposes together with the root + and disallow-internal-subset arguments. +
    • +
    • root -- the expected root element + name, or nil (the default). +
    • +
    • + entity-resolver -- nil or a function of two + arguments which is invoked for every entity referenced by the + document with the entity's Public ID (a rod) and System ID (an + URI object) as arguments. The function may either return + nil, CXML will then try to resolve the entity as usual. + Alternatively it may return a Common Lisp stream specialized on + (unsigned-byte 8) which will be used instead. (It may + also signal an error, of course, which can be useful to prohibit + parsed XML documents from including arbitrary files readable by + the parser.) +
    • +
    • + disallow-internal-subset -- a boolean. If true, signal + an error if the document contains an internal subset. +
    • +
    • + recode -- a boolean. (Ignored on Lisps with Unicode + support.) Recode rods to UTF-8 strings. Defaults to true. + Make sure to use utf8-dom:make-dom-builder if this + option is enabled and rune-dom:make-dom-builder + otherwise. +
    • +
    +

    + Note: parse-rod assumes that the input has already been + decoded into Unicode runes and ignores the encoding + specified in the XML declaration, if any. +

    + +

    +

    Function CXML:PARSE-FILE (uri qname handler &key public-id system-id entity-resolver recode)
    +

    +

    + Simulate parsing a document with a document element qname + having no attributes except for an optional namespace + declaration to uri. If an external ID is specified + (system-id, public-id), find, parse, and report + this DTD as if with parse-file, using the specified + entity resolver. +

    + +

    +

    Function CXML:PARSE-DTD-FILE (pathname)
    +
    Function CXML:PARSE-DTD-STREAM (stream)
    + Parse declarations + from a stand-alone file and return an object representing the DTD, + suitable as an argument to validate. +

    +
      +
    • pathname -- a Common Lisp pathname
    • +
    • stream -- a Common Lisp stream with element-type + (unsigned-byte 8)
    • +
    + +

    +

    Function CXML:MAKE-EXTID (publicid systemid)
    + Create an object representing the External ID composed + of the specified Public ID, a rod or nil, and System ID + (an URI object). +

    + +

    +

    Condition class CXML:XML-PARSE-ERROR ()
    + Superclass of all conditions signalled by the CXML parser. +

    +

    +

    Condition class CXML:WELL-FORMEDNESS-VIOLATION (cxml:xml-parse-error)
    + This condition is signalled for all well-formedness violations. + (Note that, when parsing document that is not well-formed in validating + mode, the parser might encounter validity errors before detecting + well-formedness problems, so also be prepared for validity-error + in that situation.) +

    +

    +

    Condition class CXML:VALIDITY-ERROR (cxml:xml-parse-error)
    + Reports the violation of a validity constraint. +

    + + +

    Serialization

    +

    + Serialization is performed using sink objects. A sink + is an output stream for runes. There are different kinds of sinks + for output to lisp streams, vectors, etc. +

    +

    + Technically, sinks are SAX handlers that write XML output for SAX + events sent to them. In practise, user code would normally not + generate those SAX events manually, and instead use a function + like dom:map-document or xmls-compat:map-node to serialize an + in-memory document. +

    +

    + In addition to map-document, cxml has a set of + convenience macros for serialization (see below for + with-xml-output, with-element, etc). +

    + +
    + Portable sinks:
    + Function CXML:MAKE-OCTET-VECTOR-SINK (&rest keys) => sink
    + Function CXML:MAKE-OCTET-STREAM-SINK (stream &rest keys) => sink
    + Function CXML:MAKE-ROD-SINK (&rest keys) => sink
    +
    + Only on Lisps with Unicode support:
    + Function CXML:MAKE-STRING-SINK -- alias for cxml:make-rod-sink
    + Function CXML:MAKE-CHARACTER-STREAM-SINK (stream &rest keys) => sink
    +
    + Only on Lisps without Unicode support:
    + Function CXML:MAKE-STRING-SINK/UTF8 (&rest keys) => sink
    + Function CXML:MAKE-CHARACTER-STREAM-SINK/UTF8 (stream &rest keys) => sink
    +
    +

    + Return a SAX serialization handle. +

    +
      +
    • + The -octet- functions write the document encoded into + UTF-8. + make-octet-stream-sink works with Lisp streams of + element-type (unsigned-byte 8). + make-octet-vector-sink returns a vector of + (unsigned-byte 8). +
    • +
    • + make-character-stream-sink works with character + streams. It serializes the document into characters without + encoding it into an external format. When using these + functions, take care to avoid encoding the result into + an incorrect external format. (Note that characters undergo + external format conversion when written to a character stream. + If the document's XML declaration specifies an encoding, make + sure to specify this encoding as the external format if and when + writing the serialized document to a character stream. If the + document does not specify an encoding, either UTF-8 or UTF-16 + must be used.) This function is available only on Lisps with + unicode support. +
    • +
    • + make-rod-sink serializes the document into a vector of + runes without encoding it into an external format. + (On Lisp with unicode support, the result will be a string; + otherwise, a vector of character codes will be returned.) + The warnings given for make-character-stream-sink + apply to this function as well. +
    • +
    • + The /utf8 functions write the document encoded into + characters representing a UTF-8 encoding. + When using these functions, take care to avoid encoding the + result into an external format for a second time. (Note + that characters undergo external format conversion when written + to a character stream. Since these functions already perform + external format conversion, make sure to specify an external + format that does "nothing" if and when writing the serialized document + to a character stream. ISO-8859-1 external formats usually + achieve the desired effect.) + make-character-stream-sink/utf8 works with character streams. + make-string-sink/utf8 returns a string. + These functions are available only on Lisps without unicode support. +
    • +
    +

    Keyword arguments:

    +
      +
    • + canonical -- canonical form, one of NIL, T, 1, 2 +
    • +
    • + indentation -- indentation level. An integer or nil. +
    • +
    +

    + The following canonical values are allowed: +

    + +

    + An internal subset will be included in the result regardless of + the canonical setting. It is the responsibility of the + caller to not report an internal subset for + canonical <= 1, or only notations as required for + canonical = 2. For example, the + include-doctype argument to dom:map-document + should be set to nil for the former behaviour and + :canonical-notations for the latter. +

    +

    + With an indentation level, pretty-print the XML by + inserting additional whitespace.  Note that indentation + changes the document model and should only be used if whitespace + does not matter to the application. +

    + +

    +

    Macro CXML:WITH-XML-OUTPUT (sink &body body) => sink-specific result
    +
    Macro CXML:WITH-ELEMENT (qname &body body) => result
    +
    Function CXML:ATTRIBUTE (name value) => value
    +
    Function CXML:TEXT (data) => data
    +
    Function CXML:CDATA (data) => data
    + Convenience syntax for event-based serialization. +

    +

    + Example: +

    +
    (with-xml-output (make-octet-stream-sink stream :indentation 2 :canonical nil)
    +  (with-element "foo"
    +    (attribute "xyz" "abc")
    +    (with-element "bar"
    +      (attribute "blub" "bla"))
    +    (text "Hi there.")))
    +

    + Prints this to stream: +

    +
    <foo xyz="abc">
    +  <bar blub="bla"></bar>
    +  Hi there.
    +</foo>
    + +

    +

    Macro XHTML-GENERATOR:WITH-XHTML (sink &rest forms)
    +
    Macro XHTML-GENERATOR:WRITE-DOCTYPE (sink)
    + Macro with-xhtml is a modified version of + Franz' htmlgen works as a SAX driver for XHTML. + It aims to be a plug-in replacement for the html macro. +

    +

    + xhtmlgen is included as contrib/xhtmlgen.lisp in + the cxml distribution. Example: +

    +
    (let ((sink (cxml:make-character-stream-sink *standard-output*)))
    +  (sax:start-document sink)
    +  (xhtml-generator:write-doctype sink)
    +  (xhtml-generator:with-html sink
    +    (:html
    +     (:head
    +      (:title "Titel"))
    +     (:body
    +      ((:p "style" "font-weight: bold")
    +       "Inhalt")
    +      (:ul
    +       (:li "Eins")
    +       (:li "Zwei")
    +       (:li "Drei")))))
    +  (sax:end-document sink))
    + + +

    Miscellaneous SAX handlers

    +

    +

    Function CXML:MAKE-VALIDATOR (dtd root)
    + Create a SAX handler which validates against a DTD instance.  + The document's root element must be named root.  + Used with dom:map-document, this validates a document + object as if by re-reading it with a validating parser, except + that declarations recorded in the document instance are completely + ignored.
    + Example: +

    +
    (let ((d (parse-file "~/test.xml" (cxml-dom:make-dom-builder)))
    +      (x (parse-dtd-file "~/test.dtd")))
    +  (dom:map-document (cxml:make-validator x #"foo") d))
    + +

    +

    Class CXML:SAX-PROXY ()
    +
    Accessor CXML:PROXY-CHAINED-HANDLER
    + sax-proxy is a SAX handler which passes all events it + receives on to a user-defined second handler, which defaults + to nil. Use sax-proxy to modify the events a + SAX handler receives by defining your own subclass + of sax-proxy. Setting the chained handler to the target + handler, and define methods on your handler class for the events + to be modified. All other events will pass through to the chained + handler unmodified. +

    + +

    +

    Accessor CXML:MAKE-NAMESPACE-NORMALIZER (next-handler)
    +

    +

    + Return a SAX handler that performs DOM + 3-style namespace normalization on attribute lists in + start-element events before passing them on the next + handler. +

    +

    +

    Function CXML:MAKE-WHITESPACE-NORMALIZER (chained-handler &optional dtd)
    + Return a SAX handler which removes whitespace from elements that + have element content and have not been declared to + preserve space using an xml:space attribute. +

    +

    Example:

    +
    (cxml:parse-file "example.xml"
    +                 (cxml:make-whitespace-normalizer (cxml-dom:make-dom-builder))
    +                 :validate t)
    +

    Example input:

    +
    <!DOCTYPE test [
    +<!ELEMENT test (foo,bar*)>
    +<!ATTLIST test a CDATA #IMPLIED>
    +<!ELEMENT foo #PCDATA>
    +<!ELEMENT bar (foo?)>
    +<!ATTLIST bar xml:space (default|preserve) "default">
    +]>
    +<test a='b'>
    +  <foo>   </foo>
    +  <bar>   </bar>
    +  <bar xml:space="preserve">   </bar>
    +</test>
    +
    +

    Example result:

    +
    <test a="b"><foo>   </foo><bar></bar><bar xml:space="preserve">   </bar></test>
    + + +

    Recoders

    +

    + Recoders are a mechanism used by CXML internally on Lisp implementations + without Unicode support to recode UTF-16 vectors (rods) of + integers (runes) into UTF-8 strings. +

    +

    + User code does not usually need to deal with recoders in current + versions of CXML. +

    +

    +

    Function CXML:MAKE-RECODER (chained-handler recoder-fn)
    + Return a SAX handler which passes all events on to + chained-handler after converting all strings and rods + using recoder-fn, a function of one argument. +

    + +
    +

    Caching of DTD Objects

    +

    + To avoid spending time parsing the same DTD over and over again, + CXML can cache DTD objects. The parser consults + cxml:*dtd-cache* whenever it is looking for an external + subset in a document which does not have an internal subset and + uses the cached DTD instance if one is present in the cache for + the System ID in question. +

    +

    + Note that DTDs do not expire from the cache automatically. + (Future versions of CXML might introduce automatic checks for + outdated DTDs.) +

    +

    +

    Variable CXML:*DTD-CACHE*
    + The DTD cache object consulted by the parser when it needs a DTD. +

    +

    +

    Function CXML:MAKE-DTD-CACHE ()
    + Return a new, empty DTD cache object. +

    +

    +

    Variable CXML:*CACHE-ALL-DTDS*
    + If true, instructs the parser to enter all DTDs that could have + been cached into *dtd-cache* if they were not cached + already. Defaults to nil. +

    +

    +

    Reader CXML:GETDTD (uri dtd-cache)
    + Return a cached instance of the DTD at uri, if present in + the cache, or nil. +

    +

    +

    Writer CXML:GETDTD (uri dtd-cache)
    + Enter a new value for uri into dtd-cache. +

    +

    +

    Function CXML:REMDTD (uri dtd-cache)
    + Ensure that no DTD is recorded for uri in the cache and + return true if such a DTD was present. +

    +

    +

    Function CXML:CLEAR-DTD-CACHE (dtd-cache)
    + Remove all entries from dtd-cache. +

    +

    + fixme: thread-safety +

    + +
    +

    XML Catalogs

    +

    + External entities (for example, DTDs) are referred to using their + Public and System IDs. Usually the System ID, a URI, is used to + locate the entity. CXML itself handles only file://-URIs, but + many System IDs in practical use are http://-URIs. There are two + different mechanims applications can use to allow CXML to locate + entities using arbitrary Public ID or System ID: +

    +
    +

    + This section describes XML Catalogs, the second solution. CXML + implements Oasis + XML Catalogs. +

    +

    +

    Variable CXML:*CATALOG*
    + The XML Catalog object consulted by the parser before trying to + open an entity. Initially nil. +

    +

    +

    Variable CXML:*PREFER*
    + The default "prefer" mode from the Catalog specification, one + of :public or :system. Defaults + to :public. +

    +

    +

    Function CXML:MAKE-CATALOG (&optional uris)
    + Return a catalog object for the catalog files specified. +

    +

    +

    Function CXML:RESOLVE-URI (uri catalog)
    + Look up uri in catalog and return the + resulting URI, or nil if no match was found. +

    +

    +

    Function CXML:RESOLVE-EXTID (publicid systemid catalog)
    + Look up the External ID (publicid, systemid) + in catalog and return the resulting URI, or nil + if no match was found. +

    +

    + Example: +

    +
    * (setf cxml:*catalog* nil)
    +* (cxml:parse-file "test.xhtml" nil)
    +=> Error: URI scheme :HTTP not supported
    +
    +* (setf cxml:*catalog* (cxml:make-catalog))
    +* (cxml:parse-file "test.xhtml" nil)
    +;; no error!
    +NIL
    +

    + Note that parsed catalog files are cached in the catalog object. + Catalog files cached do not expire automatically. To ensure that + all catalog files are parsed again, create a new catalog object. +

    + + +

    SAX Interface

    +

    + A SAX handler is an arbitrary objects that implements some of the + generic functions in the SAX package.  Note that no default + handler class is necessary, because all generic functions have default + methods which do nothing.  SAX functions are: +

    Function SAX:START-DOCUMENT (handler)
    +
    Function SAX:END-DOCUMENT (handler)
    +
    +
    Function SAX:START-ELEMENT (handler namespace-uri local-name qname attributes)
    +
    Function SAX:END-ELEMENT (handler namespace-uri local-name qname)
    +
    Function SAX:START-PREFIX-MAPPING (handler prefix uri)
    +
    Function SAX:END-PREFIX-MAPPING (handler prefix)
    +
    Function SAX:PROCESSING-INSTRUCTION (handler target data)
    +
    Function SAX:COMMENT (handler data)
    +
    Function SAX:START-CDATA (handler)
    +
    Function SAX:END-CDATA (handler)
    +
    Function SAX:CHARACTERS (handler data)
    +
    +
    Function SAX:START-DTD (handler name public-id system-id)
    +
    Function SAX:END-DTD (handler)
    +
    Function SAX:START-INTERNAL-SUBSET (handler)
    +
    Function SAX:END-INTERNAL-SUBSET (handler)
    +
    Function SAX:UNPARSED-ENTITY-DECLARATION (handler name public-id system-id notation-name)
    +
    Function SAX:EXTERNAL-ENTITY-DECLARATION (handler kind name public-id system-id)
    +
    Function SAX:INTERNAL-ENTITY-DECLARATION (handler kind name value)
    +
    Function SAX:NOTATION-DECLARATION (handler name public-id system-id)
    +
    Function SAX:ELEMENT-DECLARATION (handler name model)
    +
    Function SAX:ATTRIBUTE-DECLARATION (handler ename aname type default)
    +
    +
    Accessor SAX:ATTRIBUTE-PREFIX (attribute)
    +
    Accessor SAX:ATTRIBUTE-NAMESPACE-URI (attribute)
    +
    Accessor SAX:ATTRIBUTE-LOCAL-NAME (attribute)
    +
    Accessor SAX:ATTRIBUTE-QNAME (attribute)
    +
    Accessor SAX:ATTRIBUTE-SPECIFIED-P (attribute)
    +
    Accessor SAX:ATTRIBUTE-VALUE (attribute)
    +
    +
    Function SAX:FIND-ATTRIBUTE (qname attributes)
    +
    Function SAX:FIND-ATTRIBUTE-NS (uri lname attributes)
    +

    +

    + The entity declaration methods are similar to Java SAX + definitions, but parameter entities are distinguished from + general entities not by a % prefix to the name, but by + the kind argument, either :parameter or + :general. +

    +

    + The arguments to sax:element-declaration and + sax:attribute-declaration differ significantly from their + Java counterparts. +

    +

    + fixme: For more information on these functions refer to the docstrings. +

    + + Added: branches/grin-neu/thirdparty/cxml/doc/xmls-compat.html =================================================================== --- branches/grin-neu/thirdparty/cxml/doc/xmls-compat.html 2006-12-01 10:37:34 UTC (rev 2093) +++ branches/grin-neu/thirdparty/cxml/doc/xmls-compat.html 2006-12-01 10:39:49 UTC (rev 2094) @@ -0,0 +1,133 @@ + + + + + Closure XML + + + +
    + +

    XMLS Builder

    +

    + Like other XML parsers written in Lisp, CXML can work with + documents represented as list structures. The specific model + implemented by cxml is compatible with the xmls parser. Xmls + list structures are a simpler and faster alternative to full DOM + document trees. They also serve as an example showing how to + implement user-defined document models as an independent layer + over the the base parser (c.f. xml/xmls-compat.lisp in + the cxml distribution). However, note that the list structures do + not include all information available in DOM documents + (notably, things like dom:parent-node) and are + sometimes more difficult to work with because of that since many + DOM functions cannot be implemented on them. +

    +

    +

    Function CXML-XMLS:MAKE-XMLS-BUILDER (&key include-default-values)
    + Create a SAX handler which builds XMLS list structures.  + If include-default-values is true, default values for + attributes declared in a DTD are included as attributes in the + xmls output. include-default-values is true by default + and can be set to nil to suppress inclusion of default + values. +

    +

    + Example: +

    +
    (cxml:parse-file "test.xml" (cxml-xmls:make-xmls-builder))
    +

    +

    Function CXML-XMLS:MAP-NODE (handler node &key include-xmlns-attributes)
    + Traverse an XMLS document/node and call SAX functions as if an XML + representation of the document were processed by a SAX parser. +

    +

    + Use this function to serialize XMLS data. For example, we could + define a replacement for xmls:write-xml like this: +

    +
    (defun write-xml (stream node &key indent)
    +  (let ((sink (cxml:make-character-stream-sink
    +               stream :canonical nil :indentation indent)))
    +    (cxml-xmls:map-node sink node)))
    +

    +

    Function CXML-XMLS:MAKE-NODE (&key name ns attrs + children) => xmls node
    + Build a list node of the form + (name ((name value)*child*). +

    +

    + The node list's car can also be a cons of local name + and namespace prefix ns. +

    +

    + 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 and the namespace URI. We + currently follow the xmls implementation and use the + namespace prefix instead of following its documentation 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. +

    +

    +

    Accessor CXML-XMLS:NODE-NAME (node)
    +
    Accessor CXML-XMLS:NODE-NS (node)
    +
    Accessor CXML-XMLS:NODE-ATTRS (node)
    +
    Accessor CXML-XMLS:NODE-CHILDREN (node)
    + Accessors for xmls node data. +

    +

    +

    + + Modified: branches/grin-neu/thirdparty/cxml/dom/dom-builder.lisp =================================================================== --- branches/grin-neu/thirdparty/cxml/dom/dom-builder.lisp 2006-12-01 10:37:34 UTC (rev 2093) +++ branches/grin-neu/thirdparty/cxml/dom/dom-builder.lisp 2006-12-01 10:39:49 UTC (rev 2094) @@ -1,6 +1,6 @@ ;;;; dom-builder.lisp -- DOM-building SAX handler ;;;; -;;;; This file is part of the CXML parser, released under (L)LGPL. +;;;; This file is part of the CXML parser, released under Lisp-LGPL. ;;;; See file COPYING for details. ;;;; ;;;; Author: Gilbert Baumann @@ -8,26 +8,32 @@ ;;;; Author: David Lichteblau ;;;; Author: knowledgeTools Int. GmbH -;;; XXX this DOM builder knows too much about the specifics of the DOM -;;; implementation for my taste. We need a sensible protocol for fast DOM -;;; building. +#-cxml-system::utf8dom-file +(in-package :rune-dom) -(in-package :dom-impl) +#+cxml-system::utf8dom-file +(in-package :utf8-dom) + (defclass dom-builder () ((document :initform nil :accessor document) - (element-stack :initform '() :accessor element-stack))) + (element-stack :initform '() :accessor element-stack) + (internal-subset :accessor internal-subset))) -(defun dom:make-dom-builder () +(defun make-dom-builder () (make-instance 'dom-builder)) (defun fast-push (new-element vector) (vector-push-extend new-element vector (max 1 (array-dimension vector 0)))) (defmethod sax:start-document ((handler dom-builder)) - (let ((document (make-instance 'dom-impl::document))) - (setf (slot-value document 'dom-impl::owner) nil - (slot-value document 'dom-impl::doc-type) nil) + (when (and sax:*namespace-processing* + (not (and sax:*include-xmlns-attributes* + sax:*use-xmlns-namespace*))) + (error "SAX configuration is incompatible with DOM: *namespace-processing* is activated, but *include-xmlns-attributes* or *use-xmlns-namespace* are not")) + (let ((document (make-instance 'document))) + (setf (slot-value document 'owner) nil + (slot-value document 'doc-type) nil) (setf (document handler) document) (push document (element-stack handler)))) @@ -43,45 +49,76 @@ (setf (slot-value (document handler) 'entity-resolver) resolver)) (defmethod sax:start-dtd ((handler dom-builder) name publicid systemid) - (declare (ignore publicid systemid)) (let* ((document (document handler)) - (doctype (make-instance 'dom-impl::document-type - :name name - :notations (make-instance 'dom-impl::named-node-map - :element-type :notation - :owner document) - :entities (make-instance 'dom-impl::named-node-map - :element-type :entity - :owner document)))) - (setf (slot-value doctype 'dom-impl::owner) document - (slot-value document 'dom-impl::doc-type) doctype))) + (doctype (%create-document-type name publicid systemid))) + (setf (slot-value doctype 'owner) document + (slot-value (dom:notations doctype) 'owner) document + (slot-value (dom:entities doctype) 'owner) document + (slot-value document 'doc-type) doctype))) +(defmethod sax:start-internal-subset ((handler dom-builder)) + (setf (internal-subset handler) nil)) + +(defmethod sax:end-internal-subset ((handler dom-builder)) + (setf (dom::%internal-subset (slot-value (document handler) 'doc-type)) + (nreverse (internal-subset handler))) + (slot-makunbound handler 'internal-subset)) + +(macrolet ((defhandler (name &rest args) + `(defmethod ,name ((handler dom-builder) , at args) + (when (slot-boundp handler 'internal-subset) + (push (list ',name , at args) (internal-subset handler)))))) + (defhandler sax:unparsed-entity-declaration + name public-id system-id notation-name) + (defhandler sax:external-entity-declaration + kind name public-id system-id) + (defhandler sax:internal-entity-declaration + kind name value) + (defhandler sax:notation-declaration + name public-id system-id) + (defhandler sax:element-declaration + name model) + (defhandler sax:attribute-declaration + element-name attribute-name type default)) + (defmethod sax:start-element ((handler dom-builder) namespace-uri local-name qname attributes) - (declare (ignore namespace-uri local-name)) + (check-type qname rod) ;catch recoder/builder mismatch (with-slots (document element-stack) handler - (let ((element (make-instance 'element + (let* ((nsp sax:*namespace-processing*) + (element (make-instance 'element :tag-name qname - :owner document)) + :owner document + :namespace-uri (when nsp namespace-uri) + :local-name (when nsp local-name) + :prefix (%rod (when nsp (cxml::split-qname (real-rod qname)))))) (parent (car element-stack)) (anodes '())) (dolist (attr attributes) (let ((anode - (dom:create-attribute document (sax:attribute-qname attr))) + (if nsp + (dom:create-attribute-ns document + (sax:attribute-namespace-uri attr) + (sax:attribute-qname attr)) + (dom:create-attribute document (sax:attribute-qname attr)))) (text (dom:create-text-node document (sax:attribute-value attr)))) - (setf (slot-value anode 'dom-impl::specified-p) + (setf (slot-value anode 'specified-p) (sax:attribute-specified-p attr)) + (setf (slot-value anode 'owner-element) element) (dom:append-child anode text) (push anode anodes))) - (setf (slot-value element 'dom-impl::parent) parent) - (fast-push element (slot-value parent 'dom-impl::children)) - (setf (slot-value element 'dom-impl::attributes) - (make-instance 'attribute-node-map - :items anodes - :element-type :attribute - :element element - :owner document)) + (setf (slot-value element 'parent) parent) + (fast-push element (slot-value parent 'children)) + (let ((map + (make-instance 'attribute-node-map + :items anodes + :element-type :attribute + :element element + :owner document))) + (setf (slot-value element 'attributes) map) + (dolist (anode anodes) + (setf (slot-value anode 'map) map))) (push element element-stack)))) (defmethod sax:end-element ((handler dom-builder) namespace-uri local-name qname) @@ -103,15 +140,15 @@ (dom:append-data last-child data)) (t (let ((node (dom:create-text-node document data))) - (setf (slot-value node 'dom-impl::parent) parent) - (fast-push node (slot-value (car element-stack) 'dom-impl::children)))))))) + (setf (slot-value node 'parent) parent) + (fast-push node (slot-value (car element-stack) 'children)))))))) (defmethod sax:start-cdata ((handler dom-builder)) (with-slots (document element-stack) handler (let ((node (dom:create-cdata-section document #"")) (parent (car element-stack))) - (setf (slot-value node 'dom-impl::parent) parent) - (fast-push node (slot-value parent 'dom-impl::children)) + (setf (slot-value node 'parent) parent) + (fast-push node (slot-value parent 'children)) (push node element-stack)))) (defmethod sax:end-cdata ((handler dom-builder)) @@ -122,15 +159,15 @@ (with-slots (document element-stack) handler (let ((node (dom:create-processing-instruction document target data)) (parent (car element-stack))) - (setf (slot-value node 'dom-impl::parent) parent) - (fast-push node (slot-value (car element-stack) 'dom-impl::children))))) + (setf (slot-value node 'parent) parent) + (fast-push node (slot-value (car element-stack) 'children))))) (defmethod sax:comment ((handler dom-builder) data) (with-slots (document element-stack) handler (let ((node (dom:create-comment document data)) (parent (car element-stack))) - (setf (slot-value node 'dom-impl::parent) parent) - (fast-push node (slot-value (car element-stack) 'dom-impl::children))))) + (setf (slot-value node 'parent) parent) + (fast-push node (slot-value (car element-stack) 'children))))) (defmethod sax:unparsed-entity-declaration ((handler dom-builder) name public-id system-id notation-name) @@ -151,7 +188,7 @@ (defun set-entity (handler name pid sid notation) (dom:set-named-item (dom:entities (dom:doctype (document handler))) - (make-instance 'dom-impl::entity + (make-instance 'entity :owner (document handler) :name name :public-id pid @@ -161,7 +198,7 @@ (defmethod sax:notation-declaration ((handler dom-builder) name public-id system-id) (dom:set-named-item (dom:notations (dom:doctype (document handler))) - (make-instance 'dom-impl::notation + (make-instance 'notation :owner (document handler) :name name :public-id public-id Modified: branches/grin-neu/thirdparty/cxml/dom/dom-impl.lisp =================================================================== --- branches/grin-neu/thirdparty/cxml/dom/dom-impl.lisp 2006-12-01 10:37:34 UTC (rev 2093) +++ branches/grin-neu/thirdparty/cxml/dom/dom-impl.lisp 2006-12-01 10:39:49 UTC (rev 2094) @@ -1,17 +1,31 @@ -;;;; dom-impl.lisp -- Implementation of DOM 1 Core +;;;; dom-impl.lisp -- Implementation of DOM 1 Core -*- package: rune-dom -*- ;;;; -;;;; This file is part of the CXML parser, released under (L)LGPL. +;;;; This file is part of the CXML parser, released under Lisp-LGPL. ;;;; See file COPYING for details. ;;;; ;;;; Author: Gilbert Baumann ;;;; Author: David Lichteblau ;;;; Author: knowledgeTools Int. GmbH -(defpackage :dom-impl - (:use :cl :runes)) +#-cxml-system::utf8dom-file +(defpackage :rune-dom + (:use :cl :runes) + #+rune-is-character (:nicknames :cxml-dom) + (:export #:implementation #:make-dom-builder #:create-document)) -(in-package :dom-impl) +#+cxml-system::utf8dom-file +(defpackage :utf8-dom + (:use :cl :utf8-runes) + (:nicknames :cxml-dom) + (:export #:implementation #:make-dom-builder #:create-document)) +#-cxml-system::utf8dom-file +(in-package :rune-dom) + +#+cxml-system::utf8dom-file +(in-package :utf8-dom) + + ;; Classes (define-condition dom-exception (error) @@ -26,75 +40,107 @@ (dom-exception-string c) (dom-exception-arguments c))))) -(defclass node () +(defclass node (dom:node) ((parent :initarg :parent :initform nil) (children :initarg :children :initform (make-node-list)) (owner :initarg :owner :initform nil) (read-only-p :initform nil :reader read-only-p) (map :initform nil))) -(defclass document (node) +(defmethod dom:prefix ((node node)) nil) +(defmethod dom:local-name ((node node)) nil) +(defmethod dom:namespace-uri ((node node)) nil) + +(defclass namespace-mixin () + ((prefix :initarg :prefix :reader dom:prefix) + (local-name :initarg :local-name :reader dom:local-name) + (namespace-uri :initarg :namespace-uri :reader dom:namespace-uri))) + +(defmethod (setf dom:prefix) (newval (node namespace-mixin)) + (assert-writeable node) + (when newval + (safe-split-qname (concatenate 'rod newval #":foo") + (dom:namespace-uri node))) + (setf (slot-value node 'prefix) newval)) + +(defclass document (node dom:document) ((doc-type :initarg :doc-type :reader dom:doctype) (dtd :initform nil :reader dtd) (entity-resolver :initform nil))) -(defclass document-fragment (node) +(defclass document-fragment (node dom:document-fragment) ()) -(defclass character-data (node) +(defclass character-data (node dom:character-data) ((value :initarg :data :reader dom:data))) -(defclass attribute (node) +(defclass attribute (namespace-mixin node dom:attr) ((name :initarg :name :reader dom:name) + (owner-element :initarg :owner-element :reader dom:owner-element) (specified-p :initarg :specified-p :reader dom:specified))) +(defmethod (setf dom:prefix) :before (newval (node attribute)) + (when (rod= (dom:node-name node) #"xmlns") + (dom-error :NAMESPACE_ERR "must not change xmlns attribute prefix"))) + +(defmethod (setf dom:prefix) :after (newval (node attribute)) + (setf (slot-value node 'name) + (concatenate 'rod newval #":" (dom:local-name node)))) + (defmethod print-object ((object attribute) stream) (print-unreadable-object (object stream :type t :identity t) (format stream "~A=~S" (rod-string (dom:name object)) (rod-string (dom:value object))))) -(defclass element (node) +(defclass element (namespace-mixin node dom:element) ((tag-name :initarg :tag-name :reader dom:tag-name) (attributes :initarg :attributes :reader dom:attributes))) +(defmethod (setf dom:prefix) :after (newval (node element)) + (setf (slot-value node 'tag-name) + (concatenate 'rod newval #":" (dom:local-name node)))) + (defmethod print-object ((object element) stream) (print-unreadable-object (object stream :type t :identity t) (princ (rod-string (dom:tag-name object)) stream))) -(defclass text (character-data) +(defclass text (character-data dom:text) ()) -(defclass comment (character-data) +(defclass comment (character-data dom:comment) ()) -(defclass cdata-section (text) +(defclass cdata-section (text dom:cdata-section) ()) -(defclass document-type (node) +(defclass document-type (node dom:document-type) ((name :initarg :name :reader dom:name) + (public-id :initarg :public-id :reader dom:public-id) + (system-id :initarg :system-id :reader dom:system-id) (entities :initarg :entities :reader dom:entities) - (notations :initarg :notations :reader dom:notations))) + (notations :initarg :notations :reader dom:notations) + (dom::%internal-subset :accessor dom::%internal-subset))) -(defclass notation (node) +(defclass notation (node dom:notation) ((name :initarg :name :reader dom:name) (public-id :initarg :public-id :reader dom:public-id) (system-id :initarg :system-id :reader dom:system-id))) -(defclass entity (node) +(defclass entity (node dom:entity) ((name :initarg :name :reader dom:name) (public-id :initarg :public-id :reader dom:public-id) (system-id :initarg :system-id :reader dom:system-id) (notation-name :initarg :notation-name :reader dom:notation-name))) -(defclass entity-reference (node) +(defclass entity-reference (node dom:entity-reference) ((name :initarg :name :reader dom:name))) -(defclass processing-instruction (node) +(defclass processing-instruction (node dom:processing-instruction) ((target :initarg :target :reader dom:target) (data :initarg :data :reader dom:data))) -(defclass named-node-map () +(defclass named-node-map (dom:named-node-map) ((items :initarg :items :reader dom:items :initform nil) (owner :initarg :owner :reader dom:owner-document) @@ -107,6 +153,28 @@ ;;; Implementation +(defun %rod (x) + (etypecase x + (null x) + (rod x) + #+cxml-system::utf8dom-file (runes::rod (cxml::rod-to-utf8-string x)) + (string (string-rod x)) + (vector x))) + +#-cxml-system::utf8dom-file +(defun real-rod (x) + (%rod x)) + +#+cxml-system::utf8dom-file +(defun real-rod (x) + (etypecase x + (null x) + (runes::rod x) + (string (cxml::utf8-string-to-rod x)))) + +(defun valid-name-p (x) + (cxml::valid-name-p (real-rod x))) + (defun assert-writeable (node) (when (read-only-p node) (dom-error :NO_MODIFICATION_ALLOWED_ERR "~S is marked read-only." node))) @@ -120,6 +188,15 @@ (dom:map-node-list (lambda (,var) , at body) ,nodelist) ,resultform)) +(defun dom:map-node-map (fn node-map) + (with-slots (items) node-map + (mapc fn items))) + +(defmacro dom:do-node-map ((var node-map &optional resultform) &body body) + `(block nil + (dom:map-node-map (lambda (,var) , at body) ,node-map) + ,resultform)) + (defmacro dovector ((var vector &optional resultform) &body body) `(loop for ,var across ,vector do (progn , at body) @@ -174,8 +251,60 @@ (:NO_MODIFICATION_ALLOWED_ERR 7) (:NOT_FOUND_ERR 8) (:NOT_SUPPORTED_ERR 9) - (:INUSE_ATTRIBUTE_ERR 10))) + (:INUSE_ATTRIBUTE_ERR 10) + (:INVALID_STATE_ERR 11) + (:SYNTAX_ERR 12) + (:INVALID_MODIFICATION_ERR 13) + (:NAMESPACE_ERR 14) + (:INVALID_ACCESS_ERR 15))) +;; dom-implementation protocol + +(defmethod dom:has-feature ((factory (eql 'implementation)) feature version) + (and (or (string-equal (rod-string feature) "xml") + (string-equal (rod-string feature) "core")) + (or (zerop (length version)) + (string-equal (rod-string version) "1.0") + (string-equal (rod-string version) "2.0")))) + +(defun %create-document-type (name publicid systemid) + (make-instance 'document-type + :name name + :notations (make-instance 'named-node-map + :element-type :notation + :owner nil) + :entities (make-instance 'named-node-map + :element-type :entity + :owner nil) + :public-id publicid + :system-id systemid)) + +(defmethod dom:create-document-type + ((factory (eql 'implementation)) name publicid systemid) + (safe-split-qname name #"") + (let ((result (%create-document-type name publicid systemid))) + (setf (slot-value (dom:entities result) 'read-only-p) t) + (setf (slot-value (dom:notations result) 'read-only-p) t) + result)) + +(defmethod dom:create-document + ((factory (eql 'implementation)) uri qname doctype) + (let ((document (make-instance 'document))) + (setf (slot-value document 'owner) nil + (slot-value document 'doc-type) doctype) + (when doctype + (unless (typep doctype 'document-type) + (dom-error :WRONG_DOCUMENT_ERR + "doctype was created by a different dom implementation")) + (when (dom:owner-document doctype) + (dom-error :WRONG_DOCUMENT_ERR "doctype already in use")) + (setf (slot-value doctype 'owner) document + (slot-value (dom:notations doctype) 'owner) document + (slot-value (dom:entities doctype) 'owner) document)) + (when (or uri qname) + (dom:append-child document (dom:create-element-ns document uri qname))) + document)) + ;; document-fragment protocol ;; document protocol @@ -188,11 +317,14 @@ (return k))))) (defmethod dom:create-element ((document document) tag-name) - (setf tag-name (rod tag-name)) - (unless (cxml::valid-name-p tag-name) + (setf tag-name (%rod tag-name)) + (unless (valid-name-p tag-name) (dom-error :INVALID_CHARACTER_ERR "not a name: ~A" (rod-string tag-name))) - (let ((result (make-instance 'element + (let ((result (make-instance 'element :tag-name tag-name + :namespace-uri nil + :local-name nil + :prefix nil :owner document))) (setf (slot-value result 'attributes) (make-instance 'attribute-node-map @@ -202,32 +334,71 @@ (add-default-attributes result) result)) +(defun safe-split-qname (qname uri) + (unless (valid-name-p qname) + (dom-error :INVALID_CHARACTER_ERR "not a name: ~A" (rod-string qname))) + (multiple-value-bind (prefix local-name) + (handler-case + (cxml::split-qname (real-rod qname)) + (cxml:well-formedness-violation (c) + (dom-error :NAMESPACE_ERR "~A" c))) + (setf local-name (%rod local-name)) + (when prefix + (setf prefix (%rod prefix)) + (unless uri + (dom-error :NAMESPACE_ERR "prefix specified but no namespace URI")) + (when (and (rod= prefix #"xml") + (not (rod= uri #"http://www.w3.org/XML/1998/namespace"))) + (dom-error :NAMESPACE_ERR "invalid uri for prefix `xml'")) + (when (and (rod= prefix #"xmlns") + (not (rod= uri #"http://www.w3.org/2000/xmlns/"))) + (dom-error :NAMESPACE_ERR "invalid uri for prefix `xmlns'"))) + (values prefix local-name))) + +(defmethod dom:create-element-ns ((document document) uri qname) + (setf qname (%rod qname)) + (multiple-value-bind (prefix local-name) + (safe-split-qname qname uri) + (let ((result (make-instance 'element + :tag-name qname + :namespace-uri uri + :local-name local-name + :prefix prefix + :owner document))) + (setf (slot-value result 'attributes) + (make-instance 'attribute-node-map + :element-type :attribute + :owner document + :element result)) + (add-default-attributes result) + result))) + (defmethod dom:create-document-fragment ((document document)) (make-instance 'document-fragment :owner document)) (defmethod dom:create-text-node ((document document) data) - (setf data (rod data)) + (setf data (%rod data)) (make-instance 'text :data data :owner document)) (defmethod dom:create-comment ((document document) data) - (setf data (rod data)) + (setf data (%rod data)) (make-instance 'comment :data data :owner document)) (defmethod dom:create-cdata-section ((document document) data) - (setf data (rod data)) + (setf data (%rod data)) (make-instance 'cdata-section :data data :owner document)) (defmethod dom:create-processing-instruction ((document document) target data) - (setf target (rod target)) - (setf data (rod data)) - (unless (cxml::valid-name-p target) + (setf target (%rod target)) + (setf data (%rod data)) + (unless (valid-name-p target) (dom-error :INVALID_CHARACTER_ERR "not a name: ~A" (rod-string target))) (make-instance 'processing-instruction :owner document @@ -235,41 +406,108 @@ :data data)) (defmethod dom:create-attribute ((document document) name) - (setf name (rod name)) - (unless (cxml::valid-name-p name) + (setf name (%rod name)) + (unless (valid-name-p name) (dom-error :INVALID_CHARACTER_ERR "not a name: ~A" (rod-string name))) (make-instance 'attribute :name name + :local-name nil + :prefix nil + :namespace-uri nil :specified-p t + :owner-element nil :owner document)) +(defmethod dom:create-attribute-ns ((document document) uri qname) + (setf uri (%rod uri)) + (setf qname (%rod qname)) + (when (and (rod= qname #"xmlns") + (not (rod= uri #"http://www.w3.org/2000/xmlns/"))) + (dom-error :NAMESPACE_ERR "invalid uri for qname `xmlns'")) + (multiple-value-bind (prefix local-name) + (safe-split-qname qname uri) + (make-instance 'attribute + :name qname + :namespace-uri uri + :local-name local-name + :prefix prefix + :specified-p t + :owner-element nil + :owner document))) + (defmethod dom:create-entity-reference ((document document) name) - (setf name (rod name)) - (unless (cxml::valid-name-p name) + (setf name (%rod name)) + (unless (valid-name-p name) (dom-error :INVALID_CHARACTER_ERR "not a name: ~A" (rod-string name))) (make-instance 'entity-reference :name name :owner document)) (defmethod get-elements-by-tag-name-internal (node tag-name) - (setf tag-name (rod tag-name)) - (let ((result (make-node-list))) - (setf tag-name (rod tag-name)) - (let ((wild-p (rod= tag-name '#.(string-rod "*")))) - (labels ((walk (n) - (dovector (c (dom:child-nodes n)) - (when (dom:element-p c) - (when (or wild-p (rod= tag-name (dom:node-name c))) - (vector-push-extend c result (extension result))) - (walk c))))) - (walk node))) + (setf tag-name (%rod tag-name)) + (let ((result (make-node-list)) + (wild-p (rod= tag-name #"*"))) + (labels ((walk (n) + (dovector (c (dom:child-nodes n)) + (when (dom:element-p c) + (when (or wild-p (rod= tag-name (dom:node-name c))) + (vector-push-extend c result (extension result))) + (walk c))))) + (walk node)) result)) +(defmethod get-elements-by-tag-name-internal-ns (node uri lname) + (setf uri (%rod uri)) + (setf lname (%rod lname)) + (let ((result (make-node-list)) + (wild-uri-p (rod= uri #"*")) + (wild-lname-p (rod= lname #"*"))) + (labels ((walk (n) + (dovector (c (dom:child-nodes n)) + (when (dom:element-p c) + (when (and (or wild-lname-p (rod= lname (dom:local-name c))) + (or wild-uri-p (rod= uri (dom:namespace-uri c)))) + (vector-push-extend c result (extension result))) + (walk c))))) + (walk node)) + result)) + (defmethod dom:get-elements-by-tag-name ((document document) tag-name) (get-elements-by-tag-name-internal document tag-name)) +(defmethod dom:get-elements-by-tag-name-ns ((document document) uri lname) + (get-elements-by-tag-name-internal-ns document uri lname)) + +(defmethod dom:get-element-by-id ((document document) id) + (block t + (unless (dtd document) + (return-from t nil)) + (setf id (%rod id)) + (labels ((walk (n) + (dovector (c (dom:child-nodes n)) + (when (dom:element-p c) + (let ((e (cxml::find-element + (real-rod (dom:tag-name c)) + (dtd document)))) + (when e + (dolist (a (cxml::elmdef-attributes e)) + (when (eq :ID (cxml::attdef-type a)) + (let* ((name (%rod (cxml::attdef-name a))) + (value (dom:get-attribute c name))) + (when (and value (rod= value id)) + (return-from t c))))))) + (walk c))))) + (walk document)))) + + ;;; Node +(defmethod dom:has-attributes ((element node)) + nil) + +(defmethod dom:is-supported ((node node) feature version) + (dom:has-feature 'implementation feature version)) + (defmethod dom:parent-node ((node node)) (slot-value node 'parent)) @@ -349,9 +587,11 @@ (setf (slot-value new-child 'parent) node) new-child)) -(defmethod dom:insert-before ((node node) (fragment document-fragment) ref-child) - (dovector (child (dom:child-nodes fragment)) - (dom:insert-before node child ref-child)) +(defmethod dom:insert-before + ((node node) (fragment document-fragment) ref-child) + (let ((children (dom:child-nodes fragment))) + (cxml::while (plusp (length children)) + (dom:insert-before node (elt children 0) ref-child))) fragment) (defmethod dom:replace-child ((node node) (new-child node) (old-child node)) @@ -393,8 +633,9 @@ (defmethod dom:append-child ((node node) (new-child document-fragment)) (assert-writeable node) - (dovector (child (dom:child-nodes new-child)) - (dom:append-child node child)) + (let ((children (dom:child-nodes new-child))) + (cxml::while (plusp (length children)) + (dom:append-child node (elt children 0)))) new-child) ;; was auf node noch implemetiert werden muss: @@ -407,19 +648,19 @@ ;; node-name (defmethod dom:node-name ((self document)) - '#.(string-rod "#document")) + #"#document") (defmethod dom:node-name ((self document-fragment)) - '#.(string-rod "#document-fragment")) + #"#document-fragment") (defmethod dom:node-name ((self text)) - '#.(string-rod "#text")) + #"#text") (defmethod dom:node-name ((self cdata-section)) - '#.(string-rod "#cdata-section")) + #"#cdata-section") (defmethod dom:node-name ((self comment)) - '#.(string-rod "#comment")) + #"#comment") (defmethod dom:node-name ((self attribute)) (dom:name self)) @@ -541,42 +782,75 @@ ;;; NAMED-NODE-MAP (defmethod dom:get-named-item ((self named-node-map) name) - (setf name (rod name)) + (setf name (%rod name)) (with-slots (items) self (dolist (k items nil) - (cond ((rod= name (dom:node-name k)) - (return k)))))) + (when (rod= name (dom:node-name k)) + (return k))))) -(defmethod dom:set-named-item ((self named-node-map) arg) - (assert-writeable self) - (unless (eq (dom:node-type arg) (slot-value self 'element-type)) +(defmethod dom:get-named-item-ns ((self named-node-map) uri lname) + (setf uri (%rod uri)) + (setf lname (%rod lname)) + (with-slots (items) self + (dolist (k items nil) + (when (and (rod= uri (dom:namespace-uri k)) + (rod= lname (dom:local-name k))) + (return k))))) + +(defun %set-named-item (map arg test) + (assert-writeable map) + (unless (eq (dom:node-type arg) (slot-value map 'element-type)) (dom-error :HIERARCHY_REQUEST_ERR "~S cannot adopt ~S, since it is not of type ~S." - self arg (slot-value self 'element-type))) - (unless (eq (dom:owner-document self) (dom:owner-document arg)) + map arg (slot-value map 'element-type))) + (unless (eq (dom:owner-document map) (dom:owner-document arg)) (dom-error :WRONG_DOCUMENT_ERR "~S cannot adopt ~S, since it was created by a different document." - self arg)) + map arg)) (let ((old-map (slot-value arg 'map))) - (when (and old-map (not (eq old-map self))) + (when (and old-map (not (eq old-map map))) (dom-error :INUSE_ATTRIBUTE_ERR "Attribute node already mapped" arg))) - (setf (slot-value arg 'map) self) + (setf (slot-value arg 'map) map) + (with-slots (items) map + (dolist (k items (progn (setf items (cons arg items)) nil)) + (when (funcall test k) + (setf items (cons arg (delete k items))) + (return k))))) + +(defmethod dom:set-named-item ((self named-node-map) arg) (let ((name (dom:node-name arg))) - (with-slots (items) self - (dolist (k items (progn (setf items (cons arg items))nil)) - (cond ((rod= name (dom:node-name k)) - (setf items (cons arg (delete k items))) - (return k))))))) + (%set-named-item self arg (lambda (k) (rod= name (dom:node-name k)))))) +(defmethod dom:set-named-item-ns ((self named-node-map) arg) + (let ((uri (dom:namespace-uri arg)) + (lname (dom:local-name arg))) + (%set-named-item self + arg + (lambda (k) + (and (rod= lname (dom:local-name k)) + (rod= uri (dom:namespace-uri k))))))) + (defmethod dom:remove-named-item ((self named-node-map) name) (assert-writeable self) - (setf name (rod name)) + (setf name (%rod name)) (with-slots (items) self (dolist (k items (dom-error :NOT_FOUND_ERR "~A not found in ~A" name self)) (cond ((rod= name (dom:node-name k)) (setf items (delete k items)) (return k)))))) +(defmethod dom:remove-named-item-ns ((self named-node-map) uri lname) + (assert-writeable self) + (setf uri (%rod uri)) + (setf lname (%rod lname)) + (with-slots (items) self + (dolist (k items + (dom-error :NOT_FOUND_ERR "~A not found in ~A" lname self)) + (when (and (rod= lname (dom:local-name k)) + (rod= uri (dom:namespace-uri k))) + (setf items (delete k items)) + (return k))))) + (defmethod dom:length ((self named-node-map)) (with-slots (items) self (length items))) @@ -591,7 +865,7 @@ (defmethod (setf dom:data) (newval (self character-data)) (assert-writeable self) - (setf newval (rod newval)) + (setf newval (%rod newval)) (setf (slot-value self 'value) newval)) (defmethod dom:length ((node character-data)) @@ -606,7 +880,7 @@ (defmethod dom:append-data ((node character-data) arg) (assert-writeable node) - (setq arg (rod arg)) + (setq arg (%rod arg)) (with-slots (value) node (setf value (concatenate 'rod value arg))) (values)) @@ -634,7 +908,7 @@ ;; Although we could implement this by calling DELETE-DATA, then INSERT-DATA, ;; we implement this function directly to avoid creating temporary garbage. (assert-writeable node) - (setf arg (rod arg)) + (setf arg (%rod arg)) (with-slots (value) node (unless (<= 0 offset (length value)) (dom-error :INDEX_SIZE_ERR "offset is invalid")) @@ -657,7 +931,7 @@ (defmethod dom:insert-data ((node character-data) offset arg) (assert-writeable node) - (setf arg (rod arg)) + (setf arg (%rod arg)) (with-slots (value) node (unless (<= 0 offset (length value)) (dom-error :INDEX_SIZE_ERR "offset is invalid")) @@ -694,11 +968,11 @@ (defmethod (setf dom:value) (new-value (node attribute)) (assert-writeable node) - (let ((rod (rod new-value))) + (let ((rod (%rod new-value))) (with-slots (children owner) node ;; remove children, add new TEXT-NODE child ;; (alas, we must not reuse an old TEXT-NODE) - (while (plusp (length children)) + (cxml::while (plusp (length children)) (dom:remove-child node (dom:last-child node))) (dom:append-child node (dom:create-text-node owner rod)))) new-value) @@ -714,7 +988,7 @@ (rod-stream-buf stream))) (defmethod write-attribute-child ((node node) stream) - (write-rod (dom:node-value node) stream)) + (put-rod (dom:node-value node) stream)) (defmethod write-attribute-child ((node entity-reference) stream) (dovector (child (dom:child-nodes node)) @@ -729,7 +1003,7 @@ (buf nil) (position 0)) -(defun write-rod (rod rod-stream) +(defun put-rod (rod rod-stream) (let ((buf (rod-stream-buf rod-stream))) (when buf (move rod buf 0 (rod-stream-position rod-stream) (length rod))) @@ -743,6 +1017,15 @@ ;;; ELEMENT +(defmethod dom:has-attributes ((element element)) + (plusp (length (dom:items (dom:attributes element))))) + +(defmethod dom:has-attribute ((element element) name) + (and (dom:get-named-item (dom:attributes element) name) t)) + +(defmethod dom:has-attribute-ns ((element element) uri lname) + (and (dom:get-named-item-ns (dom:attributes element) uri lname) t)) + (defmethod dom:get-attribute-node ((element element) name) (dom:get-named-item (dom:attributes element) name)) @@ -750,68 +1033,141 @@ (assert-writeable element) (dom:set-named-item (dom:attributes element) new-attr)) +(defmethod dom:get-attribute-node-ns ((element element) uri lname) + (dom:get-named-item-ns (dom:attributes element) uri lname)) + +(defmethod dom:set-attribute-node-ns ((element element) (new-attr attribute)) + (assert-writeable element) + (dom:set-named-item-ns (dom:attributes element) new-attr)) + (defmethod dom:get-attribute ((element element) name) (let ((a (dom:get-attribute-node element name))) (if a (dom:value a) - #.(string-rod "")))) + #""))) +(defmethod dom:get-attribute-ns ((element element) uri lname) + (let ((a (dom:get-attribute-node-ns element uri lname))) + (if a + (dom:value a) + #""))) + (defmethod dom:set-attribute ((element element) name value) (assert-writeable element) (with-slots (owner) element (let ((attr (dom:create-attribute owner name))) + (setf (slot-value attr 'owner-element) element) (setf (dom:value attr) value) (dom:set-attribute-node element attr)) (values))) +(defmethod dom:set-attribute-ns ((element element) uri lname value) + (assert-writeable element) + (with-slots (owner) element + (let ((attr (dom:create-attribute-ns owner uri lname))) + (setf (slot-value attr 'owner-element) element) + (setf (dom:value attr) value) + (dom:set-attribute-node-ns element attr)) + (values))) + (defmethod dom:remove-attribute ((element element) name) (assert-writeable element) (dom:remove-attribute-node element (dom:get-attribute-node element name))) +(defmethod dom:remove-attribute-ns ((elt element) uri lname) + (assert-writeable elt) + (dom:remove-attribute-node elt (dom:get-attribute-node-ns elt uri lname))) + (defmethod dom:remove-attribute-node ((element element) (old-attr attribute)) (assert-writeable element) (with-slots (items) (dom:attributes element) (unless (find old-attr items) (dom-error :NOT_FOUND_ERR "Attribute not found.")) (setf items (remove old-attr items)) - (maybe-add-default-attribute element (dom:name old-attr)) + (maybe-add-default-attribute element old-attr) old-attr)) ;; eek, defaulting: -(defun maybe-add-default-attribute (element name) - (let* ((dtd (dtd (slot-value element 'owner))) - (e (cxml::find-element (dom:tag-name element) dtd)) - (a (when e (cxml::find-attribute e name)))) +(defun maybe-add-default-attribute (element old-attr) + (let* ((qname (dom:name old-attr)) + (dtd (dtd (slot-value element 'owner))) + (e (when dtd (cxml::find-element + (real-rod (dom:tag-name element)) + dtd))) + (a (when e (cxml::find-attribute e (real-rod qname))))) (when (and a (listp (cxml::attdef-default a))) - (add-default-attribute element a)))) + (let ((new (add-default-attribute element a))) + (setf (slot-value new 'namespace-uri) (dom:namespace-uri old-attr)) + (setf (slot-value new 'prefix) (dom:prefix old-attr)) + (setf (slot-value new 'local-name) (dom:local-name old-attr)))))) (defun add-default-attributes (element) (let* ((dtd (dtd (slot-value element 'owner))) - (e (cxml::find-element (dom:tag-name element) dtd))) + (e (when dtd (cxml::find-element + (real-rod (dom:tag-name element)) + dtd)))) (when e (dolist (a (cxml::elmdef-attributes e)) - (when (and a (listp (cxml::attdef-default a))) - (add-default-attribute element a)))))) + (when (and a + (listp (cxml::attdef-default a)) + (not (dom:get-attribute-node + element + (%rod (cxml::attdef-name a))))) + (let ((anode (add-default-attribute element a))) + (multiple-value-bind (prefix local-name) + (handler-case + (cxml::split-qname (cxml::attdef-name a)) + (cxml:well-formedness-violation (c) + (dom-error :NAMESPACE_ERR "~A" c))) + (when prefix (setf prefix (%rod prefix))) + (setf local-name (%rod local-name)) + ;; das ist fuer importnode07. + ;; so richtig ueberzeugend finde ich das ja nicht. + (setf (slot-value anode 'prefix) prefix) + (setf (slot-value anode 'local-name) local-name)))))))) (defun add-default-attribute (element adef) (let* ((value (second (cxml::attdef-default adef))) (owner (slot-value element 'owner)) (anode (dom:create-attribute owner (cxml::attdef-name adef))) (text (dom:create-text-node owner value))) - (setf (slot-value anode 'dom-impl::specified-p) nil) + (setf (slot-value anode 'specified-p) nil) + (setf (slot-value anode 'owner-element) element) (dom:append-child anode text) - (push anode (slot-value (dom:attributes element) 'items)))) + (push anode (slot-value (dom:attributes element) 'items)) + anode)) -(defmethod dom:remove-named-item :after ((self attribute-node-map) name) - (maybe-add-default-attribute (slot-value self 'element) name)) +(defmethod dom:remove-named-item ((self attribute-node-map) name) + name + (let ((k (call-next-method))) + (maybe-add-default-attribute (slot-value self 'element) k) + k)) +(defmethod dom:remove-named-item-ns ((self attribute-node-map) uri lname) + uri lname + (let ((k (call-next-method))) + (maybe-add-default-attribute (slot-value self 'element) k) + k)) + (defmethod dom:get-elements-by-tag-name ((element element) name) (assert-writeable element) (get-elements-by-tag-name-internal element name)) -(defmethod dom:normalize ((element element)) +(defmethod dom:get-elements-by-tag-name-ns ((element element) uri lname) (assert-writeable element) + (get-elements-by-tag-name-internal-ns element uri lname)) + +(defmethod dom:set-named-item :after ((self attribute-node-map) arg) + (setf (slot-value arg 'owner-element) + (slot-value self 'element))) + +(defmethod dom:set-named-item-ns :after ((self attribute-node-map) arg) + (setf (slot-value arg 'owner-element) + (slot-value self 'element))) + +(defmethod dom:normalize ((node node)) + (assert-writeable node) (labels ((walk (n) (when (eq (dom:node-type n) :element) (map nil #'walk (dom:items (dom:attributes n)))) @@ -819,7 +1175,7 @@ (i 0) (previous nil)) ;; careful here, we're modifying the array we are iterating over - (while (< i (length children)) + (cxml::while (< i (length children)) (let ((child (elt children i))) (cond ((not (eq (dom:node-type child) :text)) @@ -833,11 +1189,15 @@ (dom:remove-child n child) ;; not (incf i) ) + ((zerop (length (dom:data child))) + (dom:remove-child n child) + ;; not (incf i) + ) (t (setf previous child) (incf i)))))) (map nil #'walk (dom:child-nodes n)))) - (walk element)) + (walk node)) (values)) ;;; TEXT @@ -856,7 +1216,23 @@ ;;; COMMENT -- nix ;;; CDATA-SECTION -- nix -;;; DOCUMENT-TYPE -- missing +;;; DOCUMENT-TYPE + +(defmethod dom:internal-subset ((node document-type)) + ;; FIXME: encoding ist falsch, anderen sink nehmen! + (if (and (slot-boundp node 'dom::%internal-subset) + ;; die damen und herren von der test suite sind wohl der meinung, + ;; dass ein leeres internal subset nicht vorhanden ist und + ;; wir daher nil liefern sollen. bittesehr! + (dom::%internal-subset node)) + (let ((sink + #+rune-is-character (cxml:make-string-sink) + #-rune-is-character (cxml:make-string-sink/utf8))) + (dolist (def (dom::%internal-subset node)) + (apply (car def) sink (cdr def))) + (sax:end-document sink)) + nil)) + ;;; NOTATION -- nix ;;; ENTITY -- nix @@ -864,16 +1240,18 @@ (defmethod initialize-instance :after ((instance entity-reference) &key) (let* ((owner (dom:owner-document instance)) - (handler (dom:make-dom-builder)) + (handler (make-dom-builder)) (resolver (slot-value owner 'entity-resolver))) - (unless resolver - (dom-error :NOT_SUPPORTED_ERR "No entity resolver registered.")) - (setf (document handler) owner) - (push instance (element-stack handler)) - (funcall resolver (dom:name instance) handler)) + (when resolver + (setf (document handler) owner) + (push instance (element-stack handler)) + #+cxml-system::utf8dom-file + (setf handler (cxml:make-recoder handler #'cxml:rod-to-utf8-string)) + (funcall resolver (real-rod (dom:name instance)) handler))) (labels ((walk (n) (setf (slot-value n 'read-only-p) t) (when (dom:element-p n) + (setf (slot-value (dom:attributes n) 'read-only-p) t) (map nil #'walk (dom:items (dom:attributes n)))) (map nil #'walk (dom:child-nodes n)))) (walk instance))) @@ -882,7 +1260,7 @@ (defmethod (setf dom:data) (newval (self processing-instruction)) (assert-writeable self) - (setf newval (rod newval)) + (setf newval (%rod newval)) (setf (slot-value self 'data) newval)) ;; das koennte man auch mit einer GF machen @@ -965,9 +1343,21 @@ (dom:append-child result (dom:import-node document child t)))) result)) +(defmethod dom:import-node ((document document) (node t) deep) + (declare (ignore deep)) + (dom-error :NOT_SUPPORTED_ERR "not implemented")) + (defmethod dom:import-node ((document document) (node attribute) deep) (declare (ignore deep)) - (import-node-internal 'attribute document node t :name (dom:name node))) + (import-node-internal 'attribute + document node + t + :specified-p (dom:specified node) + :name (dom:name node) + :namespace-uri (dom:namespace-uri node) + :local-name (dom:local-name node) + :prefix (dom:prefix node) + :owner-element nil)) (defmethod dom:import-node ((document document) (node document-fragment) deep) (import-node-internal 'document-fragment document node deep)) @@ -978,27 +1368,31 @@ :owner document)) (result (import-node-internal 'element document node deep :attributes attributes + :namespace-uri (dom:namespace-uri node) + :local-name (dom:local-name node) + :prefix (dom:prefix node) :tag-name (dom:tag-name node)))) (setf (slot-value attributes 'element) result) (dolist (attribute (dom:items (dom:attributes node))) (when (or (dom:specified attribute) *clone-not-import*) - (dom:set-attribute result (dom:name attribute) (dom:value attribute)))) + (let ((attr (dom:import-node document attribute t))) + (if (dom:namespace-uri attribute) + (dom:set-attribute-node-ns result attr) + (dom:set-attribute-node result attr))))) + (add-default-attributes result) result)) (defmethod dom:import-node ((document document) (node entity) deep) (import-node-internal 'entity document node deep + :name (dom:name node) :public-id (dom:public-id node) :system-id (dom:system-id node) :notation-name (dom:notation-name node))) (defmethod dom:import-node ((document document) (node entity-reference) deep) (declare (ignore deep)) - #+(or) (import-node-internal 'entity-reference document node nil - :name (dom:name node)) - ;; XXX If the document being imported into provides a definition for - ;; this entity name, its value is assigned. - (dom-error :NOT_SUPPORTED_ERR "not implemented")) + :name (dom:name node))) (defmethod dom:import-node ((document document) (node notation) deep) (import-node-internal 'notation document node deep @@ -1031,13 +1425,49 @@ (let ((*clone-not-import* t)) (dom:import-node (dom:owner-document node) node deep))) +;; extension: +(defmethod dom:clone-node ((node document) deep) + (let* ((document (make-instance 'document)) + (original-doctype (dom:doctype node)) + (doctype + (when original-doctype + (make-instance 'document-type + :owner document + :name (dom:name original-doctype) + :public-id (dom:public-id original-doctype) + :system-id (dom:system-id original-doctype) + :notations (make-instance 'named-node-map + :element-type :notation + :owner document + :items (dom:items (dom:notations original-doctype))) + :entities (make-instance 'named-node-map + :element-type :entity + :owner document + :items (dom:items + (dom:entities original-doctype))))))) + (setf (slot-value document 'owner) nil) + (setf (slot-value document 'doc-type) doctype) + (setf (slot-value document 'dtd) (dtd node)) + (setf (slot-value document 'entity-resolver) + (slot-value node 'entity-resolver)) + (setf (slot-value (dom:entities doctype) 'read-only-p) t) + (setf (slot-value (dom:notations doctype) 'read-only-p) t) + (when (and doctype (slot-boundp doctype 'dom::%internal-subset)) + (setf (dom::%internal-subset doctype) + (dom::%internal-subset original-doctype))) + (when (and (dom:document-element node) deep) + (let* ((*clone-not-import* t) + (clone (dom:import-node document (dom:document-element node) t))) + (dom:append-child document clone))) + document)) + ;;; Erweiterung -(defun dom:create-document (&optional document-element) +(defun create-document (&optional document-element) ;; Um ein neues Dokumentenobject zu erzeugen, parsen wir einfach ein ;; Dummydokument. - (let* ((handler (dom:make-dom-builder)) + (let* ((handler (make-dom-builder)) (cxml::*ctx* (cxml::make-context :handler handler)) (result (progn Modified: branches/grin-neu/thirdparty/cxml/dom/dom-sax.lisp =================================================================== --- branches/grin-neu/thirdparty/cxml/dom/dom-sax.lisp 2006-12-01 10:37:34 UTC (rev 2093) +++ branches/grin-neu/thirdparty/cxml/dom/dom-sax.lisp 2006-12-01 10:39:49 UTC (rev 2094) @@ -1,50 +1,70 @@ ;;;; dom-sax.lisp -- DOM walker ;;;; -;;;; This file is part of the CXML parser, released under (L)LGPL. +;;;; This file is part of the CXML parser, released under Lisp-LGPL. ;;;; See file COPYING for details. ;;;; ;;;; Author: David Lichteblau ;;;; Copyright (c) 2004 knowledgeTools Int. GmbH -(in-package :dom-impl) +(in-package :cxml) (defun dom:map-document (handler document &key (include-xmlns-attributes sax:*include-xmlns-attributes*) - include-default-values) + include-doctype + include-default-values + (recode (and #+rune-is-integer (typep document 'utf8-dom::node)))) + (declare (ignorable recode)) + #+rune-is-integer + (when recode + (setf handler (make-recoder handler #'utf8-string-to-rod))) (sax:start-document handler) - (let ((doctype (dom:doctype document))) - (when doctype - (sax:start-dtd handler (dom:name doctype) nil nil) - ;; need notations for canonical mode 2 - (let* ((ns (dom:notations doctype)) - (a (make-array (dom:length ns)))) - ;; get them - (dotimes (k (dom:length ns)) - (setf (elt a k) (dom:item ns k))) - ;; sort them - (setf a (sort a #'rod< :key #'dom:name)) - (loop for n across a do - (sax:notation-declaration handler - (dom:name n) - (dom:public-id n) - (dom:system-id n))) - ;; fixme: entities! - (sax:end-dtd handler)))) + (when include-doctype + (let ((doctype (dom:doctype document))) + (when doctype + (sax:start-dtd handler + (dom:name doctype) + (dom:public-id doctype) + (dom:system-id doctype)) + (ecase include-doctype + (:full-internal-subset + (when (slot-boundp doctype 'dom::%internal-subset) + (sax:start-internal-subset handler) + (dolist (def (dom::%internal-subset doctype)) + (apply (car def) handler (cdr def))) + (sax:end-internal-subset handler))) + (:canonical-notations + ;; need notations for canonical mode 2 + (let* ((ns (dom:notations doctype)) + (a (make-array (dom:length ns)))) + (when (plusp (dom:length ns)) + (sax:start-internal-subset handler) + ;; get them + (dotimes (k (dom:length ns)) + (setf (elt a k) (dom:item ns k))) + ;; sort them + (setf a (sort a #'rod< :key #'dom:name)) + (loop for n across a do + (sax:notation-declaration handler + (dom:name n) + (dom:public-id n) + (dom:system-id n))) + (sax:end-internal-subset handler))))) + (sax:end-dtd handler)))) (labels ((walk (node) (dom:do-node-list (child (dom:child-nodes node)) (ecase (dom:node-type child) (:element - ;; fixme: namespaces (let ((attlist (compute-attributes child include-xmlns-attributes include-default-values)) - (lname (dom:tag-name child)) + (uri (dom:namespace-uri child)) + (lname (dom:local-name child)) (qname (dom:tag-name child))) - (sax:start-element handler nil lname qname attlist) + (sax:start-element handler uri lname qname attlist) (walk child) - (sax:end-element handler nil lname qname))) + (sax:end-element handler uri lname qname))) (:cdata-section (sax:start-cdata handler) (sax:characters handler (dom:data child)) @@ -64,10 +84,12 @@ (let ((results '())) (dom:do-node-list (a (dom:attributes element)) (when (and (or defaultp (dom:specified a)) - (or xmlnsp (not (cxml::xmlns-attr-p (dom:name a))))) + (or xmlnsp (not (cxml::xmlns-attr-p (rod (dom:name a)))))) (push (sax:make-attribute :qname (dom:name a) :value (dom:value a) + :local-name (dom:local-name a) + :namespace-uri (dom:namespace-uri a) :specified-p (dom:specified a)) results))) (reverse results))) Modified: branches/grin-neu/thirdparty/cxml/dom/package.lisp =================================================================== --- branches/grin-neu/thirdparty/cxml/dom/package.lisp 2006-12-01 10:37:34 UTC (rev 2093) +++ branches/grin-neu/thirdparty/cxml/dom/package.lisp 2006-12-01 10:39:49 UTC (rev 2094) @@ -1,6 +1,6 @@ ;;;; package.lisp -- Paketdefinition ;;;; -;;;; This file is part of the CXML parser, released under (L)LGPL. +;;;; This file is part of the CXML parser, released under Lisp-LGPL. ;;;; See file COPYING for details. (in-package :cl-user) @@ -8,11 +8,33 @@ (defpackage :dom (:use) (:export - - ;; lisp-specific extensions - #:make-dom-builder + ;; DOM 2 functions + #:owner-element + #:import-node + #:create-element-ns + #:create-attribute-ns + #:get-elements-by-tag-name-ns + #:get-element-by-id + #:get-named-item-ns + #:set-named-item-ns + #:remove-named-item-ns + #:is-supported + #:has-attributes + #:namespace-uri + #:prefix + #:local-name + #:internal-subset + #:create-document-type + #:create-document + #:get-attribute-ns + #:set-attribute-ns + #:remove-attribute-ns + #:get-attribute-node-ns + #:set-attribute-node-ns + #:has-attribute + #:has-attribute-ns - ;; methods + ;; DOM 1 functions #:has-feature #:doctype #:implementation @@ -72,16 +94,12 @@ #:system-id #:notation-name #:target - #:import-node #:code - - ;; protocol classes - #:dom-implementation + + ;; IDL interfaces, exported "inofficially" + #:node + #:document #:document-fragment - #:document - #:node - #:node-list - #:named-node-map #:character-data #:attr #:element @@ -93,8 +111,14 @@ #:entity #:entity-reference #:processing-instruction + #:named-node-map + ;; no classes: +;;; #:dom-implementation +;;; #:node-list + ;; #:items + ;; #:node-p #:document-p @@ -114,5 +138,24 @@ #:map-node-list #:do-node-list + #:map-node-map + #:do-node-map #:create-document #:map-document)) + +(defclass dom:node () ()) +(defclass dom:document (dom:node) ()) +(defclass dom:document-fragment (dom:node) ()) +(defclass dom:character-data (dom:node) ()) +(defclass dom:attr (dom:node) ()) +(defclass dom:element (dom:node) ()) +(defclass dom:text (dom:character-data) ()) +(defclass dom:comment (dom:character-data) ()) +(defclass dom:cdata-section (dom:text) ()) +(defclass dom:document-type (dom:node) ()) +(defclass dom:notation (dom:node) ()) +(defclass dom:entity (dom:node) ()) +(defclass dom:entity-reference (dom:node) ()) +(defclass dom:processing-instruction (dom:node) ()) + +(defclass dom:named-node-map () ()) Modified: branches/grin-neu/thirdparty/cxml/mlisp-patch.diff =================================================================== --- branches/grin-neu/thirdparty/cxml/mlisp-patch.diff 2006-12-01 10:37:34 UTC (rev 2093) +++ branches/grin-neu/thirdparty/cxml/mlisp-patch.diff 2006-12-01 10:39:49 UTC (rev 2094) @@ -1,44 +1,5 @@ -* looking for david at knowledgetools.de--cxml/cxml--devel--1.0--patch-194 to compare with -* comparing to david at knowledgetools.de--cxml/cxml--devel--1.0--patch-194 -M xml/xml-name-rune-p.lisp -M xml/xml-parse.lisp - -* modified files - ---- orig/xml/xml-name-rune-p.lisp -+++ mod/xml/xml-name-rune-p.lisp -@@ -206,15 +206,15 @@ - (setf (aref r i) 1))))) ) - - `(progn -- (DEFSUBST NAME-RUNE-P (RUNE) -- (SETF RUNE (RUNE-CODE RUNE)) -- (AND (<= 0 RUNE ,*max*) -- (LOCALLY (DECLARE (OPTIMIZE (SAFETY 0) (SPEED 3))) -- (= 1 (SBIT ',(predicate-to-bv #'name-rune-p) -- (THE FIXNUM RUNE)))))) -- (DEFSUBST NAME-START-RUNE-P (RUNE) -- (SETF RUNE (RUNE-CODE RUNE)) -- (AND (<= 0 RUNE ,*MAX*) -- (LOCALLY (DECLARE (OPTIMIZE (SAFETY 0) (SPEED 3))) -- (= 1 (SBIT ',(predicate-to-bv #'name-start-rune-p) -- (THE FIXNUM RUNE)))))))) )))) -+ (defsubst name-rune-p (rune) -+ (setf rune (rune-code rune)) -+ (and (<= 0 rune ,*max*) -+ (locally (declare (optimize (safety 0) (speed 3))) -+ (= 1 (sbit ',(predicate-to-bv #'name-rune-p) -+ (the fixnum rune)))))) -+ (defsubst name-start-rune-p (rune) -+ (setf rune (rune-code rune)) -+ (and (<= 0 rune ,*max*) -+ (locally (declare (optimize (safety 0) (speed 3))) -+ (= 1 (sbit ',(predicate-to-bv #'name-start-rune-p) -+ (the fixnum rune)))))))) )))) - - ---- orig/xml/xml-parse.lisp -+++ mod/xml/xml-parse.lisp +--- xml/xml-parse.lisp ++++ xml/xml-parse.lisp @@ -2497,20 +2497,20 @@ (let ((input-var (gensym)) (collect (gensym)) @@ -74,3 +35,34 @@ +Index: xml/xml-name-rune-p.lisp +=================================================================== +RCS file: /project/cxml/cvsroot/cxml/xml/xml-name-rune-p.lisp,v +retrieving revision 1.2 +diff -r1.2 xml-name-rune-p.lisp +214,225c214,225 +< (DEFINLINE NAME-RUNE-P (RUNE) +< (SETF RUNE (RUNE-CODE RUNE)) +< (AND (<= 0 RUNE ,*max*) +< (LOCALLY (DECLARE (OPTIMIZE (SAFETY 0) (SPEED 3))) +< (= 1 (SBIT ',(predicate-to-bv #'name-rune-p) +< (THE FIXNUM RUNE)))))) +< (DEFINLINE NAME-START-RUNE-P (RUNE) +< (SETF RUNE (RUNE-CODE RUNE)) +< (AND (<= 0 RUNE ,*MAX*) +< (LOCALLY (DECLARE (OPTIMIZE (SAFETY 0) (SPEED 3))) +< (= 1 (SBIT ',(predicate-to-bv #'name-start-rune-p) +< (THE FIXNUM RUNE)))))))) )))) +--- +> (definline name-rune-p (rune) +> (setf rune (rune-code rune)) +> (and (<= 0 rune ,*max*) +> (locally (declare (optimize (safety 0) (speed 3))) +> (= 1 (sbit ',(predicate-to-bv #'name-rune-p) +> (the fixnum rune)))))) +> (definline name-start-rune-p (rune) +> (setf rune (rune-code rune)) +> (and (<= 0 rune ,*max*) +> (locally (declare (optimize (safety 0) (speed 3))) +> (= 1 (sbit ',(predicate-to-bv #'name-start-rune-p) +> (the fixnum rune)))))))) )))) Modified: branches/grin-neu/thirdparty/cxml/runes/characters.lisp =================================================================== --- branches/grin-neu/thirdparty/cxml/runes/characters.lisp 2006-12-01 10:37:34 UTC (rev 2093) +++ branches/grin-neu/thirdparty/cxml/runes/characters.lisp 2006-12-01 10:39:49 UTC (rev 2094) @@ -3,7 +3,7 @@ ;;; ;;; derived from runes.lisp, (c) copyright 1998,1999 by Gilbert Baumann ;;; -;;; License: LLGPL (See file COPYING for details). +;;; License: Lisp-LGPL (See file COPYING for details). ;;; ;;; This code is free software; you can redistribute it and/or modify it ;;; under the terms of the version 2.1 of the GNU Lesser General Public @@ -24,35 +24,35 @@ (in-package :runes) -(deftype rune () 'base-char) -(deftype rod () 'base-string) -(deftype simple-rod () 'simple-string) +(deftype rune () #-lispworks 'character #+lispworks 'lw:simple-char) +(deftype rod () '(vector rune)) +(deftype simple-rod () '(simple-array rune)) -(defsubst rune (rod index) +(definline rune (rod index) (char rod index)) (defun (setf rune) (new rod index) (setf (char rod index) new)) -(defsubst %rune (rod index) +(definline %rune (rod index) (aref (the simple-string rod) (the fixnum index))) -(defsubst (setf %rune) (new rod index) +(definline (setf %rune) (new rod index) (setf (aref (the simple-string rod) (the fixnum index)) new)) (defun rod-capitalize (rod) (string-upcase rod)) -(defsubst code-rune (x) (code-char x)) -(defsubst rune-code (x) (char-code x)) +(definline code-rune (x) (code-char x)) +(definline rune-code (x) (char-code x)) -(defsubst rune= (x y) +(definline rune= (x y) (char= x y)) (defun rune-downcase (rune) (char-downcase rune)) -(defsubst rune-upcase (rune) +(definline rune-upcase (rune) (char-upcase rune)) (defun rune-upper-case-letter-p (rune) @@ -70,13 +70,13 @@ (defun rod-upcase (rod) (string-upcase rod)) -(defsubst white-space-rune-p (char) +(definline white-space-rune-p (char) (or (char= char #\tab) (char= char #.(code-char 10)) ;Linefeed (char= char #.(code-char 13)) ;Carriage Return (char= char #\space))) -(defsubst digit-rune-p (char &optional (radix 10)) +(definline digit-rune-p (char &optional (radix 10)) (digit-char-p char radix)) (defun rod (x) @@ -95,13 +95,15 @@ (stringp x)) (defun rod= (x y) - (string= x y)) + (if (zerop (length x)) + (zerop (length y)) + (and (plusp (length y)) (string= x y)))) (defun rod-equal (x y) (string-equal x y)) -(defsubst make-rod (size) - (make-string size)) +(definline make-rod (size) + (make-string size :element-type 'rune)) (defun char-rune (char) char) Added: branches/grin-neu/thirdparty/cxml/runes/definline.lisp =================================================================== --- branches/grin-neu/thirdparty/cxml/runes/definline.lisp 2006-12-01 10:37:34 UTC (rev 2093) +++ branches/grin-neu/thirdparty/cxml/runes/definline.lisp 2006-12-01 10:39:49 UTC (rev 2094) @@ -0,0 +1,63 @@ +;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: CL-USER; -*- +;;; --------------------------------------------------------------------------- +;;; Title: definline +;;; Created: 1999-05-25 22:32 +;;; Author: Gilbert Baumann +;;; License: Lisp-LGPL (See file COPYING for details). +;;; --------------------------------------------------------------------------- +;;; (c) copyright 1999 by Gilbert Baumann + +;;; This code is free software; you can redistribute it and/or modify it +;;; under the terms of the version 2.1 of the GNU Lesser General Public +;;; License as published by the Free Software Foundation, as clarified +;;; by the "Preamble to the Gnu Lesser General Public License" found in +;;; the file COPYING. +;;; +;;; This code 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 +;;; Lesser General Public License for more details. +;;; +;;; Version 2.1 of the GNU Lesser General Public License is in the file +;;; COPYING that was distributed with this file. If it is not present, +;;; you can access it from http://www.gnu.org/copyleft/lesser.txt (until +;;; superseded by a newer version) or write to the Free Software +;;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + +(in-package :runes) + +#-(or allegro openmcl) +(defmacro definline (name args &body body) + `(progn + (declaim (inline ,name)) + (defun ,name ,args .,body))) + +#+openmcl +(defmacro runes::definline (fun args &body body) + (if (consp fun) + `(defun ,fun ,args + , at body) + `(progn + (defun ,fun ,args .,body) + (define-compiler-macro ,fun (&rest .args.) + (cons '(lambda ,args .,body) + .args.))))) + +#+allegro +(defmacro definline (fun args &body body) + (if (and (consp fun) (eq (car fun) 'setf)) + (let ((fnam (intern (concatenate 'string "(SETF " (symbol-name (cadr fun)) ")") + (symbol-package (cadr fun))))) + `(progn + (defsetf ,(cadr fun) (&rest ap) (new-value) (list* ',fnam new-value ap)) + (definline ,fnam ,args .,body))) + (labels ((declp (x) + (and (consp x) (eq (car x) 'declare)))) + `(progn + (defun ,fun ,args .,body) + (define-compiler-macro ,fun (&rest .args.) + (cons '(lambda ,args + ,@(remove-if-not #'declp body) + (block ,fun + ,@(remove-if #'declp body))) + .args.)))))) Added: branches/grin-neu/thirdparty/cxml/runes/definline.x86f =================================================================== --- branches/grin-neu/thirdparty/cxml/runes/definline.x86f 2006-12-01 10:37:34 UTC (rev 2093) +++ branches/grin-neu/thirdparty/cxml/runes/definline.x86f 2006-12-01 10:39:49 UTC (rev 2094) @@ -0,0 +1,30 @@ +FASL FILE output from /usr/home/hans/bknr-svn/thirdparty/cxml/runes/definline.lisp. +Compiled Thursday, 11/30/06 10:08:49 pm GMT on ibuprofen.huebner.org +Compiler 1.1, Lisp 19c Release (19C) +Targeted for Intel x86, FASL version 19C +???Q&KERNEL %IN-PACKAGE& COMMON-LISP QUOTE&RUNES6R?>#?B INLINE DECLAIM DEFUN PROGN DEFMACROQ&RUNESR DEFINLINE NAME ARGS &BODY BODYLDO-ARG-COUNT-ERROR<Q&C COMPILED-DEBUG-INFORQR($$-Q& +EXTENSIONS INSTANCER($$-Q STRUCTURE-OBJECTR($$-Q  +DEBUG-INFOR($$-($$- &DEFMACRO DEFINLINE!&RUNES"Q COMPILED-DEBUG-FUNCTIONRQ DEBUG-FUNCTIONR(%$$-&('$$ -(NMACRO +*NEXTERNAL+ +G1MG2?,+??-$$$ DELETED(/NSTANDARD$'$$#1 1$*(+2LIST COMMON-LISPNNAME??TAILLISPNWHOLE-0C2+p*$# ? L  +T + + + +3$$.(40$'$$*# 1 5(617*?58; ?~?E??e??????U??M???$<?????H??$<??1??#??B????????????????I?? ?(t??$<t?????M???$<?????H??$<???A????E??H??$<???I??$<???A??E??E??H??$<???I??$<???A?E?????4?(??(?|?(;??(v??|?(?[???P????@??x??@ ?(??(?=4?(t? ????4?(??(?|?(;??(v??|?(?[???P????@??x??@ ?(??(?=4?(t? ?]?????u??E??E??4?(??(?|?(;??(v??|?(?[???P????@??x????@??p??M??H??(?=4?(t? ????}??4?(??(?|?(;??(v??|?(?[???P????@??x????@??p??@ ?(??(?=4?(t? ???M??E??????????M???$<?????p?????!?=%?)?C??C??C? ?(?-??k????P???1? +@??????? +M? +N? +N?4?(??(?|?(;??(v??|?(? +?@?P???(?=4?(t? ?????? + +? +N? +N? +N? +N? +N? +N? +NQNRELATIVER?alloc_overflow_eax9QNABSOLUTER??QNABSOLUTER??QNABSOLUTER??QNABSOLUTER??QNABSOLUTER??QNRELATIVER?alloc_overflow_ebxXQNABSOLUTER?/QNRELATIVER?alloc_overflow_ebx?QNABSOLUTER??QNRELATIVER?alloc_overflow_ebx?QNABSOLUTER?_QNRELATIVER?alloc_overflow_ebx'QNABSOLUTER??=?G*&(name args &body body)H FUNCTIONJ LISTL?*MJ +M&Top-Level FormN1OP; +? !0?q0?QN$$Q SIMPLE-BYTE-FUNCTIONRQ FUNCTIONR(T$$-UQ FUNCALLABLE-INSTANCERU(W$$-XQ BYTE-FUNCTION-OR-CLOSURERUX(Z$$-[Q BYTE-FUNCTIONRUX[(]$$-^(_$$-`?a8Q  DEBUG-SOURCER(c$$ -dNFILE&m@ \ No newline at end of file Modified: branches/grin-neu/thirdparty/cxml/runes/encodings-data.lisp =================================================================== --- branches/grin-neu/thirdparty/cxml/runes/encodings-data.lisp 2006-12-01 10:37:34 UTC (rev 2093) +++ branches/grin-neu/thirdparty/cxml/runes/encodings-data.lisp 2006-12-01 10:39:49 UTC (rev 2094) @@ -1,4 +1,4 @@ -(in-package :encoding) +(in-package :runes-encoding) (progn (add-name :us-ascii "ANSI_X3.4-1968") Modified: branches/grin-neu/thirdparty/cxml/runes/encodings.lisp =================================================================== --- branches/grin-neu/thirdparty/cxml/runes/encodings.lisp 2006-12-01 10:37:34 UTC (rev 2093) +++ branches/grin-neu/thirdparty/cxml/runes/encodings.lisp 2006-12-01 10:39:49 UTC (rev 2094) @@ -1,5 +1,10 @@ -(in-package :encoding) +(in-package :runes-encoding) +(define-condition encoding-error (simple-error) ()) + +(defun xerror (fmt &rest args) + (error 'encoding-error :format-control fmt :format-arguments args)) + ;;;; --------------------------------------------------------------------------- ;;;; Encoding names ;;;; @@ -102,6 +107,39 @@ (defmacro %< (&rest xs) `(fx-pred < , at xs)) (defmacro %> (&rest xs) `(fx-pred > , at xs)) +;;; Decoders + +;; The decoders share a common signature: +;; +;; DECODE input input-start input-end +;; output output-start output-end +;; eof-p +;; -> first-not-written ; first-not-read +;; +;; These decode functions should decode as much characters off `input' +;; into the `output' as possible and return the indexes to the first +;; not read and first not written element of `input' and `output' +;; respectively. If there are not enough bytes in `input' to decode a +;; full character, decoding shold be abandomed; the caller has to +;; ensure that the remaining bytes of `input' are passed to the +;; decoder again with more bytes appended. +;; +;; `eof-p' now in turn indicates, if the given input sequence, is all +;; the producer does have and might be used to produce error messages +;; in case of incomplete codes or decided what to do. +;; +;; Decoders are expected to handle the various CR/NL conventions and +;; canonicalize each end of line into a single NL rune (#xA) in good +;; old Lisp tradition. +;; + +;; TODO: change this to an encoding class, which then might carry +;; additional state. Stateless encodings could been represented by +;; keywords. e.g. +;; +;; defmethod DECODE-SEQUENCE ((encoding (eql :utf-8)) ...) +;; + (defmethod decode-sequence ((encoding (eql :utf-16-big-endian)) in in-start in-end out out-start out-end eof?) ;; -> new wptr, new rptr @@ -115,7 +153,13 @@ (let ((hi (aref in rptr)) (lo (aref in (%+ 1 rptr)))) (setf rptr (%+ 2 rptr)) - (setf (aref out wptr) (logior (ash hi 8) lo)) + ;; FIXME: Wenn wir hier ein Surrogate sehen, muessen wir das naechste + ;; Zeichen abwarten und nachgucken, dass nicht etwa die andere + ;; Haelfte fehlt! + (let ((x (logior (ash hi 8) lo))) + (when (or (eql x #xFFFE) (eql x #xFFFF)) + (xerror "not a valid code point: #x~X" x)) + (setf (aref out wptr) x)) (setf wptr (%+ 1 wptr)))) (values wptr rptr))) @@ -132,7 +176,13 @@ (let ((lo (aref in (%+ 0 rptr))) (hi (aref in (%+ 1 rptr)))) (setf rptr (%+ 2 rptr)) - (setf (aref out wptr) (logior (ash hi 8) lo)) + ;; FIXME: Wenn wir hier ein Surrogate sehen, muessen wir das naechste + ;; Zeichen abwarten und nachgucken, dass nicht etwa die andere + ;; Haelfte fehlt! + (let ((x (logior (ash hi 8) lo))) + (when (or (eql x #xFFFE) (eql x #xFFFF)) + (xerror "not a valid code point: #x~X" x)) + (setf (aref out wptr) x)) (setf wptr (%+ 1 wptr)))) (values wptr rptr))) @@ -147,14 +197,14 @@ byte0) (macrolet ((put (x) `((lambda (x) - (cond ((or (<= #xD800 x #xDBFF) - (<= #xDC00 x #xDFFF)) - (error "Encoding UTF-16 in UTF-8? : #x~x." x))) - '(unless (data-char-p x) - (error "#x~x is not a data character." x)) - ;;(fresh-line) - ;;(prin1 x) (princ "-> ") - (cond ((%> x #xFFFF) + (when (or (<= #xD800 x #xDBFF) + (<= #xDC00 x #xDFFF)) + (xerror "surrogate encoded in UTF-8: #x~X." x)) + (cond ((or (%> x #x10FFFF) + (eql x #xFFFE) + (eql x #xFFFF)) + (xerror "not a valid code point: #x~X" x)) + ((%> x #xFFFF) (setf (aref out (%+ 0 wptr)) (%+ #xD7C0 (ash x -10)) (aref out (%+ 1 wptr)) (%ior #xDC00 (%and x #x3FF))) (setf wptr (%+ wptr 2))) @@ -196,7 +246,7 @@ (setf rptr (%+ rptr 1))) ((%<= #|#b10000000|# byte0 #b10111111) - (error "Corrupted UTF-8 input (initial byte was #b~8,'0B)" byte0) + (xerror "Corrupted UTF-8 input (initial byte was #b~8,'0B)" byte0) (setf rptr (%+ rptr 1))) ((%<= #|#b11000000|# byte0 #b11011111) @@ -260,7 +310,7 @@ (return)))) (t - (error "Corrupted UTF-8 input (initial byte was #b~8,'0B)" byte0)) ) )) + (xerror "Corrupted UTF-8 input (initial byte was #b~8,'0B)" byte0)) ) )) (values wptr rptr)) ) (defmethod encoding-p ((object (eql :utf-16-little-endian))) t) @@ -343,5 +393,4 @@ (defun find-charset (name) (or (gethash name *charsets*) - (error "There is no character set named ~S." name))) - + (xerror "There is no character set named ~S." name))) Modified: branches/grin-neu/thirdparty/cxml/runes/package.lisp =================================================================== --- branches/grin-neu/thirdparty/cxml/runes/package.lisp 2006-12-01 10:37:34 UTC (rev 2093) +++ branches/grin-neu/thirdparty/cxml/runes/package.lisp 2006-12-01 10:39:49 UTC (rev 2094) @@ -10,15 +10,8 @@ (defpackage :runes (:use :cl) - (:export #:defsubst + (:export #:definline - ;; util.lisp : - #:compose - #:curry - #:rcurry - #:until - #:while - ;; runes.lisp #:rune #:rod @@ -50,6 +43,7 @@ #:rod< ;; xstream.lisp + #:xstream #:make-xstream #:make-rod-xstream #:close-xstream @@ -66,10 +60,31 @@ #:xstream-plist #:xstream-encoding #:set-to-full-speed - #:xstream-name)) + #:xstream-name -(defpackage :encoding + ;; ystream.lisp + #:ystream + #:close-ystream + #:write-rune + #:write-rod + #:ystream-column + #:make-octet-vector-ystream + #:make-octet-stream-ystream + #:make-rod-ystream + #+rune-is-character #:make-character-stream-ystream + #+rune-is-integer #:make-string-ystream/utf8 + #+rune-is-integer #:make-character-stream-ystream/utf8 + #:runes-to-utf8/adjustable-string)) + +(defpackage :utf8-runes + (:use :cl) + (:export *utf8-runes-readtable* + #:rune #:rod #:simple-rod #:rod-string #:rod= #:make-rod + #:string-rod)) + +(defpackage :runes-encoding (:use :cl :runes) (:export + #:encoding-error #:find-encoding #:decode-sequence)) Modified: branches/grin-neu/thirdparty/cxml/runes/runes.lisp =================================================================== --- branches/grin-neu/thirdparty/cxml/runes/runes.lisp 2006-12-01 10:37:34 UTC (rev 2093) +++ branches/grin-neu/thirdparty/cxml/runes/runes.lisp 2006-12-01 10:39:49 UTC (rev 2094) @@ -3,7 +3,7 @@ ;;; Title: Unicode strings (called RODs) ;;; Created: 1999-05-25 22:29 ;;; Author: Gilbert Baumann -;;; License: LLGPL (See file COPYING for details). +;;; License: Lisp-LGPL (See file COPYING for details). ;;; --------------------------------------------------------------------------- ;;; (c) copyright 1998,1999 by Gilbert Baumann @@ -42,26 +42,26 @@ (deftype rod () '(array rune (*))) (deftype simple-rod () '(simple-array rune (*))) -(defsubst rune (rod index) +(definline rune (rod index) (aref rod index)) (defun (setf rune) (new rod index) (setf (aref rod index) new)) -(defsubst %rune (rod index) +(definline %rune (rod index) (aref (the (simple-array (unsigned-byte 16) (*)) rod) (the fixnum index))) -(defsubst (setf %rune) (new rod index) +(definline (setf %rune) (new rod index) (setf (aref (the (simple-array (unsigned-byte 16) (*)) rod) (the fixnum index)) new)) (defun rod-capitalize (rod) (warn "~S is not implemented." 'rod-capitalize) rod) -(defsubst code-rune (x) x) -(defsubst rune-code (x) x) +(definline code-rune (x) x) +(definline rune-code (x) x) -(defsubst rune= (x y) +(definline rune= (x y) (= x y)) (defun rune-downcase (rune) @@ -70,7 +70,7 @@ ((<= #x00c0 rune #x00de) (+ rune #x20)) (t rune))) -(defsubst rune-upcase (rune) +(definline rune-upcase (rune) (cond ((<= #x0061 rune #x007a) (- rune #x20)) ((= rune #x00f7) rune) ((<= #x00e0 rune #x00fe) (- rune #x20)) @@ -95,13 +95,13 @@ ;; FIXME (map '(simple-array (unsigned-byte 16) (*)) #'rune-upcase rod)) -(defsubst white-space-rune-p (char) +(definline white-space-rune-p (char) (or (= char 9) ;TAB (= char 10) ;Linefeed (= char 13) ;Carriage Return (= char 32))) ;Space -(defsubst digit-rune-p (char &optional (radix 10)) +(definline digit-rune-p (char &optional (radix 10)) (cond ((<= #.(char-code #\0) char #.(char-code #\9)) (and (< (- char #.(char-code #\0)) radix) (- char #.(char-code #\0)))) @@ -141,18 +141,23 @@ (unless (rune-equal (rune x i) (rune y i)) (return nil))))) -(defsubst make-rod (size) +(definline make-rod (size) (make-array size :element-type 'rune)) (defun char-rune (char) (code-rune (char-code char))) -(defun rune-char (rune &optional (default #\?)) - (if (>= rune char-code-limit) - default - (or (code-char rune) default))) +(defparameter *invalid-rune* nil ;;#\? + "Rune to use as a replacement in RUNE-CHAR and ROD-STRING for runes not + representable as characters. If NIL, an error is signalled instead.") -(defun rod-string (rod &optional (default-char #\?)) +(defun rune-char (rune &optional (default *invalid-rune*)) + (or (if (>= rune char-code-limit) + default + (or (code-char rune) default)) + (error "rune cannot be represented as a character: ~A" rune))) + +(defun rod-string (rod &optional (default-char *invalid-rune*)) (map 'string (lambda (x) (rune-char x default-char)) rod)) (defun string-rod (string) Modified: branches/grin-neu/thirdparty/cxml/runes/syntax.lisp =================================================================== --- branches/grin-neu/thirdparty/cxml/runes/syntax.lisp 2006-12-01 10:37:34 UTC (rev 2093) +++ branches/grin-neu/thirdparty/cxml/runes/syntax.lisp 2006-12-01 10:39:49 UTC (rev 2094) @@ -3,7 +3,7 @@ ;;; Title: Unicode strings (called RODs) ;;; Created: 1999-05-25 22:29 ;;; Author: Gilbert Baumann -;;; License: LLGPL (See file COPYING for details). +;;; License: Lisp-LGPL (See file COPYING for details). ;;; --------------------------------------------------------------------------- ;;; (c) copyright 1998,1999 by Gilbert Baumann Added: branches/grin-neu/thirdparty/cxml/runes/utf8.lisp =================================================================== --- branches/grin-neu/thirdparty/cxml/runes/utf8.lisp 2006-12-01 10:37:34 UTC (rev 2093) +++ branches/grin-neu/thirdparty/cxml/runes/utf8.lisp 2006-12-01 10:39:49 UTC (rev 2094) @@ -0,0 +1,36 @@ +;;; copyright (c) 2005 David Lichteblau +;;; License: Lisp-LGPL (See file COPYING for details). +;;; +;;; Rune emulation for the UTF-8-compatible DOM implementation. +;;; Used only with 8 bit characters on non-unicode Lisps. + +(in-package :utf8-runes) + +(deftype rune () 'character) +(deftype rod () '(vector rune)) +(deftype simple-rod () '(simple-array rune)) + +(defun rod= (r s) + (string= r s)) + +(defun rod-string (rod &optional default) + (declare (ignore default)) + rod) + +(defun string-rod (string) + string) + +(defun make-rod (size) + (make-string size :element-type 'rune)) + +(defun rune-reader (stream subchar arg) + (runes::rune-char (runes::rune-reader stream subchar arg))) + +(defun rod-reader (stream subchar arg) + (runes::rod-string (runes::rod-reader stream subchar arg))) + +(setf cxml-system::*utf8-runes-readtable* + (let ((rt (copy-readtable))) + (set-dispatch-macro-character #\# #\/ 'rune-reader rt) + (set-dispatch-macro-character #\# #\" 'rod-reader rt) + rt)) Modified: branches/grin-neu/thirdparty/cxml/runes/xstream.lisp =================================================================== --- branches/grin-neu/thirdparty/cxml/runes/xstream.lisp 2006-12-01 10:37:34 UTC (rev 2093) +++ branches/grin-neu/thirdparty/cxml/runes/xstream.lisp 2006-12-01 10:39:49 UTC (rev 2094) @@ -1,11 +1,11 @@ -;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: runes; readtable: runes; Encoding: utf-8; -*- +;;; -*- Mode: Lisp; Syntax: Common-Lisp; readtable: runes; Encoding: utf-8; -*- ;;; --------------------------------------------------------------------------- ;;; Title: Fast streams ;;; Created: 1999-07-17 ;;; Author: Gilbert Baumann -;;; License: LGPL (See file COPYING for details). +;;; License: Lisp-LGPL (See file COPYING for details). ;;; --------------------------------------------------------------------------- -;;; copyright 1999 by Gilbert Baumann +;;; (c) copyright 1999 by Gilbert Baumann ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public @@ -66,9 +66,7 @@ ;; (eval-when (:compile-toplevel :load-toplevel :execute) - (defparameter *fast* '(optimize (speed 3) (safety 0))) - ;;(defparameter *fast* '(optimize (speed 2) (safety 3))) - ) + (defparameter *fast* '(optimize (speed 3) (safety 0)))) ;; Let us first define fast fixnum arithmetric get rid of type ;; checks. (After all we know what we do here). @@ -217,7 +215,7 @@ nil) ,input)) -(defsubst unread-rune (rune input) +(definline unread-rune (rune input) "Unread the last recently read rune; if there wasn't such a rune, you deserve to lose." (declare (ignore rune)) @@ -258,9 +256,7 @@ ;;; Underflow -;;(defun read-runes (sequence input)) - -(defun xstream-underflow (input) +(defmethod xstream-underflow ((input xstream)) (declare (type xstream input)) ;; we are about to fill new data into the buffer, so we need to ;; adjust buffer-start. @@ -277,10 +273,14 @@ :end2 (xstream-os-left-end input)) ;; then we take care that the buffer is large enough to carry at ;; least 100 bytes (a random number) + ;; + ;; david: was heisst da random? ich nehme an, dass 100 einfach + ;; ausreichend sein soll, um die laengste utf-8 bytesequenz oder die + ;; beiden utf-16 surrogates zu halten? dann ist 100 ja wohl dicke + ;; ausreichend und koennte in make-xstream ordentlich geprueft werden. + ;; oder was geht hier vor? (unless (>= (length (xstream-os-buffer input)) 100) - (error "You lost") - ;; todo: enlarge buffer - )) + (error "You lost"))) (setf n (read-octets (xstream-os-buffer input) (xstream-os-stream input) m (min (1- (length (xstream-os-buffer input))) @@ -292,7 +292,7 @@ :eof) (t (multiple-value-bind (fnw fnr) - (encoding:decode-sequence + (runes-encoding:decode-sequence (xstream-encoding input) (xstream-os-buffer input) 0 n (xstream-buffer input) 0 (1- (length (xstream-buffer input))) Added: branches/grin-neu/thirdparty/cxml/runes/ystream.lisp =================================================================== --- branches/grin-neu/thirdparty/cxml/runes/ystream.lisp 2006-12-01 10:37:34 UTC (rev 2093) +++ branches/grin-neu/thirdparty/cxml/runes/ystream.lisp 2006-12-01 10:39:49 UTC (rev 2094) @@ -0,0 +1,250 @@ +;;; (c) 2005 David Lichteblau +;;; License: Lisp-LGPL (See file COPYING for details). +;;; +;;; ystream (for lack of a better name): a rune output "stream" + +(in-package :runes) + +(defconstant +ystream-bufsize+ 1024) + +(defun make-ub8-array (n) + (make-array n :element-type '(unsigned-byte 8))) + +(defun make-ub16-array (n) + (make-array n :element-type '(unsigned-byte 16))) + +(defun make-buffer (&key (element-type '(unsigned-byte 8))) + (make-array 1 + :element-type element-type + :adjustable t + :fill-pointer 0)) + +(defmacro while (test &body body) + `(until (not ,test) , at body)) + +(defmacro until (test &body body) + `(do () (,test) , at body)) + +;;; ystream +;;; +- utf8-ystream +;;; | +- octet-vector-ystream +;;; | \- %stream-ystream +;;; | +- octet-stream-ystream +;;; | \- character-stream-ystream/utf8 +;;; | \- string-ystream/utf8 +;;; +- rod-ystream +;;; \-- character-stream-ystream + +(defstruct ystream + (column 0 :type integer) + (in-ptr 0 :type fixnum) + (in-buffer (make-rod +ystream-bufsize+) :type simple-rod)) + +(defstruct (utf8-ystream + (:include 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-")) + (os-stream nil)) + +(definline write-rune (rune ystream) + (let ((in (ystream-in-buffer ystream))) + (when (eql (ystream-in-ptr ystream) (length in)) + (flush-ystream ystream) + (setf in (ystream-in-buffer ystream))) + (setf (elt in (ystream-in-ptr ystream)) rune) + (incf (ystream-in-ptr ystream)) + (setf (ystream-column ystream) + (if (eql rune #/U+0010) 0 (1+ (ystream-column ystream)))) + rune)) + +(defmethod close-ystream :before ((ystream ystream)) + (flush-ystream ystream)) + + +;;;; UTF8-YSTREAM (abstract) + +(defmethod close-ystream ((ystream %stream-ystream)) + (ystream-os-stream ystream)) + +(defgeneric ystream-device-write (ystream buf nbytes)) + +(defmethod flush-ystream ((ystream utf8-ystream)) + (let ((ptr (ystream-in-ptr ystream))) + (when (plusp ptr) + (let* ((in (ystream-in-buffer ystream)) + (out (ystream-out-buffer ystream)) + (surrogatep (<= #xD800 (rune-code (elt in (1- ptr))) #xDBFF)) + n) + (when surrogatep + (decf ptr)) + (when (plusp ptr) + (setf n (runes-to-utf8 out in ptr)) + (ystream-device-write ystream out n) + (cond + (surrogatep + (setf (elt in 0) (elt in (1- ptr))) + (setf (ystream-in-ptr ystream) 1)) + (t + (setf (ystream-in-ptr ystream) 0)))))))) + +(defun write-rod (rod sink) + (loop for rune across rod do (write-rune rune sink))) + +(defun fast-push (new-element vector) + (vector-push-extend new-element vector (max 1 (array-dimension vector 0)))) + +(macrolet ((define-utf8-writer (name (byte &rest aux) result &body body) + `(defun ,name (out in n) + (let ((high-surrogate nil) + , at aux) + (labels + ((write0 (,byte) + , at body) + (write1 (r) + (cond + ((<= #x00000000 r #x0000007F) + (write0 r)) + ((<= #x00000080 r #x000007FF) + (write0 (logior #b11000000 (ldb (byte 5 6) r))) + (write0 (logior #b10000000 (ldb (byte 6 0) r)))) + ((<= #x00000800 r #x0000FFFF) + (write0 (logior #b11100000 (ldb (byte 4 12) r))) + (write0 (logior #b10000000 (ldb (byte 6 6) r))) + (write0 (logior #b10000000 (ldb (byte 6 0) r)))) + ((<= #x00010000 r #x001FFFFF) + (write0 (logior #b11110000 (ldb (byte 3 18) r))) + (write0 (logior #b10000000 (ldb (byte 6 12) r))) + (write0 (logior #b10000000 (ldb (byte 6 6) r))) + (write0 (logior #b10000000 (ldb (byte 6 0) r)))) + ((<= #x00200000 r #x03FFFFFF) + (write0 (logior #b11111000 (ldb (byte 2 24) r))) + (write0 (logior #b10000000 (ldb (byte 6 18) r))) + (write0 (logior #b10000000 (ldb (byte 6 12) r))) + (write0 (logior #b10000000 (ldb (byte 6 6) r))) + (write0 (logior #b10000000 (ldb (byte 6 0) r)))) + ((<= #x04000000 r #x7FFFFFFF) + (write0 (logior #b11111100 (ldb (byte 1 30) r))) + (write0 (logior #b10000000 (ldb (byte 6 24) r))) + (write0 (logior #b10000000 (ldb (byte 6 18) r))) + (write0 (logior #b10000000 (ldb (byte 6 12) r))) + (write0 (logior #b10000000 (ldb (byte 6 6) r))) + (write0 (logior #b10000000 (ldb (byte 6 0) r)))))) + (write2 (r) + (cond + ((<= #xD800 r #xDBFF) + (setf high-surrogate r)) + ((<= #xDC00 r #xDFFF) + (let ((q (logior (ash (- high-surrogate #xD7C0) 10) + (- r #xDC00)))) + (write1 q)) + (setf high-surrogate nil)) + (t + (write1 r))))) + (dotimes (j n) + (write2 (rune-code (elt in j))))) + ,result)))) + (define-utf8-writer runes-to-utf8 (x (i 0)) + i + (setf (elt out i) x) + (incf i)) + (define-utf8-writer runes-to-utf8/adjustable-string (x) + nil + (fast-push (code-char x) out))) + + +;;;; ROD-YSTREAM + +(defstruct (rod-ystream (:include ystream))) + +(defmethod flush-ystream ((ystream rod-ystream)) + (let* ((old (ystream-in-buffer ystream)) + (new (make-rod (* 2 (length old))))) + (replace new old) + (setf (ystream-in-buffer ystream) new))) + +(defmethod close-ystream ((ystream rod-ystream)) + (subseq (ystream-in-buffer ystream) 0 (ystream-in-ptr ystream))) + + +;;;; CHARACTER-STREAM-YSTREAM + +#+rune-is-character +(progn + (defstruct (character-stream-ystream + (:constructor make-character-stream-ystream (target-stream)) + (:include ystream) + (:conc-name "YSTREAM-")) + (target-stream nil)) + + (defmethod flush-ystream ((ystream character-stream-ystream)) + (write-string (ystream-in-buffer ystream) + (ystream-target-stream ystream) + :end (ystream-in-ptr ystream)) + (setf (ystream-in-ptr ystream) 0)) + + (defmethod close-ystream ((ystream character-stream-ystream)) + (ystream-target-stream ystream))) + + +;;;; OCTET-VECTOR-YSTREAM + +(defstruct (octet-vector-ystream + (:include utf8-ystream) + (:conc-name "YSTREAM-")) + (result (make-buffer))) + +(defmethod ystream-device-write ((ystream octet-vector-ystream) buf nbytes) + (let* ((result (ystream-result ystream)) + (start (length result)) + (size (array-dimension result 0))) + (while (> (+ start nbytes) size) + (setf size (* 2 size))) + (adjust-array result size :fill-pointer (+ start nbytes)) + (replace result buf :start1 start :end2 nbytes))) + +(defmethod close-ystream ((ystream octet-vector-ystream)) + (ystream-result ystream)) + + +;;;; OCTET-STREAM-YSTREAM + +(defstruct (octet-stream-ystream + (:include %stream-ystream) + (:constructor make-octet-stream-ystream (os-stream)) + (:conc-name "YSTREAM-"))) + +(defmethod ystream-device-write ((ystream octet-stream-ystream) buf nbytes) + (write-sequence buf (ystream-os-stream ystream) :end nbytes)) + + +;;;; CHARACTER-STREAM-YSTREAM/UTF8 + +#+rune-is-integer +(progn + (defstruct (character-stream-ystream/utf8 + (:constructor make-character-stream-ystream/utf8 (os-stream)) + (:include %stream-ystream) + (:conc-name "YSTREAM-"))) + + (defmethod ystream-device-write + ((ystream character-stream-ystream/utf8) buf nbytes) + (declare (type (simple-array (unsigned-byte 8) (*)) buf)) + (let ((out (ystream-os-stream ystream))) + (dotimes (x nbytes) + (write-char (code-char (elt buf x)) out))))) + + +;;;; STRING-YSTREAM/UTF8 + +#+rune-is-integer +(progn + (defstruct (string-ystream/utf8 + (:include character-stream-ystream/utf8 + (os-stream (make-string-output-stream))) + (:conc-name "YSTREAM-"))) + + (defmethod close-ystream ((ystream string-ystream/utf8)) + (get-output-stream-string (ystream-os-stream ystream)))) Modified: branches/grin-neu/thirdparty/cxml/test/domtest.lisp =================================================================== --- branches/grin-neu/thirdparty/cxml/test/domtest.lisp 2006-12-01 10:37:34 UTC (rev 2093) +++ branches/grin-neu/thirdparty/cxml/test/domtest.lisp 2006-12-01 10:39:49 UTC (rev 2094) @@ -126,28 +126,32 @@ (map-child-elements 'list #'identity element)) (defun parse-java-literal (str) - (unless (stringp str) - (setf str (runes:rod-string str))) + (when (stringp str) + (setf str (runes:string-rod str))) (cond ((zerop (length str)) nil) - ((equal str "true") + ((runes:rod= str #"true") t) - ((equal str "false") + ((runes:rod= str #"false") nil) - ((digit-char-p (char str 0)) - (parse-integer str)) - ((char= (char str 0) #\") - (runes:rod - (with-output-to-string (out) - (with-input-from-string (in str) - (read-char in) - (for ((c = (read-char in)) - :until (char= c #\")) - (if (char= c #\\) - (ecase (read-char in) - ;; ... - (#\n (write-char #\newline out))) - (write-char c out))))))) + ((digit-char-p (runes:rune-char (elt str 0))) + (parse-integer (runes:rod-string str))) + ((runes:rune= (elt str 0) #.(runes:char-rune #\")) + (let ((v (make-array 1 :fill-pointer 0 :adjustable t))) + (for* ((i = 1 :then (1+ i)) + (c = (elt str i)) + :until (runes:rune= c #.(runes:char-rune #\"))) + (if (runes:rune= c #.(runes:char-rune #\\)) + (let ((frob + (progn + (incf i) + (elt str i)))) + (ecase frob + ;; ... + (#/n (vector-push-extend #/newline v (length v))) + ((#/\\ #/\") (vector-push-extend #/\\ v (length v))))) + (vector-push-extend c v (length v)))) + (make-array (length v) :element-type 'runes:rune :initial-contents v))) (t (%intern str)))) @@ -162,15 +166,17 @@ ;;;; dom1-interfaces.xml auslesen -(defvar *methods* '()) -(defvar *fields* '()) +(defparameter *methods* '()) +(defparameter *fields* '()) (declaim (special *directory*)) +(declaim (special *files-directory*)) -(defun read-members () - (let* ((pathname (merge-pathnames "patches/dom1-interfaces.xml" *directory*)) - (builder (dom:make-dom-builder)) - (library (dom:document-element (cxml:parse-file pathname builder))) +(defun read-members (&optional (directory *directory*)) + (let* ((pathname (merge-pathnames "build/dom2-interfaces.xml" directory)) + (builder (rune-dom:make-dom-builder)) + (library (dom:document-element + (cxml:parse-file pathname builder :recode nil))) (methods '()) (fields '())) (do-child-elements (interface library :name "interface") @@ -192,20 +198,21 @@ (defun translate-condition (element) (string-case (tag-name element) ("equals" (translate-equals element)) + ("notEquals" (translate-not-equals element)) ("contentType" (translate-content-type element)) - ("hasFeature" (translate-has-feature element)) ("implementationAttribute" (assert-have-implementation-attribute element)) ("isNull" (translate-is-null element)) ("not" (translate-is-null element)) ("notNull" (translate-not-null element)) ("or" (translate-or element)) ("same" (translate-same element)) + ("less" (translate-less element)) (t (error "unknown condition: ~A" element)))) (defun equalsp (a b test) - (when (typep a 'dom-impl::named-node-map) + (when (dom:named-node-map-p a) (setf a (dom:items a))) - (when (typep b 'dom-impl::named-node-map) + (when (dom:named-node-map-p b) (setf b (dom:items b))) (if (and (typep a 'sequence) (typep b 'sequence)) (null (set-exclusive-or (coerce a 'list) (coerce b 'list) :test test)) @@ -223,10 +230,17 @@ ,(parse-java-literal |expected|) ',(if (parse-java-literal |ignoreCase|) '%equal '%equal)))) +(defun translate-not-equals (element) + `(not ,(translate-equals element))) + (defun translate-same (element) (with-attributes (|actual| |expected|) element `(eql ,(%intern |actual|) ,(parse-java-literal |expected|)))) +(defun translate-less (element) + (with-attributes (|actual| |expected|) element + `(< ,(%intern |actual|) ,(parse-java-literal |expected|)))) + (defun translate-or (element) `(or ,@(map-child-elements 'list #'translate-condition element))) @@ -317,10 +331,12 @@ ("assertTrue" (translate-assert-true element)) ("assertFalse" (translate-assert-false element)) ("assertURIEquals" (translate-assert-uri-equals element)) + ("assign" (translate-assign element)) ("for-each" (translate-for-each element)) ("fail" (translate-fail element)) ("hasFeature" (translate-has-feature element)) ("if" (translate-if element)) + ("implementation" (translate-implementation element)) ("increment" (translate-unary-assignment '+ element)) ("decrement" (translate-unary-assignment '- element)) ("length" (translate-length element)) @@ -337,6 +353,10 @@ `(,fn ,(parse-java-literal |op1|) ,(parse-java-literal |op2|))))) +(defun translate-assign (element) + (with-attributes (|var| |value|) element + (maybe-setf (%intern |var|) (parse-java-literal |value|)))) + (defun translate-unary-assignment (fn element) (with-attributes (|var| |value|) element (maybe-setf (%intern |var|) @@ -347,6 +367,10 @@ (maybe-setf (%intern |var|) `(load-file ,|href| ,(parse-java-literal |willBeModified|))))) +(defun translate-implementation (elt) + (with-attributes (|var|) elt + (maybe-setf (%intern |var|) `'rune-dom:implementation))) + (defun translate-length (load) ;; XXX Soweit ich sehe unterscheiden die Tests nicht zwischen ;; der Laenge von DOMString und der length()-Methode der uebrigen @@ -379,11 +403,13 @@ (error "oops"))))) (defun translate-has-feature (element) - (with-attributes (|var| |feature| |version|) element - (maybe-setf (%intern |var|) - `(and (runes:rod-equal ,(parse-java-literal |feature|) #"XML") - (or (zerop (length ,(parse-java-literal |version|))) - (runes:rod-equal ,(parse-java-literal |version|) #"1.0")))))) + (with-attributes (|obj| |var| |feature| |version|) element + (if (nullify |obj|) + (translate-member element) + (maybe-setf (%intern |var|) + `(dom:has-feature 'rune-dom:implementation + ,(parse-java-literal |feature|) + ,(parse-java-literal |version|)))))) (defun translate-fail (element) (declare (ignore element)) @@ -433,7 +459,7 @@ (defun translate-assert-size (element) (with-attributes (|collection| |size|) element `(let ((collection ,(%intern |collection|))) - (when (typep collection 'dom-impl::named-node-map) + (when (dom:named-node-map-p collection) (setf collection (dom:items collection))) (assert (eql (length collection) ,(parse-java-literal |size|)))))) @@ -468,9 +494,9 @@ (return `(block assert-domexception (handler-bind - ((dom-impl::dom-exception + ((rune-dom::dom-exception (lambda (c) - (when (eq (dom-impl::dom-exception-key c) + (when (eq (rune-dom::dom-exception-key c) ,(intern (tag-name c) :keyword)) (return-from assert-domexception))))) ,@(translate-body c) @@ -481,7 +507,7 @@ ,@(map-child-elements 'list (lambda (exception) - `(when (eq (dom-impl::dom-exception-key c) + `(when (eq (rune-dom::dom-exception-key c) ,(intern (runes:rod-string (dom:get-attribute exception "code")) :keyword)) ,@(translate-body exception) @@ -491,7 +517,7 @@ (defun translate-try (element) `(block try (handler-bind - ((dom-impl::dom-exception + ((rune-dom::dom-exception ,(translate-catch (do-child-elements (c element :name "catch") (return c)) '(return-from try)))) @@ -531,7 +557,7 @@ (defun translate-for-each (element) (with-attributes (|collection| |member|) element `(let ((collection ,(%intern |collection|))) - (when (typep collection 'dom-impl::named-node-map) + (when (dom:named-node-map-p collection) (setf collection (dom:items collection))) (map nil (lambda (,(%intern |member|)) ,@(translate-body element)) collection)))) @@ -539,8 +565,15 @@ (defun assert-have-implementation-attribute (element) (let ((attribute (runes:rod-string (dom:get-attribute element "name")))) (string-case attribute + ;; fixme: expandEntityReferences sollten wir auch mal anschalten, wo + ;; wir uns schon die muehe machen... ("validating" (setf cxml::*validate* t)) + ("namespaceAware" + ;; ??? dom 2 ohne namespace-support gibt's doch gar nicht, + ;; ausser vielleicht in html-only implementationen, und dann sollen + ;; sie halt auf hasFeature "XML" testen. + ) (t (format t "~&implementationAttribute ~A not supported, skipping test~%" attribute) @@ -550,9 +583,10 @@ (unless *fields* (multiple-value-setq (*methods* *fields*) (read-members))) (catch 'give-up - (let* ((builder (dom:make-dom-builder)) + (let* ((builder (rune-dom:make-dom-builder)) (cxml::*validate* nil) ;dom1.dtd is buggy - (test (dom:document-element (cxml:parse-file pathname builder))) + (test (dom:document-element + (cxml:parse-file pathname builder :recode nil))) title (bindings '()) (code '())) @@ -569,6 +603,11 @@ (("byte" "short" "int" "long") 0) (t nil))) bindings) + (let ((value (dom:get-attribute e "value"))) + (when value + (push `(setf ,(%intern (dom:get-attribute e "name")) + ,(parse-java-literal value)) + code))) (do-child-elements (member e :name "member") e (push `(setf ,(%intern (dom:get-attribute e "name")) (append ,(%intern (dom:get-attribute e "name")) @@ -584,66 +623,104 @@ (t (push (translate-statement e) code)))) `(lambda () - (let (, at bindings) + (let ((*files-directory* ,*files-directory*) ;fuer copy&paste: + , at bindings) (declare (ignorable ,@(mapcar #'car bindings))) ,@(reverse code)))))) (defun load-file (name &optional will-be-modified-p) (declare (ignore will-be-modified-p)) (setf name (runes:rod-string name)) - (let* ((directory (merge-pathnames "tests/level1/core/files/" *directory*)) - (document - (cxml:parse-file - (make-pathname :name name :type "xml" :defaults directory) - (dom:make-dom-builder)))) - document)) + (cxml:parse-file + (make-pathname :name name :type "xml" :defaults *files-directory*) + (rune-dom:make-dom-builder) + :recode nil)) (defparameter *bad-tests* - '("hc_elementnormalize2.xml" "hc_nodereplacechildnewchildexists.xml")) + '("hc_elementnormalize2.xml" + "hc_nodereplacechildnewchildexists.xml" + "characterdatadeletedatanomodificationallowederr.xml")) +(defun dribble-tests (directory) + (let ((base (slot-value (asdf:find-system :cxml) 'asdf::relative-pathname))) + (with-open-file (*standard-output* + (merge-pathnames "DOMTEST" base) + :direction :output + :if-exists :supersede) + (run-all-tests directory)))) + (defun run-all-tests (*directory* &optional verbose) (let* ((cxml::*redefinition-warning* nil) - (test-directory (merge-pathnames "tests/level1/core/" *directory*)) - (all-tests (merge-pathnames "alltests.xml" test-directory)) - (builder (dom:make-dom-builder)) - (suite (dom:document-element (cxml:parse-file all-tests builder))) (n 0) (i 0) (ntried 0) (nfailed 0)) - (do-child-elements (member suite) - (unless - (member (runes:rod-string (dom:get-attribute member "href")) - *bad-tests* - :test 'equal) - (incf n))) - (do-child-elements (member suite) - (let ((href (runes:rod-string (dom:get-attribute member "href")))) - (unless (member href *bad-tests* :test 'equal) - (format t "~&~D/~D ~A~%" i n href) - (let ((lisp (slurp-test (merge-pathnames href test-directory)))) - (when verbose - (print lisp)) - (when lisp - (incf ntried) - (with-simple-restart (skip-test "Skip this test") - (handler-case - (let ((cxml::*validate* nil)) - (funcall (compile nil lisp))) - (serious-condition (c) - (incf nfailed) - (warn "test failed: ~A" c)))))) - (incf i)))) + (flet ((parse (test-directory) + (let* ((all-tests (merge-pathnames "alltests.xml" test-directory)) + (builder (rune-dom:make-dom-builder)) + (suite (dom:document-element + (cxml:parse-file all-tests builder :recode nil))) + (*files-directory* + (merge-pathnames "files/" test-directory))) + (do-child-elements (member suite) + (unless + (or (equal (dom:tag-name member) "metadata") + (member (runes:rod-string + (dom:get-attribute member "href")) + *bad-tests* + :test 'equal)) + (incf n))) + suite)) + (run (test-directory suite) + (print test-directory) + (let ((*files-directory* + (merge-pathnames "files/" test-directory))) + (do-child-elements (member suite) + (let ((href (runes:rod-string + (dom:get-attribute member "href")))) + (unless (or (runes:rod= (dom:tag-name member) #"metadata") + (member href *bad-tests* :test 'equal)) + (format t "~&~D/~D ~A~%" i n href) + (let ((lisp (slurp-test + (merge-pathnames href test-directory)))) + (when verbose + (print lisp)) + (when lisp + (incf ntried) + (with-simple-restart (skip-test "Skip this test") + (handler-case + (let ((cxml::*validate* nil)) + (funcall (compile nil lisp))) + (serious-condition (c) + (incf nfailed) + (format t "~&TEST FAILED: ~A~&" c)))))) + (incf i))))))) + (let* ((d1 (merge-pathnames "tests/level1/core/" *directory*)) + (d2 (merge-pathnames "tests/level2/core/" *directory*)) + (suite1 (parse d1)) + (suite2 (parse d2))) + (run d1 suite1) + (run d2 suite2))) (format t "~&~D/~D tests failed; ~D test~:P were skipped" nfailed ntried (- n ntried)))) -(defun run-test (*directory* href) - (let* ((test-directory (merge-pathnames "tests/level1/core/" *directory*)) - (lisp (slurp-test (merge-pathnames href test-directory))) +(defun run-test (*directory* level href) + (let* ((test-directory + (ecase level + (1 (merge-pathnames "tests/level1/core/" *directory*)) + (2 (merge-pathnames "tests/level2/core/" *directory*)))) + (*files-directory* (merge-pathnames "files/" test-directory)) + (lisp (slurp-test (merge-pathnames href test-directory))) (cxml::*validate* nil)) (print lisp) + (fresh-line) (when lisp (funcall (compile nil lisp))))) #+(or) -(run-all-tests "~/src/2001/DOM-Test-Suite/") +(domtest::run-all-tests "/home/david/2001/DOM-Test-Suite/") + +#+(or) +(domtest::run-test "/home/david/2001/DOM-Test-Suite/" + 1 + "attrcreatedocumentfragment.xml") Added: branches/grin-neu/thirdparty/cxml/test/utf8domtest.diff =================================================================== --- branches/grin-neu/thirdparty/cxml/test/utf8domtest.diff 2006-12-01 10:37:34 UTC (rev 2093) +++ branches/grin-neu/thirdparty/cxml/test/utf8domtest.diff 2006-12-01 10:39:49 UTC (rev 2094) @@ -0,0 +1,102 @@ +Index: test/domtest.lisp +=================================================================== +RCS file: /project/cxml/cvsroot/cxml/test/domtest.lisp,v +retrieving revision 1.13 +diff -u -r1.13 domtest.lisp +--- test/domtest.lisp 27 Dec 2005 00:21:37 -0000 1.13 ++++ test/domtest.lisp 27 Dec 2005 00:46:00 -0000 +@@ -137,21 +137,22 @@ + ((digit-char-p (runes:rune-char (elt str 0))) + (parse-integer (runes:rod-string str))) + ((runes:rune= (elt str 0) #.(runes:char-rune #\")) +- (let ((v (make-array 1 :fill-pointer 0 :adjustable t))) +- (for* ((i = 1 :then (1+ i)) +- (c = (elt str i)) +- :until (runes:rune= c #.(runes:char-rune #\"))) +- (if (runes:rune= c #.(runes:char-rune #\\)) +- (let ((frob +- (progn +- (incf i) +- (elt str i)))) +- (ecase frob +- ;; ... +- (#/n (vector-push-extend #/newline v (length v))) +- ((#/\\ #/\") (vector-push-extend #/\\ v (length v))))) +- (vector-push-extend c v (length v)))) +- (coerce v 'runes::simple-rod))) ++ (utf8-dom::%rod ++ (let ((v (make-array 1 :fill-pointer 0 :adjustable t))) ++ (for* ((i = 1 :then (1+ i)) ++ (c = (elt str i)) ++ :until (runes:rune= c #.(runes:char-rune #\"))) ++ (if (runes:rune= c #.(runes:char-rune #\\)) ++ (let ((frob ++ (progn ++ (incf i) ++ (elt str i)))) ++ (ecase frob ++ ;; ... ++ (#/n (vector-push-extend #/newline v (length v))) ++ ((#/\\ #/\") (vector-push-extend #/\\ v (length v))))) ++ (vector-push-extend c v (length v)))) ++ (coerce v 'runes::simple-rod)))) + (t + (%intern str)))) + +@@ -368,7 +369,7 @@ + + (defun translate-implementation (elt) + (with-attributes (|var|) elt +- (maybe-setf (%intern |var|) `'rune-dom:implementation))) ++ (maybe-setf (%intern |var|) `'utf8-dom:implementation))) + + (defun translate-length (load) + ;; XXX Soweit ich sehe unterscheiden die Tests nicht zwischen +@@ -406,7 +407,7 @@ + (if (nullify |obj|) + (translate-member element) + (maybe-setf (%intern |var|) +- `(dom:has-feature 'rune-dom:implementation ++ `(dom:has-feature 'utf8-dom:implementation + ,(parse-java-literal |feature|) + ,(parse-java-literal |version|)))))) + +@@ -493,9 +494,9 @@ + (return + `(block assert-domexception + (handler-bind +- ((rune-dom::dom-exception ++ ((utf8-dom::dom-exception + (lambda (c) +- (when (eq (rune-dom::dom-exception-key c) ++ (when (eq (utf8-dom::dom-exception-key c) + ,(intern (tag-name c) :keyword)) + (return-from assert-domexception))))) + ,@(translate-body c) +@@ -506,7 +507,7 @@ + ,@(map-child-elements + 'list + (lambda (exception) +- `(when (eq (rune-dom::dom-exception-key c) ++ `(when (eq (utf8-dom::dom-exception-key c) + ,(intern (runes:rod-string (dom:get-attribute exception "code")) + :keyword)) + ,@(translate-body exception) +@@ -516,7 +517,7 @@ + (defun translate-try (element) + `(block try + (handler-bind +- ((rune-dom::dom-exception ++ ((utf8-dom::dom-exception + ,(translate-catch + (do-child-elements (c element :name "catch") (return c)) + '(return-from try)))) +@@ -631,7 +632,7 @@ + (setf name (runes:rod-string name)) + (cxml:parse-file + (make-pathname :name name :type "xml" :defaults *files-directory*) +- (rune-dom:make-dom-builder))) ++ (cxml:make-recoder (utf8-dom:make-dom-builder) 'cxml:rod-to-utf8-string))) + + (defparameter *bad-tests* + '("hc_elementnormalize2.xml" Modified: branches/grin-neu/thirdparty/cxml/test/xmlconf.lisp =================================================================== --- branches/grin-neu/thirdparty/cxml/test/xmlconf.lisp 2006-12-01 10:37:34 UTC (rev 2093) +++ branches/grin-neu/thirdparty/cxml/test/xmlconf.lisp 2006-12-01 10:39:49 UTC (rev 2094) @@ -18,7 +18,8 @@ ((not (and (let ((version (get-attribute test "RECOMMENDATION"))) (cond ((or (equal version "") ;XXX - (equal version "XML1.0")) + (equal version "XML1.0") + (equal version "NS1.0")) (cond ((equal (get-attribute test "NAMESPACE") "no") (format t "~A: test applies to parsers without namespace support, skipping~%" @@ -36,6 +37,7 @@ nil) ((equal (get-attribute test "TYPE") "valid") :valid) ((equal (get-attribute test "TYPE") "invalid") :invalid) + ((equal (get-attribute test "TYPE") "not-wf") :not-wf) (t nil))) (defun test-pathnames (directory test) @@ -52,9 +54,10 @@ (merge-pathnames output sub-directory))))) (defun serialize-document (document) - (map 'vector #'char-code - (with-output-to-string (s) - (cxml:unparse-document document s :canonical 2)))) + (dom:map-document (cxml:make-octet-vector-sink :canonical 2) + document + :include-doctype :canonical-notations + :include-default-values t)) (defun file-contents (pathname) (with-open-file (s pathname :element-type '(unsigned-byte 8)) @@ -63,10 +66,19 @@ (read-sequence result s ) result))) +(defun dribble-tests (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)))) + (defun run-all-tests (directory) (let* ((pathname (merge-pathnames "xmlconf.xml" directory)) - (builder (dom:make-dom-builder)) - (xmlconf (cxml:parse-file pathname builder)) + (builder (rune-dom:make-dom-builder)) + (xmlconf (cxml:parse-file pathname builder :recode nil)) (ntried 0) (nfailed 0) (nskipped 0) @@ -75,14 +87,21 @@ (puri:*strict-parse* nil)) (dom:do-node-list (test (dom:get-elements-by-tag-name xmlconf "TEST")) (let ((description - (rod-string (dom:data (dom:item (dom:child-nodes test) 0)))) + (apply #'concatenate + 'string + (map 'list + (lambda (child) + (if (dom:text-node-p child) + (rod-string (dom:data child)) + "")) + (dom:child-nodes test)))) (class (test-class test))) (cond (class (incf ntried) (multiple-value-bind (pathname output) (test-pathnames directory test) - (princ pathname) + (princ (enough-namestring pathname directory)) (unless (probe-file pathname) (error "file not found: ~A" pathname)) (with-simple-restart (skip-test "Skip this test") @@ -95,7 +114,7 @@ nfailed ntried nskipped))) (defmethod run-test :around (class pathname output description &rest args) - class pathname output args + (declare (ignore class pathname output args)) (handler-case (call-next-method) (serious-condition (c) @@ -106,7 +125,8 @@ (declare (ignore description)) (let ((document (apply #'cxml:parse-file pathname - (dom:make-dom-builder) + (rune-dom:make-dom-builder) + :recode nil args))) (cond ((null output) @@ -143,17 +163,47 @@ (handler-case (progn (format t " [validating:]") - (cxml:parse-file pathname (dom:make-dom-builder) :validate t) + (cxml:parse-file pathname + (rune-dom:make-dom-builder) + :recode nil + :validate t) (error "validity error not detected") nil) (cxml:validity-error () (format t " invalid") t)))) -#+(or) -(xmlconf::run-all-tests "/mnt/debian/space/xmlconf/") +(defmethod run-test + ((class (eql :not-wf)) pathname output description &rest args) + (assert (null args)) + (handler-case + (progn + (format t " [not validating:]") + (cxml:parse-file pathname + (rune-dom:make-dom-builder) + :recode nil + :validate nil) + (error "well-formedness violation not detected") + nil) + (cxml:well-formedness-violation () + (format t " not-wf") + t)) + (handler-case + (progn + (format t " [validating:]") + (cxml:parse-file pathname + (rune-dom:make-dom-builder) + :recode nil + :validate t) + (error "well-formedness violation not detected") + nil) + (cxml:well-formedness-violation () + (format t " not-wf") + t) + (cxml:validity-error () + ;; das erlauben wir mal auch, denn valide => wf + (format t " invalid") + t))) #+(or) -(progn - (#+allegro mp:with-timeout #+allegro (60) #-allegro progn - )) +(xmlconf::run-all-tests "/home/david/2001/XML-Test-Suite/xmlconf/") Modified: branches/grin-neu/thirdparty/cxml/xml/catalog.lisp =================================================================== --- branches/grin-neu/thirdparty/cxml/xml/catalog.lisp 2006-12-01 10:37:34 UTC (rev 2093) +++ branches/grin-neu/thirdparty/cxml/xml/catalog.lisp 2006-12-01 10:39:49 UTC (rev 2094) @@ -1,6 +1,6 @@ ;;;; catalogs.lisp -- XML Catalogs -*- Mode: Lisp; readtable: runes -*- ;;;; -;;;; This file is part of the CXML parser, released under (L)LGPL. +;;;; This file is part of the CXML parser, released under Lisp-LGPL. ;;;; See file COPYING for details. ;;;; ;;;; Developed 2004 for headcraft - http://headcraft.de/ @@ -222,8 +222,8 @@ (defun parse-catalog-file (uri) (handler-case (parse-catalog-file/strict uri) - (file-error () nil) - (parser-error () nil))) + ((or file-error xml-parse-error) (c) + (warn "ignoring catalog error: ~A" c)))) (defparameter *catalog-dtd* (let* ((cxml @@ -248,9 +248,8 @@ :element-type '(unsigned-byte 8) :direction :input)) (parse-stream s - (make-recoder (make-instance 'catalog-parser :uri uri) - #'rod-to-utf8-string) - :validate t + (make-instance 'catalog-parser :uri uri) + :validate nil :dtd (make-extid nil dtd-sysid) :root #"catalog" :entity-resolver #'entity-resolver))))) @@ -284,7 +283,11 @@ (setf lname (or lname qname)) ;; we can dispatch on lnames only because we validate against the DTD, ;; which disallows other namespaces. - (push (string-or (get-attribute/lname "prefer" attrs) (prefer handler)) + (push (let ((new (get-attribute/lname "prefer" attrs))) + (cond + ((equal new "public") :public) + ((equal new "system") :system) + ((null new) (prefer handler)))) (prefer-stack handler)) (push (string-or (get-attribute/lname "base" attrs) (base handler)) (base-stack handler)) Modified: branches/grin-neu/thirdparty/cxml/xml/package.lisp =================================================================== --- branches/grin-neu/thirdparty/cxml/xml/package.lisp 2006-12-01 10:37:34 UTC (rev 2093) +++ branches/grin-neu/thirdparty/cxml/xml/package.lisp 2006-12-01 10:39:49 UTC (rev 2094) @@ -1,20 +1,12 @@ ;;;; package.lisp -- Paketdefinition ;;;; -;;;; This file is part of the CXML parser, released under (L)LGPL. +;;;; This file is part of the CXML parser, released under Lisp-LGPL. ;;;; See file COPYING for details. (in-package :cl-user) (defpackage :cxml - (:use :cl :runes :encoding) - (:import-from #+sbcl :sb-gray - #+allegro :excl - #+cmu :ext - #+clisp :gray - #-(or sbcl allegro cmu clisp) ... - #:fundamental-binary-input-stream - #-clisp #:stream-read-sequence - stream-read-byte) + (:use :cl :runes :runes-encoding :trivial-gray-streams) (:export ;; xstreams #:make-xstream @@ -42,25 +34,36 @@ #:parse-file #:parse-stream - ;; XXX encoding is mis-handled by parse-string, don't export it - ;; #:parse-string + #:parse-rod #:parse-octets + #:parse-empty-document - #:make-character-stream-sink #:make-octet-vector-sink #:make-octet-stream-sink - #:unparse-document - #:unparse-document-to-octets + #:make-rod-sink + #| + #+rune-is-character #:make-string-sink + #+rune-is-character #:make-character-stream-sink + #-rune-is-character #:make-string-sink/utf8 + #-rune-is-character #:make-character-stream-sink/utf8 + |# + + #:make-string-sink + #:make-character-stream-sink + #:with-xml-output #:with-element #:attribute #:cdata #:text + #:xml-parse-error + #:well-formedness-violation + #:validity-error + #:parse-dtd-file #:parse-dtd-stream - #:validity-error #:make-validator #:*cache-all-dtds* @@ -77,4 +80,10 @@ #:resolve-uri #:resolve-extid - #:make-recoder)) + #:make-recoder + #:sax-proxy + #:proxy-chained-handler + #:make-namespace-normalizer + #:make-whitespace-normalizer + #:rod-to-utf8-string + #:utf8-string-to-rod)) Modified: branches/grin-neu/thirdparty/cxml/xml/recoder.lisp =================================================================== --- branches/grin-neu/thirdparty/cxml/xml/recoder.lisp 2006-12-01 10:37:34 UTC (rev 2093) +++ branches/grin-neu/thirdparty/cxml/xml/recoder.lisp 2006-12-01 10:39:49 UTC (rev 2094) @@ -1,6 +1,6 @@ ;;;; recoder.lisp -- SAX handler for string conversion ;;;; -;;;; This file is part of the CXML parser, released under (L)LGPL. +;;;; This file is part of the CXML parser, released under Lisp-LGPL. ;;;; See file COPYING for details. ;;;; ;;;; Developed 2004 for headcraft - http://headcraft.de/ @@ -12,7 +12,7 @@ ((recoder :initarg :recoder :accessor recoder) (chained-handler :initarg :chained-handler :accessor chained-handler))) -(defun make-recoder (chained-handler &optional (recoder-fn #'rod-string)) +(defun make-recoder (chained-handler recoder-fn) (make-instance 'recoder :recoder recoder-fn :chained-handler chained-handler)) @@ -74,6 +74,9 @@ (%string public-id) (%string system-id)) + (defwrapper sax:start-internal-subset ()) + (defwrapper sax:end-internal-subset ()) + (defwrapper sax:end-dtd ()) (defwrapper sax:unparsed-entity-declaration @@ -115,4 +118,8 @@ (defwrapper sax:entity-resolver (resolver) - resolver)) + resolver) + + (defwrapper sax::dtd + (dtd) + dtd)) Modified: branches/grin-neu/thirdparty/cxml/xml/sax-handler.lisp =================================================================== --- branches/grin-neu/thirdparty/cxml/xml/sax-handler.lisp 2006-12-01 10:37:34 UTC (rev 2093) +++ branches/grin-neu/thirdparty/cxml/xml/sax-handler.lisp 2006-12-01 10:39:49 UTC (rev 2094) @@ -6,8 +6,8 @@ ;;; Author: David Lichteblau (DTD-related changes) ;;; License: BSD ;;; --------------------------------------------------------------------------- -;;; copyright 2003 by Henrik Motakef -;;; copyright 2004 knowledgeTools Int. GmbH +;;; (c) copyright 2003 by Henrik Motakef +;;; (c) copyright 2004 knowledgeTools Int. GmbH ;;; Redistribution and use in source and binary forms, with or without ;;; modification, are permitted provided that the following conditions are @@ -53,6 +53,8 @@ #:*use-xmlns-namespace* #:make-attribute + #:find-attribute + #:find-attribute-ns #:attribute-namespace-uri #:attribute-local-name #:attribute-qname @@ -72,6 +74,8 @@ #:end-cdata #:start-dtd #:end-dtd + #:start-internal-subset + #:end-internal-subset #:unparsed-entity-declaration #:external-entity-declaration #:internal-entity-declaration @@ -92,7 +96,7 @@ related options.") ;; The http://xml.org/sax/features/namespace-prefixes property. -(defvar *include-xmlns-attributes* nil +(defvar *include-xmlns-attributes* t "If non-nil, namespace declarations are reported as normal attributes. @@ -102,7 +106,7 @@ See also `*use-xmlns-namespace*', and `start-element' for a detailed description of the consequences of setting this variable.") -(defvar *use-xmlns-namespace* nil +(defvar *use-xmlns-namespace* t "If this variable is nil (the default), attributes with a name like 'xmlns:x' are not considered to be in a namespace, following the 'Namespaces in XML' specification. @@ -135,6 +139,23 @@ value specified-p) +(defun %rod= (x y) + ;; allow rods *and* strings *and* null + (cond + ((zerop (length x)) (zerop (length y))) + ((zerop (length y)) nil) + ((stringp x) (string= x y)) + (t (runes:rod= x y)))) + +(defun find-attribute (qname attrs) + (find qname attrs :key #'attribute-qname :test #'%rod=)) + +(defun find-attribute-ns (uri lname attrs) + (find-if (lambda (attr) + (and (%rod= uri (sax:attribute-namespace-uri attr)) + (%rod= lname (sax:attribute-local-name attr)))) + attrs)) + (defgeneric start-document (handler) (:documentation "Called at the beginning of the parsing process, before any element, processing instruction or comment is reported. @@ -160,7 +181,7 @@ local-name properties, the same rules as for the element name apply. Additionally, namespace-declaring attributes (those whose name is \"xmlns\" or starts with \"xmlns:\") are only included if -*namespace-prefixes* is non-nil.") +*include-xmlns-attributes* is non-nil.") (:method ((handler t) namespace-uri local-name qname attributes) (declare (ignore namespace-uri local-name qname attributes)) nil)) @@ -254,6 +275,16 @@ (:documentation "Called at the end of parsing a DTD.") (:method ((handler t)) nil)) +(defgeneric start-internal-subset (handler) + (:documentation "Reports that an internal subset is present. Called before +any definition from the internal subset is reported.") + (:method ((handler t)) nil)) + +(defgeneric end-internal-subset (handler) + (:documentation "Called after processing of the internal subset has +finished, if present.") + (:method ((handler t)) nil)) + (defgeneric unparsed-entity-declaration (handler name public-id system-id notation-name) (:documentation @@ -313,7 +344,11 @@ (:documentation "Called between sax:end-dtd and sax:end-document to register an entity resolver, a function of two arguments: An entity name and SAX handler. - When called, the resolver function will parse the named entities data.") + When called, the resolver function will parse the named entity's data.") (:method ((handler t) resolver) (declare (ignore resolver)) nil)) + +;; internal for now +(defgeneric dtd (handler dtd) + (:method ((handler t) dtd) (declare (ignore dtd)) nil)) Added: branches/grin-neu/thirdparty/cxml/xml/sax-proxy.lisp =================================================================== --- branches/grin-neu/thirdparty/cxml/xml/sax-proxy.lisp 2006-12-01 10:37:34 UTC (rev 2093) +++ branches/grin-neu/thirdparty/cxml/xml/sax-proxy.lisp 2006-12-01 10:39:49 UTC (rev 2094) @@ -0,0 +1,41 @@ +;;;; sax-proxy.lisp +;;;; +;;;; This file is part of the CXML parser, released under Lisp-LGPL. +;;;; See file COPYING for details. +;;;; +;;;; Copyright (c) 2004 David Lichteblau +;;;; Author: David Lichteblau + +(in-package :cxml) + +(defclass sax-proxy () + ((chained-handler :initform nil + :initarg :chained-handler + :accessor proxy-chained-handler))) + +(macrolet ((define-proxy-method (name (&rest args)) + `(defmethod ,name ((handler sax-proxy) , at args) + (,name (proxy-chained-handler handler) , at args)))) + (define-proxy-method sax:start-document ()) + (define-proxy-method sax:start-element (uri lname qname attributes)) + (define-proxy-method sax:start-prefix-mapping (prefix uri)) + (define-proxy-method sax:characters (data)) + (define-proxy-method sax:processing-instruction (target data)) + (define-proxy-method sax:end-prefix-mapping (prefix)) + (define-proxy-method sax:end-element (namespace-uri local-name qname)) + (define-proxy-method sax:end-document ()) + (define-proxy-method sax:comment (data)) + (define-proxy-method sax:start-cdata ()) + (define-proxy-method sax:end-cdata ()) + (define-proxy-method sax:start-dtd (name public-id system-id)) + (define-proxy-method sax:end-dtd ()) + (define-proxy-method sax:start-internal-subset ()) + (define-proxy-method sax:end-internal-subset ()) + (define-proxy-method sax:unparsed-entity-declaration (name pub sys not)) + (define-proxy-method sax:external-entity-declaration (kind name pub sys)) + (define-proxy-method sax:internal-entity-declaration (kind name value)) + (define-proxy-method sax:notation-declaration (name public-id system-id)) + (define-proxy-method sax:element-declaration (name model)) + (define-proxy-method sax:attribute-declaration (elt attr type default)) + (define-proxy-method sax:entity-resolver (resolver)) + (define-proxy-method sax::dtd (dtd))) Modified: branches/grin-neu/thirdparty/cxml/xml/sax-tests/tests.lisp =================================================================== --- branches/grin-neu/thirdparty/cxml/xml/sax-tests/tests.lisp 2006-12-01 10:37:34 UTC (rev 2093) +++ branches/grin-neu/thirdparty/cxml/xml/sax-tests/tests.lisp 2006-12-01 10:39:49 UTC (rev 2094) @@ -1,7 +1,7 @@ (in-package :sax-tests) (defun first-start-element-event (string) - (let ((events (xml::parse-string string (make-instance 'event-collecting-handler)))) + (let ((events (cxml:parse-rod string (make-instance 'event-collecting-handler)))) (find :start-element events :key #'car))) @@ -17,7 +17,7 @@ (deftest attribute-uniqueness-1 (handler-case - (xml::parse-string "") + (cxml:parse-rod "") (error () t) (:no-error (&rest junk) (declare (ignore junk)) @@ -26,7 +26,7 @@ (deftest attribute-uniqueness-2 (handler-case - (xml::parse-string "") + (cxml:parse-rod "") (error () nil) (:no-error (&rest junk) (declare (ignore junk)) @@ -36,7 +36,7 @@ (deftest attribute-uniqueness-3 (let ((sax:*namespace-processing* nil)) (handler-case - (xml::parse-string "") + (cxml:parse-rod "") (error () nil) (:no-error (&rest junk) (declare (ignore junk)) @@ -46,7 +46,7 @@ ;;; Namespace undeclaring (deftest undeclare-default-namespace-1 - (let* ((evts (xml::parse-string "" + (let* ((evts (cxml:parse-rod "" (make-instance 'event-collecting-handler))) (start-elt-events (remove :start-element evts :test (complement #'eql) :key #'car)) (evt1 (first start-elt-events)) @@ -59,7 +59,7 @@ (deftest undeclare-other-namespace (handler-case - (xml::parse-string "") + (cxml:parse-rod "") (error () t) (:no-error (&rest junk) (declare (ignore junk)) @@ -71,7 +71,7 @@ (deftest pi-names-are-ncnames-when-namespace-processing-1 (handler-case - (xml::parse-string "") + (cxml:parse-rod "") (error () t) (:no-error (&rest junk) (declare (ignore junk)) @@ -81,7 +81,7 @@ (deftest pi-names-are-ncnames-when-namespace-processing-2 (let ((sax:*namespace-processing* nil)) (handler-case - (xml::parse-string "") + (cxml:parse-rod "") (error () nil) (:no-error (&rest junk) (declare (ignore junk)) @@ -90,7 +90,7 @@ (deftest entity-names-are-ncnames-when-namespace-processing-1 (handler-case - (xml::parse-string " ]>&y:z;") + (cxml:parse-rod " ]>&y:z;") (error () t) (:no-error (&rest junk) (declare (ignore junk)) @@ -99,7 +99,7 @@ (deftest entity-names-are-ncnames-when-namespace-processing-2 (handler-case - (xml::parse-string " ]>") + (cxml:parse-rod " ]>") (error () t) (:no-error (&rest junk) (declare (ignore junk)) @@ -109,7 +109,7 @@ (deftest entity-names-are-ncnames-when-namespace-processing-3 (let ((sax:*namespace-processing* nil)) (handler-case - (xml::parse-string " ]>&y:z;") + (cxml:parse-rod " ]>&y:z;") (error () nil) (:no-error (&rest junk) (declare (ignore junk)) @@ -119,7 +119,7 @@ (deftest entity-names-are-ncnames-when-namespace-processing-4 (let ((sax:*namespace-processing* nil)) (handler-case - (xml::parse-string " ]>") + (cxml:parse-rod " ]>") (error () nil) (:no-error (&rest junk) (declare (ignore junk)) @@ -259,7 +259,7 @@ (deftest redefine-xml-namespace-1 (handler-case - (xml::parse-string "") + (cxml:parse-rod "") (error () nil) (:no-error (&rest junk) (declare (ignore junk)) @@ -268,7 +268,7 @@ (deftest redefine-xml-namespace-2 (handler-case - (xml::parse-string "") + (cxml:parse-rod "") (error () t) (:no-error (&rest junk) (declare (ignore junk)) @@ -277,7 +277,7 @@ (deftest redefine-xml-namespace-3 (handler-case - (xml::parse-string "") + (cxml:parse-rod "") (error () t) (:no-error (&rest junk) (declare (ignore junk)) @@ -286,7 +286,7 @@ (deftest redefine-xml-namespace-4 (handler-case - (xml::parse-string "") + (cxml:parse-rod "") (error () t) (:no-error (&rest junk) (declare (ignore junk)) @@ -295,7 +295,7 @@ (deftest redefine-xmlns-namespace-1 (handler-case - (xml::parse-string "") + (cxml:parse-rod "") (error () t) (:no-error (&rest junk) (declare (ignore junk)) @@ -304,7 +304,7 @@ (deftest redefine-xmlns-namespace-2 (handler-case - (xml::parse-string "") + (cxml:parse-rod "") (error () t) (:no-error (&rest junk) (declare (ignore junk)) @@ -313,7 +313,7 @@ (deftest redefine-xmlns-namespace-3 (handler-case - (xml::parse-string "") + (cxml:parse-rod "") (error () t) (:no-error (&rest junk) (declare (ignore junk)) @@ -322,11 +322,9 @@ (deftest redefine-xmlns-namespace-4 (handler-case - (xml::parse-string "") + (cxml:parse-rod "") (error () t) (:no-error (&rest junk) (declare (ignore junk)) nil)) t) - - Added: branches/grin-neu/thirdparty/cxml/xml/space-normalizer.lisp =================================================================== --- branches/grin-neu/thirdparty/cxml/xml/space-normalizer.lisp 2006-12-01 10:37:34 UTC (rev 2093) +++ branches/grin-neu/thirdparty/cxml/xml/space-normalizer.lisp 2006-12-01 10:39:49 UTC (rev 2094) @@ -0,0 +1,62 @@ +;;;; space-normalizer.lisp -- whitespace removal +;;;; +;;;; This file is part of the CXML parser, released under Lisp-LGPL. +;;;; See file COPYING for details. +;;;; +;;;; Copyright (c) 2005 David Lichteblau + +(in-package :cxml) + +(defclass whitespace-normalizer (sax-proxy) + ((attributes :initform '(t) :accessor xml-space-attributes) + (models :initform nil :accessor xml-space-models) + (dtd :initarg :dtd :accessor xml-space-dtd))) + +(defun make-whitespace-normalizer (chained-handler &optional dtd) + (make-instance 'whitespace-normalizer + :dtd dtd + :chained-handler chained-handler)) + +(defmethod sax::dtd ((handler whitespace-normalizer) dtd) + (unless (xml-space-dtd handler) + (setf (xml-space-dtd handler) dtd))) + +(defmethod sax:start-element + ((handler whitespace-normalizer) uri lname qname attrs) + (declare (ignore uri lname)) + (let ((dtd (xml-space-dtd handler))) + (when dtd + (let ((xml-space + (sax:find-attribute (if (stringp qname) "xml:space" #"xml:space") + attrs))) + (push (if xml-space + (rod= (rod (sax:attribute-value xml-space)) #"default") + (car (xml-space-attributes handler))) + (xml-space-attributes handler))) + (let* ((e (cxml::find-element (rod qname) dtd)) + (cspec (when e (cxml::elmdef-content e)))) + (push (and (consp cspec) + (not (and (eq (car cspec) '*) + (let ((subspec (second cspec))) + (and (eq (car subspec) 'or) + (eq (cadr subspec) :PCDATA)))))) + (xml-space-models handler))))) + (call-next-method)) + +(defmethod sax:characters ((handler whitespace-normalizer) data) + (cond + ((and (xml-space-dtd handler) + (car (xml-space-attributes handler)) + (car (xml-space-models handler))) + (unless (every #'white-space-rune-p (rod data)) + (warn "non-whitespace character data in element content") + (call-next-method))) + (t + (call-next-method)))) + +(defmethod sax:end-element ((handler whitespace-normalizer) uri lname qname) + (declare (ignore uri lname qname)) + (when (xml-space-dtd handler) + (pop (xml-space-attributes handler)) + (pop (xml-space-models handler))) + (call-next-method)) Modified: branches/grin-neu/thirdparty/cxml/xml/unparse.lisp =================================================================== --- branches/grin-neu/thirdparty/cxml/xml/unparse.lisp 2006-12-01 10:37:34 UTC (rev 2093) +++ branches/grin-neu/thirdparty/cxml/xml/unparse.lisp 2006-12-01 10:39:49 UTC (rev 2094) @@ -5,11 +5,11 @@ ;;; Created: 1999-09-09 ;;; Author: Gilbert Baumann ;;; Author: David Lichteblau -;;; License: LGPL (See file COPYING for details). +;;; License: Lisp-LGPL (See file COPYING for details). ;;; --------------------------------------------------------------------------- -;;; copyright 1999 by Gilbert Baumann -;;; copyright 2004 by knowledgeTools Int. GmbH -;;; copyright 2004 by David Lichteblau (for headcraft.de) +;;; (c) copyright 1999 by Gilbert Baumann +;;; (c) copyright 2004 by knowledgeTools Int. GmbH +;;; (c) copyright 2004 by David Lichteblau (for headcraft.de) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public @@ -67,12 +67,11 @@ ;; -- James Clark (jjc at jclark.com) -;;;; SINK: a rune output "stream" +;;;; SINK: an xml output sink (defclass sink () - ((high-surrogate :initform nil) - (column :initform 0 :accessor column) - (width :initform nil :initarg :width :accessor width) + ((ystream :initarg :ystream :accessor sink-ystream) + (width :initform 79 :initarg :width :accessor width) (canonical :initform t :initarg :canonical :accessor canonical) (indentation :initform nil :initarg :indentation :accessor indentation) (current-indentation :initform 0 :accessor current-indentation) @@ -90,77 +89,49 @@ (when (and (canonical instance) (indentation instance)) (error "Cannot indent XML in canonical mode"))) -;; WRITE-OCTET als generisch zu machen ist vielleicht nicht die schnellste -;; Loesung, aber die einfachste. -(defgeneric write-octet (octet sink)) - (defun make-buffer (&key (element-type '(unsigned-byte 8))) (make-array 1 :element-type element-type :adjustable t :fill-pointer 0)) -(defmethod write-octet :after (octet sink) - (with-slots (column) sink - (setf column (if (eql octet 10) 0 (1+ column))))) +;; total haesslich, aber die ystreams will ich im moment eigentlich nicht +;; dokumentieren +(macrolet ((define-maker (make-sink make-ystream &rest args) + `(defun ,make-sink (, at args &rest initargs) + (apply #'make-instance + 'sink + :ystream (,make-ystream , at args) + initargs)))) + (define-maker make-octet-vector-sink make-octet-vector-ystream) + (define-maker make-octet-stream-sink make-octet-stream-ystream stream) + (define-maker make-rod-sink make-rod-ystream) + #+rune-is-character + (define-maker make-character-stream-sink make-character-stream-ystream stream) -;; vector (octet) sinks + #-rune-is-character + (define-maker make-string-sink make-string-ystream/utf8) -(defclass vector-sink (sink) - ((target-vector :initform (make-buffer)))) + #-rune-is-character + (define-maker make-character-stream-sink + make-character-stream-ystream/utf8 + stream)) -(defun make-octet-vector-sink (&rest initargs) - (apply #'make-instance 'vector-sink initargs)) +#+rune-is-character +(defun make-string-sink (&rest args) (apply #'make-rod-sink args)) -(defmethod write-octet (octet (sink vector-sink)) - (let ((target-vector (slot-value sink 'target-vector))) - (vector-push-extend octet target-vector (length target-vector)))) -(defmethod sax:end-document ((sink vector-sink)) - (slot-value sink 'target-vector)) +(defmethod sax:end-document ((sink sink)) + (close-ystream (sink-ystream sink))) -;; character stream sinks - -(defclass character-stream-sink (sink) - ((target-stream :initarg :target-stream))) - -(defun make-character-stream-sink (character-stream &rest initargs) - (apply #'make-instance 'character-stream-sink - :target-stream character-stream - initargs)) - -(defmethod write-octet (octet (sink character-stream-sink)) - (write-char (code-char octet) (slot-value sink 'target-stream))) - -(defmethod sax:end-document ((sink character-stream-sink)) - (slot-value sink 'target-stream)) - - -;; octet stream sinks - -(defclass octet-stream-sink (sink) - ((target-stream :initarg :target-stream))) - -(defun make-octet-stream-sink (octet-stream &rest initargs) - (apply #'make-instance 'octet-stream-sink - :target-stream octet-stream - initargs)) - -(defmethod write-octet (octet (sink octet-stream-sink)) - (write-byte octet (slot-value sink 'target-stream))) - -(defmethod sax:end-document ((sink octet-stream-sink)) - (slot-value sink 'target-stream)) - - ;;;; doctype and notations (defmethod sax:start-document ((sink sink)) (unless (canonical sink) - (write-rod #"" sink) - (write-rune #/U+000A sink))) + (%write-rod #"" sink) + (%write-rune #/U+000A sink))) (defmethod sax:start-dtd ((sink sink) name public-id system-id) (setf (name-for-dtd sink) name) @@ -170,58 +141,201 @@ (defun ensure-doctype (sink &optional public-id system-id) (unless (have-doctype sink) (setf (have-doctype sink) t) - (write-rod #"= (canonical sink) 2)) - (let ((prev (previous-notation sink))) - (cond - (prev - (unless (rod< prev name) - (error "misordered notations; cannot unparse canonically"))) - (t - (ensure-doctype sink) - (write-rod #" [" sink) - (write-rune #/U+000A sink))) - (setf (previous-notation sink) name)) - (write-rod #"= (canonical sink) 2)) + prev + (not (rod< prev name))) + (error "misordered notations; cannot unparse canonically")) + (setf (previous-notation sink) name)) + (%write-rod #" sink) + (%write-rune #/U+000A sink)) + +(defmethod sax:unparsed-entity-declaration + ((sink sink) name public-id system-id notation-name) + (unless (and (canonical sink) (< (canonical sink) 3)) + (%write-rod #" sink) - (write-rune #/U+000A sink))) + (%write-rod #" PUBLIC '" sink) + (%write-rod public-id sink) + (%write-rod #"' '" sink) + (%write-rod system-id sink) + (%write-rune #/' sink))) + (%write-rod #" NDATA " sink) + (%write-rod notation-name sink) + (%write-rune #/> sink) + (%write-rune #/U+000A sink))) +(defmethod sax:external-entity-declaration + ((sink sink) kind name public-id system-id) + (when (canonical sink) + (error "cannot serialize parsed entities in canonical mode")) + (%write-rod #" sink) + (%write-rune #/U+000A sink)) + +(defmethod sax:internal-entity-declaration ((sink sink) kind name value) + (when (canonical sink) + (error "cannot serialize parsed entities in canonical mode")) + (%write-rod #" sink) + (%write-rune #/U+000A sink)) + +(defmethod sax:element-declaration ((sink sink) name model) + (when (canonical sink) + (error "cannot serialize element type declarations in canonical mode")) + (%write-rod #" sink) + (%write-rune #/U+000A sink)) + +(defmethod sax:attribute-declaration ((sink sink) ename aname type default) + (when (canonical sink) + (error "cannot serialize attribute type declarations in canonical mode")) + (%write-rod #" sink) + (%write-rune #/U+000A sink)) + (defmethod sax:end-dtd ((sink sink)) (when (have-doctype sink) - (when (previous-notation sink) - (write-rod #"]" sink)) - (write-rod #">" sink) - (write-rune #/U+000A sink))) + (%write-rod #">" sink) + (%write-rune #/U+000A sink))) ;;;; elements @@ -232,15 +346,15 @@ (have-gt nil)) (defun sink-fresh-line (sink) - (unless (zerop (column sink)) - (write-rune-0 10 sink) + (unless (zerop (ystream-column (sink-ystream sink))) + (%write-rune #/U+000A sink) ;newline (indent sink))) (defun maybe-close-tag (sink) (let ((tag (car (stack sink)))) (when (and (tag-p tag) (not (tag-have-gt tag))) (setf (tag-have-gt tag) t) - (write-rune #/> sink)))) + (%write-rune #/> sink)))) (defmethod sax:start-element ((sink sink) namespace-uri local-name qname attributes) @@ -252,16 +366,16 @@ (when (indentation sink) (sink-fresh-line sink) (start-indentation-block sink)) - (write-rune #/< sink) - (write-rod qname sink) + (%write-rune #/< sink) + (%write-rod qname sink) (let ((atts (sort (copy-list attributes) #'rod< :key #'sax:attribute-qname))) (dolist (a atts) - (write-rune #/space sink) - (write-rod (sax:attribute-qname a) sink) - (write-rune #/= sink) - (write-rune #/\" sink) - (map nil (lambda (c) (unparse-datachar c sink)) (sax:attribute-value a)) - (write-rune #/\" sink))) + (%write-rune #/space sink) + (%write-rod (sax:attribute-qname a) sink) + (%write-rune #/= sink) + (%write-rune #/\" sink) + (unparse-string (sax:attribute-value a) sink) + (%write-rune #/\" sink))) (when (canonical sink) (maybe-close-tag sink))) @@ -280,21 +394,21 @@ (sink-fresh-line sink))) (cond ((tag-have-gt tag) - (write-rod '#.(string-rod "") sink)) + (%write-rod '#.(string-rod "") sink)) (t - (write-rod #"/>" sink))))) + (%write-rod #"/>" sink))))) (defmethod sax:processing-instruction ((sink sink) target data) (maybe-close-tag sink) (unless (rod-equal target '#.(string-rod "xml")) - (write-rod '#.(string-rod "") sink) - (write-rune #/U+000A sink))) + (%write-rod '#.(string-rod "") sink))) (defmethod sax:start-cdata ((sink sink)) (maybe-close-tag sink) @@ -308,17 +422,17 @@ (not (search #"]]" data))) (when (indentation sink) (sink-fresh-line sink)) - (write-rod #"" sink)) + (map nil (lambda (c) (%write-rune c sink)) data) + (%write-rod #"]]>" sink)) (t (if (indentation sink) (unparse-indented-text data sink) - (map nil (if (canonical sink) - (lambda (c) (unparse-datachar c sink)) - (lambda (c) (unparse-datachar-readable c sink))) - data))))) + (let ((y (sink-ystream sink))) + (if (canonical sink) + (loop for c across data do (unparse-datachar c y)) + (loop for c across data do (unparse-datachar-readable c y)))))))) (defmethod sax:end-cdata ((sink sink)) (unless (eq (pop (stack sink)) :cdata) @@ -326,7 +440,7 @@ (defun indent (sink) (dotimes (x (current-indentation sink)) - (write-rune-0 32 sink))) + (%write-rune #/U+0020 sink))) ; space (defun start-indentation-block (sink) (incf (current-indentation sink) (indentation sink))) @@ -348,92 +462,49 @@ (let* ((w (or (position-if #'whitespacep data :start (1+ pos)) n)) (next (or (position-if-not #'whitespacep data :start w) n))) (when need-whitespace-p - (if (or (not (width sink)) - (< (+ (column sink) w (- pos)) (width sink))) - (write-rune-0 32 sink) + (if (< (+ (ystream-column (sink-ystream sink)) w (- pos)) + (width sink)) + (%write-rune #/U+0020 sink) (sink-fresh-line sink))) (loop + with y = (sink-ystream sink) for i from pos below w do - (unparse-datachar-readable (elt data i) sink)) + (unparse-datachar-readable (elt data i) y)) (setf need-whitespace-p (< w n)) (setf pos next)))) (t - (write-rune-0 32 sink)))))) + (%write-rune #/U+0020 sink)))))) (defun unparse-string (str sink) - (map nil (lambda (c) (unparse-datachar c sink)) str)) + (let ((y (sink-ystream sink))) + (loop for rune across str do (unparse-datachar rune y)))) -(defun unparse-datachar (c sink) - (cond ((rune= c #/&) (write-rod '#.(string-rod "&") sink)) - ((rune= c #/<) (write-rod '#.(string-rod "<") sink)) - ((rune= c #/>) (write-rod '#.(string-rod ">") sink)) - ((rune= c #/\") (write-rod '#.(string-rod """) sink)) - ((rune= c #/U+0009) (write-rod '#.(string-rod " ") sink)) - ((rune= c #/U+000A) (write-rod '#.(string-rod " ") sink)) - ((rune= c #/U+000D) (write-rod '#.(string-rod " ") sink)) +(defun unparse-datachar (c ystream) + (cond ((rune= c #/&) (write-rod '#.(string-rod "&") ystream)) + ((rune= c #/<) (write-rod '#.(string-rod "<") ystream)) + ((rune= c #/>) (write-rod '#.(string-rod ">") ystream)) + ((rune= c #/\") (write-rod '#.(string-rod """) ystream)) + ((rune= c #/U+0009) (write-rod '#.(string-rod " ") ystream)) + ((rune= c #/U+000A) (write-rod '#.(string-rod " ") ystream)) + ((rune= c #/U+000D) (write-rod '#.(string-rod " ") ystream)) (t - (write-rune c sink)))) + (write-rune c ystream)))) -(defun unparse-datachar-readable (c sink) - (cond ((rune= c #/&) (write-rod '#.(string-rod "&") sink)) - ((rune= c #/<) (write-rod '#.(string-rod "<") sink)) - ((rune= c #/>) (write-rod '#.(string-rod ">") sink)) - ((rune= c #/\") (write-rod '#.(string-rod """) sink)) +(defun unparse-datachar-readable (c ystream) + (cond ((rune= c #/&) (write-rod '#.(string-rod "&") ystream)) + ((rune= c #/<) (write-rod '#.(string-rod "<") ystream)) + ((rune= c #/>) (write-rod '#.(string-rod ">") ystream)) + ((rune= c #/\") (write-rod '#.(string-rod """) ystream)) (t - (write-rune c sink)))) + (write-rune c ystream)))) +(defun %write-rune (c sink) + (write-rune c (sink-ystream sink))) -;;;; UTF-8 output for SINKs +(defun %write-rod (r sink) + (write-rod r (sink-ystream sink))) -(defun write-rod (rod sink) - (map nil (lambda (c) (write-rune c sink)) rod)) -(defun write-rune (rune sink) - (let ((code (rune-code rune))) - (with-slots (high-surrogate) sink - (cond - ((<= #xD800 code #xDBFF) - (setf high-surrogate code)) - ((<= #xDC00 code #xDFFF) - (let ((q (logior (ash (- high-surrogate #xD7C0) 10) - (- code #xDC00)))) - (write-rune-0 q sink)) - (setf high-surrogate nil)) - (t - (write-rune-0 code sink)))))) - -(defun write-rune-0 (code sink) - (labels ((wr (x) - (write-octet x sink))) - (cond ((<= #x00000000 code #x0000007F) - (wr code)) - ((<= #x00000080 code #x000007FF) - (wr (logior #b11000000 (ldb (byte 5 6) code))) - (wr (logior #b10000000 (ldb (byte 6 0) code)))) - ((<= #x00000800 code #x0000FFFF) - (wr (logior #b11100000 (ldb (byte 4 12) code))) - (wr (logior #b10000000 (ldb (byte 6 6) code))) - (wr (logior #b10000000 (ldb (byte 6 0) code)))) - ((<= #x00010000 code #x001FFFFF) - (wr (logior #b11110000 (ldb (byte 3 18) code))) - (wr (logior #b10000000 (ldb (byte 6 12) code))) - (wr (logior #b10000000 (ldb (byte 6 6) code))) - (wr (logior #b10000000 (ldb (byte 6 0) code)))) - ((<= #x00200000 code #x03FFFFFF) - (wr (logior #b11111000 (ldb (byte 2 24) code))) - (wr (logior #b10000000 (ldb (byte 6 18) code))) - (wr (logior #b10000000 (ldb (byte 6 12) code))) - (wr (logior #b10000000 (ldb (byte 6 6) code))) - (wr (logior #b10000000 (ldb (byte 6 0) code)))) - ((<= #x04000000 code #x7FFFFFFF) - (wr (logior #b11111100 (ldb (byte 1 30) code))) - (wr (logior #b10000000 (ldb (byte 6 24) code))) - (wr (logior #b10000000 (ldb (byte 6 18) code))) - (wr (logior #b10000000 (ldb (byte 6 12) code))) - (wr (logior #b10000000 (ldb (byte 6 6) code))) - (wr (logior #b10000000 (ldb (byte 6 0) code))))))) - - ;;;; convenience functions for DOMless XML serialization (defvar *current-element*) @@ -450,14 +521,6 @@ (sax:end-document *sink*))) (defmacro with-element (qname &body body) - ;; XXX Statt qname soll man in zukunft auch mal (lname prefix) angeben - ;; koennen. Hat aber Zeit bis DOM 2. - #+(or) - ;; XXX we want to be able to produce computed element names, so the - ;; following code has been disabled. - (when (listp qname) - (destructuring-bind (n) qname - (setf qname n))) `(invoke-with-element (lambda () , at body) ,qname)) (defun maybe-emit-start-tag () @@ -494,13 +557,14 @@ data) (defun rod-to-utf8-string (rod) - (with-output-to-string (s) - (write-rod rod (cxml:make-character-stream-sink s)))) + (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 'rod))) + (result (make-array n :element-type 'rune))) (map-into result #'code-rune buffer) result)) Added: branches/grin-neu/thirdparty/cxml/xml/util.lisp =================================================================== --- branches/grin-neu/thirdparty/cxml/xml/util.lisp 2006-12-01 10:37:34 UTC (rev 2093) +++ branches/grin-neu/thirdparty/cxml/xml/util.lisp 2006-12-01 10:39:49 UTC (rev 2094) @@ -0,0 +1,73 @@ +;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: RUNES; -*- +;;; --------------------------------------------------------------------------- +;;; Title: Some common utilities for the Closure browser +;;; Created: 1997-12-27 +;;; Author: Gilbert Baumann +;;; License: Lisp-LGPL (See file COPYING for details). +;;; --------------------------------------------------------------------------- +;;; (c) copyright 1997-1999 by Gilbert Baumann + +;;; This code is free software; you can redistribute it and/or modify it +;;; under the terms of the version 2.1 of the GNU Lesser General Public +;;; License as published by the Free Software Foundation, as clarified +;;; by the "Preamble to the Gnu Lesser General Public License" found in +;;; the file COPYING. +;;; +;;; This code 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 +;;; Lesser General Public License for more details. +;;; +;;; Version 2.1 of the GNU Lesser General Public License is in the file +;;; COPYING that was distributed with this file. If it is not present, +;;; you can access it from http://www.gnu.org/copyleft/lesser.txt (until +;;; superseded by a newer version) or write to the Free Software +;;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + +;; Changes +;; +;; When Who What +;; ---------------------------------------------------------------------------- +;; 1999-08-24 GB = fixed MULTIPLE-VALUE-OR it now takes any number of +;; subforms +;; + +(in-package :cxml) + +;;; -------------------------------------------------------------------------------- +;;; Meta functions + +(defun curry (fun &rest args) + #'(lambda (&rest more) + (apply fun (append args more)))) + +(defun rcurry (fun &rest args) + #'(lambda (&rest more) + (apply fun (append more args)))) + +(defun compose (f g) + #'(lambda (&rest args) + (funcall f (apply g args)))) + +;;; -------------------------------------------------------------------------------- +;;; while and until + +(defmacro while (test &body body) + `(until (not ,test) , at body)) + +(defmacro until (test &body body) + `(do () (,test) , at body)) + +;; prime numbers + +(defun primep (n) + "Returns true, iff `n' is prime." + (and (> n 2) + (do ((i 2 (+ i 1))) + ((> (* i i) n) t) + (cond ((zerop (mod n i)) (return nil)))))) + +(defun nearest-greater-prime (n) + "Returns the smallest prime number no less than `n'." + (cond ((primep n) n) + ((nearest-greater-prime (+ n 1))))) Modified: branches/grin-neu/thirdparty/cxml/xml/xml-name-rune-p.lisp =================================================================== --- branches/grin-neu/thirdparty/cxml/xml/xml-name-rune-p.lisp 2006-12-01 10:37:34 UTC (rev 2093) +++ branches/grin-neu/thirdparty/cxml/xml/xml-name-rune-p.lisp 2006-12-01 10:39:49 UTC (rev 2094) @@ -1,6 +1,6 @@ ;;;; xml-name-rune-p -- character class definitions ;;;; -;;;; This file is part of the CXML parser, released under (L)LGPL. +;;;; This file is part of the CXML parser, released under Lisp-LGPL. ;;;; See file COPYING for details. ;;;; ;;;; Author: Gilbert Baumann @@ -11,9 +11,115 @@ (compile nil '(lambda () - (let ((*max* #xD800)) + (let ((+max+ #xD800) + (base-char-ranges + #((#x0041 #x005A) (#x0061 #x007A) (#x00C0 #x00D6) (#x00D8 #x00F6) + (#x00F8 #x00FF) (#x0100 #x0131) (#x0134 #x013E) (#x0141 #x0148) + (#x014A #x017E) (#x0180 #x01C3) (#x01CD #x01F0) (#x01F4 #x01F5) + (#x01FA #x0217) (#x0250 #x02A8) (#x02BB #x02C1) (#x0386 #x0386) + (#x0388 #x038A) (#x038C #x038C) (#x038E #x03A1) (#x03A3 #x03CE) + (#x03D0 #x03D6) (#x03DA #x03DA) (#x03DC #x03DC) (#x03DE #x03DE) + (#x03E0 #x03E0) (#x03E2 #x03F3) (#x0401 #x040C) (#x040E #x044F) + (#x0451 #x045C) (#x045E #x0481) (#x0490 #x04C4) (#x04C7 #x04C8) + (#x04CB #x04CC) (#x04D0 #x04EB) (#x04EE #x04F5) (#x04F8 #x04F9) + (#x0531 #x0556) (#x0559 #x0559) (#x0561 #x0586) (#x05D0 #x05EA) + (#x05F0 #x05F2) (#x0621 #x063A) (#x0641 #x064A) (#x0671 #x06B7) + (#x06BA #x06BE) (#x06C0 #x06CE) (#x06D0 #x06D3) (#x06D5 #x06D5) + (#x06E5 #x06E6) (#x0905 #x0939) (#x093D #x093D) (#x0958 #x0961) + (#x0985 #x098C) (#x098F #x0990) (#x0993 #x09A8) (#x09AA #x09B0) + (#x09B2 #x09B2) (#x09B6 #x09B9) (#x09DC #x09DD) (#x09DF #x09E1) + (#x09F0 #x09F1) (#x0A05 #x0A0A) (#x0A0F #x0A10) (#x0A13 #x0A28) + (#x0A2A #x0A30) (#x0A32 #x0A33) (#x0A35 #x0A36) (#x0A38 #x0A39) + (#x0A59 #x0A5C) (#x0A5E #x0A5E) (#x0A72 #x0A74) (#x0A85 #x0A8B) + (#x0A8D #x0A8D) (#x0A8F #x0A91) (#x0A93 #x0AA8) (#x0AAA #x0AB0) + (#x0AB2 #x0AB3) (#x0AB5 #x0AB9) (#x0ABD #x0ABD) (#x0AE0 #x0AE0) + (#x0B05 #x0B0C) (#x0B0F #x0B10) (#x0B13 #x0B28) (#x0B2A #x0B30) + (#x0B32 #x0B33) (#x0B36 #x0B39) (#x0B3D #x0B3D) (#x0B5C #x0B5D) + (#x0B5F #x0B61) (#x0B85 #x0B8A) (#x0B8E #x0B90) (#x0B92 #x0B95) + (#x0B99 #x0B9A) (#x0B9C #x0B9C) (#x0B9E #x0B9F) (#x0BA3 #x0BA4) + (#x0BA8 #x0BAA) (#x0BAE #x0BB5) (#x0BB7 #x0BB9) (#x0C05 #x0C0C) + (#x0C0E #x0C10) (#x0C12 #x0C28) (#x0C2A #x0C33) (#x0C35 #x0C39) + (#x0C60 #x0C61) (#x0C85 #x0C8C) (#x0C8E #x0C90) (#x0C92 #x0CA8) + (#x0CAA #x0CB3) (#x0CB5 #x0CB9) (#x0CDE #x0CDE) (#x0CE0 #x0CE1) + (#x0D05 #x0D0C) (#x0D0E #x0D10) (#x0D12 #x0D28) (#x0D2A #x0D39) + (#x0D60 #x0D61) (#x0E01 #x0E2E) (#x0E30 #x0E30) (#x0E32 #x0E33) + (#x0E40 #x0E45) (#x0E81 #x0E82) (#x0E84 #x0E84) (#x0E87 #x0E88) + (#x0E8A #x0E8A) (#x0E8D #x0E8D) (#x0E94 #x0E97) (#x0E99 #x0E9F) + (#x0EA1 #x0EA3) (#x0EA5 #x0EA5) (#x0EA7 #x0EA7) (#x0EAA #x0EAB) + (#x0EAD #x0EAE) (#x0EB0 #x0EB0) (#x0EB2 #x0EB3) (#x0EBD #x0EBD) + (#x0EC0 #x0EC4) (#x0F40 #x0F47) (#x0F49 #x0F69) (#x10A0 #x10C5) + (#x10D0 #x10F6) (#x1100 #x1100) (#x1102 #x1103) (#x1105 #x1107) + (#x1109 #x1109) (#x110B #x110C) (#x110E #x1112) (#x113C #x113C) + (#x113E #x113E) (#x1140 #x1140) (#x114C #x114C) (#x114E #x114E) + (#x1150 #x1150) (#x1154 #x1155) (#x1159 #x1159) (#x115F #x1161) + (#x1163 #x1163) (#x1165 #x1165) (#x1167 #x1167) (#x1169 #x1169) + (#x116D #x116E) (#x1172 #x1173) (#x1175 #x1175) (#x119E #x119E) + (#x11A8 #x11A8) (#x11AB #x11AB) (#x11AE #x11AF) (#x11B7 #x11B8) + (#x11BA #x11BA) (#x11BC #x11C2) (#x11EB #x11EB) (#x11F0 #x11F0) + (#x11F9 #x11F9) (#x1E00 #x1E9B) (#x1EA0 #x1EF9) (#x1F00 #x1F15) + (#x1F18 #x1F1D) (#x1F20 #x1F45) (#x1F48 #x1F4D) (#x1F50 #x1F57) + (#x1F59 #x1F59) (#x1F5B #x1F5B) (#x1F5D #x1F5D) (#x1F5F #x1F7D) + (#x1F80 #x1FB4) (#x1FB6 #x1FBC) (#x1FBE #x1FBE) (#x1FC2 #x1FC4) + (#x1FC6 #x1FCC) (#x1FD0 #x1FD3) (#x1FD6 #x1FDB) (#x1FE0 #x1FEC) + (#x1FF2 #x1FF4) (#x1FF6 #x1FFC) (#x2126 #x2126) (#x212A #x212B) + (#x212E #x212E) (#x2180 #x2182) (#x3041 #x3094) (#x30A1 #x30FA) + (#x3105 #x312C) (#xAC00 #xD7A3))) + (ideographic-ranges #((#x3007 #x3007) (#x3021 #x3029)(#x4E00 #x9FA5))) + (combining-char-ranges + #((#x0300 #x0345) (#x0360 #x0361) (#x0483 #x0486) (#x0591 #x05A1) + (#x05A3 #x05B9) (#x05BB #x05BD) (#x05BF #x05BF) (#x05C1 #x05C2) + (#x05C4 #x05C4) (#x064B #x0652) (#x0670 #x0670) (#x06D6 #x06DC) + (#x06DD #x06DF) (#x06E0 #x06E4) (#x06E7 #x06E8) (#x06EA #x06ED) + (#x0901 #x0903) (#x093C #x093C) (#x093E #x094C) (#x094D #x094D) + (#x0951 #x0954) (#x0962 #x0963) (#x0981 #x0983) (#x09BC #x09BC) + (#x09BE #x09BE) (#x09BF #x09BF) (#x09C0 #x09C4) (#x09C7 #x09C8) + (#x09CB #x09CD) (#x09D7 #x09D7) (#x09E2 #x09E3) (#x0A02 #x0A02) + (#x0A3C #x0A3C) (#x0A3E #x0A3E) (#x0A3F #x0A3F) (#x0A40 #x0A42) + (#x0A47 #x0A48) (#x0A4B #x0A4D) (#x0A70 #x0A71) (#x0A81 #x0A83) + (#x0ABC #x0ABC) (#x0ABE #x0AC5) (#x0AC7 #x0AC9) (#x0ACB #x0ACD) + (#x0B01 #x0B03) (#x0B3C #x0B3C) (#x0B3E #x0B43) (#x0B47 #x0B48) + (#x0B4B #x0B4D) (#x0B56 #x0B57) (#x0B82 #x0B83) (#x0BBE #x0BC2) + (#x0BC6 #x0BC8) (#x0BCA #x0BCD) (#x0BD7 #x0BD7) (#x0C01 #x0C03) + (#x0C3E #x0C44) (#x0C46 #x0C48) (#x0C4A #x0C4D) (#x0C55 #x0C56) + (#x0C82 #x0C83) (#x0CBE #x0CC4) (#x0CC6 #x0CC8) (#x0CCA #x0CCD) + (#x0CD5 #x0CD6) (#x0D02 #x0D03) (#x0D3E #x0D43) (#x0D46 #x0D48) + (#x0D4A #x0D4D) (#x0D57 #x0D57) (#x0E31 #x0E31) (#x0E34 #x0E3A) + (#x0E47 #x0E4E) (#x0EB1 #x0EB1) (#x0EB4 #x0EB9) (#x0EBB #x0EBC) + (#x0EC8 #x0ECD) (#x0F18 #x0F19) (#x0F35 #x0F35) (#x0F37 #x0F37) + (#x0F39 #x0F39) (#x0F3E #x0F3E) (#x0F3F #x0F3F) (#x0F71 #x0F84) + (#x0F86 #x0F8B) (#x0F90 #x0F95) (#x0F97 #x0F97) (#x0F99 #x0FAD) + (#x0FB1 #x0FB7) (#x0FB9 #x0FB9) (#x20D0 #x20DC) (#x20E1 #x20E1) + (#x302A #x302F) (#x3099 #x3099) (#x309A #x309A)) + ) + (digit-ranges + #((#x0030 #x0039) (#x0660 #x0669) (#x06F0 #x06F9) (#x0966 #x096F) + (#x09E6 #x09EF) (#x0A66 #x0A6F) (#x0AE6 #x0AEF) (#x0B66 #x0B6F) + (#x0BE7 #x0BEF) (#x0C66 #x0C6F) (#x0CE6 #x0CEF) (#x0D66 #x0D6F) + (#x0E50 #x0E59) (#x0ED0 #x0ED9) (#x0F20 #x0F29))) + (extender-ranges + #((#x00B7 #x00B7) (#x02D0 #x02D0) (#x02D1 #x02D1) (#x0387 #x0387) + (#x0640 #x0640) (#x0E46 #x0E46) (#x0EC6 #x0EC6) (#x3005 #x3005) + (#x3031 #x3035) (#x309D #x309E) (#x30FC #x30FE)))) (labels - ((name-start-rune-p (rune) + ((rune-in-range-p (code range-vector) + (declare (type simple-vector range-vector)) + ;;we were always dealing with a sorted vector... bin search it + + (let ((start 0) + (end (length range-vector))) + (while (< start end) + (let ((mid-index (+ start (floor (- end start) 2)))) + (destructuring-bind (mid-item-low mid-item-high) + (aref range-vector mid-index) + (cond + ((< mid-item-high code) + (setf start (1+ mid-index))) + ((< code mid-item-low) + (setf end mid-index)) + (t + (return t)))))))) + + (name-start-rune-p (rune) (or (letter-rune-p rune) (= #.(char-code #\_) rune) (= #.(char-code #\:) rune))) @@ -33,193 +139,47 @@ (ideographic-rune-p rune))) (digit-rune-p* (rune) - (or (<= 48 rune 57) - (<= 1632 rune 1641) - (<= 1776 rune 1785) - (<= 2406 rune 2415) - (<= 2534 rune 2543) - (<= 2662 rune 2671) - (<= 2790 rune 2799) - (<= 2918 rune 2927) - (<= 3047 rune 3055) - (<= 3174 rune 3183) - (<= 3302 rune 3311) - (<= 3430 rune 3439) - (<= 3664 rune 3673) - (<= 3792 rune 3801) - (<= 3872 rune 3881))) + (rune-in-range-p rune digit-ranges)) (combining-rune-p (rune) - (or (<= 768 rune 837) - (<= 864 rune 865) - (<= 1155 rune 1158) - (<= 1425 rune 1441) - (<= 1443 rune 1465) - (<= 1467 rune 1469) - (= 1471 rune) - (<= 1473 rune 1474) - (= 1476 rune) - (<= 1611 rune 1618) - (= 1648 rune) - (<= 1750 rune 1756) - (<= 1757 rune 1759) - (<= 1760 rune 1764) - (<= 1767 rune 1768) - (<= 1770 rune 1773) - (<= 2305 rune 2307) - (= 2364 rune) - (<= 2366 rune 2380) - (= 2381 rune) - (<= 2385 rune 2388) - (<= 2402 rune 2403) - (<= 2433 rune 2435) - (= 2492 rune) - (= 2494 rune) - (= 2495 rune) - (<= 2496 rune 2500) - (<= 2503 rune 2504) - (<= 2507 rune 2509) - (= 2519 rune) - (<= 2530 rune 2531) - (= 2562 rune) - (= 2620 rune) - (= 2622 rune) - (= 2623 rune) - (<= 2624 rune 2626) - (<= 2631 rune 2632) - (<= 2635 rune 2637) - (<= 2672 rune 2673) - (<= 2689 rune 2691) - (= 2748 rune) - (<= 2750 rune 2757) - (<= 2759 rune 2761) - (<= 2763 rune 2765) - (<= 2817 rune 2819) - (= 2876 rune) - (<= 2878 rune 2883) - (<= 2887 rune 2888) - (<= 2891 rune 2893) - (<= 2902 rune 2903) - (<= 2946 rune 2947) - (<= 3006 rune 3010) - (<= 3014 rune 3016) - (<= 3018 rune 3021) - (= 3031 rune) - (<= 3073 rune 3075) - (<= 3134 rune 3140) - (<= 3142 rune 3144) - (<= 3146 rune 3149) - (<= 3157 rune 3158) - (<= 3202 rune 3203) - (<= 3262 rune 3268) - (<= 3270 rune 3272) - (<= 3274 rune 3277) - (<= 3285 rune 3286) - (<= 3330 rune 3331) - (<= 3390 rune 3395) - (<= 3398 rune 3400) - (<= 3402 rune 3405) - (= 3415 rune) - (= 3633 rune) - (<= 3636 rune 3642) - (<= 3655 rune 3662) - (= 3761 rune) - (<= 3764 rune 3769) - (<= 3771 rune 3772) - (<= 3784 rune 3789) - (<= 3864 rune 3865) - (= 3893 rune) - (= 3895 rune) - (= 3897 rune) - (= 3902 rune) - (= 3903 rune) - (<= 3953 rune 3972) - (<= 3974 rune 3979) - (<= 3984 rune 3989) - (= 3991 rune) - (<= 3993 rune 4013) - (<= 4017 rune 4023) - (= 4025 rune) - (<= 8400 rune 8412) - (= 8417 rune) - (<= 12330 rune 12335) - (= 12441 rune) - (= 12442 rune))) + (rune-in-range-p rune combining-char-ranges)) (extender-rune-p (rune) - (or - (= 183 rune) - (= 720 rune) - (= 721 rune) - (= 903 rune) - (= 1600 rune) - (= 3654 rune) - (= 3782 rune) - (= 12293 rune) - (<= 12337 rune 12341) - (<= 12445 rune 12446) - (<= 12540 rune 12542))) + (rune-in-range-p rune extender-ranges)) (base-rune-p (rune) - (or - (<= 65 rune 90) (<= 97 rune 122) (<= 192 rune 214) (<= 216 rune 246) (<= 248 rune 255) (<= 256 rune 305) - (<= 308 rune 318) (<= 321 rune 328) (<= 330 rune 382) (<= 384 rune 451) (<= 461 rune 496) (<= 500 rune 501) - (<= 506 rune 535) (<= 592 rune 680) (<= 699 rune 705) (= 902 rune) (<= 904 rune 906) (= 908 rune) - (<= 910 rune 929) (<= 931 rune 974) (<= 976 rune 982) (= 986 rune) (= 988 rune) (= 990 rune) (= 992 rune) - (<= 994 rune 1011) (<= 1025 rune 1036) (<= 1038 rune 1103) (<= 1105 rune 1116) (<= 1118 rune 1153) - (<= 1168 rune 1220) (<= 1223 rune 1224) (<= 1227 rune 1228) (<= 1232 rune 1259) (<= 1262 rune 1269) - (<= 1272 rune 1273) (<= 1329 rune 1366) (= 1369 rune) (<= 1377 rune 1414) (<= 1488 rune 1514) - (<= 1520 rune 1522) (<= 1569 rune 1594) (<= 1601 rune 1610) (<= 1649 rune 1719) (<= 1722 rune 1726) - (<= 1728 rune 1742) (<= 1744 rune 1747) (= 1749 rune) (<= 1765 rune 1766) (<= 2309 rune 2361) (= 2365 rune) - (<= 2392 rune 2401) (<= 2437 rune 2444) (<= 2447 rune 2448) (<= 2451 rune 2472) (<= 2474 rune 2480) - (= 2482 rune) (<= 2486 rune 2489) (<= 2524 rune 2525) (<= 2527 rune 2529) (<= 2544 rune 2545) - (<= 2565 rune 2570) (<= 2575 rune 2576) (<= 2579 rune 2600) (<= 2602 rune 2608) (<= 2610 rune 2611) - (<= 2613 rune 2614) (<= 2616 rune 2617) (<= 2649 rune 2652) (= 2654 rune) (<= 2674 rune 2676) - (<= 2693 rune 2699) (= 2701 rune) (<= 2703 rune 2705) (<= 2707 rune 2728) (<= 2730 rune 2736) - (<= 2738 rune 2739) (<= 2741 rune 2745) (= 2749 rune) (= 2784 rune) (<= 2821 rune 2828) (<= 2831 rune 2832) - (<= 2835 rune 2856) (<= 2858 rune 2864) (<= 2866 rune 2867) (<= 2870 rune 2873) (= 2877 rune) - (<= 2908 rune 2909) (<= 2911 rune 2913) (<= 2949 rune 2954) (<= 2958 rune 2960) (<= 2962 rune 2965) - (<= 2969 rune 2970) (= 2972 rune) (<= 2974 rune 2975) (<= 2979 rune 2980) (<= 2984 rune 2986) - (<= 2990 rune 2997) (<= 2999 rune 3001) (<= 3077 rune 3084) (<= 3086 rune 3088) (<= 3090 rune 3112) - (<= 3114 rune 3123) (<= 3125 rune 3129) (<= 3168 rune 3169) (<= 3205 rune 3212) (<= 3214 rune 3216) - (<= 3218 rune 3240) (<= 3242 rune 3251) (<= 3253 rune 3257) (= 3294 rune) (<= 3296 rune 3297) - (<= 3333 rune 3340) (<= 3342 rune 3344) (<= 3346 rune 3368) (<= 3370 rune 3385) (<= 3424 rune 3425) - (<= 3585 rune 3630) (= 3632 rune) (<= 3634 rune 3635) (<= 3648 rune 3653) (<= 3713 rune 3714) (= 3716 rune) - (<= 3719 rune 3720) (= 3722 rune) (= 3725 rune) (<= 3732 rune 3735) (<= 3737 rune 3743) (<= 3745 rune 3747) - (= 3749 rune) (= 3751 rune) (<= 3754 rune 3755) (<= 3757 rune 3758) (= 3760 rune) (<= 3762 rune 3763) (= 3773 rune) - (<= 3776 rune 3780) (<= 3904 rune 3911) (<= 3913 rune 3945) (<= 4256 rune 4293) (<= 4304 rune 4342) - (= 4352 rune) (<= 4354 rune 4355) (<= 4357 rune 4359) (= 4361 rune) (<= 4363 rune 4364) (<= 4366 rune 4370) - (= 4412 rune) (= 4414 rune) (= 4416 rune) (= 4428 rune) (= 4430 rune) (= 4432 rune) (<= 4436 rune 4437) (= 4441 rune) - (<= 4447 rune 4449) (= 4451 rune) (= 4453 rune) (= 4455 rune) (= 4457 rune) (<= 4461 rune 4462) (<= 4466 rune 4467) - (= 4469 rune) (= 4510 rune) (= 4520 rune) (= 4523 rune) (<= 4526 rune 4527) (<= 4535 rune 4536) (= 4538 rune) - (<= 4540 rune 4546) (= 4587 rune) (= 4592 rune) (= 4601 rune) (<= 7680 rune 7835) (<= 7840 rune 7929) - (<= 7936 rune 7957) (<= 7960 rune 7965) (<= 7968 rune 8005) (<= 8008 rune 8013) (<= 8016 rune 8023) - (= 8025 rune) (= 8027 rune) (= 8029 rune) (<= 8031 rune 8061) (<= 8064 rune 8116) (<= 8118 rune 8124) (= 8126 rune) - (<= 8130 rune 8132) (<= 8134 rune 8140) (<= 8144 rune 8147) (<= 8150 rune 8155) (<= 8160 rune 8172) - (<= 8178 rune 8180) (<= 8182 rune 8188) (= 8486 rune) (<= 8490 rune 8491) (= 8494 rune) (<= 8576 rune 8578) - (<= 12353 rune 12436) (<= 12449 rune 12538) (<= 12549 rune 12588) (<= 44032 rune 55203))) + (rune-in-range-p rune base-char-ranges)) (ideographic-rune-p (rune) - (or (<= 19968 rune 40869) (= 12295 rune) (<= 12321 rune 12329))) + (rune-in-range-p rune ideographic-ranges)) (predicate-to-bv (p) - (let ((r (make-array *max* :element-type 'bit :initial-element 0))) - (dotimes (i #x10000 r) + (let ((r (make-array +max+ :element-type 'bit :initial-element 0))) + (dotimes (i +max+ r) (when (funcall p i) (setf (aref r i) 1))))) ) `(progn - (DEFSUBST NAME-RUNE-P (RUNE) - (SETF RUNE (RUNE-CODE RUNE)) - (AND (<= 0 RUNE ,*max*) - (LOCALLY (DECLARE (OPTIMIZE (SAFETY 0) (SPEED 3))) - (= 1 (SBIT ',(predicate-to-bv #'name-rune-p) - (THE FIXNUM RUNE)))))) - (DEFSUBST NAME-START-RUNE-P (RUNE) - (SETF RUNE (RUNE-CODE RUNE)) - (AND (<= 0 RUNE ,*MAX*) - (LOCALLY (DECLARE (OPTIMIZE (SAFETY 0) (SPEED 3))) - (= 1 (SBIT ',(predicate-to-bv #'name-start-rune-p) - (THE FIXNUM RUNE)))))))) )))) + (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)) + (type fixnum 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)) + (every #'name-rune-p rod))) + (definline valid-nmtoken-p (rod) + (and (plusp (length rod)) + (every #'name-rune-p rod))))))))) Modified: branches/grin-neu/thirdparty/cxml/xml/xml-parse.lisp =================================================================== --- branches/grin-neu/thirdparty/cxml/xml/xml-parse.lisp 2006-12-01 10:37:34 UTC (rev 2093) +++ branches/grin-neu/thirdparty/cxml/xml/xml-parse.lisp 2006-12-01 10:39:49 UTC (rev 2094) @@ -5,12 +5,13 @@ ;;; Author: Gilbert Baumann ;;; Author: Henrik Motakef ;;; Author: David Lichteblau -;;; License: LGPL (See file COPYING for details). +;;; License: Lisp-LGPL (See file COPYING for details). ;;; --------------------------------------------------------------------------- -;;; copyright 1999 by Gilbert Baumann -;;; copyright 2003 by Henrik Motakef -;;; copyright 2004 knowledgeTools Int. GmbH -;;; copyright 2004 David Lichteblau +;;; (c) copyright 1999 by Gilbert Baumann +;;; (c) copyright 2003 by Henrik Motakef +;;; (c) copyright 2004 knowledgeTools Int. GmbH +;;; (c) copyright 2004 David Lichteblau +;;; (c) copyright 2005 David Lichteblau ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public @@ -23,8 +24,8 @@ ;;; 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, +;;; License along with this library; if not, write to the +;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. ;;; Streams @@ -62,7 +63,7 @@ ;; slot of zstreams instead). ;; Common -;; :xml-pi ( . ) ;processing-instruction starting with " . ) ;processing-instruction starting with " . ) ;processing-instruction ;; :stag ( . ) ;start tag ;; :etag ( . ) ;end tag @@ -77,13 +78,13 @@ ;; *data-behaviour* = :DTD ;; -;; :name +;; :nmtoken ;; :#required ;; :#implied ;; :#fixed ;; :#pcdata ;; :s -;; :\[ :\] :\( :\) :|\ :\> :\" :\' :\, :\? :\* :\+ +;; :\[ :\] :\( :\) :|\ :\> :\" :\' :\, :\? :\* :\+ ;; *data-behaviour* = :DOC ;; @@ -91,29 +92,8 @@ ;; :cdata - - -;;; NOTES -;; -;; Stream buffers as well as RODs are supposed to be encoded in -;; UTF-16. - -;; where does the time go? -;; DATA-RUNE-P -;; CANON-NOT-CDATA-ATTVAL -;; READ-ATTVAL (MUFFLE) -;; CLOSy DOM -;; UTF-8 decoder (13%) -;; READ-ATTVAL (10%) -;; - ;;; TODO ;; -;; o Improve error messages: -;; - line and column number counters -;; - better texts -;; - better handling of errors (no crash'n burn behaviour) -;; ;; o provide for a faster DOM ;; ;; o morph zstream into a context object and thus also get rid of @@ -132,58 +112,24 @@ ;; ;; o max depth together with circle detection ;; (or proof, that our circle detection is enough). +;; [gemeint ist zstream-push--david] ;; -;; o element definitions (with att definitions in the elements) -;; [das haben wir doch, oder?] -;; -;; o store entities in the DTD -;; ;; o better extensibility wrt character representation, one may want to ;; have -;; - UTF-8 in standard CL strings -;; - UCS-2 in RODs -;; - UTF-16 in RODs ;; - UCS-4 in vectoren -;; [habe ich eigentlich nicht vor--david] ;; ;; o xstreams auslagern, documententieren und dann auch in SGML und ;; CSS parser verwenden. (halt alles was zeichen liest). ;; [ausgelagert sind sie; dokumentiert "so la la"; die Reintegration ;; in Closure ist ein ganz anderes Thema] ;; -;; o merge node representation with SGML module -;; [???] -;; -;; o line/column number recording -;; -;; o better error messages -;; ;; o recording of source locations for nodes. ;; -;; o make the *scratch-pad* hack safe -;; ;; o based on the DTD and xml:space attribute implement HTML white ;; space rules. ;; ;; o on a parser option, do not expand external entities. -;; -;; o does the user need the distinction between "" and " " ? -;; That is literal and 'quoted' white space. -;; [verstehe ich nicht --david] -;; -;; o on an option merge CDATA section; -;; -;; o data in parse tree? extra nodes like in SGML?! -;; -;; o what to store in the node-gi field? Some name object or the -;; string used? -;; -;; Test that fail: -;; -;; not-wf/sa/128 is false a alarm -;; - ;;;; Validity constraints: ;;;; (00) Root Element Type like (03), c.f. MAKE-ROOT-MODEL ;;;; (01) Proper Declaration/PE Nesting P/MARKUP-DECL @@ -231,34 +177,46 @@ ;;; parser context -(defvar *ctx*) +(defvar *ctx* nil) -;; forward declaration for DEFVAR -(declaim (special *default-namespace-bindings*)) - (defstruct (context (:conc-name nil)) handler - (namespace-bindings *default-namespace-bindings*) (dtd nil) model-stack (referenced-notations '()) (id-table (%make-rod-hash-table)) + ;; FIXME: Wofuer ist name-hashtable da? Will man das wissen? + (name-hashtable (make-rod-hashtable :size 2000)) (standalone-p nil) (entity-resolver nil) - (disallow-internal-subset nil)) + (disallow-internal-subset nil) + main-zstream) -(defvar *expand-pe-p*) +(defvar *expand-pe-p* nil) +(defparameter *namespace-bindings* + '((#"" . nil) + (#"xmlns" . #"http://www.w3.org/2000/xmlns/") + (#"xml" . #"http://www.w3.org/XML/1998/namespace"))) + ;;;; --------------------------------------------------------------------------- ;;;; xstreams ;;;; -(defstruct (stream-name (:type list)) +(defstruct (stream-name + (:print-function print-stream-name)) entity-name entity-kind uri) +(defun print-stream-name (object stream depth) + (declare (ignore depth)) + (format stream "[~A ~S ~A]" + (rod-string (stream-name-entity-name object)) + (stream-name-entity-kind object) + (stream-name-uri object))) + (deftype read-element () 'rune) (defun call-with-open-xstream (fn stream) @@ -279,39 +237,6 @@ (defmacro with-open-xfile ((stream &rest open-args) &body body) `(call-with-open-xfile (lambda (,stream) .,body) .,open-args)) -;;; Decoders - -;; The decoders share a common signature: -;; -;; DECODE input input-start input-end -;; output output-start output-end -;; eof-p -;; -> first-not-written ; first-not-read -;; -;; These decode functions should decode as much characters off `input' -;; into the `output' as possible and return the indexes to the first -;; not read and first not written element of `input' and `output' -;; respectively. If there are not enough bytes in `input' to decode a -;; full character, decoding shold be abandomed; the caller has to -;; ensure that the remaining bytes of `input' are passed to the -;; decoder again with more bytes appended. -;; -;; `eof-p' now in turn indicates, if the given input sequence, is all -;; the producer does have and might be used to produce error messages -;; in case of incomplete codes or decided what to do. -;; -;; Decoders are expected to handle the various CR/NL conventions and -;; canonicalize each end of line into a single NL rune (#xA) in good -;; old Lisp tradition. -;; - -;; TODO: change this to an encoding class, which then might carry -;; additional state. Stateless encodings could been represented by -;; keywords. e.g. -;; -;; defmethod DECODE-SEQUENCE ((encoding (eql :utf-8)) ...) -;; - ;;;; ------------------------------------------------------------------- ;;;; Rechnen mit Runen ;;;; @@ -319,9 +244,9 @@ ;; Let us first define fast fixnum arithmetric get rid of type ;; checks. (After all we know what we do here). -(defmacro fx-op (op &rest xs) +(defmacro fx-op (op &rest xs) `(the fixnum (,op ,@(mapcar (lambda (x) `(the fixnum ,x)) xs)))) -(defmacro fx-pred (op &rest xs) +(defmacro fx-pred (op &rest xs) `(,op ,@(mapcar (lambda (x) `(the fixnum ,x)) xs))) (defmacro %+ (&rest xs) `(fx-op + , at xs)) @@ -342,9 +267,9 @@ ;;; XXX Geschwindigkeit dieser Definitionen untersuchen! -(defmacro rune-op (op &rest xs) +(defmacro rune-op (op &rest xs) `(code-rune (,op ,@(mapcar (lambda (x) `(rune-code ,x)) xs)))) -(defmacro rune-pred (op &rest xs) +(defmacro rune-pred (op &rest xs) `(,op ,@(mapcar (lambda (x) `(rune-code ,x)) xs))) (defmacro %rune+ (&rest xs) `(rune-op + , at xs)) @@ -370,7 +295,7 @@ ;;; make-rod-hashtable ;;; rod-hash-get hashtable rod &optional start end -> value ; successp ;;; (setf (rod-hash-get hashtable rod &optional start end) new-value -;;; +;;; (defstruct (rod-hashtable (:constructor make-rod-hashtable/low)) size ;size of table @@ -378,7 +303,7 @@ ) (defun make-rod-hashtable (&key (size 200)) - (setf size (runes::nearest-greater-prime size)) + (setf size (nearest-greater-prime size)) (make-rod-hashtable/low :size size :table (make-array size :initial-element nil))) @@ -392,13 +317,13 @@ (1- (expt 2 +fixnum-bits+)) "Pessimistic approximation of the largest bit-mask, still being a fixnum.")) -(defsubst stir (a b) +(definline stir (a b) (%and +fixnum-mask+ (%xor (%ior (%ash (%and a #.(ash +fixnum-mask+ -5)) 5) (%ash a #.(- 5 +fixnum-bits+))) b))) -(defsubst rod-hash (rod start end) +(definline rod-hash (rod start end) "Compute a hash code out of a rod." (let ((res (%- end start))) (do ((i start (%+ i 1))) @@ -407,7 +332,7 @@ (setf res (stir res (rune-code (%rune rod i))))) res)) -(defsubst rod=* (x y &key (start1 0) (end1 (length x)) +(definline rod=* (x y &key (start1 0) (end1 (length x)) (start2 0) (end2 (length y))) (and (%= (%- end1 start1) (%- end2 start2)) (do ((i start1 (%+ i 1)) @@ -417,7 +342,7 @@ (unless (rune= (%rune x i) (%rune y j)) (return nil))))) -(defsubst rod=** (x y start1 end1 start2 end2) +(definline rod=** (x y start1 end1 start2 end2) (and (%= (%- end1 start1) (%- end2 start2)) (do ((i start1 (%+ i 1)) (j start2 (%+ j 1))) @@ -500,14 +425,12 @@ (defun (setf rod-hash-get) (new-value hashtable rod &optional (start 0) (end (length rod))) (rod-hash-set new-value hashtable rod start end)) -(defparameter *name-hashtable* (make-rod-hashtable :size 2000)) - (defun intern-name (rod &optional (start 0) (end (length rod))) - (multiple-value-bind (value successp key) (rod-hash-get *name-hashtable* rod start end) + (multiple-value-bind (value successp key) (rod-hash-get (name-hashtable *ctx*) rod start end) (declare (ignore value)) (if successp key - (nth-value 1 (rod-hash-set t *name-hashtable* rod start end))))) + (nth-value 1 (rod-hash-set t (name-hashtable *ctx*) rod start end))))) ;;;; --------------------------------------------------------------------------- ;;;; @@ -554,8 +477,8 @@ (,i 0) (,b ,scratch)) (declare (type fixnum ,n ,i)) - (macrolet - ((,collect (x) + (macrolet + ((,collect (x) `((lambda (x) (locally (declare #.*fast*) @@ -575,7 +498,7 @@ `(let ((,rod (make-rod ,i))) (while (not (%= ,i 0)) (setf ,i (%- ,i 1)) - (setf (%rune ,rod ,i) + (setf (%rune ,rod ,i) (aref (the (simple-array rune (*)) ,b) ,i))) ,rod)) (:raw @@ -590,8 +513,8 @@ `(let ((,n (length ,scratch)) (,i 0)) (declare (type fixnum ,n ,i)) - (macrolet - ((,collect (x) + (macrolet + ((,collect (x) `((lambda (x) (locally (declare #.*fast*) @@ -611,7 +534,7 @@ `(let ((,rod (make-rod ,i))) (while (%> ,i 0) (setf ,i (%- ,i 1)) - (setf (%rune ,rod ,i) + (setf (%rune ,rod ,i) (aref (the (simple-array rune (*)) ,scratch) ,i))) ,rod)) (:raw @@ -670,16 +593,72 @@ ;;;; DTD ;;;; -(define-condition parser-error (simple-error) ()) -(define-condition validity-error (parser-error) ()) +(define-condition xml-parse-error (simple-error) ()) +(define-condition well-formedness-violation (xml-parse-error) ()) +(define-condition validity-error (xml-parse-error) ()) -(defun validity-error (x &rest args) - (error 'validity-error - :format-control "Validity constraint violated: ~@?" - :format-arguments (list x args))) +;; We make some effort to signal end of file as a special condition, but we +;; don't actually try very hard. Not sure whether we should. Right now I +;; would prefer not to document this class. +(define-condition end-of-xstream (well-formedness-violation) ()) +(defun describe-xstream (x s) + (format s " Line ~D, column ~D in ~A~%" + (xstream-line-number x) + (xstream-column-number x) + (let ((name (xstream-name x))) + (cond + ((null name) + "") + ((eq :main (stream-name-entity-kind name)) + (stream-name-uri name)) + (t + name))))) + +(defun %error (class stream message) + (let* ((zmain (if *ctx* (main-zstream *ctx*) nil)) + (zstream (if (zstream-p stream) stream zmain)) + (xstream (if (xstream-p stream) stream nil)) + (s (make-string-output-stream))) + (write-line message s) + (when xstream + (write-line "Location:" s) + (describe-xstream xstream s)) + (when zstream + (let ((stack + (remove xstream (remove :stop (zstream-input-stack zstream))))) + (when stack + (write-line "Context:" s) + (dolist (x stack) + (describe-xstream x s))))) + (when (and zmain (not (eq zstream zmain))) + (let ((stack + (remove xstream (remove :stop (zstream-input-stack zmain))))) + (when stack + (write-line "Context in main document:" s) + (dolist (x stack) + (describe-xstream x s))))) + (error class + :format-control "~A" + :format-arguments (list (get-output-stream-string s))))) + +(defun validity-error (fmt &rest args) + (%error 'validity-error + nil + (format nil "Document not valid: ~?" fmt args))) + +(defun wf-error (stream fmt &rest args) + (%error 'well-formedness-violation + stream + (format nil "Document not well-formed: ~?" fmt args))) + +(defun eox (stream &optional x &rest args) + (%error 'end-of-xstream + stream + (format nil "End of file~@[: ~?~]" x args))) + (defvar *validate* t) -(defvar *markup-declaration-external-p* nil) +(defvar *external-subset-p* nil) (defun validate-start-element (ctx name) (when *validate* @@ -718,6 +697,8 @@ (elmdef (elmdef-external-p def)) (attdef (attdef-external-p def))))) +;; attribute validation, defaulting, and normalization -- except for for +;; uniqueness checks, which are done after namespaces have been declared (defun process-attributes (ctx name attlist) (let ((e (find-element name (dtd ctx)))) (cond @@ -733,20 +714,26 @@ (t (when (standalone-check-necessary-p ad) (validity-error "(02) Standalone Document Declaration: missing attribute value")) - (push (build-attribute (attdef-name ad) - (cadr (attdef-default ad)) - nil) + (push (sax:make-attribute :qname (attdef-name ad) + :value (cadr (attdef-default ad)) + :specified-p nil) attlist))))) - (dolist (a attlist) ;normalize non-CDATA values + (dolist (a attlist) ;normalize non-CDATA values (let* ((qname (sax:attribute-qname a)) (adef (find-attribute e qname))) - (when (and adef (not (eq (attdef-type adef) :CDATA))) - (let ((canon (canon-not-cdata-attval (sax:attribute-value a)))) - (when (and (standalone-check-necessary-p adef) - (not (rod= (sax:attribute-value a) canon))) - (validity-error "(02) Standalone Document Declaration: attribute value not normalized")) - (setf (sax:attribute-value a) canon))))) - (when *validate* ;maybe validate attribute values + (when adef + (when (and *validate* + sax:*namespace-processing* + (eq (attdef-type adef) :ID) + (find #/: (sax:attribute-value a))) + (validity-error "colon in ID attribute")) + (unless (eq (attdef-type adef) :CDATA) + (let ((canon (canon-not-cdata-attval (sax:attribute-value a)))) + (when (and (standalone-check-necessary-p adef) + (not (rod= (sax:attribute-value a) canon))) + (validity-error "(02) Standalone Document Declaration: attribute value not normalized")) + (setf (sax:attribute-value a) canon)))))) + (when *validate* ;maybe validate attribute values (dolist (a attlist) (validate-attribute ctx e a)))) ((and *validate* attlist) @@ -768,7 +755,7 @@ (defun validate-attribute* (ctx adef value) (let ((type (attdef-type adef)) - (default (attdef-default adef))) + (default (attdef-default adef))) (when (and (listp default) (eq (car default) :FIXED) (not (rod= value (cadr default)))) @@ -828,14 +815,15 @@ (defstruct (internal-entdef (:include entdef) (:constructor make-internal-entdef (value)) - (:conc-name #:ENTDEF-)) + (:conc-name #:entdef-)) (value (error "missing argument") :type rod) - (expansion nil)) + (expansion nil) + (external-subset-p *external-subset-p*)) (defstruct (external-entdef (:include entdef) (:constructor make-external-entdef (extid ndata)) - (:conc-name #:ENTDEF-)) + (:conc-name #:entdef-)) (extid (error "missing argument") :type extid) (ndata nil :type (or rod null))) @@ -875,8 +863,10 @@ (defun absolute-uri (sysid source-stream) (let ((base-sysid (zstream-base-sysid source-stream))) - (assert (not (null base-sysid))) - (puri:merge-uris sysid base-sysid))) + ;; XXX is the IF correct? + (if base-sysid + (puri:merge-uris sysid base-sysid) + sysid))) (defstruct (extid (:constructor make-extid (public system))) (public nil :type (or rod null)) @@ -890,6 +880,8 @@ (defun define-entity (source-stream name kind def) (setf name (intern-name name)) + (when (and sax:*namespace-processing* (find #/: name)) + (wf-error source-stream "colon in entity name")) (let ((table (ecase kind (:general (dtd-gentities (dtd *ctx*))) @@ -901,9 +893,11 @@ (setf (entdef-extid def) (absolute-extid source-stream (entdef-extid def)))) (setf (gethash name table) - (cons *markup-declaration-external-p* def))))) + (cons *external-subset-p* def))))) (defun get-entity-definition (entity-name kind dtd) + (unless dtd + (wf-error nil "entity not defined: ~A" (rod-string entity-name))) (destructuring-bind (extp &rest def) (gethash entity-name (ecase kind @@ -915,22 +909,32 @@ (rod-string entity-name))) def)) -(defun entity->xstream (entity-name kind &optional zstream) +(defun entity->xstream (zstream entity-name kind &optional internalp) ;; `zstream' is for error messages (let ((def (get-entity-definition entity-name kind (dtd *ctx*)))) (unless def - (if zstream - (perror zstream "Entity '~A' is not defined." (rod-string entity-name)) - (error "Entity '~A' is not defined." (rod-string entity-name)))) + (wf-error zstream "Entity '~A' is not defined." (rod-string entity-name))) (let (r) (etypecase def (internal-entdef + (when (and (standalone-p *ctx*) + (entdef-external-subset-p def)) + (wf-error + zstream + "entity declared in external subset, but document is standalone")) (setf r (make-rod-xstream (entdef-value def))) (setf (xstream-name r) (make-stream-name :entity-name entity-name :entity-kind kind :uri nil))) (external-entdef + (when internalp + (wf-error zstream + "entity not internal: ~A" (rod-string entity-name))) + (when (entdef-ndata def) + (wf-error zstream + "reference to unparsed entity: ~A" + (rod-string entity-name))) (setf r (xstream-open-extid (extid-using-catalog (entdef-extid def)))) (setf (stream-name-entity-name (xstream-name r)) entity-name (stream-name-entity-kind (xstream-name r)) kind))) @@ -939,7 +943,7 @@ (defun checked-get-entdef (name type) (let ((def (get-entity-definition name type (dtd *ctx*)))) (unless def - (error "Entity '~A' is not defined." (rod-string name))) + (wf-error nil "Entity '~A' is not defined." (rod-string name))) def)) (defun xstream-open-extid (extid) @@ -955,9 +959,9 @@ :name (make-stream-name :uri sysid) :initial-speed 1))) -(defun call-with-entity-expansion-as-stream (zstream cont name kind) - ;; `zstream' is for error messages -- we need something better! - (let ((in (entity->xstream name kind zstream))) +(defun call-with-entity-expansion-as-stream (zstream cont name kind internalp) + ;; `zstream' is for error messages + (let ((in (entity->xstream zstream name kind internalp))) (unwind-protect (funcall cont in) (close-xstream in)))) @@ -984,7 +988,7 @@ ; (:ENUMERATION *) default ;default value of attribute: ; :REQUIRED, :IMPLIED, (:FIXED content) or (:DEFAULT content) - (external-p *markup-declaration-external-p*) + (external-p *external-subset-p*) ) (defstruct elmdef @@ -993,7 +997,7 @@ content ;content model [*] attributes ;list of defined attributes compiled-cspec ;cons of validation function for contentspec - (external-p *markup-declaration-external-p*) + (external-p *external-subset-p*) ) ;; [*] in XML it is possible to define attributes before the element @@ -1067,10 +1071,10 @@ (rod-string element-name))))))) (sax:element-declaration (handler *ctx*) element-name content-model) (setf (elmdef-content e) content-model) - (setf (elmdef-external-p e) *markup-declaration-external-p*) + (setf (elmdef-external-p e) *external-subset-p*) e)))) -(defvar *redefinition-warning* t) +(defvar *redefinition-warning* nil) (defun define-attribute (dtd element name type default) (let ((adef (make-attdef :element element @@ -1143,7 +1147,7 @@ (defun peek-token (input) (cond ((zstream-token-category input) - (values + (values (zstream-token-category input) (zstream-token-semantic input))) (t @@ -1199,15 +1203,15 @@ ((rune= #/\+ c) :\+) ((name-rune-p c) (unread-rune c input) - (values :name (read-name-token input))) + (values :nmtoken (read-name-token input))) ((rune= #/# c) (let ((q (read-name-token input))) - (cond ((equalp q '#.(string-rod "REQUIRED")) :|#REQUIRED|) - ((equalp q '#.(string-rod "IMPLIED")) :|#IMPLIED|) - ((equalp q '#.(string-rod "FIXED")) :|#FIXED|) - ((equalp q '#.(string-rod "PCDATA")) :|#PCDATA|) + (cond ((rod= q '#.(string-rod "REQUIRED")) :|#REQUIRED|) + ((rod= q '#.(string-rod "IMPLIED")) :|#IMPLIED|) + ((rod= q '#.(string-rod "FIXED")) :|#FIXED|) + ((rod= q '#.(string-rod "PCDATA")) :|#PCDATA|) (t - (error "Unknown token: ~S." q))))) + (wf-error zinput "Unknown token: ~S." q))))) ((or (rune= c #/U+0020) (rune= c #/U+0009) (rune= c #/U+000D) @@ -1220,28 +1224,34 @@ (t (values :%)))) (t - (error "Unexpected character ~S." c)))) + (wf-error zinput "Unexpected character ~S." c)))) (:DOC - (cond + (cond ((rune= c #/&) - (multiple-value-bind (kind data) (read-entity-ref input) - (cond ((eq kind :NAMED) - (values :ENTITY-REF data) ) - ((eq kind :NUMERIC) + (multiple-value-bind (kind data) (read-entity-like input) + (cond ((eq kind :ENTITY-REFERENCE) + (values :ENTITY-REF data)) + ((eq kind :CHARACTER-REFERENCE) (values :CDATA (with-rune-collector (collect) (%put-unicode-char data collect))))))) (t (unread-rune c input) - (values :CDATA (read-cdata input))) )))))))) + (values :CDATA (read-cdata input))))))))))) +(definline check-rune (input actual expected) + (unless (eql actual expected) + (wf-error input "expected #/~A but found #/~A" + (rune-char expected) + (rune-char actual)))) + (defun read-pe-reference (zinput) (let* ((input (car (zstream-input-stack zinput))) (nam (read-name-token input))) - (assert (rune= #/\; (read-rune input))) + (check-rune input #/\; (read-rune input)) (cond (*expand-pe-p* ;; no external entities here! - (let ((i2 (entity->xstream nam :parameter))) + (let ((i2 (entity->xstream zinput nam :parameter))) (zstream-push i2 zinput)) (values :S nil) ;space before inserted PE expansion. ) @@ -1251,36 +1261,45 @@ (defun read-token-after-|<| (zinput input) (let ((d (read-rune input))) (cond ((eq d :eof) - (error "EOF after '<'")) + (eox input "EOF after '<'")) ((rune= #/! d) (read-token-after-| in case of a named entity - or :NUMERIC in case of numeric entities. + either :ENTITY-REFERENCE in case of a named entity + or :CHARACTER-REFERENCE in case of character references. The initial #\\& is considered to be consumed already." (let ((c (peek-rune input))) (cond ((eq c :eof) - (error "EOF after '&'")) + (eox input "EOF after '&'")) ((rune= c #/#) - (values :NUMERIC (read-numeric-entity input))) + (values :CHARACTER-REFERENCE (read-character-reference input))) (t (unless (name-start-rune-p (peek-rune input)) - (error "Expecting name after &.")) + (wf-error input "Expecting name after &.")) (let ((name (read-name-token input))) (setf c (read-rune input)) (unless (rune= c #/\;) - (perror input "Expected \";\".")) - (values :NAMED name)))))) + (wf-error input "Expected \";\".")) + (values :ENTITY-REFERENCE name)))))) -(defsubst read-S? (input) - (while (member (peek-rune input) '(#/U+0020 #/U+0009 #/U+000A #/U+000D) - :test #'eq) - (consume-rune input))) - (defun read-tag-2 (zinput input kind) (let ((name (read-name-token input)) (atts nil)) @@ -1353,23 +1372,23 @@ (do ((q atts (cdr q))) ((null q)) (cond ((find (caar q) (cdr q) :key #'car) - (error "Attribute ~S has two definitions in element ~S." - (rod-string (caar q)) - (rod-string name))))) + (wf-error zinput "Attribute ~S has two definitions in element ~S." + (rod-string (caar q)) + (rod-string name))))) (cond ((eq (peek-rune input) #/>) (consume-rune input) (values kind (cons name atts))) ((eq (peek-rune input) #//) (consume-rune input) - (assert (rune= #/> (read-rune input))) + (check-rune input #/> (read-rune input)) (values :ztag (cons name atts))) (t - (error "syntax error in read-tag-2.")) ))) + (wf-error zinput "syntax error in read-tag-2.")) ))) (defun read-attribute (zinput input) (unless (name-start-rune-p (peek-rune input)) - (error "Expected name.")) + (wf-error zinput "Expected name.")) ;; arg thanks to the post mortem nature of name space declarations, ;; we could only process the attribute values post mortem. (let ((name (read-name-token input))) @@ -1381,7 +1400,7 @@ (rune= c #/U+000D)))) (consume-rune input)) (unless (eq (read-rune input) #/=) - (perror zinput "Expected \"=\".")) + (wf-error zinput "Expected \"=\".")) (while (let ((c (peek-rune input))) (and (not (eq c :eof)) (or (rune= c #/U+0020) @@ -1389,9 +1408,7 @@ (rune= c #/U+000A) (rune= c #/U+000D)))) (consume-rune input)) - (cons name (read-att-value-2 input)) - ;;(cons name (read-att-value zinput input :ATT t)) - )) + (cons name (read-att-value-2 input)))) (defun canon-not-cdata-attval (value) ;; | If the declared value is not CDATA, then the XML processor must @@ -1413,17 +1430,20 @@ (collect c)))) value)))) -(defsubst data-rune-p (rune) +(definline data-rune-p (rune) ;; any Unicode character, excluding the surrogate blocks, FFFE, and FFFF. + ;; + ;; FIXME: das halte ich fuer verkehrt. Surrogates als Unicode-Zeichen + ;; sind verboten. Das liegt hier aber nicht vor, denn wir arbeiten + ;; ja tatsaechlich mit UTF-16. Verboten ist es nur, wenn wir ein + ;; solches Zeichen beim Dekodieren finden, das wird aber eben + ;; in encodings.lisp bereits geprueft. --david (let ((c (rune-code rune))) (or (= c #x9) (= c #xA) (= c #xD) (<= #x20 c #xD7FF) (<= #xE000 c #xFFFD) - ;; (<= #xD800 c #xDBFF) - (<= #xDC00 c #xDFFF) - ;; - ))) + (<= #xDC00 c #xDFFF)))) (defun read-att-value (zinput input mode &optional canon-space-p (delim nil)) (with-rune-collector-2 (collect) @@ -1434,25 +1454,28 @@ (cond ((eql delim c) (return)) ((eq c :eof) - (error "EOF")) + (eox input "EOF")) ((rune= c #/&) (setf c (peek-rune input)) - (cond ((rune= c #/#) - (let ((c (read-numeric-entity 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 (peek-rune input)) - (error "Expecting name after &.")) + (wf-error zinput "Expecting name after &.")) (let ((name (read-name-token input))) (setf c (read-rune input)) - (assert (rune= c #/\;)) + (check-rune input c #/\;) (ecase mode (:ATT - (recurse-on-entity + (recurse-on-entity zinput name :general (lambda (zinput) (muffle (car (zstream-input-stack zinput)) - :eof)))) + :eof)) + t)) (:ENT ;; bypass, but never the less we ;; need to check for legal @@ -1463,72 +1486,85 @@ (map nil (lambda (x) (collect x)) name) (collect #/\; ))))))) ((and (eq mode :ENT) (rune= c #/%)) - (unless (name-start-rune-p (peek-rune input)) - (error "Expecting name after %.")) + (let ((d (peek-rune input))) + (when (eq d :eof) + (eox input)) + (unless (name-start-rune-p d) + (wf-error zinput "Expecting name after %."))) (let ((name (read-name-token input))) (setf c (read-rune input)) - (assert (rune= c #/\;)) + (check-rune input c #/\;) (cond (*expand-pe-p* - (recurse-on-entity + (recurse-on-entity zinput name :parameter (lambda (zinput) (muffle (car (zstream-input-stack zinput)) :eof)))) (t - (error "No PE here."))))) + (wf-error zinput "No PE here."))))) ((and (eq mode :ATT) (rune= c #/<)) - ;; xxx fix error message - (cerror "Eat them in spite of this." - "For no apparent reason #\/< is forbidden in attribute values. ~ - You lost -- next time choose SEXPR syntax.") - (collect c)) + (wf-error zinput "unexpected #\/<")) ((and canon-space-p (space-rune-p c)) (collect #/space)) ((not (data-rune-p c)) - (error "illegal char: ~S." c)) + (wf-error zinput "illegal char: ~S." c)) (t (collect c))))))) (declare (dynamic-extent #'muffle)) (muffle input (or delim (let ((delim (read-rune input))) - (assert (member delim '(#/\" #/\'))) + (unless (member delim '(#/\" #/\') :test #'eql) + (wf-error zinput "invalid attribute delimiter")) delim)))))) -(defun read-numeric-entity (input) - ;; xxx eof handling +(defun read-character-reference (input) ;; The #/& is already read (let ((res (let ((c (read-rune input))) - (assert (rune= c #/#)) + (check-rune input c #/#) (setq c (read-rune input)) - (cond ((rune= c #/x) + (cond ((eql c :eof) + (eox input)) + ((eql c #/x) ;; hexadecimal (setq c (read-rune input)) - (assert (digit-rune-p c 16)) + (when (eql c :eof) + (eox input)) + (unless (digit-rune-p c 16) + (wf-error input "garbage in character reference")) (prog1 (parse-integer (with-output-to-string (sink) (write-char (rune-char c) sink) - (while (digit-rune-p (setq c (read-rune input)) 16) + (while (progn + (setq c (read-rune input)) + (when (eql c :eof) + (eox input)) + (digit-rune-p c 16)) (write-char (rune-char c) sink))) :radix 16) - (assert (rune= c #/\;))) - ) + (check-rune input c #/\;))) ((rune<= #/0 c #/9) ;; decimal (prog1 (parse-integer (with-output-to-string (sink) (write-char (rune-char c) sink) - (while (rune<= #/0 (setq c (read-rune input)) #/9) + (while (progn + (setq c (read-rune input)) + (when (eql c :eof) + (eox input)) + (rune<= #/0 c #/9)) (write-char (rune-char c) sink))) :radix 10) - (assert (rune= c #/\;))) ) + (check-rune input c #/\;))) (t - (error "Bad char in numeric character entity.") ))))) + (wf-error input "Bad char in numeric character entity.")))))) (unless (code-data-char-p res) - (error "expansion of numeric character reference (#x~X) is no data char." - res)) + (wf-error + input + "expansion of numeric character reference (#x~X) is no data char." + res)) res)) (defun read-pi (input) @@ -1536,71 +1572,86 @@ (let (name) (let ((c (peek-rune input))) (unless (name-start-rune-p c) - (error "Expecting name after ')) + (wf-error input "malformed processing instruction")) + (values name ""))))) -(defun read-pi-content (input &aux d) +(defun read-pi-content (input) (read-S? input) + (let (d) + (with-rune-collector (collect) + (block nil + (tagbody + state-1 + (setf d (read-rune input)) + (when (eq d :eof) + (eox input)) + (unless (data-rune-p d) + (wf-error input "Illegal char: ~S." d)) + (when (rune= d #/?) (go state-2)) + (collect d) + (go state-1) + state-2 ;; #/? seen + (setf d (read-rune input)) + (when (eq d :eof) + (eox input)) + (unless (data-rune-p d) + (wf-error input "Illegal char: ~S." d)) + (when (rune= d #/>) (return)) + (when (rune= d #/?) + (collect #/?) + (go state-2)) + (collect #/?) + (collect d) + (go state-1)))))) + +(defun read-comment-content (input &aux d) (with-rune-collector (collect) (block nil (tagbody state-1 - (setf d (read-rune input)) - (unless (data-rune-p d) - (error "Illegal char: ~S." d)) - (when (rune= d #/?) (go state-2)) - (collect d) - (go state-1) - state-2 ;; #/? seen - (setf d (read-rune input)) - (unless (data-rune-p d) - (error "Illegal char: ~S." d)) - (when (rune= d #/>) (return)) - (when (rune= d #/?) - (collect #/?) - (go state-2)) - (collect #/?) - (collect d) - (go state-1))))) + (setf d (read-rune input)) + (when (eq d :eof) + (eox input)) + (unless (data-rune-p d) + (wf-error input "Illegal char: ~S." d)) + (when (rune= d #/-) (go state-2)) + (collect d) + (go state-1) + state-2 ;; #/- seen + (setf d (read-rune input)) + (when (eq d :eof) + (eox input)) + (unless (data-rune-p d) + (wf-error input "Illegal char: ~S." d)) + (when (rune= d #/-) (go state-3)) + (collect #/-) + (collect d) + (go state-1) + state-3 ;; #/- #/- seen + (setf d (read-rune input)) + (when (eq d :eof) + (eox input)) + (unless (data-rune-p d) + (wf-error input "Illegal char: ~S." d)) + (when (rune= d #/>) (return)) + (wf-error input "'--' not allowed in a comment") + (when (rune= d #/-) + (collect #/-) + (go state-3)) + (collect #/-) + (collect #/-) + (collect d) + (go state-1))))) -(defun read-comment-content (input &aux d) - (let ((warnedp nil)) - (with-rune-collector (collect) - (block nil - (tagbody - state-1 - (setf d (read-rune input)) - (unless (data-rune-p d) - (error "Illegal char: ~S." d)) - (when (rune= d #/-) (go state-2)) - (collect d) - (go state-1) - state-2 ;; #/- seen - (setf d (read-rune input)) - (unless (data-rune-p d) - (error "Illegal char: ~S." d)) - (when (rune= d #/-) (go state-3)) - (collect #/-) - (collect d) - (go state-1) - state-3 ;; #/- #/- seen - (setf d (read-rune input)) - (unless (data-rune-p d) - (error "Illegal char: ~S." d)) - (when (rune= d #/>) (return)) - (unless warnedp - (warn "WFC: no '--' in comments please.") - (setf warnedp t)) - (when (rune= d #/-) - (collect #/-) - (go state-3)) - (collect #/-) - (collect #/-) - (collect d) - (go state-1)))))) - (defun read-cdata-sect (input &aux d) ;; @@ -1609,23 +1660,29 @@ (tagbody state-1 (setf d (read-rune input)) + (when (eq d :eof) + (eox input)) (unless (data-rune-p d) - (error "Illegal char: ~S." d)) + (wf-error input "Illegal char: ~S." d)) (when (rune= d #/\]) (go state-2)) (collect d) (go state-1) state-2 ;; #/] seen (setf d (read-rune input)) + (when (eq d :eof) + (eox input)) (unless (data-rune-p d) - (error "Illegal char: ~S." d)) + (wf-error input "Illegal char: ~S." d)) (when (rune= d #/\]) (go state-3)) (collect #/\]) (collect d) (go state-1) state-3 ;; #/\] #/\] seen (setf d (read-rune input)) + (when (eq d :eof) + (eox input)) (unless (data-rune-p d) - (error "Illegal char: ~S." d)) + (wf-error input "Illegal char: ~S." d)) (when (rune= d #/>) (return)) (when (rune= d #/\]) @@ -1636,61 +1693,6 @@ (collect d) (go state-1))))) -#+(or) ;; FIXME: There is another definition below that looks more reasonable. -(defun read-cdata (input initial-char &aux d) - (cond ((not (data-rune-p initial-char)) - (error "Illegal char: ~S." initial-char))) - (with-rune-collector (collect) - (block nil - (tagbody - (cond ((rune= initial-char #/\]) - (go state-2)) - (t - (collect initial-char))) - state-1 - (setf d (peek-rune input)) - (when (or (eq d :eof) (rune= d #/<) (rune= d #/&)) - (return)) - (read-rune input) - (unless (data-rune-p d) - (error "Illegal char: ~S." d)) - (when (rune= d #/\]) (go state-2)) - (collect d) - (go state-1) - - state-2 ;; #/\] seen - (setf d (peek-rune input)) - (when (or (eq d :eof) (rune= d #/<) (rune= d #/&)) - (collect #/\]) - (return)) - (read-rune input) - (unless (data-rune-p d) - (error "Illegal char: ~S." d)) - (when (rune= d #/\]) (go state-3)) - (collect #/\]) - (collect d) - (go state-1) - - state-3 ;; #/\] #/\] seen - (setf d (peek-rune input)) - (when (or (eq d :eof) (rune= d #/<) (rune= d #/&)) - (collect #/\]) - (collect #/\]) - (return)) - (read-rune input) - (unless (data-rune-p d) - (error "Illegal char: ~S." d)) - (when (rune= d #/>) - (error "For no apparent reason ']]>' in not allowed in a CharData token -- you lost.")) - (when (rune= d #/\]) - (collect #/\]) - (go state-3)) - (collect #/\]) - (collect #/\]) - (collect d) - (go state-1))))) - - ;; some character categories (defun space-rune-p (rune) @@ -1720,7 +1722,7 @@ (defun expect (input category) (multiple-value-bind (cat sem) (read-token input) (unless (eq cat category) - (error "Expected ~S saw ~S [~S]" category cat sem)) + (wf-error input "Expected ~S saw ~S [~S]" category cat sem)) (values cat sem))) (defun consume-token (input) @@ -1741,15 +1743,21 @@ (while (eq (peek-token input) :S) (consume-token input))) +(defun p/nmtoken (input) + (nth-value 1 (expect input :nmtoken))) + (defun p/name (input) - (nth-value 1 (expect input :name))) + (let ((result (p/nmtoken input))) + (unless (name-start-rune-p (elt result 0)) + (wf-error input "Expected name.")) + result)) (defun p/attlist-decl (input) ;; [52] AttlistDecl ::= '' (let (elm-name) (expect input :| (return)) (otherwise - (error "Expected either another AttDef or end of \") (when *validate* @@ -2071,9 +2080,9 @@ ;;; to indicate whether the end tag is valid. ;;; ;;; Function B will be called with the character data rod as its argument, it -;;; returns a boolean indicating whether this text element is allowed. +;;; returns a boolean indicating whether this text node is allowed. ;;; -;;; That is, if one of the functions ever returns NIL, the element is +;;; That is, if one of the functions ever returns NIL, the node is ;;; rejected as invalid. (defun cmodel-done (actual-value) @@ -2171,27 +2180,29 @@ ((and (walk (car x)) (walk (cdr x))))))) (walk cspec)))) - + ;; wir fahren besser, wenn wir machen: -;; cspec ::= 'EMPTY' | 'ANY' | '#PCDATA' +;; cspec ::= 'EMPTY' | 'ANY' | '#PCDATA' ;; | Name ;; | cs ;; cs ::= '(' S? cspec ( S? '|' S? cspec)* S? ')' ('?' | '*' | '+')? -;; und eine post mortem analyse +;; und eine post factum analyse -(defun p/cspec (input) +(defun p/cspec (input &optional recursivep) (let ((term (let ((names nil) op-cat op res stream) (multiple-value-bind (cat sem) (peek-token input) - (cond ((eq cat :name) - (consume-token input) + (cond ((eq cat :nmtoken) + (consume-token input) (cond ((rod= sem '#.(string-rod "EMPTY")) :EMPTY) ((rod= sem '#.(string-rod "ANY")) :ANY) - (t - sem))) + ((not recursivep) + (wf-error input "invalid content spec")) + (t + sem))) ((eq cat :\#PCDATA) (consume-token input) :PCDATA) @@ -2199,7 +2210,7 @@ (setf stream (car (zstream-input-stack input))) (consume-token input) (p/S? input) - (setq names (list (p/cspec input))) + (setq names (list (p/cspec input t))) (p/S? input) (cond ((member (peek-token input) '(:\| :\,)) (setf op-cat (peek-token input)) @@ -2207,7 +2218,7 @@ (while (eq (peek-token input) op-cat) (consume-token input) (p/S? input) - (push (p/cspec input) names) + (push (p/cspec input t) names) (p/S? input)) (setf res (cons op (reverse names)))) (t @@ -2219,7 +2230,7 @@ (validity-error "(06) Proper Group/PE Nesting"))) res) (t - (error "p/cspec - ~s / ~s" cat sem))))))) + (wf-error input "p/cspec - ~s / ~s" cat sem))))))) (cond ((eq (peek-token input) :?) (consume-token input) (list '? term)) ((eq (peek-token input) :+) (consume-token input) (list '+ term)) ((eq (peek-token input) :*) (consume-token input) (list '* term)) @@ -2245,14 +2256,14 @@ (trivialp (cadr cspec))))) :PCDATA cspec))) - + ;; [52] AttlistDecl ::= '' - + ;; [52] AttlistDecl ::= '' ;; [52] AttlistDecl ::= '' ;; [53] AttDefs ::= S Name S AttType S DefaultDecl AttDefs -;; [53] AttDefs ::= +;; [53] AttDefs ::= (defun p/notation-decl (input) (let (name id) @@ -2269,6 +2280,8 @@ (normalize-public-id (extid-public id)) nil) (uri-rod (extid-system id))) + (when (and sax:*namespace-processing* (find #/: name)) + (wf-error input "colon in notation name")) (when *validate* (define-notation (dtd *ctx*) name id)) (list :notation-decl name id))) @@ -2299,14 +2312,14 @@ (let ((stream (car (zstream-input-stack input)))) (p/S? input) (multiple-value-bind (cat sem) (read-token input) - (cond ((and (eq cat :name) + (cond ((and (eq cat :nmtoken) (rod= sem '#.(string-rod "INCLUDE"))) (p/include-sect input stream)) - ((and (eq cat :name) + ((and (eq cat :nmtoken) (rod= sem '#.(string-rod "IGNORE"))) (p/ignore-sect input stream)) (t - (error "Expected INCLUDE or IGNORE after \""))) + (eox input "EOF in "))) (cond ((and (rune= c3 #/<) (rune= c2 #/!) (rune= c1 #/\[)) (incf level))) (cond ((and (rune= c3 #/\]) (rune= c2 #/\]) (rune= c1 #/>)) @@ -2353,7 +2366,7 @@ (:eof (return)) ((:|) (when extid @@ -2501,7 +2518,8 @@ (let ((dtd (dtd *ctx*))) (sax:entity-resolver (handler *ctx*) - (lambda (name handler) (resolve-entity name handler dtd)))) + (lambda (name handler) (resolve-entity name handler dtd))) + (sax::dtd (handler *ctx*) dtd)) (list :DOCTYPE name extid)))) (defun report-cached-dtd (dtd) @@ -2528,17 +2546,29 @@ (:COMMENT (sax:comment (handler *ctx*) (nth-value 1 (peek-token input)))) (:PI - (sax:processing-instruction + (sax:processing-instruction (handler *ctx*) (car (nth-value 1 (peek-token input))) (cdr (nth-value 1 (peek-token input)))))) (consume-token input))) - + (defun p/document (input handler - &key validate dtd root entity-resolver disallow-internal-subset) + &key validate dtd root entity-resolver disallow-internal-subset + (recode t)) + ;; check types of user-supplied arguments for better error messages: + (check-type validate boolean) + (check-type recode boolean) + (check-type dtd (or null extid)) + (check-type root (or null rod)) + (check-type entity-resolver (or null function symbol)) + (check-type disallow-internal-subset boolean) + #+rune-is-integer + (when recode + (setf handler (make-recoder handler #'rod-to-utf8-string))) (let ((*ctx* (make-context :handler handler + :main-zstream input :entity-resolver entity-resolver :disallow-internal-subset disallow-internal-subset)) (*validate* validate)) @@ -2551,8 +2581,8 @@ ;; we will use the attribute-value parser for the xml decl. (let ((*data-behaviour* :DTD)) ;; optional XMLDecl? - (cond ((eq (peek-token input) :xml-pi) - (let ((hd (parse-xml-pi (cdr (nth-value 1 (peek-token input))) t))) + (cond ((eq (peek-token input) :xml-decl) + (let ((hd (parse-xml-decl (cdr (nth-value 1 (peek-token input)))))) (setf (standalone-p *ctx*) (eq (xml-header-standalone-p hd) :yes)) (setup-encoding input hd)) (read-token input))) @@ -2580,87 +2610,75 @@ (setf (model-stack *ctx*) (list (make-root-model root)))) ;; element (let ((*data-behaviour* :DOC)) + (when (eq (peek-token input) :seen-<) + (multiple-value-bind (c s) + (read-token-after-|<| input (car (zstream-input-stack input))) + (setf (zstream-token-category input) c + (zstream-token-semantic input) s))) (p/element input)) ;; optional Misc* (p/misc*-2 input) (unless (eq (peek-token input) :eof) - (error "Garbage at end of document.")) + (wf-error input "Garbage at end of document.")) (when *validate* (maphash (lambda (k v) (unless v (validity-error "(11) IDREF: ~S not defined" (rod-string k)))) (id-table *ctx*)) - - (dolist (name (referenced-notations *ctx*)) + + (dolist (name (referenced-notations *ctx*)) (unless (find-notation name (dtd *ctx*)) - (validity-error "(23) Notation Declared: ~S" (rod-string name))))) + (validity-error "(23) Notation Declared: ~S" (rod-string name))))) (sax:end-document handler)))) (defun p/element (input) - (if sax:*namespace-processing* - (p/element-ns input) - (p/element-no-ns input))) - -(defun p/element-no-ns (input) - ;; [39] element ::= EmptyElemTag | STag content ETag - (error "sorry, bitrot") - #+(or) (multiple-value-bind (cat sem) (read-token input) - (cond ((eq cat :ztag) - (sax:start-element (handler *ctx*) nil nil (car sem) (build-attribute-list-no-ns (cdr sem))) - (sax:end-element (handler *ctx*) nil nil (car sem))) - - ((eq cat :stag) - (sax:start-element (handler *ctx*) nil nil (car sem) (build-attribute-list-no-ns (cdr sem))) - (p/content input) - (multiple-value-bind (cat2 sem2) (read-token input) - (unless (and (eq cat2 :etag) - (eq (car sem2) (car sem))) - (perror input "Bad nesting. ~S / ~S" (mu sem) (mu (cons cat2 sem2))))) - (sax:end-element (handler *ctx*) nil nil (car sem))) - - (t - (error "Expecting element."))))) - - -(defun p/element-ns (input) - (destructuring-bind (cat (name &rest attrs)) - (multiple-value-list (read-token input)) - (validate-start-element *ctx* name) - (let ((ns-decls (declare-namespaces name attrs))) - (multiple-value-bind (ns-uri prefix local-name) (decode-qname name) - (declare (ignore prefix)) - (let* ((raw-attlist (build-attribute-list-ns attrs)) - (attlist - (remove-if-not (lambda (a) - (or sax:*include-xmlns-attributes* - (not (xmlns-attr-p (sax:attribute-qname a))))) - (process-attributes *ctx* name raw-attlist)))) - (cond ((eq cat :ztag) - (sax:start-element (handler *ctx*) ns-uri local-name name attlist) - (sax:end-element (handler *ctx*) ns-uri local-name name)) + (case cat + ((:stag :ztag)) + (:eof (eox input)) + (t (wf-error input "element expected"))) + (destructuring-bind (&optional name &rest raw-attrs) sem + (validate-start-element *ctx* name) + (let* ((attrs + (process-attributes *ctx* name (build-attribute-list raw-attrs))) + (*namespace-bindings* *namespace-bindings*) + new-namespaces) + (when sax:*namespace-processing* + (setf new-namespaces (declare-namespaces attrs)) + (mapc #'set-attribute-namespace attrs)) + (multiple-value-bind (uri prefix local-name) + (if sax:*namespace-processing* + (decode-qname name) + (values nil nil nil)) + (declare (ignore prefix)) + (check-attribute-uniqueness attrs) + (unless (or sax:*include-xmlns-attributes* + (null sax:*namespace-processing*)) + (setf attrs + (remove-if (compose #'xmlns-attr-p #'sax:attribute-qname) + attrs))) + (cond + ((eq cat :ztag) + (sax:start-element (handler *ctx*) uri local-name name attrs) + (sax:end-element (handler *ctx*) uri local-name name)) - ((eq cat :stag) - (sax:start-element (handler *ctx*) ns-uri local-name name attlist) - (p/content input) - (multiple-value-bind (cat2 sem2) (read-token input) - (unless (and (eq cat2 :etag) - (eq (car sem2) name)) - (perror input "Bad nesting. ~S / ~S" (mu name) (mu (cons cat2 sem2))))) - (sax:end-element (handler *ctx*) ns-uri local-name name)) + ((eq cat :stag) + (sax:start-element (handler *ctx*) uri local-name name attrs) + (p/content input) + (multiple-value-bind (cat2 sem2) (read-token input) + (unless (and (eq cat2 :etag) + (eq (car sem2) name)) + (wf-error input "Bad nesting. ~S / ~S" + (mu name) + (mu (cons cat2 sem2)))) + (when (cdr sem2) + (wf-error input "no attributes allowed in end tag"))) + (sax:end-element (handler *ctx*) uri local-name name)) - (t - (error "Expecting element, got ~S." cat))))) - (undeclare-namespaces ns-decls)) - (validate-end-element *ctx* name))) - -(defun perror (stream format-string &rest format-args) - (when (zstream-p stream) - (setf stream (car (zstream-input-stack stream)))) - (error "Parse error at line ~D column ~D: ~A" - (xstream-line-number stream) - (xstream-column-number stream) - (apply #'format nil format-string format-args))) + (t + (wf-error input "Expecting element, got ~S." cat)))) + (undeclare-namespaces new-namespaces)) + (validate-end-element *ctx* name)))) (defun p/content (input) ;; [43] content ::= (element | CharData | Reference | CDSect | PI | Comment)* @@ -2671,13 +2689,15 @@ (p/content input)) ((:CDATA) (consume-token input) + (when (search #"]]>" sem) + (wf-error input "']]>' not allowed in CharData")) (validate-characters *ctx* sem) (sax:characters (handler *ctx*) sem) (p/content input)) ((:ENTITY-REF) (let ((name sem)) (consume-token input) - (append ;; nil #+(OR) + (append (recurse-on-entity input name :general (lambda (input) (prog1 @@ -2685,11 +2705,12 @@ (internal-entdef (p/content input)) (external-entdef (p/ext-parsed-ent input))) (unless (eq (peek-token input) :eof) - (error "Trailing garbage. - ~S" (peek-token input)))))) + (wf-error input "Trailing garbage. - ~S" + (peek-token input)))))) (p/content input)))) ((:' content - (when (eq (peek-token input) :xml-pi) - (let ((hd (parse-xml-pi (cdr (nth-value 1 (peek-token input))) nil))) + (when (eq (peek-token input) :xml-decl) + (let ((hd (parse-text-decl (cdr (nth-value 1 (peek-token input)))))) (setup-encoding input hd)) - (consume-token input) ) + (consume-token input)) (set-full-speed input) (p/content input)) -(defun parse-xml-pi (content sd-ok-p) - ;; --> xml-header - ;;(make-xml-header)) +(defun parse-xml-decl (content) (let* ((res (make-xml-header)) (i (make-rod-xstream content)) - (atts (read-attribute-list 'foo i t))) ;xxx on 'foo + (z (make-zstream :input-stack (list i))) + (atts (read-attribute-list z i t))) (unless (eq (peek-rune i) :eof) - (error "Garbage at end of XML PI.")) + (wf-error i "Garbage at end of XMLDecl.")) ;; versioninfo muss da sein - ;; dann ? encodingdecl + ;; dann ? encodingdecl ;; dann ? sddecl ;; dann ende - (when (and (not (eq (caar atts) (intern-name '#.(string-rod "version")))) - sd-ok-p) - (error "XML PI needs version.")) - (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))) - (error "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 "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) @@ -2772,30 +2790,72 @@ (cdar atts)) ((lambda (x) (or (rune<= #/a x #/z) - (rune<= #/A x #/Z) - (rune<= #/0 x #/9))) + (rune<= #/A x #/Z))) (aref (cdar atts) 0))) - (error "Bad XML encoding name: ~S." (rod-string (cdar atts)))) + (wf-error i "Bad XML encoding name: ~S." (rod-string (cdar atts)))) (setf (xml-header-encoding res) (rod-string (cdar atts))) (pop atts)) - (when (and sd-ok-p (eq (caar atts) (intern-name '#.(string-rod "standalone")))) + (when (eq (caar atts) (intern-name '#.(string-rod "standalone"))) (unless (or (rod= (cdar atts) '#.(string-rod "yes")) (rod= (cdar atts) '#.(string-rod "no"))) - (error "Hypersensitivity pitfall: ~ - XML PI's 'standalone' attribute must be exactly \"yes\" or \"no\" and not ~S." + (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)) + (setf (xml-header-standalone-p res) + (if (rod-equal '#.(string-rod "yes") (cdar atts)) + :yes + :no)) (pop atts)) (when atts - (error "XML designers decided to disallow future extensions to the set ~ - of allowed XML PI's attributes -- you might have lost big on ~S (~S)" - (rod-string content) sd-ok-p - )) + (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))) + res)) + ;;;; --------------------------------------------------------------------------- ;;;; mu ;;;; @@ -2838,7 +2898,7 @@ (dolist (pair pairs) (if first (setf first nil) - (write-char #\& s)) + (write-char #\& s)) (write-string (escape (car pair)) s) (write-char #\= s) (write-string (escape (cdr pair)) s)))))) @@ -2875,7 +2935,7 @@ (make-uri :path path) (make-uri :scheme :file :host (concatenate 'string - (specific-or (pathname-host pathname)) + (string-or (host-namestring pathname)) "+" (specific-or (pathname-device pathname))) :path path)))) @@ -2892,14 +2952,13 @@ (let ((scheme (puri:uri-scheme uri)) (path (puri:uri-parsed-path uri))) (unless (member scheme '(nil :file)) - (error 'parser-error + (error 'xml-parse-error :format-control "URI scheme ~S not supported" :format-arguments (list scheme))) (if (eq (car path) :relative) (multiple-value-bind (name type) (parse-name.type (car (last path))) - (make-pathname :host "" - :directory (butlast path) + (make-pathname :directory (butlast path) :name name :type type)) (multiple-value-bind (name type) @@ -2907,17 +2966,21 @@ (destructuring-bind (host device) (split-sequence-if (lambda (x) (eql x #\+)) (or (puri:uri-host uri) "+")) - (make-pathname :host host + (make-pathname :host (string-or host) :device (string-or device) :directory (cons :absolute (butlast (cdr path))) :name name :type type)))))) (defun parse-xstream (xstream handler &rest args) - (let ((zstream (make-zstream :input-stack (list xstream)))) - (peek-rune xstream) - (with-scratch-pads () - (apply #'p/document zstream handler args)))) + (let ((*ctx* nil)) + (handler-case + (let ((zstream (make-zstream :input-stack (list xstream)))) + (peek-rune xstream) + (with-scratch-pads () + (apply #'p/document zstream handler args))) + (runes-encoding:encoding-error (c) + (wf-error xstream "~A" c))))) (defun parse-file (filename handler &rest args) (with-open-xfile (input filename) @@ -2925,7 +2988,7 @@ (make-stream-name :entity-name "main document" :entity-kind :main - :uri (pathname-to-uri filename))) + :uri (pathname-to-uri (merge-pathnames filename)))) (apply #'parse-xstream input handler args))) (defun resolve-synonym-stream (stream) @@ -2934,13 +2997,16 @@ stream) (defun safe-stream-sysid (stream) - (if (typep (resolve-synonym-stream stream) 'file-stream) - (pathname-to-uri (pathname stream)) + (if (and (typep (resolve-synonym-stream stream) 'file-stream) + ;; ignore-errors, because sb-bsd-sockets creates instances of + ;; FILE-STREAMs that aren't + (ignore-errors (pathname stream))) + (pathname-to-uri (merge-pathnames (pathname stream))) nil)) (defun parse-stream (stream handler &rest args) (let ((xstream - (make-xstream + (make-xstream stream :name (make-stream-name :entity-name "main document" @@ -2949,11 +3015,69 @@ :initial-speed 1))) (apply #'parse-xstream xstream handler args))) -(defun parse-dtd-file (filename) +(defun parse-empty-document + (uri qname handler &key public-id system-id entity-resolver (recode t)) + (check-type uri (or null rod)) + (check-type qname (or null rod)) + (check-type public-id (or null rod)) + (check-type system-id (or null puri:uri)) + (check-type entity-resolver (or null function symbol)) + (check-type recode boolean) + #+rune-is-integer + (when recode + (setf handler (make-recoder handler #'rod-to-utf8-string))) + (let ((*ctx* + (make-context :handler handler :entity-resolver entity-resolver)) + (*validate* nil) + (extid + (when (or public-id system-id) + (extid-using-catalog (make-extid public-id system-id))))) + (sax:start-document handler) + (when extid + (sax:start-dtd handler + qname + (and public-id) + (and system-id (uri-rod system-id))) + (setf (dtd *ctx*) (getdtd (extid-system extid) *dtd-cache*)) + (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))))) + (sax:end-dtd handler) + (let ((dtd (dtd *ctx*))) + (sax:entity-resolver handler (lambda (n h) (resolve-entity n h dtd))) + (sax::dtd handler dtd))) + (ensure-dtd) + (when (or uri qname) + (let* ((attrs + (when uri + (list (sax:make-attribute :qname #"xmlns" + :value (rod uri) + :specified-p t)))) + (*namespace-bindings* *namespace-bindings*) + new-namespaces) + (when sax:*namespace-processing* + (setf new-namespaces (declare-namespaces attrs)) + (mapc #'set-attribute-namespace attrs)) + (multiple-value-bind (uri prefix local-name) + (if sax:*namespace-processing* (decode-qname qname) nil) + (declare (ignore prefix)) + (unless (or sax:*include-xmlns-attributes* + (null sax:*namespace-processing*)) + (setf attrs nil)) + (sax:start-element (handler *ctx*) uri local-name qname attrs) + (sax:end-element (handler *ctx*) uri local-name qname)) + (undeclare-namespaces new-namespaces))) + (sax:end-document handler))) + +(defun parse-dtd-file (filename &optional handler) (with-open-file (s filename :element-type '(unsigned-byte 8)) - (parse-dtd-stream s))) + (parse-dtd-stream s handler))) -(defun parse-dtd-stream (stream) +(defun parse-dtd-stream (stream &optional handler) (let ((input (make-xstream stream))) (setf (xstream-name input) (make-stream-name @@ -2961,7 +3085,7 @@ :entity-kind :main :uri (safe-stream-sysid stream))) (let ((zstream (make-zstream :input-stack (list input))) - (*ctx* (make-context :handler nil)) + (*ctx* (make-context :handler handler)) (*validate* t) (*data-behaviour* :DTD)) (with-scratch-pads () @@ -2970,18 +3094,20 @@ (p/ext-subset zstream) (dtd *ctx*))))) -(defun parse-string (string handler) - ;; XXX this function mis-handles encoding - (with-scratch-pads () - (let* ((x (string->xstream string)) - (z (make-zstream :input-stack (list x)))) - (p/document z handler)))) +(defun parse-rod (string handler &rest args) + (let ((xstream (string->xstream string))) + (setf (xstream-name xstream) + (make-stream-name + :entity-name "main document" + :entity-kind :main + :uri nil)) + (apply #'parse-xstream xstream handler args))) (defun string->xstream (string) - ;; XXX encoding is mis-handled by this kind of stream (make-rod-xstream (string-rod string))) -(defclass octet-input-stream (fundamental-binary-input-stream) +(defclass octet-input-stream + (trivial-gray-stream-mixin fundamental-binary-input-stream) ((octets :initarg :octets) (pos :initform 0))) @@ -2997,8 +3123,8 @@ (elt octets pos) (incf pos))))) -(defmethod stream-read-sequence ((stream octet-input-stream) sequence - &optional (start 0) (end (length sequence))) +(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)) @@ -3015,20 +3141,6 @@ ;;;; -#+allegro -(defmacro sp (&body body) - `(progn - (prof:with-profiling (:type :space) .,body) - (prof:show-flat-profile))) - -#+allegro -(defmacro tm (&body body) - `(progn - (prof:with-profiling (:type :time) .,body) - (prof:show-flat-profile))) - -;;;; - (defun zstream-push (new-xstream zstream) (cond ((find-if (lambda (x) (and (xstream-p x) @@ -3037,14 +3149,12 @@ (eql (stream-name-entity-kind (xstream-name x)) (stream-name-entity-kind (xstream-name new-xstream))))) (zstream-input-stack zstream)) - (error "Infinite recursion."))) + (wf-error zstream "Infinite recursion."))) (push new-xstream (zstream-input-stack zstream)) zstream) -(defun recurse-on-entity (zstream name kind continuation) +(defun recurse-on-entity (zstream name kind continuation &optional internalp) (assert (not (zstream-token-category zstream))) - ;;(sleep .2) - ;;(warn "~S / ~S[~S]." (zstream-input-stack zstream) (mu name) kind) (call-with-entity-expansion-as-stream zstream (lambda (new-xstream) @@ -3058,115 +3168,10 @@ (assert (eq (pop (zstream-input-stack zstream)) :stop)) (setf (zstream-token-category zstream) nil) '(consume-token zstream)) ) - name kind)) + name + kind + internalp)) -;;;; - -#| - -(defparameter *test-files* - '(;;"jclark:xmltest;not-wf;*;*.xml" - "jclark:xmltest;valid;*;*.xml" - ;;"jclark:xmltest;invalid;*.xml" - )) - -(defun run-all-tests (&optional (test-files *test-files*)) - (let ((failed nil)) - (dolist (k test-files) - (dolist (j (sort (directory k) #'string< :key #'pathname-name)) - (unless (test-file j) - (push j failed)))) - (fresh-line) - (cond (failed - (write-string "**** Test failed on") - (dolist (k failed) - (format t "~%**** ~S." k)) - nil) - (t - (write-string "**** Test passed!") - t)))) - -(defun test-file (filename) - (let ((out-filename (merge-pathnames "out/" filename))) - (if (probe-file out-filename) - (positive-test-file filename out-filename) - (negative-test-file filename)))) - -(defun positive-test-file (filename out-filename) - (multiple-value-bind (nodes condition) - (ignore-errors (parse-file filename)) - (cond (condition - (warn "**** Error in ~S: ~A." filename condition) - nil) - (t - (let (res equal?) - (setf res (with-output-to-string (sink) - (unparse-document nodes sink))) - (setf equal? - (with-open-file (in out-filename :direction :input :element-type 'character) - (do ((i 0 (+ i 1)) - (c (read-char in nil nil) (read-char in nil nil))) - ((or (eq c nil) (= i (length res))) - (and (eq c nil) (= i (length res)))) - (unless (eql c (char res i)) - (return nil))))) - (cond ((not equal?) - (format t "~&**** Test failed on ~S." filename) - (fresh-line) - (format t "** me: ~A" res) - (fresh-line) - (format t "** he: " res) - (finish-output) - (with-open-file (in out-filename :direction :input :element-type 'character) - (do ((c (read-char in nil nil) (read-char in nil nil))) - ((eq c nil)) - (write-char c))) - nil) - (t - t))))))) - -(defun negative-test-file (filename) - (multiple-value-bind (nodes condition) - (ignore-errors (parse-file filename)) - (declare (ignore nodes)) - (cond (condition - t) - (t - (warn "**** negative test failed on ~S." filename))))) - -|# - -;;;; - -#+(or) ;was ist das? -(progn - - (defmethod dom:create-processing-instruction ((document null) target data) - (declare (ignorable document target data)) - nil) - - (defmethod dom:append-child ((node null) child) - (declare (ignorable node child)) - nil) - - (defmethod dom:create-element ((document null) name) - (declare (ignorable document name)) - nil) - - (defmethod dom:set-attribute ((document null) name value) - (declare (ignorable document name value)) - nil) - - (defmethod dom:create-text-node ((document null) data) - (declare (ignorable document data)) - nil) - - (defmethod dom:create-cdata-section ((document null) data) - (declare (ignorable document data)) - nil) - ) - - #|| (defmacro read-data-until* ((predicate input res res-start res-end) &body body) ;; fast variant -- for now disabled for no apparent reason @@ -3218,17 +3223,14 @@ (t we continue (sf rptr (%+ rptr 1))) )) - , at body )) + , at body )) ||# -;(defun read-data-until (predicate input continuation) -; ) - (defmacro read-data-until* ((predicate input res res-start res-end) &body body) - "Read data from `input' until `predicate' applied to the read char + "Read data from `input' until `predicate' applied to the read char turns true. Then execute `body' with `res', `res-start', `res-end' bound to denote a subsequence (of RUNEs) containing the read portion. - The rune upon which `predicate' turned true is neither consumed from + The rune upon which `predicate' turned true is neither consumed from the stream, nor included in `res'. Keep the predicate short, this it may be included more than once into @@ -3238,11 +3240,11 @@ (collect (gensym)) (c (gensym))) `(LET ((,input-var ,input)) - (MULTIPLE-VALUE-BIND (,res ,res-start ,res-end) + (MULTIPLE-VALUE-BIND (,res ,res-start ,res-end) (WITH-RUNE-COLLECTOR/RAW (,collect) (LOOP (LET ((,c (PEEK-RUNE ,input-var))) - (COND ((EQ ,c :EOF) + (COND ((EQ ,c :EOF) ;; xxx error message (RETURN)) ((FUNCALL ,predicate ,c) @@ -3252,11 +3254,11 @@ (CONSUME-RUNE ,input-var)))))) (LOCALLY , at body))))) - + (defun read-name-token (input) (read-data-until* ((lambda (rune) (declare (type rune rune)) - (not (name-rune-p rune))) + (not (name-rune-p rune))) input r rs re) (intern-name r rs re))) @@ -3264,6 +3266,11 @@ (defun read-cdata (input) (read-data-until* ((lambda (rune) (declare (type rune rune)) + (when (and (%rune< rune #/U+0020) + (not (or (%rune= rune #/U+0009) + (%rune= rune #/U+000a) + (%rune= rune #/U+000d)))) + (wf-error input "code point invalid: ~A" rune)) (or (%rune= rune #/<) (%rune= rune #/&))) input source start end) @@ -3286,9 +3293,9 @@ (defun internal-entity-expansion (name) (let ((def (get-entity-definition name :general (dtd *ctx*)))) (unless def - (error "Entity '~A' is not defined." (rod-string name))) + (wf-error nil "Entity '~A' is not defined." (rod-string name))) (unless (typep def 'internal-entdef) - (error "Entity '~A' is not an internal entity." name)) + (wf-error nil "Entity '~A' is not an internal entity." name)) (or (entdef-expansion def) (setf (entdef-expansion def) (find-internal-entity-expansion name))))) @@ -3303,33 +3310,31 @@ (return)) ((rune= c #/&) (setf c (peek-rune input)) - (cond ((rune= c #/#) - (let ((c (read-numeric-entity 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 (peek-rune input)) - (error "Expecting name after &.")) + (unless (name-start-rune-p c) + (wf-error zinput "Expecting name after &.")) (let ((name (read-name-token input))) (setf c (read-rune input)) - (assert (rune= c #/\;)) - (recurse-on-entity + (check-rune input c #/\;) + (recurse-on-entity zinput name :general (lambda (zinput) (muffle (car (zstream-input-stack zinput))))))))) - ((and (rune= c #/<)) - ;; xxx fix error message - (cerror "Eat them in spite of this." - "For no apparent reason #\/< is forbidden in attribute values. ~ - You lost -- next time choose SEXPR syntax.") - (collect c)) + ((rune= c #/<) + (wf-error zinput "unexpected #\/<")) ((space-rune-p c) (collect #/space)) ((not (data-rune-p c)) - (error "illegal char: ~S." c)) + (wf-error zinput "illegal char: ~S." c)) (t (collect c))))))) (declare (dynamic-extent #'muffle)) - (recurse-on-entity + (recurse-on-entity zinput name :general (lambda (zinput) (muffle (car (zstream-input-stack zinput))))) )))) @@ -3349,27 +3354,33 @@ (internal-entdef (p/content input)) (external-entdef (p/ext-parsed-ent input))) (unless (eq (peek-token input) :eof) - (error "Trailing garbage. - ~S" (peek-token input)))))))) + (wf-error input "Trailing garbage. - ~S" + (peek-token input)))))))) nil))) (defun read-att-value-2 (input) (let ((delim (read-rune input))) + (when (eql delim :eof) + (eox input)) (unless (member delim '(#/\" #/\') :test #'eql) - (error "Bad attribute value delimiter ~S, must be either #\\\" or #\\\'." - (if (< delim char-code-limit) (code-char delim) delim))) + (wf-error input + "Bad attribute value delimiter ~S, must be either #\\\" or #\\\'." + (rune-char delim))) (with-rune-collector-4 (collect) (loop (let ((c (read-rune input))) (cond ((eq c :eof) - (error "EOF")) + (eox input "EOF")) ((rune= c delim) (return)) + ((rune= c #/<) + (wf-error input "'<' not allowed in attribute values")) ((rune= #/& c) - (multiple-value-bind (kind sem) (read-entity-ref input) + (multiple-value-bind (kind sem) (read-entity-like input) (ecase kind - (:NUMERIC + (:CHARACTER-REFERENCE (%put-unicode-char sem collect)) - (:NAMED + (:ENTITY-REFERENCE (let* ((exp (internal-entity-expansion sem)) (n (length exp))) (declare (type (simple-array rune (*)) exp)) @@ -3385,16 +3396,12 @@ ;;; Namespace stuff -(defvar *default-namespace-bindings* - '((#"" . nil) - (#"xmlns" . #"http://www.w3.org/2000/xmlns/") - (#"xml" . #"http://www.w3.org/XML/1998/namespace"))) - ;; We already know that name is part of a valid XML name, so all we ;; have to check is that the first rune is a name-start-rune and that ;; there is not colon in it. (defun nc-name-p (name) - (and (name-start-rune-p (rune name 0)) + (and (plusp (length name)) + (name-start-rune-p (rune name 0)) (notany #'(lambda (rune) (rune= #/: rune)) name))) (defun split-qname (qname) @@ -3403,11 +3410,14 @@ (if pos (let ((prefix (subseq qname 0 pos)) (local-name (subseq qname (1+ pos)))) + (when (zerop pos) + (wf-error nil "empty namespace prefix")) (if (nc-name-p local-name) (values prefix local-name) - (error "~S is not a valid NcName." local-name))) + (wf-error nil "~S is not a valid NcName." + (rod-string local-name)))) (values () qname)))) - + (defun decode-qname (qname) "decode-qname name => namespace-uri, prefix, local-name" (declare (type runes:simple-rod qname)) @@ -3415,12 +3425,12 @@ (let ((uri (find-namespace-binding prefix))) (if uri (values uri prefix local-name) - (values nil nil nil))))) + (values nil nil qname))))) (defun find-namespace-binding (prefix) - (cdr (or (assoc (or prefix #"") (namespace-bindings *ctx*) :test #'rod=) - (error "Undeclared namespace prefix: ~A" (rod-string prefix))))) + (cdr (or (assoc (or prefix #"") *namespace-bindings* :test #'rod=) + (wf-error nil "Undeclared namespace prefix: ~A" (rod-string prefix))))) ;; FIXME: Should probably be refactored by adding :start and :end to rod=/rod-equal (defun rod-starts-with (prefix rod) @@ -3437,142 +3447,112 @@ (subseq attrname 6) nil)) -(defun find-namespace-declarations (element attr-alist) - (let ((result - (mapcar #'(lambda (attr) - (cons (attrname->prefix (car attr)) (cdr attr))) - (remove-if-not #'xmlns-attr-p attr-alist :key #'car)))) - ;; Argh! PROCESS-ATTRIBUTES needs to know the attributes' namespaces - ;; already. But namespace declarations can be done using default values - ;; in the DTD. So we need to handle defaulting of attribute values twice, - ;; once for xmlns attributes, then for all others. (I really hope I'm - ;; wrong on this one, but I don't see how.) - (let ((e (find-element element (dtd *ctx*)))) - (when e - (dolist (ad (elmdef-attributes e)) ;handle default values - (let* ((name (attdef-name ad)) - (prefix (attrname->prefix name))) - (when (and (xmlns-attr-p name) - (not (member prefix result :key #'car :test #'rod=)) - (listp (attdef-default ad)) ;:DEFAULT or :FIXED - ) - (push (cons prefix (cadr (attdef-default ad))) result)))))) - result)) +(defun find-namespace-declarations (attributes) + (loop + for attribute in attributes + for qname = (sax:attribute-qname attribute) + when (xmlns-attr-p qname) + collect (cons (attrname->prefix qname) (sax:attribute-value attribute)))) -(defun declare-namespaces (element attr-alist) - (let ((ns-decls (find-namespace-declarations element attr-alist))) - (dolist (ns-decl ns-decls ) +(defun declare-namespaces (attributes) + (let ((ns-decls (find-namespace-declarations attributes))) + (dolist (ns-decl ns-decls) ;; check some namespace validity constraints - ;; FIXME: Would be nice to add "this is insane, go ahead" restarts (let ((prefix (car ns-decl)) - (uri (if (rod= #"" (cdr ns-decl)) - nil - (cdr ns-decl)))) + (uri (cdr ns-decl))) (cond ((and (rod= prefix #"xml") (not (rod= uri #"http://www.w3.org/XML/1998/namespace"))) - (error "Attempt to rebind the prefix \"xml\" to ~S." (mu uri))) + (wf-error nil + "Attempt to rebind the prefix \"xml\" to ~S." (mu uri))) ((and (rod= uri #"http://www.w3.org/XML/1998/namespace") (not (rod= prefix #"xml"))) - (error "The namespace URI \"http://www.w3.org/XML/1998/namespace\" ~ - may not be bound to the prefix ~S, only \"xml\" is legal." - (mu prefix))) + (wf-error nil + "The namespace ~ + URI \"http://www.w3.org/XML/1998/namespace\" may not ~ + be bound to the prefix ~S, only \"xml\" is legal." + (mu prefix))) ((and (rod= prefix #"xmlns") (rod= uri #"http://www.w3.org/2000/xmlns/")) - (error "Attempt to bind the prefix \"xmlns\" to its predefined ~ - URI \"http://www.w3.org/2000/xmlns/\", which is ~ - forbidden for no good reason.")) + (wf-error nil + "Attempt to bind the prefix \"xmlns\" to its predefined ~ + URI \"http://www.w3.org/2000/xmlns/\", which is ~ + forbidden for no good reason.")) ((rod= prefix #"xmlns") - (error "Attempt to bind the prefix \"xmlns\" to the URI ~S, ~ - but it may not be declared." (mu uri))) + (wf-error nil + "Attempt to bind the prefix \"xmlns\" to the URI ~S, ~ + but it may not be declared." (mu uri))) ((rod= uri #"http://www.w3.org/2000/xmlns/") - (error "The namespace URI \"http://www.w3.org/2000/xmlns/\" may ~ - not be bound to prefix ~S (or any other)." (mu prefix))) + (wf-error nil + "The namespace URI \"http://www.w3.org/2000/xmlns/\" may ~ + not be bound to prefix ~S (or any other)." (mu prefix))) ((and (rod= uri #"") prefix) - (error "Only the default namespace (the one without a prefix) may ~ - be bound to an empty namespace URI, thus undeclaring it.")) + (wf-error nil + "Only the default namespace (the one without a prefix) ~ + may be bound to an empty namespace URI, thus ~ + undeclaring it.")) (t - (push (cons prefix uri) (namespace-bindings *ctx*)) - (sax:start-prefix-mapping (handler *ctx*) (car ns-decl) (cdr ns-decl)))))) + (push (cons prefix (if (rod= #"" uri) nil uri)) + *namespace-bindings*) + (sax:start-prefix-mapping (handler *ctx*) + (car ns-decl) + (cdr ns-decl)))))) ns-decls)) (defun undeclare-namespaces (ns-decls) (dolist (ns-decl ns-decls) - (setf (namespace-bindings *ctx*) (delete ns-decl (namespace-bindings *ctx*))) (sax:end-prefix-mapping (handler *ctx*) (car ns-decl)))) -(defun build-attribute-list-no-ns (attr-alist) - (mapcar #'(lambda (pair) - (sax:make-attribute :qname (car pair) - :value (cdr pair) - :specified-p t)) - attr-alist)) - -;; FIXME: Use a non-braindead way to enforce attribute uniqueness -(defun build-attribute-list-ns (attr-alist) +(defun build-attribute-list (attr-alist) + ;; fixme: if there is a reason this function reverses attribute order, + ;; it should be documented. (let (attributes) (dolist (pair attr-alist) - (push (build-attribute (car pair) (cdr pair) t) attributes)) - - ;; 5.3 Uniqueness of Attributes - ;; In XML documents conforming to [the xmlns] specification, no - ;; tag may contain two attributes which: - ;; 1. have identical names, or - ;; 2. have qualified names with the same local part and with - ;; prefixes which have been bound to namespace names that are - ;; identical. - ;; - ;; 1. is checked by read-tag-2, so we only deal with 2 here - (do ((sublist attributes (cdr sublist))) - ((null sublist) attributes) - (let ((attr-1 (car sublist))) + (push (sax:make-attribute :qname (car pair) + :value (cdr pair) + :specified-p t) + attributes)) + attributes)) + +(defun check-attribute-uniqueness (attributes) + ;; 5.3 Uniqueness of Attributes + ;; In XML documents conforming to [the xmlns] specification, no + ;; tag may contain two attributes which: + ;; 1. have identical names, or + ;; 2. have qualified names with the same local part and with + ;; prefixes which have been bound to namespace names that are + ;; identical. + ;; + ;; 1. is checked by read-tag-2, so we only deal with 2 here + (loop for (attr-1 . rest) on attributes do (when (and (sax:attribute-namespace-uri attr-1) - (find-if #'(lambda (attr-2) - (and (rod= (sax:attribute-namespace-uri attr-1) - (sax:attribute-namespace-uri attr-2)) - (rod= (sax:attribute-local-name attr-1) - (sax:attribute-local-name attr-2)))) - (cdr sublist))) - (error "Multiple definitions of attribute ~S in namespace ~S." - (mu (sax:attribute-local-name attr-1)) - (mu (sax:attribute-namespace-uri attr-1)))))))) - -(defun build-attribute (name value specified-p) - (multiple-value-bind (prefix local-name) (split-qname name) - (declare (ignorable local-name)) - (if (or (not prefix) ;; default namespace doesn't apply to attributes - (and (rod= #"xmlns" prefix) (not sax:*use-xmlns-namespace*))) - (sax:make-attribute :qname name - :value value - :specified-p specified-p) - (multiple-value-bind (uri prefix local-name) - (decode-qname name) - (declare (ignore prefix)) - (sax:make-attribute :qname name - :value value - :namespace-uri uri - :local-name local-name - :specified-p specified-p))))) - -;;; Faster constructors + (find-if (lambda (attr-2) + (and (rod= (sax:attribute-namespace-uri attr-1) + (sax:attribute-namespace-uri attr-2)) + (rod= (sax:attribute-local-name attr-1) + (sax:attribute-local-name attr-2)))) + rest)) + (wf-error nil + "Multiple definitions of attribute ~S in namespace ~S." + (mu (sax:attribute-local-name attr-1)) + (mu (sax:attribute-namespace-uri attr-1)))))) -;; Since using the general DOM interface to construct the parsed trees -;; may turn out to be quite expensive (That depends on the underlying -;; DOM implementation). A particular DOM implementation may choose to -;; implement an XML:FAST-CONSTRUCTORS method: +(defun set-attribute-namespace (attribute) + (let ((qname (sax:attribute-qname attribute))) + (if (and sax:*use-xmlns-namespace* (rod= qname #"xmlns")) + (setf (sax:attribute-namespace-uri attribute) + #"http://www.w3.org/2000/xmlns/") + (multiple-value-bind (prefix local-name) (split-qname qname) + (declare (ignorable local-name)) + (when (and prefix ;; default namespace doesn't apply to attributes + (or (not (rod= #"xmlns" prefix)) + sax:*use-xmlns-namespace*)) + (multiple-value-bind (uri prefix local-name) + (decode-qname qname) + (declare (ignore prefix)) + (setf (sax:attribute-namespace-uri attribute) uri) + (setf (sax:attribute-local-name attribute) local-name))))))) -;; XML:FAST-CONSTRUCTORS document [method] -;; -;; Return an alist of constructors suitable for the document `document'. -;; -;; (:MAKE-TEXT document parent data) -;; (:MAKE-PROCESSING-INSTRUCTION document parent target content) -;; (:MAKE-NODE document parent attributes content) -;; [`attributes' now in turn is an alist] -;; (:MAKE-CDATA document parent data) -;; (:MAKE-COMMENT document parent data) -;; - ;;;;;;;;;;;;;;;;; ;; System Identifier Protocol @@ -3596,18 +3576,8 @@ ;; `base' yielding an absolute system identifier suitable for ;; OPEN-SYS-ID. -;; xstream Controller Protocol -;; -;; - -#|| -(defun xml-parse (system-id &key document standalone-p) - ) -||# - ;;;;;;;;;;;;;;;;; - ;;; SAX validation handler (defclass validator () Added: branches/grin-neu/thirdparty/cxml/xml/xmlns-normalizer.lisp =================================================================== --- branches/grin-neu/thirdparty/cxml/xml/xmlns-normalizer.lisp 2006-12-01 10:37:34 UTC (rev 2093) +++ branches/grin-neu/thirdparty/cxml/xml/xmlns-normalizer.lisp 2006-12-01 10:39:49 UTC (rev 2094) @@ -0,0 +1,133 @@ +;;;; xmlns-normalizer.lisp -- DOM 3-style namespace normalization +;;;; +;;;; This file is part of the CXML parser, released under Lisp-LGPL. +;;;; See file COPYING for details. +;;;; +;;;; Copyright (c) 2005 David Lichteblau + +;;;; Hier eine Variante des reichlich furchtbaren Algorithmus zur +;;;; Namespace-Normalisierung aus DOM 3 Core.[1] +;;;; +;;;; Gebraucht wir die Sache, weil Element- und Attributknoten in DOM +;;;; zwar ein Prefix-Attribut speichern, massgeblich fuer ihren Namespace +;;;; aber nur die URI sein soll. Und eine Anpassung der zugehoerigen +;;;; xmlns-Attribute findet bei Veraenderungen im DOM-Baum nicht statt, +;;;; bzw. wird dem Nutzer ueberlassen. +;;;; +;;;; Daher muss letztlich spaetestens beim Serialisieren eine +;;;; Namespace-Deklaration fuer die angegebene URI nachgetragen und das +;;;; Praefix ggf. umbenannt werden, damit am Ende doch etwas +;;;; Namespace-konformes heraus kommt. +;;;; +;;;; Und das nennen sie dann Namespace-Support. +;;;; +;;;; [1] http://www.w3.org/TR/2004/REC-DOM-Level-3-Core-20040407/namespaces-algorithms.html#normalizeDocumentAlgo + +(in-package :cxml) + +(defclass namespace-normalizer (sax-proxy) + ((xmlns-stack :initarg :xmlns-stack :accessor xmlns-stack))) + +(defvar *xmlns-namespace* #"http://www.w3.org/2000/xmlns/") + +(defun make-namespace-normalizer (chained-handler) + (make-instance 'namespace-normalizer + :xmlns-stack (list (mapcar (lambda (cons) + (make-xmlns-attribute (car cons) (cdr cons))) + *namespace-bindings*)) + :chained-handler chained-handler)) + +(defun normalizer-find-prefix (handler prefix) + (when (zerop (length prefix)) + (setf prefix #"xmlns")) + (block t + (dolist (bindings (xmlns-stack handler)) + (dolist (attribute bindings) + (when (rod= (sax:attribute-local-name attribute) prefix) + (return-from t attribute)))))) + +(defun normalizer-find-uri (handler uri) + (block t + (dolist (bindings (xmlns-stack handler)) + (dolist (attribute bindings) + (when (and (rod= (sax:attribute-value attribute) uri) + ;; default-namespace interessiert uns nicht + (not (rod= (sax:attribute-qname attribute) #"xmlns"))) + (return-from t attribute)))))) + +(defun make-xmlns-attribute (prefix uri) + (if (and (plusp (length prefix)) (not (equal prefix #"xmlns"))) + (sax:make-attribute + :qname (concatenate 'rod #"xmlns:" prefix) + :namespace-uri *xmlns-namespace* + :local-name prefix + :value uri) + (sax:make-attribute + :qname #"xmlns" + :namespace-uri *xmlns-namespace* + :local-name #"xmlns" + :value uri))) + +(defun rename-attribute (a new-prefix) + (setf (sax:attribute-qname a) + (concatenate 'rod new-prefix #":" (sax:attribute-local-name a)))) + +(defmethod sax:start-element + ((handler namespace-normalizer) uri lname qname attrs) + (declare (ignore qname)) + (when (null uri) + (setf uri #"")) + (let ((normal-attrs '())) + (push nil (xmlns-stack handler)) + (dolist (a attrs) + (if (rod= *xmlns-namespace* (sax:attribute-namespace-uri a)) + (push a (car (xmlns-stack handler))) + (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)))) + (multiple-value-bind (prefix local-name) (split-qname qname) + (setf lname local-name) + (let ((binding (normalizer-find-prefix handler prefix))) + (cond + ((null binding) + (unless (and (null prefix) (zerop (length uri))) + (push-namespace prefix uri))) + ((rod= (sax:attribute-value binding) uri)) + ((member binding (car (xmlns-stack handler))) + (setf (sax:attribute-value binding) uri)) + (t + (push-namespace prefix uri))))) + (dolist (a normal-attrs) + (let ((u (sax:attribute-namespace-uri a))) + (when u + (let* ((prefix (split-qname (sax:attribute-qname a))) + (prefix-binding + (when prefix + (normalizer-find-prefix handler prefix)))) + (when (or (null prefix-binding) + (not (rod= (sax:attribute-value prefix-binding) u))) + (let ((uri-binding (normalizer-find-uri handler u))) + (cond + (uri-binding + (rename-attribute + a + (sax:attribute-local-name uri-binding))) + ((and prefix (null prefix-binding)) + (push-namespace prefix u)) + (t + (loop + for i from 1 + for prefix = (rod (format nil "NS~D" i)) + unless (normalizer-find-prefix handler prefix) + do + (push-namespace prefix u) + (rename-attribute a prefix) + (return)))))))))))) + (sax:start-element (proxy-chained-handler handler) uri lname qname attrs)) + +(defmethod sax:end-element ((handler namespace-normalizer) uri lname qname) + (declare (ignore qname)) + (pop (xmlns-stack handler)) + (sax:end-element (proxy-chained-handler handler) (or uri #"") lname qname)) Modified: branches/grin-neu/thirdparty/cxml/xml/xmls-compat.lisp =================================================================== --- branches/grin-neu/thirdparty/cxml/xml/xmls-compat.lisp 2006-12-01 10:37:34 UTC (rev 2093) +++ branches/grin-neu/thirdparty/cxml/xml/xmls-compat.lisp 2006-12-01 10:39:49 UTC (rev 2094) @@ -1,19 +1,18 @@ ;;;; xml-compat.lisp -- XMLS-compatible data structures ;;;; -;;;; This file is part of the CXML parser, released under (L)LGPL. +;;;; This file is part of the CXML parser, released under Lisp-LGPL. ;;;; See file COPYING for details. ;;;; ;;;; Developed 2004 for headcraft - http://headcraft.de/ ;;;; Copyright: David Lichteblau ;;;; XXX Der namespace-Support in xmls kommt mir zweifelhaft vor. -;;;; Wir immitieren das soweit es gebraucht wurde bisher. +;;;; Wir imitieren das soweit es gebraucht wurde bisher. (defpackage cxml-xmls (:use :cl :runes) (:export #:make-node #:node-name #:node-ns #:node-attrs #:node-children - #:make-xmls-builder #:map-node - #:*identifier-case*)) + #:make-xmls-builder #:map-node)) (in-package :cxml-xmls) @@ -65,60 +64,32 @@ ;;;; SAX-Handler (Parser) -(defvar *identifier-case* nil - "One of NIL (don't intern names), :PRESERVE, :UPCASE, :DOWNCASE, or :INVERT - (intern name into the keyword package after adjusting case).") - (defclass xmls-builder () ((element-stack :initform nil :accessor element-stack) - (root :initform nil :accessor root))) + (root :initform nil :accessor root) + (include-default-values :initform t + :initarg :include-default-values + :accessor include-default-values))) -(defun make-xmls-builder () - (make-instance 'xmls-builder)) +(defun make-xmls-builder (&key (include-default-values t)) + (make-instance 'xmls-builder :include-default-values include-default-values)) (defmethod sax:end-document ((handler xmls-builder)) (root handler)) -(defun string-invert-case (str) - (map 'string - (lambda (c) - (cond - ((upper-case-p c) (char-downcase c)) - ((lower-case-p c) (char-upcase c)) - (t c))) - str)) - -(defun maybe-intern (name) - (if *identifier-case* - (let ((str (if (stringp name) name (rod-string name)))) - (intern (ecase *identifier-case* - (:preserve str) - (:upcase (string-upcase str)) - (:downcase (string-downcase str)) - (:invert (string-invert-case str))) - :keyword)) - name)) - -(defun maybe-stringify (name) - (if (symbolp name) - (let ((str (symbol-name name))) - (ecase *identifier-case* - (:preserve str) - (:upcase (string-downcase str)) - (:downcase (string-upcase str)) - (:invert (string-invert-case str)))) - name)) - (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 - (mapcar (lambda (attr) - (list (maybe-intern (sax:attribute-qname attr)) - (sax:attribute-value attr))) - attributes)) - (node (make-node :name (maybe-intern local-name) + (loop + for attr in attributes + when (or (sax:attribute-specified-p attr) + (include-default-values handler)) + collect + (list (sax:attribute-qname attr) + (sax:attribute-value attr)))) + (node (make-node :name local-name :ns (let ((lq (length qname)) (ll (length local-name))) (if (eql lq ll) @@ -163,10 +134,13 @@ (labels ((walk (node) (let* ((attlist (compute-attributes node include-xmlns-attributes)) - (lname (rod (maybe-stringify (node-name node)))) - (ns (rod (node-ns node))) - (qname (concatenate 'rod ns (rod ":") lname))) - ;; fixme: namespaces + (lname (rod (node-name node))) + (qname (if (node-ns node) + (concatenate 'rod + (rod (node-ns node)) + (rod ":") + lname) + lname))) (sax:start-element handler nil lname qname attlist) (dolist (child (node-children node)) (typecase child @@ -180,7 +154,6 @@ (remove nil (mapcar (lambda (a) (destructuring-bind (name value) a - (setf name (maybe-stringify name)) (if (or xmlnsp (not (cxml::xmlns-attr-p (rod name)))) (sax:make-attribute :qname (rod name) :value (rod value) Modified: branches/grin-neu/thirdparty/emacs/slime/swank-loader.x86f =================================================================== --- branches/grin-neu/thirdparty/emacs/slime/swank-loader.x86f 2006-12-01 10:37:34 UTC (rev 2093) +++ branches/grin-neu/thirdparty/emacs/slime/swank-loader.x86f 2006-12-01 10:39:49 UTC (rev 2094) @@ -1,22 +1,20 @@ FASL FILE output from /usr/home/hans/bknr-svn/thirdparty/emacs/slime/swank-loader.lisp. -Compiled Wednesday, 11/15/06 07:15:22 am GMT on ibuprofen.huebner.org +Compiled Thursday, 11/30/06 10:50:00 pm GMT on ibuprofen.huebner.org Compiler 1.1, Lisp 19c Release (19C) Targeted for Intel x86, FASL version 19C -???Q&KERNEL %DEFPACKAGE& SWANK-LOADER& COMMON-LISP QUOTE QUOTE QUOTE QUOTE QUOTE& COMMON-LISP QUOTE QUOTE QUOTE QUOTE 6RQ %IN-PACKAGE QUOTE& SWANK-LOADER6R?>#?B&lispNNAMENTYPE  MAKE-PATHNAME< *COMPILE-FILE-PATHNAME* MERGE-PATHNAMES< *LOAD-PATHNAME* *DEFAULT-PATHNAME-DEFAULTS*Q&C COMPILED-DEBUG-INFORQR($$-Q& -EXTENSIONS INSTANCER($$-Q STRUCTURE-OBJECTR($$- Q  -DEBUG-INFOR ("$$-#($$$-%&DEFUN MAKE-SWANK-PATHNAME&& SWANK-LOADER'Q COMPILED-DEBUG-FUNCTIONR Q DEBUG-FUNCTIONR (*$$-+(,$$ --Q& SWANK-LOADERR .MAKE-SWANK-PATHNAMENEXTERNAL+G2MG3?G4??1+&2$+$3NSTANDARD$'$$#?1 5$5-&NOPTIONAL+NAME?7+58$+94$'$$5#?1 :$A-/+NAMECTYPE COMMON-LISP?;+EA*<$$  OPTIONAL-ARGS$(>4$'$$A#?1 ?(@1AB; -?~?E??e???t??u?U??}??? -M?U???E???????}??5?E??C????k????P??? !?A?=?tH= ?(t???%??u??`? )?A?=?t#= ?(t?????-?x????t ??? -N? -N? -QNABSOLUTER??QNABSOLUTER??QNABSOLUTER??QNABSOLUTER?rQNABSOLUTER?]QNABSOLUTER?QQNABSOLUTER?HQNABSOLUTER?:=?K/&(name &optional (type "lisp"))L FUNCTION  &OPTIONALO PATHNAMEQ?/RJ?>S#B&nregexST&swank-source-path-parserU&swank-source-file-cacheV& swank-cmuclWX APPEND</< .*SYSDEP-PATHNAMES* CONS%&DEFPARAMETER *SYSDEP-PATHNAMES*\'-&Top-Level Form]N TOP-LEVEL+_+P{ W`$+a4$'$$#x1 b(c1de;~ ?E??e?? ?(?4?(??(?|?(;??(v??|?(?[???P??@ ?(??(?=4?(t? ???u??u????? ??=???k????P???u??????????}??u??V????? ???k????P???u??}??4?(??(?|?(;??(v??|?(?[???P??@ ?(??(?=4?(t? ???? ?(t>?_?v??$<u>??= ?(?c????E??@? !?A?? ?(?M??E??????????%? -!??? -??QNABSOLUTER?lQNABSOLUTER?OQNRELATIVER?alloc_overflow_ebx?QNABSOLUTER??QNABSOLUTER??QNABSOLUTER??QNABSOLUTER?QNRELATIVER?alloc_overflow_ebxE=?n]&()oM?/R&BReturn a pathname with name component NAME in the Slime directory.q PROCLAIM< SPECIALZt#]1uv;? !"?q#$?q0?w]$$Q SIMPLE-BYTE-FUNCTIONRQ FUNCTIONR(z$$-{Q FUNCALLABLE-INSTANCER{(}$$-~Q BYTE-FUNCTION-OR-CLOSURER{~(?$$-?Q BYTE-FUNCTIONR{~?(?$$-?(?$$-???8p8LSET-DEFVAR-SOURCE-LOCATION<ZQ FILE-SOURCE-LOCATIONR Q  FORM-NUMBERSR (?$$-?(?$$-?$&@/usr/home/hans/bknr-svn/thirdparty/emacs/slime/swank-loader.lisp?1?r<s .*IMPLEMENTATION-FEATURES*?NALLEGRON LISPWORKSNSBCLNOPENMCLNCMUNCLISPNCCLNCORMANN ARMEDBEARNGCLNECL ????$?1?s . *OS-FEATURES*?NMACOSXNLINUXNWINDOWSN MSWINDOWSNWIN32NSOLARISNDARWINNSUNOSNUNIX ???$?1?#]1??; !"?q#$?q%&? '(?q#)?q*+? +,?q0??]$$???8?>?$]B LISP-IMPLEMENTATION-VERSION<  -SUBSTITUTE<%&DEFUN LISP-VERSION-STRING?'- .LISP-VERSION-STRING0+G0M?+ ;?$+?4$'$$$X1 ?$"-?+?+"?$+?4$'$$"$]1 ?(?1??;]~?E??e???u6???? ?1??j????P??????-??/?? ?u??`??? -MQNABSOLUTER?GQNABSOLUTER?)=???oM SIMPLE-BASE-STRING????J?>?#&B?&&No implementation feature found in ~a.??&No os feature found in ~a.? .*ARCHITECTURE-FEATURES*&$No architecture feature found in ~a.??<&TDon't know how to get Lisp ~ - implementation version.?&~(~@{~a~^-~}~)? FORMAT<  -*FEATURES* FIND< WARN<&unknown?%&DEFUN UNIQUE-DIRECTORY-NAME?'- .UNIQUE-DIRECTORY-NAME0+G6M?+???$+?4$'$$#?1 ?$&-?+VALUE??+f&)?,?+?&+?3?$+?4$'$$&#?1 ?#?- FLET .FIRST-OF??+F? FEATURES???+C??F ??$+?+?$'$#?# 1 ?#M-? . -MAYBE-WARN??+ ARGS??FSTRINGcVALUEC?+4?M N "    <  ?$$$ REST-ARG$(?+?$'$#M#1 ?(?1??;&~?E??e?????? ?A?=????????? ???J????E???j????P???????4?(??(?|?(;??(v??|?(?[???P??@ ?(??(?=4?(t? ?????? ?q???Q??A????E?%?q?E?? ?A?=???????? ???J????E?V??????P???????4?(??(?|?(;??(v??|?(?[???P??@ ?(??(?=4?(t? ?????? ?q???Q??A????E?????E??!?X?????T?????? ?A????E??????!?P?????*?4?(??(?|?(;??(v??|?(?[???P??@ ?(??(?=4?(t? ?????? ?q??%?Q??A????E????E????? ?)1??j????P???????? ?Q??-?Q?? ?(?A????E????? ?(?=1?u??E??E??E??E??E??5??u??`? ?(??$<?<????? ?(?[?]??V??v??$<?!?u??9?x??????e??? ?]??=??k????P???]??u????? ?(u?? ?(u?? ?(?e??m?????}? ?(???]??A?x?? ?(???U???R?E????$<??????? ?(9?t?q??I??$<t?? +???Q&KERNEL %DEFPACKAGE& SWANK-LOADER& COMMON-LISP QUOTE QUOTE QUOTE QUOTE QUOTE&CL QUOTE QUOTE QUOTE& +LOAD-SWANK&*SOURCE-DIRECTORY*&*FASL-DIRECTORY* QUOTE 6RQ %IN-PACKAGE QUOTE& SWANK-LOADER6R PROCLAIM< SPECIALQ& SWANK-LOADERR *SOURCE-DIRECTORY* BOUNDP<  MAKE-PATHNAME?;C !?q"#??$%090&'?`?(?(?)*+,?q-./?q /?q?//?/?-//?q0?/???@=$$Q SIMPLE-BYTE-FUNCTIONR!Q FUNCTIONR!(C$$-DQ FUNCALLABLE-INSTANCER!D(F$$-GQ BYTE-FUNCTION-OR-CLOSURER!DG(I$$-JQ BYTE-FUNCTIONR!DGJ(L$$-M(N$$-O?P8< *IMPLEMENTATION-FEATURES*RNALLEGRON LISPWORKSNSBCLNOPENMCLNCMUNCLISPNCCLNCORMANN +CORMANLISPN ARMEDBEARNGCLNECLNSCL `Q<Q-$.1a  *OS-FEATURES*cNMACOSXNLINUXNWINDOWSN MSWINDOWSNWIN32NSOLARISNDARWINNSUNOSNHPUXNUNIX +nbb-$.1o *ARCHITECTURE-FEATURES*q<=1rs; !?q"#?$%&?q '?q()?$*+?q ,?q0?t=$$O?u8?>v#)BB LISP-IMPLEMENTATION-VERSION<  SUBSTITUTE-IF<& /xQ&SYSTEMR y%SP-FIND-CHARACTER?#&BQ&&No implementation feature found in ~a.?b&No os feature found in ~a.?p&$No architecture feature found in ~a.??<&TDon't know how to get Lisp ~ + implementation version.?&~(~@{~a~^-~}~)? FORMAT<  +*FEATURES* FIND< WARN<&unknown?}&DEFUN UNIQUE-DIRECTORY-NAME?? UNIQUE-DIRECTORY-NAME?+G6M?+???$+??$'$$#?1 ?$&??+VALUE??+f&)?,?+?&+?3?$+??$'$$&#?1 ?#?? FLET FIRST-OF??+F? FEATURES???+C??F ??$+?+?$'$#?# 1 ?#M??  +MAYBE-WARN??+ ARGS??FSTRINGcVALUEC?+4?M N "    <  ?$$$ REST-ARG$(?+?$'$#M#1 ?(?1??;&~?E??e?????? ?A?=????????? ???J????E???j????P???????4?(??(?|?(;??(v??|?(?[???P??@ ?(??(?=4?(t? ?????? ?q???Q??A????E?%?q?E?? ?A?=???????? ???J????E?V??????P???????4?(??(?|?(;??(v??|?(?[???P??@ ?(??(?=4?(t? ?????? ?q???Q??A????E?????E??!?X?????T?????? ?A????E??????!?P?????*?4?(??(?|?(;??(v??|?(?[???P??@ ?(??(?=4?(t? ?????? ?q??%?Q??A????E????E????? ?)1??j????P???????? ?Q??-?Q?? ?(?A????E????? ?(?=1?u??E??E??E??E??E??5??u??`? ?(??$<?<????? ?(?[?]??V??v??$<?!?u??9?x??????e??? ?]??=??k????P???]??u????? ?(u?? ?(u?? ?(?e??m?????}? ?(???]??A?x?? ?(???U???R?E????$<??????? ?(9?t?q??I??$<t?? N??)??]?????)??S??{??s??? ?k????P???]??E?e??m???E?????? M? N? @@ -29,38 +27,80 @@ ??? ? ? -?QNABSOLUTER??QNABSOLUTER?_QNABSOLUTER?QNABSOLUTER??QNABSOLUTER??QNABSOLUTER??QNABSOLUTER??QNABSOLUTER?sQNABSOLUTER?WQNABSOLUTER?DQNABSOLUTER?5QNRELATIVER?alloc_overflow_ebx?QNABSOLUTER??QNABSOLUTER??QNABSOLUTER??QNABSOLUTER??QNABSOLUTER?}QNRELATIVER?alloc_overflow_ebxFQNABSOLUTER?QNABSOLUTER?QNABSOLUTER??QNABSOLUTER??QNABSOLUTER??QNRELATIVER?alloc_overflow_ebx?QNABSOLUTER?XQNABSOLUTER?KQNABSOLUTER?(=? ?oM OR  BASE-STRING NULL ??Jr<s?NPOWERPCNPPCNX86NX86-64NI686NPC386NIAPX386NSPARC??<??$?1???&?Return a name that can be used as a directory name that is +?QNABSOLUTER??QNABSOLUTER?_QNABSOLUTER?QNABSOLUTER??QNABSOLUTER??QNABSOLUTER??QNABSOLUTER??QNABSOLUTER?sQNABSOLUTER?WQNABSOLUTER?DQNABSOLUTER?5QNRELATIVER?alloc_overflow_ebx?QNABSOLUTER??QNABSOLUTER??QNABSOLUTER??QNABSOLUTER??QNABSOLUTER?}QNRELATIVER?alloc_overflow_ebxFQNABSOLUTER?QNABSOLUTER?QNABSOLUTER??QNABSOLUTER??QNABSOLUTER??QNRELATIVER?alloc_overflow_ebx?QNABSOLUTER?XQNABSOLUTER?KQNABSOLUTER?(=??????  BASE-STRING??????J?>?#?B FILE-WRITE-DATE<}&DEFUN FILE-NEWER-P??  FILE-NEWER-P?+G0MG1?G2???+ {?$ +$??$'$$#?1 ?$)??+NEW-FILECOLD-FILEc?+4) +$ +?$'$$)#?1 (1;?~?E??e???uu?U??}????? ?U????k????P???U????? ?U????k????P?????U?????? ?(u? ?(?M??E??????????'?(?????? +MQNRELATIVERQ&X86  GENERIC->R?lQNABSOLUTER?SQNABSOLUTER?3=? ?&(new-file old-file) ?  MEMBER??J?>#?B& ChangeLog MERGE-PATHNAMES??J?>@# B<?< APPENDe#?B COMPILE-FILE-PATHNAME<  PATHNAME-NAME<  PATHNAME-TYPE<NTYPE<<}&DEFUN BINARY-PATHNAMEi? BINARY-PATHNAME?+G0MG1?G2??k+ ?l$ +$m?$'$$#?1 n$-?j+.BINARY-DIRECTORY?CFP???SOURCE-PATHNAMECo+* +-  +p$ +q?$'$$-#?1 r(s1tu; ?~?E??e??????U??}????? ?U????k????P?????u????? ?????k????P???u??U????? ?????k????P??????????}??5!?C??%??k????P???}??)??u??`?? +MQNABSOLUTER??QNABSOLUTER??QNABSOLUTER??QNABSOLUTER??QNABSOLUTER?zQNABSOLUTER?XQNABSOLUTER?7=?}j&"(source-pathname binary-directory)~? b?j?J?>?#DB *ERROR-OUTPUT*&B~%~<;; ~@;Error while loading: ~A~% Condition: ~A~%Aborting.~:>~%??< DIRECTORY-NAMESTRING<G< EQUAL##?B FILE-WRITE-DATE<%&DEFUN FILE-NEWER-P$'- . FILE-NEWER-P0+G0MG1?G2??&+ {'$ -+$(4$'$$#?1 )$)-%+NEW-FILECOLD-FILEc*+4) -+$ -+,4$'$$)#?1 -(.1/0;?~?E??e???uu?U??}????? ?U????k????P???U????? ?U????k????P?????U?????? ?(u? ?(?M??E??????????'?(?????? -MQNRELATIVERQ&X86 2 GENERIC->R?lQNABSOLUTER?SQNABSOLUTER?3=?6%&(new-file old-file)7M8 MEMBER:;?%<J?>=#?B COMPILE-FILE-PATHNAME<?e#` B PARSE-UNKNOWN-TYPE-SPECIFIER< NOTE-UNDEFINED-REFERENCE?# B PARSE-UNKNOWN-TYPE-SPECIFIER<h NOTE-UNDEFINED-REFERENCE$++$'$#? # 1 (1; ~ ?E??e??M??U??}??E????? ????????U??Q??U??Q??A????E???????M??E??????????????~<?E??e????V ?U????? ?U????k????P???=???u??`??~T?E??e??X?@ ???? +?P??C?1?1???@?= ?(u? ?(?e??m????P?????? +??????P???? !?A?=??? += ?(???'?(?4?(??(?|?(;??(v??|?(???@?H???(?=4?(t? ?E?? ?(?%? ??(?C???? ??(?A??Y??S?1??)? ??(?C???? ??(?A??Y??S?1??-? ??(?C???? ??(?A??Y??S?1??1? ??(?C???? ??(?A??Y??S??'?(?!? ??(?C???? ??(?A??Y??S?1??? ??(?C???? ??(?A??Y??S??4?(??(?|?(;??(v??|?(?@??(?=4?(t? ? 9?H?? 5?H???4?(??(?|?(;??(v??|?(?[???P??@ ?(??(?=4?(t? ? =?A?=????4?(??(?|?(;??(v??|?(?R??(?=4?(t? ?Z??B?=? ??(?C???? ??(?A??Y??S????(?E????(? ??(??(?E??M??U??e??M????(??i?A1?E????(????????U??Q??U??A????E????E??E?? ?(?H????(????(????????U??A????E???K????(?B??J??H??B??????(???(?B??J??H??B??????(???(?B??J??H??B??????(???(?B??J??H??B??????(???(?B??J??H??B??????(???(?B??J??H??B??????(???(?B??J??H??B??????(?E??e??m???'?(?4?(??(?|?(;??(v??|?(???@?H???(?=4?(t? ?E????(?E????(? ??(??(?E??M??U??e??M????(??i?A??E????(????????U??Q??U??A????E?t?;?E??E?? ?(?H????(????(????????E??J????E?????????????U??]??M??E??M??U????(? ??(??(?]????(9?t!?B? ?t ?J??H??B???9?u????(????????E??J????E?#?b????E??]??M???U??]??M??E??M??U????(? ??(??(?]????(9?t!?B? ?t ?J??H??B???9?u????(????????U??A????E???}?E??]??M???E? ?(?U??M???$<????= ?(???E??@??E????? ?U??}??A??k????P???U?? ?(?4?(??(?|?(;??(v??|?(???@?H???(?=4?(t? ?E????(?E????(? ??(??(?E??M??U??e??M????(??i?A? ?4?(??(?|?(;??(v??|?(???@?H???(?=4?(t? ?E??E?4?(??(? |?(; ??(v?? |?(?I?A???B?A??(?=4?(t? ?E??A?E??A ?4?(??(?|?(;??(v??|?(?@??(?=4?(t? ?I?P??H???4?(??(?|?(;??(v??|?(?[???P??@ ?(??(?=4?(t? ? =?A?=????4?(??(?|?(;??(v??|?(?R??(?=4?(t? ?Z??B?=? ??(?C???? ??(?A??Y??S??}? ?(???E?'?(???? ?U??M??k????P???????U??=Q?u??U?C??C? ?(?Y?C??C?'?(?]??k????P?????? ?U??=Y?'?(?a? ?k????P??????(?B??J??H??B??????(?E?1??H??E??@?E?????????? ?U??e??k????P???? ?(uA?'?(= ?(???????? ?U??}??i??k????P???? ?(???????#?BD<&.swank?< #?B *LOAD-TRUENAME*& site-initNDEFAULTS<?u<%&DEFUN LOAD-SITE-INIT-FILE'- .LOAD-SITE-INIT-FILE0+G0M+ s$+4$'$$#?1 $"-++"L -$+4$'$$"#?1 (1; ?~?E??e???un? ?A?=?tc??????=?5? !?K?? %?K??C??)??k????P???=-? ?(?1? ?u??`?? +QNABSOLUTER?? QNABSOLUTER?? QNABSOLUTER?? QNABSOLUTER?? QNABSOLUTER?? +QNABSOLUTER?? +QNABSOLUTER?g +QNABSOLUTER?\ +QNABSOLUTER?? +QNABSOLUTER?/ +QNABSOLUTER? +QNABSOLUTER? +QNABSOLUTER?? QNABSOLUTER?? QNRELATIVER?alloc_overflow_edx? QNABSOLUTER?a QNRELATIVER?alloc_overflow_ebx4 QNABSOLUTER? QNRELATIVER?alloc_overflow_eax?QNRELATIVER?alloc_overflow_ecx?QNABSOLUTER?eQNRELATIVER?alloc_overflow_eax8QNABSOLUTER?QNRELATIVER?alloc_overflow_eax?QNABSOLUTER?rQNRELATIVERQ UNWINDR?2QNABSOLUTER?QNRELATIVERQ UNWINDR??QNABSOLUTER??QNABSOLUTER?,QNABSOLUTER??QNABSOLUTER??QNRELATIVER?alloc_overflow_eaxgQNABSOLUTER?QQNABSOLUTER?QNABSOLUTER??QNABSOLUTER??QNRELATIVER?alloc_overflow_edxqQNABSOLUTER?=QNRELATIVER?alloc_overflow_ebxQNABSOLUTER??QNABSOLUTER??QNRELATIVER?alloc_overflow_eax?QNABSOLUTER?zQNABSOLUTER?WQNABSOLUTER?1QNABSOLUTER?QNABSOLUTER??QNABSOLUTER??QNRELATIVER?alloc_overflow_eax?QNABSOLUTER?RQNABSOLUTER?GQNRELATIVERQ  GENERIC-+R??QNABSOLUTER?&QNRELATIVERQ UNWINDR?QNABSOLUTER??QNABSOLUTER??QNABSOLUTER??QNABSOLUTER?Q=?Z????[??Z\?Z?& (lisp::c)]?? " %UNDEFINED%_`?pZa?Z?&(files fasl-directory)b? ?c??dJ?>e#?BE<&.swankeh&lispf<<?<}&DEFUN LOAD-USER-INIT-FILEg? LOAD-USER-INIT-FILE?+G0Mi+ ?j$+k?$'$$#?1 l$&?h+m+&5n$+o?$'$$&#?1 p(q1rs; ?~?E??e????????? ?1??j????P???U???????=?5?!?C??%??k????P???????? ?U??)??k????P???=-? ?(?1? ?u??`? +MQNABSOLUTER??QNABSOLUTER??QNABSOLUTER??QNABSOLUTER?bQNABSOLUTER?YQNABSOLUTER?SQNABSOLUTER?MQNABSOLUTER?GQNABSOLUTER?-=?}h??~?hJ?>?#?B& site-init?hf<?<}&DEFUN LOAD-SITE-INIT-FILE?? LOAD-SITE-INIT-FILE?+ +G0MG1??+ k?$+??$'$$#?1 ?$&??+ DIRECTORY COMMON-LISPC?+&??$+??$'$$&#?1 ?(?1??; +?~?E??e???ue?U???????=?5??C??!?C??E??C??%??k????P???=)? ?(?-? ?u??`??? +MQNABSOLUTER?wQNABSOLUTER?lQNABSOLUTER?WQNABSOLUTER?HQNABSOLUTER??QNABSOLUTER?9QNABSOLUTER?3QNABSOLUTER?-=???& (directory)???????J?>?#B0&swank??@<& swank-backend?hf< CONS}&DEFUN SWANK-SOURCE-FILES?? SWANK-SOURCE-FILES?+ G12MG13??+???$+??$'$$#1 ?$*??+SOURCE-DIRECTORYC?+d*?\? Q  +?$+??$'$$*#1 ?(?1??; ~?E??e??????U?? ?(?4?(??(?|?(;??(v??|?(?[???P??@ ?(??(?=4?(t? ???u??u???P?????l???? ?=???k????P???u??4?(??(?|?(;??(v??|?(?@??(?=4?(t? ? ?H??P???E????M??E??x??????!?5%?)?C??-?C??E??C??1??k????P???4?(??(?|?(;??(v??|?(?[???P??@ ?(??(?=4?(t? ???}? ?(t??= ?(?:????E??P?M??E??????????E?? 5? +!N???? M? -NQNABSOLUTER??QNABSOLUTER?uQNABSOLUTER?`QNABSOLUTER?TQNABSOLUTER?KQNABSOLUTER?EQNABSOLUTER??QNABSOLUTER?9QNABSOLUTER?$=?&o??'J'<?<#]1();? !0?q"?`?#?q0?*]$$??+8Q  DEBUG-SOURCER (-$$ -.NFILE?"&??0" -=?1$+@\??k?? ? ~Lu\Qo21 345?)5?5?5??5??5?Q5?05? 5??5??5??5?v5?e5?B?>6@ \ No newline at end of file +? +?QNABSOLUTER??QNRELATIVER?alloc_overflow_ebx|QNABSOLUTER?GQNABSOLUTER?8QNABSOLUTER?/QNABSOLUTER?)QNABSOLUTER?#QNABSOLUTER??QNRELATIVER?alloc_overflow_eax?QNABSOLUTER??QNABSOLUTER??QNABSOLUTER??QNRELATIVER?alloc_overflow_ebxQ=???&(source-directory)???????J?>?#"BNSOURCE-DIRECTORYNFASL-DIRECTORYNALLOW-OTHER-KEYS?<?<&$swank::*swank-wire-protocol-version*? READ-FROM-STRING<< SET>??>>>>>>>> > > +> +>     . . . ..... >. .>?$?$  +SUPPLIED-P$?$?$(??$'$#+#1 ?(?1??;"~?E??7?]?)??????? vWV?|$??)??????^_???U???t?}???t?u???e????D??E???????? ?(? ?(? ?(?E? ?(?E? ?(?E? ?(?E? ?(?E? ?(?????????+???M????4?????M????;u8?E?'?(??????}??}? ?(u?}??E?}? ?(u??E??M????? +#;t;t???E????u????E?'?(?u???? +"?}? ?(??? ?A?=????E??}? ?(???}??}????? ?U??!??k????P?????? ?}??%??k????P?????? ?)?-??k????P???U????? ?11??j????P???????? ?U??5??k????P?????? ?9?=??k????P?????? ?=A?E??k????P?????? ?I??k????P???????? 1??j????P?????? ?U??M??k????P?????? ?Q1??j????P?????? ?U?=??k????P?????? ?=Y?E??k????P?????? ?I??k????P????1??u??`?]?x????t?O????E??4???? +N? +QNABSOLUTER??QNABSOLUTER??QNABSOLUTER??QNABSOLUTER??QNABSOLUTER??QNABSOLUTER??QNABSOLUTER??QNABSOLUTER?lQNABSOLUTER?<QNABSOLUTER?"QNABSOLUTER?QNABSOLUTER?QNABSOLUTER??QNABSOLUTER??QNABSOLUTER??QNABSOLUTER??QNABSOLUTER??QNABSOLUTER??QNABSOLUTER?lQNABSOLUTER?:QNABSOLUTER? QNABSOLUTER?QNABSOLUTER??=???&N(&key (source-directory *source-directory*) (fasl-directory *fasl-directory*))?? &KEY????? *????J?d&yCompile each file in FILES if the source is newer than +its corresponding binary, or the file preceding it was +recompiled.?h&9Load the user init file, return NIL if it does not exist.?????<??<?G<?<&0The directory where fasl files should be placed.?<?-$.1??<=1;H? !"?q?#$%?q?&'0?q?()0?q*+?q,-??.?/?////?q///?q?//0?q0?=$$O?8?<<=1; ?q0?=$$O? 8Q  DEBUG-SOURCER!%(( $$ - NFILE."?J ?"???$+??a?k?? E??f???U??? 1 ?????????s??????u?R?-??????s???>@ \ No newline at end of file Modified: branches/grin-neu/thirdparty/kmrcl-1.72/byte-stream.lisp =================================================================== --- branches/grin-neu/thirdparty/kmrcl-1.72/byte-stream.lisp 2006-12-01 10:37:34 UTC (rev 2093) +++ branches/grin-neu/thirdparty/kmrcl-1.72/byte-stream.lisp 2006-12-01 10:39:49 UTC (rev 2094) @@ -7,7 +7,7 @@ ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: June 2003 ;;;; -;;;; $Id: byte-stream.lisp,v 1.1 2004/06/23 08:27:12 hans Exp $ +;;;; $Id$ ;;;; ;;;; Works for CMUCL, SBCL, and AllergoCL only ;;;; Modified: branches/grin-neu/thirdparty/kmrcl-1.72/kmrcl.asd =================================================================== --- branches/grin-neu/thirdparty/kmrcl-1.72/kmrcl.asd 2006-12-01 10:37:34 UTC (rev 2093) +++ branches/grin-neu/thirdparty/kmrcl-1.72/kmrcl.asd 2006-12-01 10:39:49 UTC (rev 2094) @@ -7,7 +7,7 @@ ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: Apr 2000 ;;;; -;;;; $Id: kmrcl.asd,v 1.1 2004/06/23 08:27:12 hans Exp $ +;;;; $Id$ ;;;; ;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg ;;;; @@ -33,13 +33,13 @@ :components ((:file "package") (:file "ifstar" :depends-on ("package")) - (:file "byte-stream" :depends-on ("package")) + #+(or) (:file "byte-stream" :depends-on ("package")) (:file "macros" :depends-on ("package")) (:file "functions" :depends-on ("macros")) (:file "lists" :depends-on ("macros")) (:file "seqs" :depends-on ("macros")) (:file "impl" :depends-on ("macros")) - (:file "io" :depends-on ("macros" "impl")) + #+(or) (:file "io" :depends-on ("macros" "impl")) (:file "console" :depends-on ("macros")) (:file "strings" :depends-on ("macros" "seqs")) (:file "strmatch" :depends-on ("strings")) Added: branches/grin-neu/thirdparty/net-telent-date/INSTALL.asdf =================================================================== --- branches/grin-neu/thirdparty/net-telent-date/INSTALL.asdf 2006-12-01 10:37:34 UTC (rev 2093) +++ branches/grin-neu/thirdparty/net-telent-date/INSTALL.asdf 2006-12-01 10:39:49 UTC (rev 2094) @@ -0,0 +1,13 @@ +1. Make a symlink in "$HOME/lisp/systems/"[*] pointing to the .asd file +2. Start your asdf-enabled lisp +2a. Ensure that "$HOME/lisp/systems/"[*] is in asdf:*central-registry* +3. At the lisp prompt, type '(asdf:operate 'asdf:load-op "net-telent-date")'. This + will compile and load the system into your running lisp. + +[*] This path ("$HOME/lisp/systems/") is only a suggestion; the important +thing is that asdf know where to find the .asd file. asdf uses the +contents of the variable ASDF:*CENTRAL-REGISTRY* to find its system +definitions. + +These instructions were automatically generated by cCLan software. Use +at your own peril. Added: branches/grin-neu/thirdparty/net-telent-date/README =================================================================== --- branches/grin-neu/thirdparty/net-telent-date/README 2006-12-01 10:37:34 UTC (rev 2093) +++ branches/grin-neu/thirdparty/net-telent-date/README 2006-12-01 10:39:49 UTC (rev 2094) @@ -0,0 +1,13 @@ +Most of the code in this package is parse-time.lisp, which was +originally written by Jim Healy in June 1987, and has been lifted +wholesale from CMUCL. + +The rest of it is a few useful functions for printing dates in +standard(sic) formats. See documentation strings for +universal-time-to-http-date, universal-time-to-rfc2822-date, dayname, +monthname. + +Thanks to Kevin Rosenberg for bouncing ideas off, for the initial +universal-time-to-rfc2822-date implementation, and for Debian +packaging + Added: branches/grin-neu/thirdparty/net-telent-date/date.lisp =================================================================== --- branches/grin-neu/thirdparty/net-telent-date/date.lisp 2006-12-01 10:37:34 UTC (rev 2093) +++ branches/grin-neu/thirdparty/net-telent-date/date.lisp 2006-12-01 10:39:49 UTC (rev 2094) @@ -0,0 +1,133 @@ +(in-package :net.telent.date) + +(defvar *daynames* + '((0 . "Monday") + (1 . "Tuesday") + (2 . "Wednesday") + (3 . "Thursday") + (4 . "Friday") + (5 . "Saturday") + (6 . "Sunday"))) + +(defun dayname (stream arg colon-p at-p &optional width (mincol 0) (colinc 1) (minpad 0) (padchar #\Space)) + "Print the day of the week (0=Sunday) corresponding to ARG on STREAM. This is intended for embedding in a FORMAT directive: WIDTH governs the number of characters of text printed, MINCOL, COLINC, MINPAD, PADCHAR work as for ~A" + (let ((daystring (cdr (assoc (mod arg 7) *daynames*)))) + (if (not daystring) (return-from dayname nil)) + (let ((truncate (if width (min width (length daystring)) nil))) + (format stream + (if at-p "~V,V,V,V at A" "~V,V,V,VA") + mincol colinc minpad padchar + (subseq daystring 0 truncate))))) + +(defvar *monthnames* + '((1 . "January") + (2 . "February") + (3 . "March") + (4 . "April") + (5 . "May") + (6 . "June") + (7 . "July") + (8 . "August") + (9 . "September") + (10 . "October") + (11 . "November") + (12 . "December"))) + +(defun monthname (stream arg colon-p at-p &optional width (mincol 0) (colinc 1) (minpad 0) (padchar #\Space)) + "Print the name of the month (1=January) corresponding to ARG on STREAM. This is intended for embedding in a FORMAT directive: WIDTH governs the number of characters of text printed, MINCOL, COLINC, MINPAD, PADCHAR work as for ~A" + (let ((monthstring (cdr (assoc arg *monthnames*)))) + (if (not monthstring) (return-from monthname nil)) + (let ((truncate (if width (min width (length monthstring)) nil))) + (format stream + (if at-p "~V,V,V,V at A" "~V,V,V,VA") + mincol colinc minpad padchar + (subseq monthstring 0 truncate))))) + +;;; the second of these functions is an attempt to fix the wrong +;;; problem (emacs likes to indent it strangely) with the first. The +;;; real problem with the first is, as c.l.l will rush to tell you, +;;; that it introduces anaphora - and lots of them. I don't really +;;; advise the use of either in user code, and they're only exported +;;; for historical reasons + +(defmacro with-date (utime zone &body body) + "UTIME is a universal-time, ZONE is a number of hours offset from UTC, or NIL to use local time. Execute BODY in an environment where SECOND MINUTE HOUR DAY-OF-MONTH MONTH YEAR DAY-OF-WEEK DAYLIGHT-P ZONE are bound to the decoded components of the universal time" + `(multiple-value-bind + (second minute hour day-of-month month year day-of-week daylight-p zone) + (decode-universal-time ,utime ,@(if zone (list zone))) + (declare (ignorable second minute hour day-of-month month year day-of-week daylight-p zone)) + , at body)) + +(defmacro with-decoding ((utime &optional zone) &body body) + "UTIME is a universal-time, ZONE is a number of hours offset from UTC, or NIL to use local time. Execute BODY in an environment where SECOND MINUTE HOUR DAY-OF-MONTH MONTH YEAR DAY-OF-WEEK DAYLIGHT-P ZONE are bound to the decoded components of the universal time" + `(multiple-value-bind + (second minute hour day-of-month month year day-of-week daylight-p zone) + (decode-universal-time ,utime ,@(if zone (list zone))) + (declare (ignorable second minute hour day-of-month month year day-of-week daylight-p zone)) + , at body)) + +(defun universal-time-to-http-date (utime) + "Decode the universal time UTIME and return a date suitable for use in HTTP 1.0 applications (RFC-822, but GMT)" + (declare (optimize (speed 3))) + (with-date + utime 0 + (format nil + (formatter "~3/net.telent.date:dayname/, ~2,'0D ~3/net.telent.date:monthname/ ~D ~2,'0D:~2,'0D:~2,'0D GMT") + day-of-week day-of-month month year hour minute second))) + +;;; follow the decode-universal-time rules for handling a time-zone parameter. +;;; CL timezones increase westward; RFC timezone specifications increase +;;; _eastward_. I love standards +(defun universal-time-to-rfc2822-date (utime &optional time-zone) + "Decode the universal time UTIME and return an RFC-2822-format string. TIME-ZONE is a CL time zone. If not supplied, it defaults to the current time zone adjusted for daylight saving time. If TIME-ZONE is supplied, daylight saving time information is ignored." + (declare (optimize (speed 3))) + (with-decoding (utime time-zone) + (let ((daylight-zone (if daylight-p (1- zone) zone))) + (multiple-value-bind (z-h z-m) (truncate (abs daylight-zone)) + (format nil + (formatter "~3/net.telent.date:dayname/, ~2,'0D ~3/net.telent.date:monthname/ ~D ~2,'0D:~2,'0D:~2,'0D ~A~2,'0D~2,'0D") + day-of-week day-of-month month year hour minute second + (if (minusp daylight-zone) #\+ #\-) + z-h (floor (* 60 z-m))))))) +#| + +Timezones are _so_ easy to get wrong that I strongly advise always using UTC +for anything that a machine might someday want to parse. When testing +changes to universal-time-to-rfc2822-date, make sure to cover + +1) Explicit timezone, in summer and in winter + +2) Local time, in summer and in winter +2a) In a zone west of Greenwich (e.g. any US zone) +:; TZ=US/Eastern date -R --date='23 Aug 2003 12:00:00 GMT' +Sat, 23 Aug 2003 08:00:00 -0400 +:; TZ=US/Eastern date -R --date='05 Jan 2003 12:00:00 GMT' +Sun, 05 Jan 2003 07:00:00 -0500 + +2b) In a zone east of Greenwich (e.g. Europe/Paris) +:; TZ=Europe/Paris date -R --date='23 Aug 2003 12:00:00 GMT' +Sat, 23 Aug 2003 14:00:00 +0200 +:; TZ=Europe/Paris date -R --date='05 Jan 2003 12:00:00 GMT' +Sun, 05 Jan 2003 13:00:00 +0100 + +2c) In Canada/Newfoundland or other non-integer zone +:; TZ=Canada/Newfoundland date -R --date='23 Aug 2003 12:00:00 GMT' +Sat, 23 Aug 2003 09:30:00 -0230 +:; TZ=Canada/Newfoundland date -R --date='05 Jan 2003 12:00:00 GMT' +Sun, 05 Jan 2003 08:30:00 -0330 + +Note signs on the timezones, and that the offset for a half-hour is +xx30 not xx50. The universal times in question are + +3250756800 is 05 Jan 2003, probably not DST +3270628800 is 23 Aug 2003 (daylight savings in effect most places) + +You probably need to change the TZ environment variable and restart your +Lisp to do most of the tests in (2). + +|# + + +;;; for backward compatibility (with araneida, mostly) +(setf (symbol-function 'universal-time-to-rfc-date) + #'universal-time-to-http-date) Added: branches/grin-neu/thirdparty/net-telent-date/defpackage.lisp =================================================================== --- branches/grin-neu/thirdparty/net-telent-date/defpackage.lisp 2006-12-01 10:37:34 UTC (rev 2093) +++ branches/grin-neu/thirdparty/net-telent-date/defpackage.lisp 2006-12-01 10:39:49 UTC (rev 2094) @@ -0,0 +1,11 @@ +(defpackage :net.telent.date + (:nicknames :date) + (:use #:CL) + (:export dayname monthname + with-date ; deprecated + with-decoding ; use this instead + second minute hour day-of-month month year day-of-week + daylight-p zone universal-time-to-rfc-date + universal-time-to-http-date + universal-time-to-rfc2822-date parse-time)) + Added: branches/grin-neu/thirdparty/net-telent-date/maintainer-Makefile =================================================================== --- branches/grin-neu/thirdparty/net-telent-date/maintainer-Makefile 2006-12-01 10:37:34 UTC (rev 2093) +++ branches/grin-neu/thirdparty/net-telent-date/maintainer-Makefile 2006-12-01 10:39:49 UTC (rev 2094) @@ -0,0 +1,20 @@ +all: + @echo "The makefile is here for my use, not yours. Use the defsystem, Luke" + +LISP=sbcl --noprogramer --no-userinit # --no-sysinit +#LISP=lisp -batch +PACKAGE=net-telent-date +test: + @echo You will need two things for the tests to succeed. + @echo '(1) Internet access ' + @echo '(2) echo services on localhost' + @echo The echo services are often disabled for security reasons, so + @echo dont forget to put them back when finished. + echo '(mk:load-system (quote $(PACKAGE))) (rt:do-tests)' | $(LISP) + +clean: + -rm *.*f *.fasl a.out *.so *.err + +deb: + CVSROOT=`cat CVS/Root` cvs-buildpackage -F -uc -us -rfakeroot -M $(PACKAGE) + Added: branches/grin-neu/thirdparty/net-telent-date/make-makefile.lisp =================================================================== --- branches/grin-neu/thirdparty/net-telent-date/make-makefile.lisp 2006-12-01 10:37:34 UTC (rev 2093) +++ branches/grin-neu/thirdparty/net-telent-date/make-makefile.lisp 2006-12-01 10:39:49 UTC (rev 2094) @@ -0,0 +1,51 @@ +(in-package :cl-user) + +;;; given a system definition, create a "Makefile" that copies all the +;;; source files in it into a given directory + +(defun print-source-file-name (component stream) + (case (make::component-type component) + ((:file) + (format stream "~A " + (enough-namestring + (translate-logical-pathname + (pathname + (make::component-full-pathname component :source)))))) + ((:module :defsystem) + (loop for c in (make::component-components component) + do (print-source-file-name c stream))) + (t (format t "Doing nothing for ~A ~%" component)))) + +(defun make-makefile (system output-file) + "List files in SYSTEM, in the order that they need to be processed" + (with-open-file (o output-file :direction :output + :if-exists :rename) + (format o "# Automatically generated, edit make-makefile.lisp instead + +FILES=") + (let* ((system-definition (make::find-system system)) + (*default-pathname-defaults* + (translate-logical-pathname (make::component-source-root-dir system-definition)))) + (print-source-file-name system-definition o)) + (format o " + +all: + @echo That did nothing: now look at the defsystem + +release: debian/changelog + head -1 debian/changelog |cut -d' ' -f2 | tr -d '()' > release + + +install: + install -d $(DESTDIR)/usr/share/common-lisp/repositories/~A + tar cf - $(FILES) ~A.system | (cd $(DESTDIR)/usr/share/common-lisp/repositories/~A && tar xvpf -) + + +clean: + -rm a.out *~~ diffs *.*f ~%" + (string-downcase (symbol-name system)) + (string-downcase (symbol-name system)) + (string-downcase (symbol-name system))))) + + + Added: branches/grin-neu/thirdparty/net-telent-date/net-telent-date.asd =================================================================== --- branches/grin-neu/thirdparty/net-telent-date/net-telent-date.asd 2006-12-01 10:37:34 UTC (rev 2093) +++ branches/grin-neu/thirdparty/net-telent-date/net-telent-date.asd 2006-12-01 10:39:49 UTC (rev 2094) @@ -0,0 +1,10 @@ +;;; -*- Lisp -*- + +(defpackage :net-telent-date-system (:use #:cl #:asdf)) +(in-package :net-telent-date-system) + +(defsystem net-telent-date + :version "0.41" + :components ((:file "defpackage") + (:file "date" :depends-on ("defpackage")) + (:file "parse-time" :depends-on ("defpackage")))) Added: branches/grin-neu/thirdparty/net-telent-date/net-telent-date.system =================================================================== --- branches/grin-neu/thirdparty/net-telent-date/net-telent-date.system 2006-12-01 10:37:34 UTC (rev 2093) +++ branches/grin-neu/thirdparty/net-telent-date/net-telent-date.system 2006-12-01 10:39:49 UTC (rev 2094) @@ -0,0 +1,9 @@ +;;; -*- Lisp -*- + +(in-package :cl-user) + +(make:defsystem net-telent-date + :source-pathname #p"cl-library:net-telent-date;" + :components ((:file "defpackage") + (:file "date" :depends-on ("defpackage")) + (:file "parse-time" :depends-on ("defpackage")))) Added: branches/grin-neu/thirdparty/net-telent-date/parse-time.lisp =================================================================== --- branches/grin-neu/thirdparty/net-telent-date/parse-time.lisp 2006-12-01 10:37:34 UTC (rev 2093) +++ branches/grin-neu/thirdparty/net-telent-date/parse-time.lisp 2006-12-01 10:39:49 UTC (rev 2094) @@ -0,0 +1,638 @@ +(in-package :net.telent.date) + +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; + +;;; It was subsequently borrowed and modified slightly by Daniel +;;; Barlow to become part of the net-telent-date +;;; package. Daniel, Tue May 22 05:45:27 BST 2001 + +;;; ********************************************************************** + +;;; Parsing routines for time and date strings. PARSE-TIME returns the +;;; universal time integer for the time and/or date given in the string. + +;;; Written by Jim Healy, June 1987. + +;;; ********************************************************************** + +(defvar whitespace-chars '(#\space #\tab #\newline #\, #\' #\`)) +(defvar time-dividers '(#\: #\.)) +(defvar date-dividers '(#\\ #\/ #\-)) + +(defvar *error-on-mismatch* nil + "If t, an error will be signalled if parse-time is unable + to determine the time/date format of the string.") + +;;; Set up hash tables for month, weekday, zone, and special strings. +;;; Provides quick, easy access to associated information for these items. + +;;; Hashlist takes an association list and hashes each pair into the +;;; specified tables using the car of the pair as the key and the cdr as +;;; the data object. + +(defmacro hashlist (list table) + `(dolist (item ,list) + (setf (gethash (car item) ,table) (cdr item)))) + +(defparameter weekday-table-size 23) +(defparameter month-table-size 31) +(defparameter zone-table-size 11) +(defparameter special-table-size 11) + +(defvar *weekday-strings* (make-hash-table :test #'equal + :size weekday-table-size)) + +(defvar *month-strings* (make-hash-table :test #'equal + :size month-table-size)) + +(defvar *zone-strings* (make-hash-table :test #'equal + :size zone-table-size)) + +(defvar *special-strings* (make-hash-table :test #'equal + :size special-table-size)) + +;;; Load-time creation of the hash tables. + +(hashlist '(("monday" . 0) ("mon" . 0) + ("tuesday" . 1) ("tues" . 1) ("tue" . 1) + ("wednesday" . 2) ("wednes" . 2) ("wed" . 2) + ("thursday" . 3) ("thurs" . 3) ("thu" . 3) + ("friday" . 4) ("fri" . 4) + ("saturday" . 5) ("sat" . 5) + ("sunday" . 6) ("sun" . 6)) + *weekday-strings*) + +(hashlist '(("january" . 1) ("jan" . 1) + ("february" . 2) ("feb" . 2) + ("march" . 3) ("mar" . 3) + ("april" . 4) ("apr" . 4) + ("may" . 5) ("june" . 6) + ("jun" . 6) ("july" . 7) + ("jul" . 7) ("august" . 8) + ("aug" . 8) ("september" . 9) + ("sept" . 9) ("sep" . 9) + ("october" . 10) ("oct" . 10) + ("november" . 11) ("nov" . 11) + ("december" . 12) ("dec" . 12)) + *month-strings*) + +(hashlist '(("gmt" . 0) ("est" . 5) + ("edt" . 4) ("cst" . 6) + ("cdt" . 5) ("mst" . 7) + ("mdt" . 6) ("pst" . 8) + ("pdt" . 7)) + *zone-strings*) + +(hashlist '(("yesterday" . yesterday) ("today" . today) + ("tomorrow" . tomorrow) ("now" . now)) + *special-strings*) + +;;; Time/date format patterns are specified as lists of symbols repre- +;;; senting the elements. Optional elements can be specified by +;;; enclosing them in parentheses. Note that the order in which the +;;; patterns are specified below determines the order of search. + +;;; Choices of pattern symbols are: second, minute, hour, day, month, +;;; year, time-divider, date-divider, am-pm, zone, izone, weekday, +;;; noon-midn, and any special symbol. + +(defparameter *default-date-time-patterns* + '( + ;; Date formats. + ((weekday) month (date-divider) day (date-divider) year (noon-midn)) + ((weekday) day (date-divider) month (date-divider) year (noon-midn)) + ((weekday) month (date-divider) day (noon-midn)) + (year (date-divider) month (date-divider) day (noon-midn)) + (month (date-divider) year (noon-midn)) + (year (date-divider) month (noon-midn)) + + ((noon-midn) (weekday) month (date-divider) day (date-divider) year) + ((noon-midn) (weekday) day (date-divider) month (date-divider) year) + ((noon-midn) (weekday) month (date-divider) day) + ((noon-midn) year (date-divider) month (date-divider) day) + ((noon-midn) month (date-divider) year) + ((noon-midn) year (date-divider) month) + + ;; Time formats. + (hour (time-divider) (minute) (time-divider) (secondp) (am-pm) + (date-divider) (zone)) + (noon-midn) + (hour (noon-midn)) + + ;; Time/date combined formats. + ((weekday) month (date-divider) day (date-divider) year + hour (time-divider) (minute) (time-divider) (secondp) + (am-pm) (date-divider) (zone)) + ((weekday) day (date-divider) month (date-divider) year + hour (time-divider) (minute) (time-divider) (secondp) + (am-pm) (date-divider) (zone)) + ((weekday) month (date-divider) day + hour (time-divider) (minute) (time-divider) (secondp) + (am-pm) (date-divider) (zone)) + (year (date-divider) month (date-divider) day + hour (time-divider) (minute) (time-divider) (secondp) + (am-pm) (date-divider) (zone)) + (month (date-divider) year + hour (time-divider) (minute) (time-divider) (secondp) + (am-pm) (date-divider) (zone)) + (year (date-divider) month + hour (time-divider) (minute) (time-divider) (secondp) + (am-pm) (date-divider) (zone)) + + (hour (time-divider) (minute) (time-divider) (secondp) (am-pm) + (date-divider) (zone) (weekday) month (date-divider) + day (date-divider) year) + (hour (time-divider) (minute) (time-divider) (secondp) (am-pm) + (date-divider) (zone) (weekday) day (date-divider) + month (date-divider) year) + (hour (time-divider) (minute) (time-divider) (secondp) (am-pm) + (date-divider) (zone) (weekday) month (date-divider) + day) + (hour (time-divider) (minute) (time-divider) (secondp) (am-pm) + (date-divider) (zone) year (date-divider) month + (date-divider) day) + (hour (time-divider) (minute) (time-divider) (secondp) (am-pm) + (date-divider) (zone) month (date-divider) year) + (hour (time-divider) (minute) (time-divider) (secondp) (am-pm) + (date-divider) (zone) year (date-divider) month) + + ;; Weird, non-standard formats. + (weekday month day hour (time-divider) minute (time-divider) + secondp (am-pm) + (zone) year) + ((weekday) day (date-divider) month (date-divider) year hour + (time-divider) minute (time-divider) (secondp) (am-pm) + (date-divider) (zone)) + ((weekday) month (date-divider) day (date-divider) year hour + (time-divider) minute (time-divider) (secondp) (am-pm) + (date-divider) (zone)) + + ;; Special-string formats. + (now (yesterday)) + ((yesterday) now) + (now (today)) + ((today) now) + (now (tomorrow)) + ((tomorrow) now) + (yesterday (noon-midn)) + ((noon-midn) yesterday) + (today (noon-midn)) + ((noon-midn) today) + (tomorrow (noon-midn)) + ((noon-midn) tomorrow) +)) + +;;; HTTP header style date/time patterns: RFC1123/RFC822, RFC850, ANSI-C. +(defparameter *http-date-time-patterns* + '( + ;; RFC1123/RFC822 and RFC850. + ((weekday) day (date-divider) month (date-divider) year + hour time-divider minute (time-divider) (secondp) izone) + ((weekday) day (date-divider) month (date-divider) year + hour time-divider minute (time-divider) (secondp) (zone)) + + ;; ANSI-C. + ((weekday) month day + hour time-divider minute (time-divider) (secondp) year))) + + +;;; The decoded-time structure holds the time/date values which are +;;; eventually passed to 'encode-universal-time' after parsing. + +;;; Note: Currently nothing is done with the day of the week. It might +;;; be appropriate to add a function to see if it matches the date. + +(defstruct decoded-time + (second 0 :type integer) ; Value between 0 and 59. + (minute 0 :type integer) ; Value between 0 and 59. + (hour 0 :type integer) ; Value between 0 and 23. + (day 1 :type integer) ; Value between 1 and 31. + (month 1 :type integer) ; Value between 1 and 12. + (year 1900 :type integer) ; Value above 1899 or between 0 and 99. + (zone 0 :type rational) ; Value between -24 and 24 inclusive. + (dotw 0 :type integer)) ; Value between 0 and 6. + +;;; Make-default-time returns a decoded-time structure with the default +;;; time values already set. The default time is currently 00:00 on +;;; the current day, current month, current year, and current time-zone. + +(defun make-default-time (def-sec def-min def-hour def-day + def-mon def-year def-zone def-dotw) + (let ((default-time (make-decoded-time))) + (multiple-value-bind (sec min hour day mon year dotw dst zone) + (get-decoded-time) + (declare (ignore dst)) + (if def-sec + (if (eq def-sec :current) + (setf (decoded-time-second default-time) sec) + (setf (decoded-time-second default-time) def-sec)) + (setf (decoded-time-second default-time) 0)) + (if def-min + (if (eq def-min :current) + (setf (decoded-time-minute default-time) min) + (setf (decoded-time-minute default-time) def-min)) + (setf (decoded-time-minute default-time) 0)) + (if def-hour + (if (eq def-hour :current) + (setf (decoded-time-hour default-time) hour) + (setf (decoded-time-hour default-time) def-hour)) + (setf (decoded-time-hour default-time) 0)) + (if def-day + (if (eq def-day :current) + (setf (decoded-time-day default-time) day) + (setf (decoded-time-day default-time) def-day)) + (setf (decoded-time-day default-time) day)) + (if def-mon + (if (eq def-mon :current) + (setf (decoded-time-month default-time) mon) + (setf (decoded-time-month default-time) def-mon)) + (setf (decoded-time-month default-time) mon)) + (if def-year + (if (eq def-year :current) + (setf (decoded-time-year default-time) year) + (setf (decoded-time-year default-time) def-year)) + (setf (decoded-time-year default-time) year)) + (if def-zone + (if (eq def-zone :current) + (setf (decoded-time-zone default-time) zone) + (setf (decoded-time-zone default-time) def-zone)) + (setf (decoded-time-zone default-time) zone)) + (if def-dotw + (if (eq def-dotw :current) + (setf (decoded-time-dotw default-time) dotw) + (setf (decoded-time-dotw default-time) def-dotw)) + (setf (decoded-time-dotw default-time) dotw)) + default-time))) + +;;; Converts the values in the decoded-time structure to universal time +;;; by calling encode-universal-time. +;;; If zone is in numerical form, tweeks it appropriately. + +(defun convert-to-unitime (parsed-values) + (let ((zone (decoded-time-zone parsed-values))) + (encode-universal-time (decoded-time-second parsed-values) + (decoded-time-minute parsed-values) + (decoded-time-hour parsed-values) + (decoded-time-day parsed-values) + (decoded-time-month parsed-values) + (decoded-time-year parsed-values) + (if (or (> zone 24) (< zone -24)) + (let ((new-zone (/ zone 100))) + (cond ((minusp new-zone) (- new-zone)) + ((plusp new-zone) (- 24 new-zone)) + ;; must be zero (GMT) + (t new-zone))) + zone)))) + +;;; Sets the current values for the time and/or date parts of the +;;; decoded time structure. + +(defun set-current-value (values-structure &key (time nil) (date nil) + (zone nil)) + (multiple-value-bind (sec min hour day mon year dotw dst tz) + (get-decoded-time) + (declare (ignore dst)) + (when time + (setf (decoded-time-second values-structure) sec) + (setf (decoded-time-minute values-structure) min) + (setf (decoded-time-hour values-structure) hour)) + (when date + (setf (decoded-time-day values-structure) day) + (setf (decoded-time-month values-structure) mon) + (setf (decoded-time-year values-structure) year) + (setf (decoded-time-dotw values-structure) dotw)) + (when zone + (setf (decoded-time-zone values-structure) tz)))) + +;;; Special function definitions. To define a special substring, add +;;; a dotted pair consisting of the substring and a symbol in the +;;; *special-strings* hashlist statement above. Then define a function +;;; here which takes one argument- the decoded time structure- and +;;; sets the values of the structure to whatever is necessary. Also, +;;; add a some patterns to the patterns list using whatever combinations +;;; of special and pre-existing symbols desired. + +(defun yesterday (parsed-values) + (set-current-value parsed-values :date t :zone t) + (setf (decoded-time-day parsed-values) + (1- (decoded-time-day parsed-values)))) + +(defun today (parsed-values) + (set-current-value parsed-values :date t :zone t)) + +(defun tomorrow (parsed-values) + (set-current-value parsed-values :date t :zone t) + (setf (decoded-time-day parsed-values) + (1+ (decoded-time-day parsed-values)))) + +(defun now (parsed-values) + (set-current-value parsed-values :time t)) + +;;; Predicates for symbols. Each symbol has a corresponding function +;;; defined here which is applied to a part of the datum to see if +;;; it matches the qualifications. + +(defun am-pm (string) + (and (simple-string-p string) + (cond ((string= string "am") 'am) + ((string= string "pm") 'pm) + (t nil)))) + +(defun noon-midn (string) + (and (simple-string-p string) + (cond ((string= string "noon") 'noon) + ((string= string "midnight") 'midn) + (t nil)))) + +(defun weekday (string) + (and (simple-string-p string) (gethash string *weekday-strings*))) + +(defun month (thing) + (or (and (simple-string-p thing) (gethash thing *month-strings*)) + (and (integerp thing) (<= 1 thing 12)))) + +(defun zone (thing) + (or (and (simple-string-p thing) (gethash thing *zone-strings*)) + (if (integerp thing) + (let ((zone (/ thing 100))) + (and (integerp zone) (<= -24 zone 24)))))) + +;;; Internet numerical time zone, e.g. RFC1123, in hours and minutes. +(defun izone (thing) + (if (integerp thing) + (multiple-value-bind (hours mins) + (truncate thing 100) + (and (<= -24 hours 24) (<= -59 mins 59))))) + +(defun special-string-p (string) + (and (simple-string-p string) (gethash string *special-strings*))) + +(defun secondp (number) + (and (integerp number) (<= 0 number 59))) + +(defun minute (number) + (and (integerp number) (<= 0 number 59))) + +(defun hour (number) + (and (integerp number) (<= 0 number 23))) + +(defun day (number) + (and (integerp number) (<= 1 number 31))) + +(defun year (number) + (and (integerp number) + (or (<= 0 number 99) + (<= 1900 number)))) + +(defun time-divider (character) + (and (characterp character) + (member character time-dividers :test #'char=))) + +(defun date-divider (character) + (and (characterp character) + (member character date-dividers :test #'char=))) + +;;; Match-substring takes a string argument and tries to match it with +;;; the strings in one of the four hash tables: *weekday-strings*, *month- +;;; strings*, *zone-strings*, *special-strings*. It returns a specific +;;; keyword and/or the object it finds in the hash table. If no match +;;; is made then it immediately signals an error. + +(defun match-substring (substring) + (let ((substring (nstring-downcase substring))) + (or (let ((test-value (month substring))) + (if test-value (cons 'month test-value))) + (let ((test-value (weekday substring))) + (if test-value (cons 'weekday test-value))) + (let ((test-value (am-pm substring))) + (if test-value (cons 'am-pm test-value))) + (let ((test-value (noon-midn substring))) + (if test-value (cons 'noon-midn test-value))) + (let ((test-value (zone substring))) + (if test-value (cons 'zone test-value))) + (let ((test-value (special-string-p substring))) + (if test-value (cons 'special test-value))) + (if *error-on-mismatch* + (error "\"~A\" is not a recognized word or abbreviation." + substring) + (return-from match-substring nil))))) + +;;; Decompose-string takes the time/date string and decomposes it into a +;;; list of alphabetic substrings, numbers, and special divider characters. +;;; It matches whatever strings it can and replaces them with a dotted pair +;;; containing a symbol and value. + +(defun decompose-string (string &key (start 0) (end (length string)) (radix 10)) + (do ((string-index start) + (next-negative nil) + (parts-list nil)) + ((eq string-index end) (nreverse parts-list)) + (let ((next-char (char string string-index)) + (prev-char (if (= string-index start) + nil + (char string (1- string-index))))) + (cond ((alpha-char-p next-char) + ;; Alphabetic character - scan to the end of the substring. + (do ((scan-index (1+ string-index) (1+ scan-index))) + ((or (eq scan-index end) + (not (alpha-char-p (char string scan-index)))) + (let ((match-symbol (match-substring + (subseq string string-index scan-index)))) + (if match-symbol + (push match-symbol parts-list) + (return-from decompose-string nil))) + (setf string-index scan-index)))) + ((digit-char-p next-char radix) + ;; Numeric digit - convert digit-string to a decimal value. + (do ((scan-index string-index (1+ scan-index)) + (numeric-value 0 (+ (* numeric-value radix) + (digit-char-p (char string scan-index) radix)))) + ((or (eq scan-index end) + (not (digit-char-p (char string scan-index) radix))) + ;; If next-negative is t, set the numeric value to it's + ;; opposite and reset next-negative to nil. + (when next-negative + (setf next-negative nil) + (setf numeric-value (- numeric-value))) + (push numeric-value parts-list) + (setf string-index scan-index)))) + ((and (or (char= next-char #\-) + (char= next-char #\+)) + (or (not prev-char) + (member prev-char whitespace-chars :test #'char=))) + ;; If we see a minus or plus sign before a number, but + ;; not after one, it is not a date divider, but an offset + ;; from GMT, so set next-negative to t if minus and + ;; continue. + (and (char= next-char #\-) + (setf next-negative t)) + (incf string-index)) + ((member next-char time-dividers :test #'char=) + ;; Time-divider - add it to the parts-list with symbol. + (push (cons 'time-divider next-char) parts-list) + (incf string-index)) + ((member next-char date-dividers :test #'char=) + ;; Date-divider - add it to the parts-list with symbol. + (push (cons 'date-divider next-char) parts-list) + (incf string-index)) + ((member next-char whitespace-chars :test #'char=) + ;; Whitespace character - ignore it completely. + (incf string-index)) + ((char= next-char #\() + ;; Parenthesized string - scan to the end and ignore it. + (do ((scan-index string-index (1+ scan-index))) + ((or (eq scan-index end) + (char= (char string scan-index) #\))) + (setf string-index (1+ scan-index))))) + (t + ;; Unrecognized character - barf voraciously. + (if *error-on-mismatch* + (error + 'simple-error + :format-control "Can't parse time/date string.~%>>> ~A~ + ~%~VT^-- Bogus character encountered here." + :format-arguments (list string (+ string-index 4))) + (return-from decompose-string nil))))))) + +;;; Match-pattern-element tries to match a pattern element with a datum +;;; element and returns the symbol associated with the datum element if +;;; successful. Otherwise nil is returned. + +(defun match-pattern-element (pattern-element datum-element) + (cond ((listp datum-element) + (let ((datum-type (if (eq (car datum-element) 'special) + (cdr datum-element) + (car datum-element)))) + (if (eq datum-type pattern-element) datum-element))) + ((funcall pattern-element datum-element) + (cons pattern-element datum-element)) + (t nil))) + +;;; Match-pattern matches a pattern against a datum, returning the +;;; pattern if successful and nil otherwise. + +(defun match-pattern (pattern datum datum-length) + (if (>= (length pattern) datum-length) + (let ((form-list nil)) + (do ((pattern pattern (cdr pattern)) + (datum datum (cdr datum))) + ((or (null pattern) (null datum)) + (cond ((and (null pattern) (null datum)) + (nreverse form-list)) + ((null pattern) nil) + ((null datum) (dolist (element pattern + (nreverse form-list)) + (if (not (listp element)) + (return nil)))))) + (let* ((pattern-element (car pattern)) + (datum-element (car datum)) + (optional (listp pattern-element)) + (matching (match-pattern-element (if optional + (car pattern-element) + pattern-element) + datum-element))) + (cond (matching (let ((form-type (car matching))) + (unless (or (eq form-type 'time-divider) + (eq form-type 'date-divider)) + (push matching form-list)))) + (optional (push datum-element datum)) + (t (return-from match-pattern nil)))))))) + +;;; Deal-with-noon-midn sets the decoded-time values to either noon +;;; or midnight depending on the argument form-value. Form-value +;;; can be either 'noon or 'midn. + +(defun deal-with-noon-midn (form-value parsed-values) + (cond ((eq form-value 'noon) + (setf (decoded-time-hour parsed-values) 12)) + ((eq form-value 'midn) + (setf (decoded-time-hour parsed-values) 0)) + (t (error "Unrecognized symbol: ~A" form-value))) + (setf (decoded-time-minute parsed-values) 0) + (setf (decoded-time-second parsed-values) 0)) + +;;; Deal-with-am-pm sets the decoded-time values to be in the am +;;; or pm depending on the argument form-value. Form-value can +;;; be either 'am or 'pm. + +(defun deal-with-am-pm (form-value parsed-values) + (let ((hour (decoded-time-hour parsed-values))) + (cond ((eq form-value 'am) + (cond ((eq hour 12) + (setf (decoded-time-hour parsed-values) 0)) + ((not (<= 0 hour 12)) + (if *error-on-mismatch* + (error "~D is not an AM hour, dummy." hour))))) + ((eq form-value 'pm) + (if (<= 0 hour 11) + (setf (decoded-time-hour parsed-values) + (mod (+ hour 12) 24)))) + (t (error "~A isn't AM/PM - this shouldn't happen." form-value))))) + +;;; Internet numerical time zone, e.g. RFC1123, in hours and minutes. +(defun deal-with-izone (form-value parsed-values) + (multiple-value-bind (hours mins) + (truncate form-value 100) + (setf (decoded-time-zone parsed-values) (- (+ hours (/ mins 60)))))) + +;;; Set-time-values uses the association list of symbols and values +;;; to set the time in the decoded-time structure. + +(defun set-time-values (string-form parsed-values) + (dolist (form-part string-form t) + (let ((form-type (car form-part)) + (form-value (cdr form-part))) + (case form-type + (secondp (setf (decoded-time-second parsed-values) form-value)) + (minute (setf (decoded-time-minute parsed-values) form-value)) + (hour (setf (decoded-time-hour parsed-values) form-value)) + (day (setf (decoded-time-day parsed-values) form-value)) + (month (setf (decoded-time-month parsed-values) form-value)) + (year (setf (decoded-time-year parsed-values) form-value)) + (zone (setf (decoded-time-zone parsed-values) form-value)) + (izone (deal-with-izone form-value parsed-values)) + (weekday (setf (decoded-time-dotw parsed-values) form-value)) + (am-pm (deal-with-am-pm form-value parsed-values)) + (noon-midn (deal-with-noon-midn form-value parsed-values)) + (special (funcall form-value parsed-values)) + (t (error "Unrecognized symbol in form list: ~A." form-type)))))) + +(defun parse-time (time-string &key (start 0) (end (length time-string)) + (error-on-mismatch nil) + (patterns *default-date-time-patterns*) + (default-seconds nil) (default-minutes nil) + (default-hours nil) (default-day nil) + (default-month nil) (default-year nil) + (default-zone nil) (default-weekday nil)) + "Tries very hard to make sense out of the argument time-string and + returns a single integer representing the universal time if + successful. If not, it returns nil. If the :error-on-mismatch + keyword is true, parse-time will signal an error instead of + returning nil. Default values for each part of the time/date + can be specified by the appropriate :default- keyword. These + keywords can be given a numeric value or the keyword :current + to set them to the current value. The default-default values + are 00:00:00 on the current date, current time-zone." + (setq *error-on-mismatch* error-on-mismatch) + (let* ((string-parts (decompose-string time-string :start start :end end)) + (parts-length (length string-parts)) + (string-form (dolist (pattern patterns) + (let ((match-result (match-pattern pattern + string-parts + parts-length))) + (if match-result (return match-result)))))) + (if string-form + (let ((parsed-values (make-default-time default-seconds default-minutes + default-hours default-day + default-month default-year + default-zone default-weekday))) + (set-time-values string-form parsed-values) + (convert-to-unitime parsed-values)) + (if *error-on-mismatch* + (error "\"~A\" is not a recognized time/date format." time-string) + nil)))) + + Added: branches/grin-neu/thirdparty/net-telent-date/tests.lisp =================================================================== --- branches/grin-neu/thirdparty/net-telent-date/tests.lisp 2006-12-01 10:37:34 UTC (rev 2093) +++ branches/grin-neu/thirdparty/net-telent-date/tests.lisp 2006-12-01 10:39:49 UTC (rev 2094) @@ -0,0 +1,19 @@ +(eval-when (:compile-toplevel :load-toplevel :execute) + (defpackage #:net.telent.date.test (:use #:net.telent.date #:rt))) + +;;; This is not presently supposed to work out of the box. When we've +;;; figured out something approximating a standard test architecture +;;; for cclan, we'll revisit it + +(in-package :net.telent.date.test) + +(deftest print-date + (with-date 3200663765 0 + (format nil + (formatter "~3/net.telent.date:dayname/, ~2,'0D ~3/net.telent.date:monthname/ ~D ~2,'0D:~2,'0D:~2,'0D") + day-of-week day-of-month month year hour minute second)) + "Mon, 04 Jun 2001 17:16:05") + +(deftest parse-date + (date:parse-time "Mon, 04 Jun 2001 17:16:05") + 3200663765) Modified: branches/grin-neu/thirdparty/net.post-office/net.post-office.asd =================================================================== --- branches/grin-neu/thirdparty/net.post-office/net.post-office.asd 2006-12-01 10:37:34 UTC (rev 2093) +++ branches/grin-neu/thirdparty/net.post-office/net.post-office.asd 2006-12-01 10:39:49 UTC (rev 2094) @@ -7,7 +7,7 @@ (defsystem net.post-office :components ((:file "packages") (:file "smtp" :depends-on ("packages")) - (:file "imap" :depends-on ("packages"))) + #+(or) (:file "imap" :depends-on ("packages"))) #-allegro :depends-on #-allegro (acl-compat) :perform (load-op :after (op net.post-office) (pushnew :net.post-office cl:*features*))) Modified: branches/grin-neu/thirdparty/net.post-office/packages.lisp =================================================================== --- branches/grin-neu/thirdparty/net.post-office/packages.lisp 2006-12-01 10:37:34 UTC (rev 2093) +++ branches/grin-neu/thirdparty/net.post-office/packages.lisp 2006-12-01 10:39:49 UTC (rev 2094) @@ -1,6 +1,6 @@ (defpackage :net.post-office - (:use #:lisp #+allegro #:excl #-allegro #:acl-compat.excl) + (:use #:common-lisp #+allegro #:excl #-allegro #:acl-compat.excl) (:export ;; smtp #:send-letter Modified: branches/grin-neu/thirdparty/portableaserve/acl-compat/sbcl/acl-excl.lisp =================================================================== --- branches/grin-neu/thirdparty/portableaserve/acl-compat/sbcl/acl-excl.lisp 2006-12-01 10:37:34 UTC (rev 2093) +++ branches/grin-neu/thirdparty/portableaserve/acl-compat/sbcl/acl-excl.lisp 2006-12-01 10:39:49 UTC (rev 2094) @@ -11,12 +11,11 @@ stream) (defun filesys-type (file-or-directory-name) - (if (eq :directory (sb-unix:unix-file-kind - (namestring file-or-directory-name))) - :directory - (if (probe-file file-or-directory-name) - :file - nil))) + (let ((mode (sb-posix:stat-mode (sb-posix:stat file-or-directory-name)))) + (cond + ((sb-posix:s-isreg mode) :file) + ((sb-posix:s-isdir mode) :directory) + (t nil)))) (defmacro atomically (&body forms) `(acl-mp:without-scheduling , at forms)) @@ -25,5 +24,9 @@ (declare (ignore signal pid)) (error "unix-signal not implemented in acl-excl-sbcl.lisp")) -(defmacro without-package-locks (&body forms) - `(progn , at forms)) +(defun filesys-inode (path) + (sb-posix:stat-ino (sb-posix:lstat path))) + +(defun cl-internal-real-time () + (round (/ (get-internal-real-time) internal-time-units-per-second))) + Modified: branches/grin-neu/thirdparty/portableaserve/acl-compat/sbcl/acl-mp.lisp =================================================================== --- branches/grin-neu/thirdparty/portableaserve/acl-compat/sbcl/acl-mp.lisp 2006-12-01 10:37:34 UTC (rev 2093) +++ branches/grin-neu/thirdparty/portableaserve/acl-compat/sbcl/acl-mp.lisp 2006-12-01 10:39:49 UTC (rev 2094) @@ -8,65 +8,6 @@ (in-package :acl-compat.mp) -#-sb-thread -(progn - -(defparameter *current-process* nil) - -(defparameter *all-processes* nil) - -(macrolet ((def (name args) - `(defun ,name ,args - (declare (ignore ,@(remove-if - (lambda (x) - (member x '(&optional &rest &key &allow-other-keys &aux))) - (mapcar (lambda (x) (if (consp x) (car x) x)) - args)))) - (error "~A: Calling a multiprocessing function on a single-threaded sbcl build" - ',name)))) - (def process-interrupt (process function)) - (defun process-name (process) ; *x - (declare (ignore process)) - "the only process") - (def process-wait-function (process)) - (def process-whostate (process)) - (def process-wait (process)) ; *x - (def process-allow-schedule ()) ; *x - (def process-property-list (process)) ; *x - (def (setf process-property-list) (new-value process)) - (def process-run-reasons (process)) ; *x - (def (setf process-run-reasons) (new-value process)) - (def process-revoke-run-reason (process object)) ; *x - (def process-add-run-reason (process object)) ; *x - (def process-run-function (name-or-options preset-function - &rest preset-arguments)) ; *x - (def process-preset (process preset-function &rest arguments)) ; *x - (def process-initial-bindings (process)) - (def (setf process-initial-bindings) (bindings process)) - (def make-process (&key (name "Anonymous") reset-action run-reasons - arrest-reasons (priority 0) quantum resume-hook - suspend-hook initial-bindings run-immediately)) ; *x - (def process-kill (process)) ; *x - (def make-process-lock (&key name))) ; *x - -(defmacro with-process-lock ((lock &key norecursive timeout whostate) &body forms) - (declare (ignore lock norecursive timeout whostate)) - `(progn , at forms)) ; *x - -(defmacro without-scheduling (&body forms) - `(progn , at forms)) ; * -) ; #-sb-thread - -;;; Same implementation for multi- and uni-thread -(defmacro with-timeout ((seconds &body timeout-forms) &body body) - (let ((c (gensym "TIMEOUT-"))) - `(handler-case - (sb-ext:with-timeout ,seconds (progn , at body)) - (sb-ext:timeout (,c) (declare (ignore ,c)) , at timeout-forms)))) - - -#+sb-thread -(progn (defstruct (process (:constructor %make-process) (:predicate processp)) @@ -76,26 +17,161 @@ function ; function wot will be run arguments ; arguments to the function id ; pid of unix thread or nil - %queue ; lock for process structure mutators + %lock ; lock for process structure mutators run-reasons ; primitive mailbox for IPC - %block-queue ; queue for condition-wait + %queue ; queue for condition-wait initial-bindings ; special variable bindings - property-list - ) + property-list) -(defvar *current-process* +(defparameter *current-process* + #-sb-thread + (%make-process) + #+sb-thread ;; We don't fill in the process id, so the process compiling this ;; (the REPL, in most cases) can't be killed by accident. (loop for ;; p in (all-processes) do (kill-process p)), anyone? (%make-process :name "initial process" :function nil)) -(defvar *all-processes* (list *current-process*)) +(defparameter *all-processes-lock* + (sb-thread:make-mutex :name "all processes lock")) -(defvar *conditional-store-queue* (sb-thread:make-waitqueue)) +(defparameter *all-processes* + (list *current-process*)) +#-sb-thread +(defun make-process (&key (name "Anonymous") reset-action run-reasons + arrest-reasons (priority 0) quantum resume-hook + suspend-hook initial-bindings run-immediately) + (declare (ignore reset-action arrest-reasons priority quantum resume-hook + suspend-hook run-immediately)) + (%make-process :name "the only process" + :run-reasons run-reasons + :initial-bindings initial-bindings)) + +#+sb-thread +(defun make-process (&key (name "Anonymous") reset-action run-reasons + arrest-reasons (priority 0) quantum resume-hook + suspend-hook initial-bindings run-immediately) + (declare (ignore reset-action arrest-reasons priority quantum resume-hook + suspend-hook run-immediately)) + (let ((p (%make-process + :name name + :run-reasons run-reasons + :initial-bindings initial-bindings + :%lock (sb-thread:make-mutex + :name (format nil "Internal lock for ~A" name)) + :%queue (sb-thread:make-waitqueue + :name (format nil "Blocking queue for ~A" name))))) + (sb-thread:with-mutex (*all-processes-lock*) + (push p *all-processes*)) + p)) + +(defmacro defun/sb-thread (name args &body body) + #-sb-thread (declare (ignore body)) + `(defun ,name ,args + #-sb-thread + (declare (ignore ,@(remove-if + (lambda (x) + (member x '(&optional &rest &key &allow-other-keys + &aux))) + (mapcar (lambda (x) (if (consp x) (car x) x)) + args)))) + #-sb-thread + (error + "~A: Calling a multiprocessing function on a single-threaded sbcl build" + ',name) + #+sb-thread + , at body)) + +(defun/sb-thread process-interrupt (process function) + (sb-thread:interrupt-thread (process-id process) function)) + +;; TODO: why no such function was in +sb-thread part? +(defun/sb-thread process-wait-function (process) + (declare (ignore process))) + +(defun/sb-thread process-wait (reason predicate &rest arguments) + (declare (type function predicate)) + (let ((old-state (process-whostate *current-process*))) + (unwind-protect + (progn + (setf old-state (process-whostate *current-process*) + (process-whostate *current-process*) reason) + (loop + (let ((it (apply predicate arguments))) + (when it (return it))) + (process-allow-schedule))) + (setf (process-whostate *current-process*) old-state)))) + +(defun/sb-thread process-allow-schedule (&optional process) + (declare (ignore process)) + (sleep .01)) + +(defun/sb-thread process-revoke-run-reason (process object) + (sb-thread:with-recursive-lock ((process-%lock process)) + (prog1 + (setf (process-run-reasons process) + (delete object (process-run-reasons process))) + (when (and (process-id process) (not (process-run-reasons process))) + (disable-process process))))) + +(defun/sb-thread process-add-run-reason (process object) + (sb-thread:with-recursive-lock ((process-%lock process)) + (prog1 + (push object (process-run-reasons process)) + (if (process-id process) + (enable-process process) + (restart-process process))))) + +(defun/sb-thread process-run-function (name-or-options preset-function + &rest preset-arguments) + (let* ((make-process-args (etypecase name-or-options + (list name-or-options) + (string (list :name name-or-options)))) + (process (apply #'make-process make-process-args))) + (apply #'process-preset process preset-function preset-arguments) + (setf (process-run-reasons process) :enable) + (restart-process process) + process)) + +(defun/sb-thread process-preset (process function &rest arguments) + (setf (process-function process) function + (process-arguments process) arguments) + (when (process-id process) (restart-process process))) + +(defun/sb-thread process-kill (process) + (when (process-id process) + (sb-thread:destroy-thread (process-id process)) + (setf (process-id process) nil)) + (sb-thread:with-mutex (*all-processes-lock*) + (setf *all-processes* (delete process *all-processes*)))) + +#+sb-thread +(defun make-process-lock (&key name) + (sb-thread:make-mutex :name name)) +#-sb-thread +(defun make-process-lock (&key name) + (declare (ignore name)) + nil) + +(defun/sb-thread process-lock (lock &optional lock-value whostate timeout) + (declare (ignore whostate timeout)) + (sb-thread:get-mutex lock lock-value)) + +(defun/sb-thread process-unlock (lock &optional lock-value) + (declare (ignore lock-value)) + (sb-thread:release-mutex lock)) + +#-sb-thread +(defmacro with-process-lock ((lock &key norecursive timeout whostate) + &body forms) + (declare (ignore lock norecursive timeout whostate)) + `(progn , at forms)) + +#+sb-thread (defmacro with-process-lock ((place &key timeout whostate norecursive) &body body) - (declare (ignore norecursive)) + (declare (ignore norecursive timeout)) (let ((old-whostate (gensym "OLD-WHOSTATE"))) `(sb-thread:with-recursive-lock (,place) (let (,old-whostate) @@ -108,25 +184,30 @@ (setf (process-whostate *current-process*) ,old-whostate)))))) -(defun make-process (&key (name "Anonymous") reset-action run-reasons - arrest-reasons (priority 0) quantum resume-hook - suspend-hook initial-bindings run-immediately) - (declare (ignore reset-action arrest-reasons priority quantum resume-hook - suspend-hook run-immediately)) - (let ((p (%make-process :name name - :run-reasons run-reasons - :initial-bindings initial-bindings - :%queue (sb-thread:make-mutex :name (format nil "Internal lock for ~A" name)) - :%block-queue (sb-thread:make-waitqueue :name (format nil "Blocking queue for ~A" name))))) - (push p *all-processes*) - p)) +#-sb-thread +(defmacro without-scheduling (&body forms) + `(progn , at forms)) ; * -(defun restart-process (process) +;;; FIXME but, of course, we can't. Fix whoever wants to use it, +;;; instead +#+sb-thread +(defmacro without-scheduling (&body body) + `(progn , at body)) + +;;; Same implementation for multi- and uni-thread +(defmacro with-timeout ((seconds &body timeout-forms) &body body) + (let ((c (gensym "TIMEOUT-"))) + `(handler-case + (sb-ext::with-timeout ,seconds (progn , at body)) + (sb-ext::timeout (,c) (declare (ignore ,c)) , at timeout-forms)))) + +(defun/sb-thread restart-process (process) (labels ((boing () (let ((*current-process* process) (bindings (process-initial-bindings process)) (function (process-function process)) (arguments (process-arguments process))) + (declare (type function function)) (if bindings (progv (mapcar #'car bindings) @@ -135,76 +216,25 @@ bindings) (apply function arguments)) (apply function arguments))))) - (when (process-id process) (sb-thread:destroy-thread process)) + (when (process-id process) + (sb-thread:terminate-thread (process-id process))) ;; XXX handle run-reasons in some way? Should a process continue ;; running if all run reasons are taken away before ;; restart-process is called? (process-revoke-run-reason handles ;; this, so let's say (setf (process-run-reasons process) nil) is ;; not guaranteed to do the Right Thing.) - (when (setf (process-id process) (sb-thread:make-thread #'boing)) + (when (setf (process-id process) + (sb-thread:make-thread #'boing :name (process-name process))) process))) -(defun process-preset (process function &rest arguments) - "Set function of process and restart it if it was already running" - (setf (process-function process) function - (process-arguments process) arguments) - (when (process-id process) (restart-process process))) - -(defun process-run-function (name-or-options preset-function - &rest preset-arguments) - (let* ((make-process-args (etypecase name-or-options - (list name-or-options) - (string (list :name name-or-options)))) - (process (apply #'make-process make-process-args))) - (apply #'process-preset process preset-function preset-arguments) - (when (process-run-reasons process) (restart-process process)) - process)) - -(defun process-kill (process) - (when (process-id process) - (sb-thread:destroy-thread (process-id process)) - (setf (process-id process) nil)) - (setf *all-processes* (delete process *all-processes*))) - (defun current-process () *current-process*) (defun all-processes () - *all-processes*) + (copy-list *all-processes*)) -(defun process-wait (reason predicate &rest arguments) - (let ((old-state (process-whostate *current-process*))) - (unwind-protect - (progn - (setf old-state (process-whostate *current-process*) - (process-whostate *current-process*) reason) - (loop - (let ((it (apply predicate arguments))) - (when it (return it))) - (process-allow-schedule))) - (setf (process-whostate *current-process*) old-state)))) - -(defun process-allow-schedule () - (sleep .01)) - -(defun process-revoke-run-reason (process object) - (sb-thread:with-recursive-lock ((process-%queue process)) - (prog1 - (setf (process-run-reasons process) - (delete object (process-run-reasons process))) - (when (and (process-id process) (not (process-run-reasons process))) - (disable-process process))))) - -(defun process-add-run-reason (process object) - (sb-thread:with-recursive-lock ((process-%queue process)) - (prog1 - (push object (process-run-reasons process)) - (if (process-id process) - (enable-process process) - (restart-process process))))) - - -(defun process-wait-with-timeout (reason timeout predicate) +(defun/sb-thread process-wait-with-timeout (reason timeout predicate) + (declare (type function predicate)) (let ((old-state (process-whostate *current-process*)) (end-time (+ (get-universal-time) timeout))) (unwind-protect @@ -218,53 +248,47 @@ (sleep .01))) (setf (process-whostate *current-process*) old-state)))) -(defun process-interrupt (process function) - (declare (ignore process function)) - (error "Sorry Dave, I'm afraid I can't do that")) - -(defun disable-process (process) +(defun/sb-thread disable-process (process) ;; TODO: set process-whostate ;; Can't figure out how to safely block a thread from a different one ;; and handle all the locking nastiness. So punt for now. - (if (eql (sb-thread:current-thread-id) (process-id process)) + (if (eq sb-thread:*current-thread* (process-id process)) ;; Keep waiting until we have a reason to run. GC and other ;; things can break a wait prematurely. Don't know if this is ;; expected or not. (do () ((process-run-reasons process) nil) - (sb-thread:condition-wait (process-%block-queue process) - (process-%queue process))) + (sb-thread:with-recursive-lock ((process-%lock process)) + (sb-thread:condition-wait (process-%queue process) + (process-%lock process)))) (error "Can't safely disable-process from another thread"))) -(defun enable-process (process) +(defun/sb-thread enable-process (process) ;; TODO: set process-whostate - (sb-thread:condition-notify (process-%block-queue process))) + (sb-thread:with-recursive-lock ((process-%lock process)) + (sb-thread:condition-notify (process-%queue process)))) -;;; FIXME but, of course, we can't. Fix whoever wants to use it, -;;; instead -(defmacro without-scheduling (&body body) - `(progn , at body)) +;;; TODO: integrate with McCLIM / system-wide queue for such things +#+sb-thread +(defvar *atomic-spinlock* (sb-thread::make-spinlock)) -;;; TODO: integrate with McCLIM / system-wide queue for such things +#-sb-thread (defmacro atomic-incf (place) - `(sb-thread::with-spinlock (*conditional-store-queue*) - (incf ,place))) + `(incf ,place)) +#+sb-thread +(defmacro atomic-incf (place) + `(sb-thread::with-spinlock (*atomic-spinlock*) + (incf ,place))) + +#-sb-thread (defmacro atomic-decf (place) - `(sb-thread::with-spinlock (*conditional-store-queue*) - (decf ,place))) + `(decf ,place)) -(defun make-process-lock (&key name) - (sb-thread:make-mutex :name name)) +#+sb-thread +(defmacro atomic-decf (place) + `(sb-thread::with-spinlock (*atomic-spinlock*) + (decf ,place))) -(defun process-active-p (thread-id) - "If a native thread exists, it is always active" - (and - (member thread-id - (let ((offset (* 4 sb-vm::thread-pid-slot))) - (sb-thread::mapcar-threads - #'(lambda (sap) (sb-sys:sap-ref-32 sap offset)))) - :test 'eql) - t)) - -) ; #+sb-thread +(defun process-active-p (process) + (sb-thread:thread-alive-p (process-id process))) Modified: branches/grin-neu/thirdparty/portableaserve/acl-compat/sbcl/acl-socket.lisp =================================================================== --- branches/grin-neu/thirdparty/portableaserve/acl-compat/sbcl/acl-socket.lisp 2006-12-01 10:37:34 UTC (rev 2093) +++ branches/grin-neu/thirdparty/portableaserve/acl-compat/sbcl/acl-socket.lisp 2006-12-01 10:39:49 UTC (rev 2094) @@ -22,10 +22,18 @@ :reader stream-type :initform (error "No value supplied for stream-type")))) +(defclass datagram-socket (server-socket) + ()) + + (defmethod print-object ((socket server-socket) stream) (print-unreadable-object (socket stream :type t :identity nil) (format stream "listening on port ~d" (port socket)))) +(defmethod print-object ((socket datagram-socket) stream) + (print-unreadable-object (socket stream :type t :identity nil) + (format stream "datagram socket listening on port ~d" (port socket)))) + (defgeneric accept-connection (socket &key wait)) (defmethod accept-connection ((server-socket server-socket) &key (wait t)) @@ -45,7 +53,37 @@ stream)) nil)) -(defun make-socket (&key (remote-host "localhost") +(defmethod receive-from ((socket datagram-socket) size &key buffer extract) + (multiple-value-bind (rbuf len address port) + (socket-receive (socket socket) buffer size) + (declare (ignore port)) + (let ((buf + (if (not extract) + rbuf + (subseq rbuf 0 len)))) ;; FIXME: am I right? + (when buffer + (replace buffer buf :end2 len)) + (values + (if buffer buffer buf) + len + address)))) + +(defmethod send-to ((socket datagram-socket) buffer size &key remote-host remote-port) + (let* ((rhost (typecase remote-host + (string (lookup-hostname remote-host)) + (otherwise remote-host))) + (s (socket socket)) + (stream (progn + (socket-connect s rhost remote-port) + (socket-make-stream s :input t :output t :buffering :none)))) + (write-sequence buffer stream) + size)) + + + +(defun make-socket (&key + (type :stream) + (remote-host "localhost") local-port remote-port (connect :active) @@ -66,8 +104,22 @@ (:text 'base-char) (:binary 'signed-byte) (:bivalent 'unsigned-byte))) - (socket (make-instance 'inet-socket :type :stream :protocol :tcp))) + (socket + (if (eq type :datagram) + (progn + (setf connect :passive-udp) + (make-instance 'inet-socket :type :datagram :protocol :udp)) + (make-instance 'inet-socket :type :stream :protocol :tcp)))) (ecase connect + (:passive-udp + (setf (sockopt-reuse-address socket) reuse-address) + (if local-port + (socket-bind socket #(0 0 0 0) local-port)) + (make-instance 'datagram-socket + :port (nth-value 1 (socket-name socket)) + :socket socket + :element-type element-type + :stream-type format)) (:passive (setf (sockopt-reuse-address socket) reuse-address) (if local-port @@ -111,7 +163,16 @@ (values a b c d) (format nil "~d.~d.~d.~d" a b c d)))) -(declaim (ftype (function (simple-vector) +(defun ipaddr-to-vector (ipaddr) + "Convert from 32-bit integer to a vector of octets." + (declare (type (unsigned-byte 32) ipaddr)) + (let ((a (logand #xff (ash ipaddr -24))) + (b (logand #xff (ash ipaddr -16))) + (c (logand #xff (ash ipaddr -8))) + (d (logand #xff ipaddr))) + (make-array 4 :initial-contents (list a b c d)))) + +(declaim (ftype (function (vector) (values (unsigned-byte 32))) vector-to-ipaddr)) (defun vector-to-ipaddr (sensible-ipaddr) @@ -148,7 +209,7 @@ (defun ipaddr-to-hostname (ipaddr &key ignore-cache) (when ignore-cache (warn ":IGNORE-CACHE keyword in IPADDR-TO-HOSTNAME not supported.")) - (host-ent-name (get-host-by-address (make-inet-address ipaddr)))) + (host-ent-name (get-host-by-address (ipaddr-to-vector ipaddr)))) (defun lookup-hostname (host &key ignore-cache) (when ignore-cache Modified: branches/grin-neu/thirdparty/portableaserve/aserve/main.cl =================================================================== --- branches/grin-neu/thirdparty/portableaserve/aserve/main.cl 2006-12-01 10:37:34 UTC (rev 2093) +++ branches/grin-neu/thirdparty/portableaserve/aserve/main.cl 2006-12-01 10:39:49 UTC (rev 2094) @@ -221,7 +221,7 @@ (defun getpid () (sb-posix:getpid)) (defun setuid (uid) (sb-posix:setuid uid)) (defun setgid (gid) (sb-posix:setgid gid)) - (defun unix-fork () (sb-unix:unix-fork))) + (defun unix-fork () (sb-posix:fork))) Added: branches/grin-neu/thirdparty/puri/LICENSE =================================================================== --- branches/grin-neu/thirdparty/puri/LICENSE 2006-12-01 10:37:34 UTC (rev 2093) +++ branches/grin-neu/thirdparty/puri/LICENSE 2006-12-01 10:39:49 UTC (rev 2094) @@ -0,0 +1,574 @@ +Copyright (c) 1999-2001 Franz, Inc. +Copyright (c) 2003 Kevin Rosenberg +All rights reserved. + +PURI is licensed under the terms of the Lisp Lesser GNU Public +License, known as the LLGPL. The LLGPL consists of a preamble (see +below) and the Lessor GNU Public License 2.1 (LGPL-2.1). Where these +conflict, the preamble takes precedence. PURI is referenced in the +preamble as the "LIBRARY." + +PURI 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. + + + +Preamble to the Gnu Lesser General Public License +------------------------------------------------- +Copyright (c) 2000 Franz Incorporated, Berkeley, CA 94704 + +The concept of the GNU Lesser General Public License version 2.1 +("LGPL") has been adopted to govern the use and distribution of +above-mentioned application. However, the LGPL uses terminology that +is more appropriate for a program written in C than one written in +Lisp. Nevertheless, the LGPL can still be applied to a Lisp program if +certain clarifications are made. This document details those +clarifications. Accordingly, the license for the open-source Lisp +applications consists of this document plus the LGPL. Wherever there +is a conflict between this document and the LGPL, this document takes +precedence over the LGPL. + +A "Library" in Lisp is a collection of Lisp functions, data and +foreign modules. The form of the Library can be Lisp source code (for +processing by an interpreter) or object code (usually the result of +compilation of source code or built with some other +mechanisms). Foreign modules are object code in a form that can be +linked into a Lisp executable. When we speak of functions we do so in +the most general way to include, in addition, methods and unnamed +functions. Lisp "data" is also a general term that includes the data +structures resulting from defining Lisp classes. A Lisp application +may include the same set of Lisp objects as does a Library, but this +does not mean that the application is necessarily a "work based on the +Library" it contains. + +The Library consists of everything in the distribution file set before +any modifications are made to the files. If any of the functions or +classes in the Library are redefined in other files, then those +redefinitions ARE considered a work based on the Library. If +additional methods are added to generic functions in the Library, +those additional methods are NOT considered a work based on the +Library. If Library classes are subclassed, these subclasses are NOT +considered a work based on the Library. If the Library is modified to +explicitly call other functions that are neither part of Lisp itself +nor an available add-on module to Lisp, then the functions called by +the modified Library ARE considered a work based on the Library. The +goal is to ensure that the Library will compile and run without +getting undefined function errors. + +It is permitted to add proprietary source code to the Library, but it +must be done in a way such that the Library will still run without +that proprietary code present. Section 5 of the LGPL distinguishes +between the case of a library being dynamically linked at runtime and +one being statically linked at build time. Section 5 of the LGPL +states that the former results in an executable that is a "work that +uses the Library." Section 5 of the LGPL states that the latter +results in one that is a "derivative of the Library", which is +therefore covered by the LGPL. Since Lisp only offers one choice, +which is to link the Library into an executable at build time, we +declare that, for the purpose applying the LGPL to the Library, an +executable that results from linking a "work that uses the Library" +with the Library is considered a "work that uses the Library" and is +therefore NOT covered by the LGPL. + +Because of this declaration, section 6 of LGPL is not applicable to +the Library. However, in connection with each distribution of this +executable, you must also deliver, in accordance with the terms and +conditions of the LGPL, the source code of Library (or your derivative +thereof) that is incorporated into this executable. + + + + GNU LESSER GENERAL PUBLIC LICENSE + Version 2.1, February 1999 + + Copyright (C) 1991, 1999 Free Software Foundation, Inc. + 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + +[This is the first released version of the Lesser GPL. It also counts + as the successor of the GNU Library Public License, version 2, hence + the version number 2.1.] + + Preamble + + The licenses for most software are designed to take away your +freedom to share and change it. By contrast, the GNU General Public +Licenses are intended to guarantee your freedom to share and change +free software--to make sure the software is free for all its users. + + This license, the Lesser General Public License, applies to some +specially designated software packages--typically libraries--of the +Free Software Foundation and other authors who decide to use it. You +can use it too, but we suggest you first think carefully about whether +this license or the ordinary General Public License is the better +strategy to use in any particular case, based on the explanations +below. + + When we speak of free software, we are referring to freedom of use, +not price. Our General Public Licenses are designed to make sure that +you have the freedom to distribute copies of free software (and charge +for this service if you wish); that you receive source code or can get +it if you want it; that you can change the software and use pieces of +it in new free programs; and that you are informed that you can do +these things. + + To protect your rights, we need to make restrictions that forbid +distributors to deny you these rights or to ask you to surrender these +rights. These restrictions translate to certain responsibilities for +you if you distribute copies of the library or if you modify it. + + For example, if you distribute copies of the library, whether gratis +or for a fee, you must give the recipients all the rights that we gave +you. You must make sure that they, too, receive or can get the source +code. If you link other code with the library, you must provide +complete object files to the recipients, so that they can relink them +with the library after making changes to the library and recompiling +it. And you must show them these terms so they know their rights. + + We protect your rights with a two-step method: (1) we copyright the +library, and (2) we offer you this license, which gives you legal +permission to copy, distribute and/or modify the library. + + To protect each distributor, we want to make it very clear that +there is no warranty for the free library. Also, if the library is +modified by someone else and passed on, the recipients should know +that what they have is not the original version, so that the original +author's reputation will not be affected by problems that might be +introduced by others. +^L + Finally, software patents pose a constant threat to the existence of +any free program. We wish to make sure that a company cannot +effectively restrict the users of a free program by obtaining a +restrictive license from a patent holder. Therefore, we insist that +any patent license obtained for a version of the library must be +consistent with the full freedom of use specified in this license. + + Most GNU software, including some libraries, is covered by the +ordinary GNU General Public License. This license, the GNU Lesser +General Public License, applies to certain designated libraries, and +is quite different from the ordinary General Public License. We use +this license for certain libraries in order to permit linking those +libraries into non-free programs. + + When a program is linked with a library, whether statically or using +a shared library, the combination of the two is legally speaking a +combined work, a derivative of the original library. The ordinary +General Public License therefore permits such linking only if the +entire combination fits its criteria of freedom. The Lesser General +Public License permits more lax criteria for linking other code with +the library. + + We call this license the "Lesser" General Public License because it +does Less to protect the user's freedom than the ordinary General +Public License. It also provides other free software developers Less +of an advantage over competing non-free programs. These disadvantages +are the reason we use the ordinary General Public License for many +libraries. However, the Lesser license provides advantages in certain +special circumstances. + + For example, on rare occasions, there may be a special need to +encourage the widest possible use of a certain library, so that it +becomes a de-facto standard. To achieve this, non-free programs must +be allowed to use the library. A more frequent case is that a free +library does the same job as widely used non-free libraries. In this +case, there is little to gain by limiting the free library to free +software only, so we use the Lesser General Public License. + + In other cases, permission to use a particular library in non-free +programs enables a greater number of people to use a large body of +free software. For example, permission to use the GNU C Library in +non-free programs enables many more people to use the whole GNU +operating system, as well as its variant, the GNU/Linux operating +system. + + Although the Lesser General Public License is Less protective of the +users' freedom, it does ensure that the user of a program that is +linked with the Library has the freedom and the wherewithal to run +that program using a modified version of the Library. + + The precise terms and conditions for copying, distribution and +modification follow. Pay close attention to the difference between a +"work based on the library" and a "work that uses the library". The +former contains code derived from the library, whereas the latter must +be combined with the library in order to run. +^L + GNU LESSER GENERAL PUBLIC LICENSE + TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION + + 0. This License Agreement applies to any software library or other +program which contains a notice placed by the copyright holder or +other authorized party saying it may be distributed under the terms of +this Lesser General Public License (also called "this License"). +Each licensee is addressed as "you". + + A "library" means a collection of software functions and/or data +prepared so as to be conveniently linked with application programs +(which use some of those functions and data) to form executables. + + The "Library", below, refers to any such software library or work +which has been distributed under these terms. A "work based on the +Library" means either the Library or any derivative work under +copyright law: that is to say, a work containing the Library or a +portion of it, either verbatim or with modifications and/or translated +straightforwardly into another language. (Hereinafter, translation is +included without limitation in the term "modification".) + + "Source code" for a work means the preferred form of the work for +making modifications to it. For a library, complete source code means +all the source code for all modules it contains, plus any associated +interface definition files, plus the scripts used to control +compilation and installation of the library. + + Activities other than copying, distribution and modification are not +covered by this License; they are outside its scope. The act of +running a program using the Library is not restricted, and output from +such a program is covered only if its contents constitute a work based +on the Library (independent of the use of the Library in a tool for +writing it). Whether that is true depends on what the Library does +and what the program that uses the Library does. + + 1. You may copy and distribute verbatim copies of the Library's +complete source code as you receive it, in any medium, provided that +you conspicuously and appropriately publish on each copy an +appropriate copyright notice and disclaimer of warranty; keep intact +all the notices that refer to this License and to the absence of any +warranty; and distribute a copy of this License along with the +Library. + + You may charge a fee for the physical act of transferring a copy, +and you may at your option offer warranty protection in exchange for a +fee. + + 2. You may modify your copy or copies of the Library or any portion +of it, thus forming a work based on the Library, and copy and +distribute such modifications or work under the terms of Section 1 +above, provided that you also meet all of these conditions: + + a) The modified work must itself be a software library. + + b) You must cause the files modified to carry prominent notices + stating that you changed the files and the date of any change. + + c) You must cause the whole of the work to be licensed at no + charge to all third parties under the terms of this License. + + d) If a facility in the modified Library refers to a function or a + table of data to be supplied by an application program that uses + the facility, other than as an argument passed when the facility + is invoked, then you must make a good faith effort to ensure that, + in the event an application does not supply such function or + table, the facility still operates, and performs whatever part of + its purpose remains meaningful. + + (For example, a function in a library to compute square roots has + a purpose that is entirely well-defined independent of the + application. Therefore, Subsection 2d requires that any + application-supplied function or table used by this function must + be optional: if the application does not supply it, the square + root function must still compute square roots.) + +These requirements apply to the modified work as a whole. If +identifiable sections of that work are not derived from the Library, +and can be reasonably considered independent and separate works in +themselves, then this License, and its terms, do not apply to those +sections when you distribute them as separate works. But when you +distribute the same sections as part of a whole which is a work based +on the Library, the distribution of the whole must be on the terms of +this License, whose permissions for other licensees extend to the +entire whole, and thus to each and every part regardless of who wrote +it. + +Thus, it is not the intent of this section to claim rights or contest +your rights to work written entirely by you; rather, the intent is to +exercise the right to control the distribution of derivative or +collective works based on the Library. + +In addition, mere aggregation of another work not based on the Library +with the Library (or with a work based on the Library) on a volume of +a storage or distribution medium does not bring the other work under +the scope of this License. + + 3. You may opt to apply the terms of the ordinary GNU General Public +License instead of this License to a given copy of the Library. To do +this, you must alter all the notices that refer to this License, so +that they refer to the ordinary GNU General Public License, version 2, +instead of to this License. (If a newer version than version 2 of the +ordinary GNU General Public License has appeared, then you can specify +that version instead if you wish.) Do not make any other change in +these notices. +^L + Once this change is made in a given copy, it is irreversible for +that copy, so the ordinary GNU General Public License applies to all +subsequent copies and derivative works made from that copy. + + This option is useful when you wish to copy part of the code of +the Library into a program that is not a library. + + 4. You may copy and distribute the Library (or a portion or +derivative of it, under Section 2) in object code or executable form +under the terms of Sections 1 and 2 above provided that you accompany +it with the complete corresponding machine-readable source code, which +must be distributed under the terms of Sections 1 and 2 above on a +medium customarily used for software interchange. + + If distribution of object code is made by offering access to copy +from a designated place, then offering equivalent access to copy the +source code from the same place satisfies the requirement to +distribute the source code, even though third parties are not +compelled to copy the source along with the object code. + + 5. A program that contains no derivative of any portion of the +Library, but is designed to work with the Library by being compiled or +linked with it, is called a "work that uses the Library". Such a +work, in isolation, is not a derivative work of the Library, and +therefore falls outside the scope of this License. + + However, linking a "work that uses the Library" with the Library +creates an executable that is a derivative of the Library (because it +contains portions of the Library), rather than a "work that uses the +library". The executable is therefore covered by this License. +Section 6 states terms for distribution of such executables. + + When a "work that uses the Library" uses material from a header file +that is part of the Library, the object code for the work may be a +derivative work of the Library even though the source code is not. +Whether this is true is especially significant if the work can be +linked without the Library, or if the work is itself a library. The +threshold for this to be true is not precisely defined by law. + + If such an object file uses only numerical parameters, data +structure layouts and accessors, and small macros and small inline +functions (ten lines or less in length), then the use of the object +file is unrestricted, regardless of whether it is legally a derivative +work. (Executables containing this object code plus portions of the +Library will still fall under Section 6.) + + Otherwise, if the work is a derivative of the Library, you may +distribute the object code for the work under the terms of Section 6. +Any executables containing that work also fall under Section 6, +whether or not they are linked directly with the Library itself. +^L + 6. As an exception to the Sections above, you may also combine or +link a "work that uses the Library" with the Library to produce a +work containing portions of the Library, and distribute that work +under terms of your choice, provided that the terms permit +modification of the work for the customer's own use and reverse +engineering for debugging such modifications. + + You must give prominent notice with each copy of the work that the +Library is used in it and that the Library and its use are covered by +this License. You must supply a copy of this License. If the work +during execution displays copyright notices, you must include the +copyright notice for the Library among them, as well as a reference +directing the user to the copy of this License. Also, you must do one +of these things: + + a) Accompany the work with the complete corresponding + machine-readable source code for the Library including whatever + changes were used in the work (which must be distributed under + Sections 1 and 2 above); and, if the work is an executable linked + with the Library, with the complete machine-readable "work that + uses the Library", as object code and/or source code, so that the + user can modify the Library and then relink to produce a modified + executable containing the modified Library. (It is understood + that the user who changes the contents of definitions files in the + Library will not necessarily be able to recompile the application + to use the modified definitions.) + + b) Use a suitable shared library mechanism for linking with the + Library. A suitable mechanism is one that (1) uses at run time a + copy of the library already present on the user's computer system, + rather than copying library functions into the executable, and (2) + will operate properly with a modified version of the library, if + the user installs one, as long as the modified version is + interface-compatible with the version that the work was made with. + + c) Accompany the work with a written offer, valid for at least + three years, to give the same user the materials specified in + Subsection 6a, above, for a charge no more than the cost of + performing this distribution. + + d) If distribution of the work is made by offering access to copy + from a designated place, offer equivalent access to copy the above + specified materials from the same place. + + e) Verify that the user has already received a copy of these + materials or that you have already sent this user a copy. + + For an executable, the required form of the "work that uses the +Library" must include any data and utility programs needed for +reproducing the executable from it. However, as a special exception, +the materials to be distributed need not include anything that is +normally distributed (in either source or binary form) with the major +components (compiler, kernel, and so on) of the operating system on +which the executable runs, unless that component itself accompanies +the executable. + + It may happen that this requirement contradicts the license +restrictions of other proprietary libraries that do not normally +accompany the operating system. Such a contradiction means you cannot +use both them and the Library together in an executable that you +distribute. +^L + 7. You may place library facilities that are a work based on the +Library side-by-side in a single library together with other library +facilities not covered by this License, and distribute such a combined +library, provided that the separate distribution of the work based on +the Library and of the other library facilities is otherwise +permitted, and provided that you do these two things: + + a) Accompany the combined library with a copy of the same work + based on the Library, uncombined with any other library + facilities. This must be distributed under the terms of the + Sections above. + + b) Give prominent notice with the combined library of the fact + that part of it is a work based on the Library, and explaining + where to find the accompanying uncombined form of the same work. + + 8. You may not copy, modify, sublicense, link with, or distribute +the Library except as expressly provided under this License. Any +attempt otherwise to copy, modify, sublicense, link with, or +distribute the Library is void, and will automatically terminate your +rights under this License. However, parties who have received copies, +or rights, from you under this License will not have their licenses +terminated so long as such parties remain in full compliance. + + 9. You are not required to accept this License, since you have not +signed it. However, nothing else grants you permission to modify or +distribute the Library or its derivative works. These actions are +prohibited by law if you do not accept this License. Therefore, by +modifying or distributing the Library (or any work based on the +Library), you indicate your acceptance of this License to do so, and +all its terms and conditions for copying, distributing or modifying +the Library or works based on it. + + 10. Each time you redistribute the Library (or any work based on the +Library), the recipient automatically receives a license from the +original licensor to copy, distribute, link with or modify the Library +subject to these terms and conditions. You may not impose any further +restrictions on the recipients' exercise of the rights granted herein. +You are not responsible for enforcing compliance by third parties with +this License. +^L + 11. If, as a consequence of a court judgment or allegation of patent +infringement or for any other reason (not limited to patent issues), +conditions are imposed on you (whether by court order, agreement or +otherwise) that contradict the conditions of this License, they do not +excuse you from the conditions of this License. If you cannot +distribute so as to satisfy simultaneously your obligations under this +License and any other pertinent obligations, then as a consequence you +may not distribute the Library at all. For example, if a patent +license would not permit royalty-free redistribution of the Library by +all those who receive copies directly or indirectly through you, then +the only way you could satisfy both it and this License would be to +refrain entirely from distribution of the Library. + +If any portion of this section is held invalid or unenforceable under +any particular circumstance, the balance of the section is intended to +apply, and the section as a whole is intended to apply in other +circumstances. + +It is not the purpose of this section to induce you to infringe any +patents or other property right claims or to contest validity of any +such claims; this section has the sole purpose of protecting the +integrity of the free software distribution system which is +implemented by public license practices. Many people have made +generous contributions to the wide range of software distributed +through that system in reliance on consistent application of that +system; it is up to the author/donor to decide if he or she is willing +to distribute software through any other system and a licensee cannot +impose that choice. + +This section is intended to make thoroughly clear what is believed to +be a consequence of the rest of this License. + + 12. If the distribution and/or use of the Library is restricted in +certain countries either by patents or by copyrighted interfaces, the +original copyright holder who places the Library under this License +may add an explicit geographical distribution limitation excluding those +countries, so that distribution is permitted only in or among +countries not thus excluded. In such case, this License incorporates +the limitation as if written in the body of this License. + + 13. The Free Software Foundation may publish revised and/or new +versions of the Lesser General Public License from time to time. +Such new versions will be similar in spirit to the present version, +but may differ in detail to address new problems or concerns. + +Each version is given a distinguishing version number. If the Library +specifies a version number of this License which applies to it and +"any later version", you have the option of following the terms and +conditions either of that version or of any later version published by +the Free Software Foundation. If the Library does not specify a +license version number, you may choose any version ever published by +the Free Software Foundation. +^L + 14. If you wish to incorporate parts of the Library into other free +programs whose distribution conditions are incompatible with these, +write to the author to ask for permission. For software which is +copyrighted by the Free Software Foundation, write to the Free +Software Foundation; we sometimes make exceptions for this. Our +decision will be guided by the two goals of preserving the free status +of all derivatives of our free software and of promoting the sharing +and reuse of software generally. + + NO WARRANTY + + 15. BECAUSE THE LIBRARY IS LICENSED FREE OF CHARGE, THERE IS NO +WARRANTY FOR THE LIBRARY, TO THE EXTENT PERMITTED BY APPLICABLE LAW. +EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR +OTHER PARTIES PROVIDE THE LIBRARY "AS IS" WITHOUT WARRANTY OF ANY +KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE +LIBRARY IS WITH YOU. SHOULD THE LIBRARY PROVE DEFECTIVE, YOU ASSUME +THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. + + 16. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN +WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY +AND/OR REDISTRIBUTE THE LIBRARY AS PERMITTED ABOVE, BE LIABLE TO YOU +FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR +CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE +LIBRARY (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING +RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A +FAILURE OF THE LIBRARY TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF +SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH +DAMAGES. + + END OF TERMS AND CONDITIONS +^L + How to Apply These Terms to Your New Libraries + + If you develop a new library, and you want it to be of the greatest +possible use to the public, we recommend making it free software that +everyone can redistribute and change. You can do so by permitting +redistribution under these terms (or, alternatively, under the terms +of the ordinary General Public License). + + To apply these terms, attach the following notices to the library. +It is safest to attach them to the start of each source file to most +effectively convey the exclusion of warranty; and each file should +have at least the "copyright" line and a pointer to where the full +notice is found. + + + + Copyright (C) + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Lesser General Public + License as published by the Free Software Foundation; either + version 2.1 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 + Lesser General Public License for more details. + + You should have received a copy of the GNU Lesser 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 + Added: branches/grin-neu/thirdparty/puri/README =================================================================== --- branches/grin-neu/thirdparty/puri/README 2006-12-01 10:37:34 UTC (rev 2093) +++ branches/grin-neu/thirdparty/puri/README 2006-12-01 10:39:49 UTC (rev 2094) @@ -0,0 +1,46 @@ +PURI - Portable URI Library +=========================== + +AUTHORS +------- +Franz, Inc +Kevin Rosenberg + + +DOWNLOAD +-------- +Puri home: http://files.b9.com/puri/ +Portable tester home: http://files.b9.com/tester/ + + +SUPPORTED PLATFORMS +------------------- + AllegroCL, CLISP, CMUCL, Lispworks, OpenMCL, SBCL + + +OVERVIEW +-------- +This is portable Universal Resource Identifier library for Common Lisp +programs. It parses URI according to the RFC 2396 specification. It's +is based on Franz, Inc's opensource URI package and has been ported to +work other CL implementations. It is licensed under the LLGPL which +is included in this distribution. + +A regression suite is included which uses Franz's open-source tester +library. I've ported that library for use on other CL +implementations. Puri completes 126/126 regression tests successfully. + +Franz's unmodified documentation file is included in the file +uri.html. + + +DIFFERENCES BETWEEN PURI and NET.URI +------------------------------------ + +* Puri uses the package 'puri while NET.URI uses the package 'net.uri + +* To signal an error parsing a URI, Puri uses the condition + :uri-parse-error while NET.URI uses the condition :parse-error. This + divergence occurs because Franz's parse-error condition uses + :format-control and :format-arguments slots which are not in the ANSI + specification for the parse-error condition. Added: branches/grin-neu/thirdparty/puri/puri.asd =================================================================== --- branches/grin-neu/thirdparty/puri/puri.asd 2006-12-01 10:37:34 UTC (rev 2093) +++ branches/grin-neu/thirdparty/puri/puri.asd 2006-12-01 10:39:49 UTC (rev 2094) @@ -0,0 +1,33 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; Programmer: Kevin Rosenberg + + +(in-package #:cl-user) +(defpackage #:puri-system (:use #:cl #:asdf)) +(in-package #:puri-system) + + +(defsystem puri + :name "cl-puri" + :maintainer "Kevin M. Rosenberg " + :licence "GNU Lesser General Public License" + :description "Portable Universal Resource Indentifier Library" + :components + ((:file "src"))) + +(defmethod perform ((o test-op) (c (eql (find-system 'puri)))) + (oos 'load-op 'puri-tests) + (oos 'test-op 'puri-tests)) + +(defsystem puri-tests + :depends-on (:puri :ptester) + :components + ((:file "tests"))) + +(defmethod perform ((o test-op) (c (eql (find-system 'puri-tests)))) + (or (funcall (intern (symbol-name '#:do-tests) + (find-package :puri-tests))) + (error "test-op failed"))) + +(defmethod operation-done-p ((o test-op) (c (eql (find-system 'puri-tests)))) + (values nil)) Added: branches/grin-neu/thirdparty/puri/src.lisp =================================================================== --- branches/grin-neu/thirdparty/puri/src.lisp 2006-12-01 10:37:34 UTC (rev 2093) +++ branches/grin-neu/thirdparty/puri/src.lisp 2006-12-01 10:39:49 UTC (rev 2094) @@ -0,0 +1,1419 @@ +;; -*- mode: common-lisp; package: puri -*- +;; Support for URIs +;; For general URI information see RFC2396. +;; +;; copyright (c) 1999-2002 Franz Inc, Berkeley, CA - All rights reserved. +;; copyright (c) 2002-2005 Franz Inc, Oakland, CA - All rights reserved. +;; copyright (c) 2003-2006 Kevin Rosenberg (porting changes) +;; +;; This code is free software; you can redistribute it and/or +;; modify it under the terms of the version 2.1 of +;; the GNU Lesser General Public License as published by +;; the Free Software Foundation, as clarified by the +;; preamble found here: +;; http://opensource.franz.com/preamble.html +;; +;; Versions ported from Franz's opensource release +;; uri.cl,v 2.3.6.4.2.1 2001/08/09 17:42:39 layer +;; uri.cl,v 2.9.84.1 2005/08/11 18:38:52 layer + +;; This code 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 +;; Lesser General Public License for more details. +;; +;; $Id: src.lisp 11030 2006-08-15 00:57:31Z kevin $ + +(defpackage #:puri + (:use #:cl) + #-allegro (:nicknames #:net.uri) + (:export + #:uri ; the type and a function + #:uri-p + #:copy-uri + + #:uri-scheme ; and slots + #:uri-host #:uri-port + #:uri-path + #:uri-query + #:uri-fragment + #:uri-plist + #:uri-authority ; pseudo-slot accessor + + #:urn ; class + #:urn-nid ; pseudo-slot accessor + #:urn-nss ; pseudo-slot accessor + + #:*strict-parse* + #:parse-uri + #:merge-uris + #:enough-uri + #:uri-parsed-path + #:render-uri + + #:make-uri-space ; interning... + #:uri-space + #:uri= + #:intern-uri + #:unintern-uri + #:do-all-uris + + #:uri-parse-error ;; Added by KMR + )) + +(in-package #:puri) + +(eval-when (:compile-toplevel) (declaim (optimize (speed 3)))) + + +#-allegro +(defun parse-body (forms &optional env) + "Parses a body, returns (VALUES docstring declarations forms)" + (declare (ignore env)) + ;; fixme -- need to add parsing of multiple declarations + (let (docstring declarations) + (when (stringp (car forms)) + (setq docstring (car forms)) + (setq forms (cdr forms))) + (when (and (listp (car forms)) + (symbolp (caar forms)) + (string-equal (symbol-name '#:declare) + (symbol-name (caar forms)))) + (setq declarations (car forms)) + (setq forms (cdr forms))) + (values docstring declarations forms))) + + +(defun shrink-vector (str size) + #+allegro + (excl::.primcall 'sys::shrink-svector str size) + #+sbcl + (setq str (sb-kernel:shrink-vector str size)) + #+cmu + (lisp::shrink-vector str size) + #+lispworks + (system::shrink-vector$vector str size) + #+scl + (common-lisp::shrink-vector str size) + #-(or allegro cmu lispworks sbcl scl) + (setq str (subseq str 0 size)) + str) + + +;; KMR: Added new condition to handle cross-implementation variances +;; in the parse-error condition many implementations define + +(define-condition uri-parse-error (parse-error) + ((fmt-control :initarg :fmt-control :accessor fmt-control) + (fmt-arguments :initarg :fmt-arguments :accessor fmt-arguments )) + (:report (lambda (c stream) + (format stream "Parse error:") + (apply #'format stream (fmt-control c) (fmt-arguments c))))) + +(defun .parse-error (fmt &rest args) + (error 'uri-parse-error :fmt-control fmt :fmt-arguments args)) + +#-allegro +(defun internal-reader-error (stream fmt &rest args) + (apply #'format stream fmt args)) + +#-allegro (defvar *current-case-mode* :case-insensitive-upper) +#+allegro (eval-when (:compile-toplevel :load-toplevel :execute) + (import '(excl:*current-case-mode* + excl:delimited-string-to-list + excl::parse-body + excl::internal-reader-error + excl:if*))) + +#-allegro +(defmethod position-char (char (string string) start max) + (declare (optimize (speed 3) (safety 0) (space 0)) + (fixnum start max) (string string)) + (do* ((i start (1+ i))) + ((= i max) nil) + (declare (fixnum i)) + (when (char= char (char string i)) (return i)))) + +#-allegro +(defun delimited-string-to-list (string &optional (separator #\space) + skip-terminal) + (declare (optimize (speed 3) (safety 0) (space 0) + (compilation-speed 0)) + (type string string) + (type character separator)) + (do* ((len (length string)) + (output '()) + (pos 0) + (end (position-char separator string pos len) + (position-char separator string pos len))) + ((null end) + (if (< pos len) + (push (subseq string pos) output) + (when (and (plusp len) (not skip-terminal)) + (push "" output))) + (nreverse output)) + (declare (type fixnum pos len) + (type (or null fixnum) end)) + (push (subseq string pos end) output) + (setq pos (1+ end)))) + +#-allegro +(eval-when (:compile-toplevel :load-toplevel :execute) + (defvar if*-keyword-list '("then" "thenret" "else" "elseif")) + + (defmacro if* (&rest args) + (do ((xx (reverse args) (cdr xx)) + (state :init) + (elseseen nil) + (totalcol nil) + (lookat nil nil) + (col nil)) + ((null xx) + (cond ((eq state :compl) + `(cond , at totalcol)) + (t (error "if*: illegal form ~s" args)))) + (cond ((and (symbolp (car xx)) + (member (symbol-name (car xx)) + if*-keyword-list + :test #'string-equal)) + (setq lookat (symbol-name (car xx))))) + + (cond ((eq state :init) + (cond (lookat (cond ((string-equal lookat "thenret") + (setq col nil + state :then)) + (t (error + "if*: bad keyword ~a" lookat)))) + (t (setq state :col + col nil) + (push (car xx) col)))) + ((eq state :col) + (cond (lookat + (cond ((string-equal lookat "else") + (cond (elseseen + (error + "if*: multiples elses"))) + (setq elseseen t) + (setq state :init) + (push `(t , at col) totalcol)) + ((string-equal lookat "then") + (setq state :then)) + (t (error "if*: bad keyword ~s" + lookat)))) + (t (push (car xx) col)))) + ((eq state :then) + (cond (lookat + (error + "if*: keyword ~s at the wrong place " (car xx))) + (t (setq state :compl) + (push `(,(car xx) , at col) totalcol)))) + ((eq state :compl) + (cond ((not (string-equal lookat "elseif")) + (error "if*: missing elseif clause "))) + (setq state :init)))))) + + +(defclass uri () + ( +;;;; external: + (scheme :initarg :scheme :initform nil :accessor uri-scheme) + (host :initarg :host :initform nil :accessor uri-host) + (port :initarg :port :initform nil :accessor uri-port) + (path :initarg :path :initform nil :accessor uri-path) + (query :initarg :query :initform nil :accessor uri-query) + (fragment :initarg :fragment :initform nil :accessor uri-fragment) + (plist :initarg :plist :initform nil :accessor uri-plist) + +;;;; internal: + (escaped + ;; used to prevent unnessary work, looking for chars to escape and + ;; unescape. + :initarg :escaped :initform nil :accessor uri-escaped) + (string + ;; the cached printable representation of the URI. It *might* be + ;; different than the original string, though, because the user might + ;; have escaped non-reserved chars--they won't be escaped when the URI + ;; is printed. + :initarg :string :initform nil :accessor uri-string) + (parsed-path + ;; the cached parsed representation of the URI path. + :initarg :parsed-path + :initform nil + :accessor .uri-parsed-path) + (hashcode + ;; cached sxhash, so we don't have to compute it more than once. + :initarg :hashcode :initform nil :accessor uri-hashcode))) + +(defclass urn (uri) + ((nid :initarg :nid :initform nil :accessor urn-nid) + (nss :initarg :nss :initform nil :accessor urn-nss))) + +(eval-when (:compile-toplevel :execute) + (defmacro clear-caching-on-slot-change (name) + `(defmethod (setf ,name) :around (new-value (self uri)) + (declare (ignore new-value)) + (prog1 (call-next-method) + (setf (uri-string self) nil) + ,@(when (eq name 'uri-path) `((setf (.uri-parsed-path self) nil))) + (setf (uri-hashcode self) nil)))) + ) + +(clear-caching-on-slot-change uri-scheme) +(clear-caching-on-slot-change uri-host) +(clear-caching-on-slot-change uri-port) +(clear-caching-on-slot-change uri-path) +(clear-caching-on-slot-change uri-query) +(clear-caching-on-slot-change uri-fragment) + + +(defmethod make-load-form ((self uri) &optional env) + (declare (ignore env)) + `(make-instance ',(class-name (class-of self)) + :scheme ,(uri-scheme self) + :host ,(uri-host self) + :port ,(uri-port self) + :path ',(uri-path self) + :query ,(uri-query self) + :fragment ,(uri-fragment self) + :plist ',(uri-plist self) + :string ,(uri-string self) + :parsed-path ',(.uri-parsed-path self))) + +(defmethod uri-p ((thing uri)) t) +(defmethod uri-p ((thing t)) nil) + +(defun copy-uri (uri + &key place + (scheme (when uri (uri-scheme uri))) + (host (when uri (uri-host uri))) + (port (when uri (uri-port uri))) + (path (when uri (uri-path uri))) + (parsed-path + (when uri (copy-list (.uri-parsed-path uri)))) + (query (when uri (uri-query uri))) + (fragment (when uri (uri-fragment uri))) + (plist (when uri (copy-list (uri-plist uri)))) + (class (when uri (class-of uri))) + &aux (escaped (when uri (uri-escaped uri)))) + (if* place + then (setf (uri-scheme place) scheme) + (setf (uri-host place) host) + (setf (uri-port place) port) + (setf (uri-path place) path) + (setf (.uri-parsed-path place) parsed-path) + (setf (uri-query place) query) + (setf (uri-fragment place) fragment) + (setf (uri-plist place) plist) + (setf (uri-escaped place) escaped) + (setf (uri-string place) nil) + (setf (uri-hashcode place) nil) + place + elseif (eq 'uri class) + then ;; allow the compiler to optimize the call to make-instance: + (make-instance 'uri + :scheme scheme :host host :port port :path path + :parsed-path parsed-path + :query query :fragment fragment :plist plist + :escaped escaped :string nil :hashcode nil) + else (make-instance class + :scheme scheme :host host :port port :path path + :parsed-path parsed-path + :query query :fragment fragment :plist plist + :escaped escaped :string nil :hashcode nil))) + +(defmethod uri-parsed-path ((uri uri)) + (when (uri-path uri) + (when (null (.uri-parsed-path uri)) + (setf (.uri-parsed-path uri) + (parse-path (uri-path uri) (uri-escaped uri)))) + (.uri-parsed-path uri))) + +(defmethod (setf uri-parsed-path) (path-list (uri uri)) + (assert (and (consp path-list) + (or (member (car path-list) '(:absolute :relative) + :test #'eq)))) + (setf (uri-path uri) (render-parsed-path path-list t)) + (setf (.uri-parsed-path uri) path-list) + path-list) + +(defun uri-authority (uri) + (when (uri-host uri) + (let ((*print-pretty* nil)) + (format nil "~a~@[:~a~]" (uri-host uri) (uri-port uri))))) + +(defun uri-nid (uri) + (if* (equalp "urn" (uri-scheme uri)) + then (uri-host uri) + else (error "URI is not a URN: ~s." uri))) + +(defun uri-nss (uri) + (if* (equalp "urn" (uri-scheme uri)) + then (uri-path uri) + else (error "URI is not a URN: ~s." uri))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Parsing + +(defparameter *excluded-characters* + '(;; `delims' (except #\%, because it's handled specially): + #\< #\> #\" #\space #\# + ;; `unwise': + #\{ #\} #\| #\\ #\^ #\[ #\] #\`)) + +(defun reserved-char-vector (chars &key except) + (do* ((a (make-array 127 :element-type 'bit :initial-element 0)) + (chars chars (cdr chars)) + (c (car chars) (car chars))) + ((null chars) a) + (if* (and except (member c except :test #'char=)) + thenret + else (setf (sbit a (char-int c)) 1)))) + +(defparameter *reserved-characters* + (reserved-char-vector + (append *excluded-characters* + '(#\; #\/ #\? #\: #\@ #\& #\= #\+ #\$ #\, #\%)))) +(defparameter *reserved-authority-characters* + (reserved-char-vector + (append *excluded-characters* '(#\; #\/ #\? #\: #\@)))) +(defparameter *reserved-path-characters* + (reserved-char-vector + (append *excluded-characters* + '(#\; +;;;;The rfc says this should be here, but it doesn't make sense. + ;; #\= + #\/ #\?)))) + +(defparameter *reserved-fragment-characters* + (reserved-char-vector (remove #\# *excluded-characters*))) + +(eval-when (:compile-toplevel :execute) +(defun gen-char-range-list (start end) + (do* ((res '()) + (endcode (1+ (char-int end))) + (chcode (char-int start) + (1+ chcode)) + (hyphen nil)) + ((= chcode endcode) + ;; - has to be first, otherwise it signifies a range! + (if* hyphen + then (setq res (nreverse res)) + (push #\- res) + res + else (nreverse res))) + (if* (= #.(char-int #\-) chcode) + then (setq hyphen t) + else (push (code-char chcode) res)))) +) + +(defparameter *valid-nid-characters* + (reserved-char-vector + '#.(nconc (gen-char-range-list #\a #\z) + (gen-char-range-list #\A #\Z) + (gen-char-range-list #\0 #\9) + '(#\- #\. #\+)))) +(defparameter *reserved-nss-characters* + (reserved-char-vector + (append *excluded-characters* '(#\& #\~ #\/ #\?)))) + +(defparameter *illegal-characters* + (reserved-char-vector (remove #\# *excluded-characters*))) +(defparameter *strict-illegal-query-characters* + (reserved-char-vector (append '(#\?) (remove #\# *excluded-characters*)))) +(defparameter *illegal-query-characters* + (reserved-char-vector + *excluded-characters* :except '(#\^ #\| #\#))) + + +(defun parse-uri (thing &key (class 'uri) &aux escape) + (when (uri-p thing) (return-from parse-uri thing)) + + (setq escape (escape-p thing)) + (multiple-value-bind (scheme host port path query fragment) + (parse-uri-string thing) + (when scheme + (setq scheme + (intern (funcall + (case *current-case-mode* + ((:case-insensitive-upper :case-sensitive-upper) + #'string-upcase) + ((:case-insensitive-lower :case-sensitive-lower) + #'string-downcase)) + (decode-escaped-encoding scheme escape)) + (find-package :keyword)))) + + (when (and scheme (eq :urn scheme)) + (return-from parse-uri + (make-instance 'urn :scheme scheme :nid host :nss path))) + + (when host (setq host (decode-escaped-encoding host escape))) + (when port + (setq port (read-from-string port)) + (when (not (numberp port)) (error "port is not a number: ~s." port)) + (when (not (plusp port)) + (error "port is not a positive integer: ~d." port)) + (when (eql port (case scheme + (:http 80) + (:https 443) + (:ftp 21) + (:telnet 23))) + (setq port nil))) + (when (or (string= "" path) + (and ;; we canonicalize away a reference to just /: + scheme + (member scheme '(:http :https :ftp) :test #'eq) + (string= "/" path))) + (setq path nil)) + (when path + (setq path + (decode-escaped-encoding path escape *reserved-path-characters*))) + (when query (setq query (decode-escaped-encoding query escape))) + (when fragment + (setq fragment + (decode-escaped-encoding fragment escape + *reserved-fragment-characters*))) + (if* (eq 'uri class) + then ;; allow the compiler to optimize the make-instance call: + (make-instance 'uri + :scheme scheme + :host host + :port port + :path path + :query query + :fragment fragment + :escaped escape) + else ;; do it the slow way: + (make-instance class + :scheme scheme + :host host + :port port + :path path + :query query + :fragment fragment + :escaped escape)))) + +(defmethod uri ((thing uri)) + thing) + +(defmethod uri ((thing string)) + (parse-uri thing)) + +(defmethod uri ((thing t)) + (error "Cannot coerce ~s to a uri." thing)) + +(defvar *strict-parse* t) + +(defun parse-uri-string (string &aux (illegal-chars *illegal-characters*)) + (declare (optimize (speed 3))) + ;; Speed is important, so use a specialized state machine instead of + ;; regular expressions for parsing the URI string. The regexp we are + ;; simulating: + ;; ^(([^:/?#]+):)? + ;; (//([^/?#]*))? + ;; ([^?#]*) + ;; (\?([^#]*))? + ;; (#(.*))? + (let* ((state 0) + (start 0) + (end (length string)) + (tokval nil) + (scheme nil) + (host nil) + (port nil) + (path-components '()) + (query nil) + (fragment nil) + ;; namespace identifier, for urn parsing only: + (nid nil)) + (declare (fixnum state start end)) + (flet ((read-token (kind &optional legal-chars) + (setq tokval nil) + (if* (>= start end) + then :end + else (let ((sindex start) + (res nil) + c) + (declare (fixnum sindex)) + (setq res + (loop + (when (>= start end) (return nil)) + (setq c (char string start)) + (let ((ci (char-int c))) + (if* legal-chars + then (if* (and (eq :colon kind) (eq c #\:)) + then (return :colon) + elseif (= 0 (sbit legal-chars ci)) + then (.parse-error + "~ +URI ~s contains illegal character ~s at position ~d." + string c start)) + elseif (and (< ci 128) + *strict-parse* + (= 1 (sbit illegal-chars ci))) + then (.parse-error "~ +URI ~s contains illegal character ~s at position ~d." + string c start))) + (case kind + (:path (case c + (#\? (return :question)) + (#\# (return :hash)))) + (:query (case c (#\# (return :hash)))) + (:rest) + (t (case c + (#\: (return :colon)) + (#\? (return :question)) + (#\# (return :hash)) + (#\/ (return :slash))))) + (incf start))) + (if* (> start sindex) + then ;; we found some chars + ;; before we stopped the parse + (setq tokval (subseq string sindex start)) + :string + else ;; immediately stopped at a special char + (incf start) + res)))) + (failure (&optional why) + (.parse-error "illegal URI: ~s [~d]~@[: ~a~]" + string state why)) + (impossible () + (.parse-error "impossible state: ~d [~s]" state string))) + (loop + (case state + (0 ;; starting to parse + (ecase (read-token t) + (:colon (failure)) + (:question (setq state 7)) + (:hash (setq state 8)) + (:slash (setq state 3)) + (:string (setq state 1)) + (:end (setq state 9)))) + (1 ;; seen + (let ((token tokval)) + (ecase (read-token t) + (:colon (setq scheme token) + (if* (equalp "urn" scheme) + then (setq state 15) + else (setq state 2))) + (:question (push token path-components) + (setq state 7)) + (:hash (push token path-components) + (setq state 8)) + (:slash (push token path-components) + (push "/" path-components) + (setq state 6)) + (:string (failure)) + (:end (push token path-components) + (setq state 9))))) + (2 ;; seen : + (ecase (read-token t) + (:colon (failure)) + (:question (setq state 7)) + (:hash (setq state 8)) + (:slash (setq state 3)) + (:string (setq state 10)) + (:end (setq state 9)))) + (10 ;; seen : + (let ((token tokval)) + (ecase (read-token t) + (:colon (failure)) + (:question (push token path-components) + (setq state 7)) + (:hash (push token path-components) + (setq state 8)) + (:slash (push token path-components) + (setq state 6)) + (:string (failure)) + (:end (push token path-components) + (setq state 9))))) + (3 ;; seen / or :/ + (ecase (read-token t) + (:colon (failure)) + (:question (push "/" path-components) + (setq state 7)) + (:hash (push "/" path-components) + (setq state 8)) + (:slash (setq state 4)) + (:string (push "/" path-components) + (push tokval path-components) + (setq state 6)) + (:end (push "/" path-components) + (setq state 9)))) + (4 ;; seen [:]// + (ecase (read-token t) + (:colon (failure)) + (:question (failure)) + (:hash (failure)) + (:slash + (if* (and (equalp "file" scheme) + (null host)) + then ;; file:///... + (push "/" path-components) + (setq state 6) + else (failure))) + (:string (setq host tokval) + (setq state 11)) + (:end (failure)))) + (11 ;; seen [:]// + (ecase (read-token t) + (:colon (setq state 5)) + (:question (setq state 7)) + (:hash (setq state 8)) + (:slash (push "/" path-components) + (setq state 6)) + (:string (impossible)) + (:end (setq state 9)))) + (5 ;; seen [:]//: + (ecase (read-token t) + (:colon (failure)) + (:question (failure)) + (:hash (failure)) + (:slash (push "/" path-components) + (setq state 6)) + (:string (setq port tokval) + (setq state 12)) + (:end (failure)))) + (12 ;; seen [:]//:[] + (ecase (read-token t) + (:colon (failure)) + (:question (setq state 7)) + (:hash (setq state 8)) + (:slash (push "/" path-components) + (setq state 6)) + (:string (impossible)) + (:end (setq state 9)))) + (6 ;; seen / + (ecase (read-token :path) + (:question (setq state 7)) + (:hash (setq state 8)) + (:string (push tokval path-components) + (setq state 13)) + (:end (setq state 9)))) + (13 ;; seen path + (ecase (read-token :path) + (:question (setq state 7)) + (:hash (setq state 8)) + (:string (impossible)) + (:end (setq state 9)))) + (7 ;; seen ? + (setq illegal-chars + (if* *strict-parse* + then *strict-illegal-query-characters* + else *illegal-query-characters*)) + (ecase (prog1 (read-token :query) + (setq illegal-chars *illegal-characters*)) + (:hash (setq state 8)) + (:string (setq query tokval) + (setq state 14)) + (:end (setq state 9)))) + (14 ;; query + (ecase (read-token :query) + (:hash (setq state 8)) + (:string (impossible)) + (:end (setq state 9)))) + (8 ;; seen # + (ecase (read-token :rest) + (:string (setq fragment tokval) + (setq state 9)) + (:end (setq state 9)))) + (9 ;; done + (return + (values + scheme host port + (apply #'concatenate 'string (nreverse path-components)) + query fragment))) + ;; URN parsing: + (15 ;; seen urn:, read nid now + (case (read-token :colon *valid-nid-characters*) + (:string (setq nid tokval) + (setq state 16)) + (t (failure "missing namespace identifier")))) + (16 ;; seen urn: + (case (read-token t) + (:colon (setq state 17)) + (t (failure "missing namespace specific string")))) + (17 ;; seen urn::, rest is nss + (return (values scheme + nid + nil + (progn + (setq illegal-chars *reserved-nss-characters*) + (read-token :rest) + tokval)))) + (t (.parse-error + "internal error in parse engine, wrong state: ~s." state))))))) + +(defun escape-p (string) + (declare (optimize (speed 3))) + (do* ((i 0 (1+ i)) + (max (the fixnum (length string)))) + ((= i max) nil) + (declare (fixnum i max)) + (when (char= #\% (char string i)) + (return t)))) + +(defun parse-path (path-string escape) + (do* ((xpath-list (delimited-string-to-list path-string #\/)) + (path-list + (progn + (if* (string= "" (car xpath-list)) + then (setf (car xpath-list) :absolute) + else (push :relative xpath-list)) + xpath-list)) + (pl (cdr path-list) (cdr pl)) + segments) + ((null pl) path-list) + + (if* (cdr (setq segments + (if* (string= "" (car pl)) + then '("") + else (delimited-string-to-list (car pl) #\;)))) + then ;; there is a param + (setf (car pl) + (mapcar #'(lambda (s) + (decode-escaped-encoding s escape + ;; decode all %xx: + nil)) + segments)) + else ;; no param + (setf (car pl) + (decode-escaped-encoding (car segments) escape + ;; decode all %xx: + nil))))) + +(defun decode-escaped-encoding (string escape + &optional (reserved-chars + *reserved-characters*)) + ;; Return a string with the real characters. + (when (null escape) (return-from decode-escaped-encoding string)) + (do* ((i 0 (1+ i)) + (max (length string)) + (new-string (copy-seq string)) + (new-i 0 (1+ new-i)) + ch ch2 chc chc2) + ((= i max) + (shrink-vector new-string new-i)) + (if* (char= #\% (setq ch (char string i))) + then (when (> (+ i 3) max) + (.parse-error + "Unsyntactic escaped encoding in ~s." string)) + (setq ch (char string (incf i))) + (setq ch2 (char string (incf i))) + (when (not (and (setq chc (digit-char-p ch 16)) + (setq chc2 (digit-char-p ch2 16)))) + (.parse-error + "Non-hexidecimal digits after %: %c%c." ch ch2)) + (let ((ci (+ (* 16 chc) chc2))) + (if* (or (null reserved-chars) + (> ci 127) ; bug11527 + (= 0 (sbit reserved-chars ci))) + then ;; ok as is + (setf (char new-string new-i) + (code-char ci)) + else (setf (char new-string new-i) #\%) + (setf (char new-string (incf new-i)) ch) + (setf (char new-string (incf new-i)) ch2))) + else (setf (char new-string new-i) ch)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;; Printing + +(defun render-uri (uri stream + &aux (escape (uri-escaped uri)) + (*print-pretty* nil)) + (when (null (uri-string uri)) + (setf (uri-string uri) + (let ((scheme (uri-scheme uri)) + (host (uri-host uri)) + (port (uri-port uri)) + (path (uri-path uri)) + (query (uri-query uri)) + (fragment (uri-fragment uri))) + (concatenate 'string + (when scheme + (encode-escaped-encoding + (string-downcase ;; for upper case lisps + (symbol-name scheme)) + *reserved-characters* escape)) + (when scheme ":") + (when (or host (eq :file scheme)) "//") + (when host + (encode-escaped-encoding + host *reserved-authority-characters* escape)) + (when port ":") + (when port + #-allegro (format nil "~D" port) + #+allegro (with-output-to-string (s) + (excl::maybe-print-fast s port)) + ) + (when path + (encode-escaped-encoding path + nil + ;;*reserved-path-characters* + escape)) + (when query "?") + (when query (encode-escaped-encoding query nil escape)) + (when fragment "#") + (when fragment (encode-escaped-encoding fragment nil escape)))))) + (if* stream + then (format stream "~a" (uri-string uri)) + else (uri-string uri))) + +(defun render-parsed-path (path-list escape) + (do* ((res '()) + (first (car path-list)) + (pl (cdr path-list) (cdr pl)) + (pe (car pl) (car pl))) + ((null pl) + (when res (apply #'concatenate 'string (nreverse res)))) + (when (or (null first) + (prog1 (eq :absolute first) + (setq first nil))) + (push "/" res)) + (if* (atom pe) + then (push + (encode-escaped-encoding pe *reserved-path-characters* escape) + res) + else ;; contains params + (push (encode-escaped-encoding + (car pe) *reserved-path-characters* escape) + res) + (dolist (item (cdr pe)) + (push ";" res) + (push (encode-escaped-encoding + item *reserved-path-characters* escape) + res))))) + +(defun render-urn (urn stream + &aux (*print-pretty* nil)) + (when (null (uri-string urn)) + (setf (uri-string urn) + (let ((nid (urn-nid urn)) + (nss (urn-nss urn))) + (concatenate 'string "urn:" nid ":" nss)))) + (if* stream + then (format stream "~a" (uri-string urn)) + else (uri-string urn))) + +(defparameter *escaped-encoding* + (vector #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 #\a #\b #\c #\d #\e #\f)) + +(defun encode-escaped-encoding (string reserved-chars escape) + (when (null escape) (return-from encode-escaped-encoding string)) + ;; Make a string as big as it possibly needs to be (3 times the original + ;; size), and truncate it at the end. + (do* ((max (length string)) + (new-max (* 3 max)) ;; worst case new size + (new-string (make-string new-max)) + (i 0 (1+ i)) + (new-i -1) + c ci) + ((= i max) + (shrink-vector new-string (incf new-i))) + (setq ci (char-int (setq c (char string i)))) + (if* (or (null reserved-chars) + (> ci 127) + (= 0 (sbit reserved-chars ci))) + then ;; ok as is + (incf new-i) + (setf (char new-string new-i) c) + else ;; need to escape it + (multiple-value-bind (q r) (truncate ci 16) + (setf (char new-string (incf new-i)) #\%) + (setf (char new-string (incf new-i)) (elt *escaped-encoding* q)) + (setf (char new-string (incf new-i)) + (elt *escaped-encoding* r)))))) + +(defmethod print-object ((uri uri) stream) + (if* *print-escape* + then (format stream "#<~a ~a>" 'uri (render-uri uri nil)) + else (render-uri uri stream))) + +(defmethod print-object ((urn urn) stream) + (if* *print-escape* + then (format stream "#<~a ~a>" 'uri (render-urn urn nil)) + else (render-urn urn stream))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; merging and unmerging + +(defmethod merge-uris ((uri string) (base string) &optional place) + (merge-uris (parse-uri uri) (parse-uri base) place)) + +(defmethod merge-uris ((uri uri) (base string) &optional place) + (merge-uris uri (parse-uri base) place)) + +(defmethod merge-uris ((uri string) (base uri) &optional place) + (merge-uris (parse-uri uri) base place)) + + +(defmethod merge-uris ((uri uri) (base uri) &optional place) + ;; See ../doc/rfc2396.txt for info on the algorithm we use to merge + ;; URIs. + ;; + (tagbody +;;;; step 2 + (when (and (null (uri-parsed-path uri)) + (null (uri-scheme uri)) + (null (uri-host uri)) + (null (uri-port uri)) + (null (uri-query uri))) + (return-from merge-uris + (let ((new (copy-uri base :place place))) + (when (uri-query uri) + (setf (uri-query new) (uri-query uri))) + (when (uri-fragment uri) + (setf (uri-fragment new) (uri-fragment uri))) + new))) + + (setq uri (copy-uri uri :place place)) + +;;;; step 3 + (when (uri-scheme uri) + (return-from merge-uris uri)) + (setf (uri-scheme uri) (uri-scheme base)) + +;;;; step 4 + (when (uri-host uri) (go :done)) + (setf (uri-host uri) (uri-host base)) + (setf (uri-port uri) (uri-port base)) + +;;;; step 5 + (let ((p (uri-parsed-path uri))) + + ;; bug13133: + ;; The following form causes our implementation to be at odds with + ;; RFC 2396, however this is apparently what was intended by the + ;; authors of the RFC. Specifically, (merge-uris "?y" "/foo") + ;; should return # instead of #, according to + ;; this: +;;; http://www.apache.org/~fielding/uri/rev-2002/issues.html#003-relative-query + (when (null p) + (setf (uri-path uri) (uri-path base)) + (go :done)) + + (when (and p (eq :absolute (car p))) + (when (equal '(:absolute "") p) + ;; Canonicalize the way parsing does: + (setf (uri-path uri) nil)) + (go :done))) + +;;;; step 6 + (let* ((base-path + (or (uri-parsed-path base) + ;; needed because we canonicalize away a path of just `/': + '(:absolute ""))) + (path (uri-parsed-path uri)) + new-path-list) + (when (not (eq :absolute (car base-path))) + (error "Cannot merge ~a and ~a, since latter is not absolute." + uri base)) + + ;; steps 6a and 6b: + (setq new-path-list + (append (butlast base-path) + (if* path then (cdr path) else '("")))) + + ;; steps 6c and 6d: + (let ((last (last new-path-list))) + (if* (atom (car last)) + then (when (string= "." (car last)) + (setf (car last) "")) + else (when (string= "." (caar last)) + (setf (caar last) "")))) + (setq new-path-list + (delete "." new-path-list :test #'(lambda (a b) + (if* (atom b) + then (string= a b) + else nil)))) + + ;; steps 6e and 6f: + (let ((npl (cdr new-path-list)) + index tmp fix-tail) + (setq fix-tail + (string= ".." (let ((l (car (last npl)))) + (if* (atom l) + then l + else (car l))))) + (loop + (setq index + (position ".." npl + :test #'(lambda (a b) + (string= a + (if* (atom b) + then b + else (car b)))))) + (when (null index) (return)) + (when (= 0 index) + ;; The RFC says, in 6g, "that the implementation may handle + ;; this error by retaining these components in the resolved + ;; path, by removing them from the resolved path, or by + ;; avoiding traversal of the reference." The examples in C.2 + ;; imply that we should do the first thing (retain them), so + ;; that's what we'll do. + (return)) + (if* (= 1 index) + then (setq npl (cddr npl)) + else (setq tmp npl) + (dotimes (x (- index 2)) (setq tmp (cdr tmp))) + (setf (cdr tmp) (cdddr tmp)))) + (setf (cdr new-path-list) npl) + (when fix-tail (setq new-path-list (nconc new-path-list '(""))))) + + ;; step 6g: + ;; don't complain if new-path-list starts with `..'. See comment + ;; above about this step. + + ;; step 6h: + (when (or (equal '(:absolute "") new-path-list) + (equal '(:absolute) new-path-list)) + (setq new-path-list nil)) + (setf (uri-path uri) + (render-parsed-path new-path-list + ;; don't know, so have to assume: + t))) + +;;;; step 7 + :done + (return-from merge-uris uri))) + +(defmethod enough-uri ((uri string) (base string) &optional place) + (enough-uri (parse-uri uri) (parse-uri base) place)) + +(defmethod enough-uri ((uri uri) (base string) &optional place) + (enough-uri uri (parse-uri base) place)) + +(defmethod enough-uri ((uri string) (base uri) &optional place) + (enough-uri (parse-uri uri) base place)) + +(defmethod enough-uri ((uri uri) (base uri) &optional place) + (let ((new-scheme nil) + (new-host nil) + (new-port nil) + (new-parsed-path nil)) + + (when (or (and (uri-scheme uri) + (not (equalp (uri-scheme uri) (uri-scheme base)))) + (and (uri-host uri) + (not (equalp (uri-host uri) (uri-host base)))) + (not (equalp (uri-port uri) (uri-port base)))) + (return-from enough-uri uri)) + + (when (null (uri-host uri)) + (setq new-host (uri-host base))) + (when (null (uri-port uri)) + (setq new-port (uri-port base))) + + (when (null (uri-scheme uri)) + (setq new-scheme (uri-scheme base))) + + ;; Now, for the hard one, path. + ;; We essentially do here what enough-namestring does. + (do* ((base-path (uri-parsed-path base)) + (path (uri-parsed-path uri)) + (bp base-path (cdr bp)) + (p path (cdr p))) + ((or (null bp) (null p)) + ;; If p is nil, that means we have something like + ;; (enough-uri "/foo/bar" "/foo/bar/baz.htm"), so + ;; new-parsed-path will be nil. + (when (null bp) + (setq new-parsed-path (copy-list p)) + (when (not (symbolp (car new-parsed-path))) + (push :relative new-parsed-path)))) + (if* (equal (car bp) (car p)) + thenret ;; skip it + else (setq new-parsed-path (copy-list p)) + (when (not (symbolp (car new-parsed-path))) + (push :relative new-parsed-path)) + (return))) + + (let ((new-path + (when new-parsed-path + (render-parsed-path new-parsed-path + ;; don't know, so have to assume: + t))) + (new-query (uri-query uri)) + (new-fragment (uri-fragment uri)) + (new-plist (copy-list (uri-plist uri)))) + (if* (and (null new-scheme) + (null new-host) + (null new-port) + (null new-path) + (null new-parsed-path) + (null new-query) + (null new-fragment)) + then ;; can't have a completely empty uri! + (copy-uri nil + :class (class-of uri) + :place place + :path "/" + :plist new-plist) + else (copy-uri nil + :class (class-of uri) + :place place + :scheme new-scheme + :host new-host + :port new-port + :path new-path + :parsed-path new-parsed-path + :query new-query + :fragment new-fragment + :plist new-plist))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; support for interning URIs + +(defun make-uri-space (&rest keys &key (size 777) &allow-other-keys) + #+allegro + (apply #'make-hash-table :size size + :hash-function 'uri-hash + :test 'uri= :values nil keys) + #-allegro + (apply #'make-hash-table :size size keys)) + +(defun gethash-uri (uri table) + #+allegro (gethash uri table) + #-allegro + (let* ((hash (uri-hash uri)) + (existing (gethash hash table))) + (dolist (u existing) + (when (uri= u uri) + (return-from gethash-uri (values u t)))) + (values nil nil))) + +(defun puthash-uri (uri table) + #+allegro (excl:puthash-key uri table) + #-allegro + (let ((existing (gethash (uri-hash uri) table))) + (dolist (u existing) + (when (uri= u uri) + (return-from puthash-uri u))) + (setf (gethash (uri-hash uri) table) + (cons uri existing)) + uri)) + + +(defun uri-hash (uri) + (if* (uri-hashcode uri) + thenret + else (setf (uri-hashcode uri) + (sxhash + #+allegro + (render-uri uri nil) + #-allegro + (string-downcase + (render-uri uri nil)))))) + +(defvar *uris* (make-uri-space)) + +(defun uri-space () *uris*) + +(defun (setf uri-space) (new-val) + (setq *uris* new-val)) + +;; bootstrapping (uri= changed from function to method): +(when (fboundp 'uri=) (fmakunbound 'uri=)) + +(defgeneric uri= (uri1 uri2)) +(defmethod uri= ((uri1 uri) (uri2 uri)) + (when (not (eq (uri-scheme uri1) (uri-scheme uri2))) + (return-from uri= nil)) + ;; RFC2396 says: a URL with an explicit ":port", where the port is + ;; the default for the scheme, is the equivalent to one where the + ;; port is elided. Hmmmm. This means that this function has to be + ;; scheme dependent. Grrrr. + (let ((default-port (case (uri-scheme uri1) + (:http 80) + (:https 443) + (:ftp 21) + (:telnet 23)))) + (and (equalp (uri-host uri1) (uri-host uri2)) + (eql (or (uri-port uri1) default-port) + (or (uri-port uri2) default-port)) + (string= (uri-path uri1) (uri-path uri2)) + (string= (uri-query uri1) (uri-query uri2)) + (string= (uri-fragment uri1) (uri-fragment uri2))))) + +(defmethod uri= ((urn1 urn) (urn2 urn)) + (when (not (eq (uri-scheme urn1) (uri-scheme urn2))) + (return-from uri= nil)) + (and (equalp (urn-nid urn1) (urn-nid urn2)) + (urn-nss-equal (urn-nss urn1) (urn-nss urn2)))) + +(defun urn-nss-equal (nss1 nss2 &aux len) + ;; Return t iff the nss values are the same. + ;; %2c and %2C are equivalent. + (when (or (null nss1) (null nss2) + (not (= (setq len (length nss1)) + (length nss2)))) + (return-from urn-nss-equal nil)) + (do* ((i 0 (1+ i)) + (state :char) + c1 c2) + ((= i len) t) + (setq c1 (char nss1 i)) + (setq c2 (char nss2 i)) + (ecase state + (:char + (if* (and (char= #\% c1) (char= #\% c2)) + then (setq state :percent+1) + elseif (char/= c1 c2) + then (return nil))) + (:percent+1 + (when (char-not-equal c1 c2) (return nil)) + (setq state :percent+2)) + (:percent+2 + (when (char-not-equal c1 c2) (return nil)) + (setq state :char))))) + +(defmethod intern-uri ((xuri uri) &optional (uri-space *uris*)) + (let ((uri (gethash-uri xuri uri-space))) + (if* uri + thenret + else (puthash-uri xuri uri-space)))) + +(defmethod intern-uri ((uri string) &optional (uri-space *uris*)) + (intern-uri (parse-uri uri) uri-space)) + +(defun unintern-uri (uri &optional (uri-space *uris*)) + (if* (eq t uri) + then (clrhash uri-space) + elseif (uri-p uri) + then (remhash uri uri-space) + else (error "bad uri: ~s." uri))) + +(defmacro do-all-uris ((var &optional uri-space result-form) + &rest forms + &environment env) + "do-all-uris (var [[uri-space] result-form]) + {declaration}* {tag | statement}* +Executes the forms once for each uri with var bound to the current uri" + (let ((f (gensym)) + (g-ignore (gensym)) + (g-uri-space (gensym)) + (body (third (parse-body forms env)))) + `(let ((,g-uri-space (or ,uri-space *uris*))) + (prog nil + (flet ((,f (,var &optional ,g-ignore) + (declare (ignore-if-unused ,var ,g-ignore)) + (tagbody , at body))) + (maphash #',f ,g-uri-space)) + (return ,result-form))))) + +(defun sharp-u (stream chr arg) + (declare (ignore chr arg)) + (let ((arg (read stream nil nil t))) + (if *read-suppress* + nil + (if* (stringp arg) + then (parse-uri arg) + else + + (internal-reader-error + stream + "#u takes a string or list argument: ~s" arg))))) + + +#+allegro +excl:: +#+allegro +(locally (declare (special std-lisp-readtable)) + (let ((*readtable* std-lisp-readtable)) + (set-dispatch-macro-character #\# #\u #'puri::sharp-u))) +#-allegro +(set-dispatch-macro-character #\# #\u #'puri::sharp-u) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(provide :uri) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; timings +;; (don't run under emacs with M-x fi:common-lisp) + +#+allegro +(eval-when (:compile-toplevel :load-toplevel :execute) + (import 'excl::gc)) + +#-allegro +(defun gc (&rest options) + (declare (ignore options)) + #+sbcl (sb-ext::gc) + #+cmu (ext::gc) + ) + +(defun time-uri-module () + (declare (optimize (speed 3) (safety 0) (debug 0))) + (let ((uri "http://www.franz.com/a/b;x;y;z/c/foo?bar=baz&xxx#foo") + (uri2 "http://www.franz.com/a/b;x;y;z/c/%2ffoo?bar=baz&xxx#foo")) + (gc t) (gc :tenure) (gc :tenure) (gc :tenure) + (format t "~&;;; starting timing testing 1...~%") + (time (dotimes (i 100000) (parse-uri uri))) + + (gc t) (gc :tenure) (gc :tenure) (gc :tenure) + (format t "~&;;; starting timing testing 2...~%") + (let ((uri (parse-uri uri))) + (time (dotimes (i 100000) + ;; forces no caching of the printed representation: + (setf (uri-string uri) nil) + (format nil "~a" uri)))) + + (gc t) (gc :tenure) (gc :tenure) (gc :tenure) + (format t "~&;;; starting timing testing 3...~%") + (time + (progn + (dotimes (i 100000) (parse-uri uri2)) + (let ((uri (parse-uri uri))) + (dotimes (i 100000) + ;; forces no caching of the printed representation: + (setf (uri-string uri) nil) + (format nil "~a" uri))))))) + +;;******** reference output (ultra, modified 5.0.1): +;;; starting timing testing 1... +; cpu time (non-gc) 13,710 msec user, 0 msec system +; cpu time (gc) 600 msec user, 10 msec system +; cpu time (total) 14,310 msec user, 10 msec system +; real time 14,465 msec +; space allocation: +; 1,804,261 cons cells, 7 symbols, 41,628,832 other bytes, 0 static bytes +;;; starting timing testing 2... +; cpu time (non-gc) 27,500 msec user, 0 msec system +; cpu time (gc) 280 msec user, 20 msec system +; cpu time (total) 27,780 msec user, 20 msec system +; real time 27,897 msec +; space allocation: +; 1,900,463 cons cells, 0 symbols, 17,693,712 other bytes, 0 static bytes +;;; starting timing testing 3... +; cpu time (non-gc) 52,290 msec user, 10 msec system +; cpu time (gc) 1,290 msec user, 30 msec system +; cpu time (total) 53,580 msec user, 40 msec system +; real time 54,062 msec +; space allocation: +; 7,800,205 cons cells, 0 symbols, 81,697,496 other bytes, 0 static bytes + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; after improving decode-escaped-encoding/encode-escaped-encoding: + +;;; starting timing testing 1... +; cpu time (non-gc) 14,520 msec user, 0 msec system +; cpu time (gc) 400 msec user, 0 msec system +; cpu time (total) 14,920 msec user, 0 msec system +; real time 15,082 msec +; space allocation: +; 1,800,270 cons cells, 0 symbols, 41,600,160 other bytes, 0 static bytes +;;; starting timing testing 2... +; cpu time (non-gc) 27,490 msec user, 10 msec system +; cpu time (gc) 300 msec user, 0 msec system +; cpu time (total) 27,790 msec user, 10 msec system +; real time 28,025 msec +; space allocation: +; 1,900,436 cons cells, 0 symbols, 17,693,712 other bytes, 0 static bytes +;;; starting timing testing 3... +; cpu time (non-gc) 47,900 msec user, 20 msec system +; cpu time (gc) 920 msec user, 10 msec system +; cpu time (total) 48,820 msec user, 30 msec system +; real time 49,188 msec +; space allocation: +; 3,700,215 cons cells, 0 symbols, 81,707,144 other bytes, 0 static bytes Added: branches/grin-neu/thirdparty/puri/tests.lisp =================================================================== --- branches/grin-neu/thirdparty/puri/tests.lisp 2006-12-01 10:37:34 UTC (rev 2093) +++ branches/grin-neu/thirdparty/puri/tests.lisp 2006-12-01 10:39:49 UTC (rev 2094) @@ -0,0 +1,419 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;; copyright (c) 1999-2001 Franz Inc, Berkeley, CA - All rights reserved. +;; copyright (c) 2003 Kevin Rosenberg (significant fixes for using +;; tester package) +;; +;; The software, data and information contained herein are proprietary +;; to, and comprise valuable trade secrets of, Franz, Inc. They are +;; given in confidence by Franz, Inc. pursuant to a written license +;; agreement, and may be stored and used only in accordance with the terms +;; of such license. +;; +;; Restricted Rights Legend +;; ------------------------ +;; Use, duplication, and disclosure of the software, data and information +;; contained herein by any agency, department or entity of the U.S. +;; Government are subject to restrictions of Restricted Rights for +;; Commercial Software developed at private expense as specified in +;; DOD FAR Supplement 52.227-7013 (c) (1) (ii), as applicable. +;; +;; Original version from ACL 6.1: +;; t-uri.cl,v 1.3.6.3.2.1 2001/08/09 17:42:43 layer +;; +;; $Id: tests.lisp 11031 2006-08-15 00:59:34Z kevin $ + + +(defpackage #:puri-tests (:use #:puri #:cl #:ptester)) +(in-package #:puri-tests) + +(unintern-uri t) + +(defmacro gen-test-forms () + (let ((res '()) + (base-uri "http://a/b/c/d;p?q")) + + (dolist (x `(;; (relative-uri result base-uri compare-function) +;;;; RFC Appendix C.1 (normal examples) + ("g:h" "g:h" ,base-uri) + ("g" "http://a/b/c/g" ,base-uri) + ("./g" "http://a/b/c/g" ,base-uri) + ("g/" "http://a/b/c/g/" ,base-uri) + ("/g" "http://a/g" ,base-uri) + ("//g" "http://g" ,base-uri) + ;; Following was changed from appendix C of RFC 2396 + ;; http://www.apache.org/~fielding/uri/rev-2002/issues.html#003-relative-query + #-ignore ("?y" "http://a/b/c/d;p?y" ,base-uri) + #+ignore ("?y" "http://a/b/c/?y" ,base-uri) + ("g?y" "http://a/b/c/g?y" ,base-uri) + ("#s" "http://a/b/c/d;p?q#s" ,base-uri) + ("g#s" "http://a/b/c/g#s" ,base-uri) + ("g?y#s" "http://a/b/c/g?y#s" ,base-uri) + (";x" "http://a/b/c/;x" ,base-uri) + ("g;x" "http://a/b/c/g;x" ,base-uri) + ("g;x?y#s" "http://a/b/c/g;x?y#s" ,base-uri) + ("." "http://a/b/c/" ,base-uri) + ("./" "http://a/b/c/" ,base-uri) + (".." "http://a/b/" ,base-uri) + ("../" "http://a/b/" ,base-uri) + ("../g" "http://a/b/g" ,base-uri) + ("../.." "http://a/" ,base-uri) + ("../../" "http://a/" ,base-uri) + ("../../g" "http://a/g" ,base-uri) +;;;; RFC Appendix C.2 (abnormal examples) + ("" "http://a/b/c/d;p?q" ,base-uri) + ("../../../g" "http://a/../g" ,base-uri) + ("../../../../g" "http://a/../../g" ,base-uri) + ("/./g" "http://a/./g" ,base-uri) + ("/../g" "http://a/../g" ,base-uri) + ("g." "http://a/b/c/g." ,base-uri) + (".g" "http://a/b/c/.g" ,base-uri) + ("g.." "http://a/b/c/g.." ,base-uri) + ("..g" "http://a/b/c/..g" ,base-uri) + ("./../g" "http://a/b/g" ,base-uri) + ("./g/." "http://a/b/c/g/" ,base-uri) + ("g/./h" "http://a/b/c/g/h" ,base-uri) + ("g/../h" "http://a/b/c/h" ,base-uri) + ("g;x=1/./y" "http://a/b/c/g;x=1/y" ,base-uri) + ("g;x=1/../y" "http://a/b/c/y" ,base-uri) + ("g?y/./x" "http://a/b/c/g?y/./x" ,base-uri) + ("g?y/../x" "http://a/b/c/g?y/../x" ,base-uri) + ("g#s/./x" "http://a/b/c/g#s/./x" ,base-uri) + ("g#s/../x" "http://a/b/c/g#s/../x" ,base-uri) + ("http:g" "http:g" ,base-uri) + + ("foo/bar/baz.htm#foo" + "http://a/b/foo/bar/baz.htm#foo" + "http://a/b/c.htm") + ("foo/bar/baz.htm#foo" + "http://a/b/foo/bar/baz.htm#foo" + "http://a/b/") + ("foo/bar/baz.htm#foo" + "http://a/foo/bar/baz.htm#foo" + "http://a/b") + ("foo/bar;x;y/bam.htm" + "http://a/b/c/foo/bar;x;y/bam.htm" + "http://a/b/c/"))) + (push `(test (intern-uri ,(second x)) + (intern-uri (merge-uris (intern-uri ,(first x)) + (intern-uri ,(third x)))) + :test 'uri=) + res)) + +;;;; intern tests + (dolist (x '(;; default port and specifying the default port are + ;; supposed to compare the same: + ("http://www.franz.com:80" "http://www.franz.com") + ("http://www.franz.com:80" "http://www.franz.com" eq) + ;; make sure they're `eq': + ("http://www.franz.com:80" "http://www.franz.com" eq) + ("http://www.franz.com" "http://www.franz.com" eq) + ("http://www.franz.com/foo" "http://www.franz.com/foo" eq) + ("http://www.franz.com/foo?bar" + "http://www.franz.com/foo?bar" eq) + ("http://www.franz.com/foo?bar#baz" + "http://www.franz.com/foo?bar#baz" eq) + ("http://WWW.FRANZ.COM" "http://www.franz.com" eq) + ("http://www.FRANZ.com" "http://www.franz.com" eq) + ("http://www.franz.com" "http://www.franz.com/" eq) + (;; %72 is "r", %2f is "/", %3b is ";" + "http://www.franz.com/ba%72%2f%3b;x;y;z/baz/" + "http://www.franz.com/bar%2f%3b;x;y;z/baz/" eq))) + (push `(test (intern-uri ,(second x)) + (intern-uri ,(first x)) + :test ',(if (third x) + (third x) + 'uri=)) + res)) + +;;;; parsing and equivalence tests + (push `(test + (parse-uri "http://foo+bar?baz=b%26lob+bof") + (parse-uri (parse-uri "http://foo+bar?baz=b%26lob+bof")) + :test 'uri=) + res) + (push '(test + (parse-uri "http://www.foo.com") + (parse-uri (parse-uri "http://www.foo.com?")) ; allow ? at end + :test 'uri=) + res) + (push `(test + "baz=b%26lob+bof" + (uri-query (parse-uri "http://foo+bar?baz=b%26lob+bof")) + :test 'string=) + res) + (push `(test + "baz=b%26lob+bof%3d" + (uri-query (parse-uri "http://foo+bar?baz=b%26lob+bof%3d")) + :test 'string=) + res) + (push + `(test (parse-uri "xxx?%41") (parse-uri "xxx?A") :test 'uri=) + res) + (push + `(test "A" (uri-query (parse-uri "xxx?%41")) :test 'string=) + res) + + (push `(test-error (parse-uri " ") + :condition-type 'uri-parse-error) + res) + (push `(test-error (parse-uri "foo ") + :condition-type 'uri-parse-error) + res) + (push `(test-error (parse-uri " foo ") + :condition-type 'uri-parse-error) + res) + (push `(test-error (parse-uri "") + :condition-type 'uri-parse-error) + res) + (push `(test-error (parse-uri "") + :condition-type 'uri-parse-error) + res) + (push `(test-error (parse-uri "%") + :condition-type 'uri-parse-error) + res) + (push `(test-error (parse-uri "foo%xyr") + :condition-type 'uri-parse-error) + res) + (push `(test-error (parse-uri "\"foo\"") + :condition-type 'uri-parse-error) + res) + (push `(test "%20" (format nil "~a" (parse-uri "%20")) + :test 'string=) + res) + (push `(test "&" (format nil "~a" (parse-uri "%26")) + :test 'string=) + res) + (push + `(test "foo%23bar" (format nil "~a" (parse-uri "foo%23bar")) + :test 'string=) + res) + (push + `(test "foo%23bar#foobar" + (format nil "~a" (parse-uri "foo%23bar#foobar")) + :test 'string=) + res) + (push + `(test "foo%23bar#foobar#baz" + (format nil "~a" (parse-uri "foo%23bar#foobar#baz")) + :test 'string=) + res) + (push + `(test "foo%23bar#foobar#baz" + (format nil "~a" (parse-uri "foo%23bar#foobar%23baz")) + :test 'string=) + res) + (push + `(test "foo%23bar#foobar/baz" + (format nil "~a" (parse-uri "foo%23bar#foobar%2fbaz")) + :test 'string=) + res) + (push `(test-error (parse-uri "foobar??") + :condition-type 'uri-parse-error) + res) + (push `(test-error (parse-uri "foobar?foo?") + :condition-type 'uri-parse-error) + res) + (push `(test "foobar?%3f" + (format nil "~a" (parse-uri "foobar?%3f")) + :test 'string=) + res) + (push `(test + "http://foo/bAr;3/baz?baf=3" + (format nil "~a" (parse-uri "http://foo/b%41r;3/baz?baf=3")) + :test 'string=) + res) + (push `(test + '(:absolute ("/bAr" "3") "baz") + (uri-parsed-path (parse-uri "http://foo/%2fb%41r;3/baz?baf=3")) + :test 'equal) + res) + (push `(test + "/%2fbAr;3/baz" + (let ((u (parse-uri "http://foo/%2fb%41r;3/baz?baf=3"))) + (setf (uri-parsed-path u) '(:absolute ("/bAr" "3") "baz")) + (uri-path u)) + :test 'string=) + res) + (push `(test + "http://www.verada.com:8010/kapow?name=foo%3Dbar%25" + (format nil "~a" + (parse-uri + "http://www.verada.com:8010/kapow?name=foo%3Dbar%25")) + :test 'string=) + res) + (push `(test + "ftp://parcftp.xerox.com/pub/pcl/mop/" + (format nil "~a" + (parse-uri "ftp://parcftp.xerox.com:/pub/pcl/mop/")) + :test 'string=) + res) + +;;;; enough-uri tests + (dolist (x `(("http://www.franz.com/foo/bar/baz.htm" + "http://www.franz.com/foo/bar/" + "baz.htm") + ("http://www.franz.com/foo/bar/baz.htm" + "http://www.franz.com/foo/bar" + "baz.htm") + ("http://www.franz.com:80/foo/bar/baz.htm" + "http://www.franz.com:80/foo/bar" + "baz.htm") + ("http:/foo/bar/baz.htm" "http:/foo/bar" "baz.htm") + ("http:/foo/bar/baz.htm" "http:/foo/bar/" "baz.htm") + ("/foo/bar/baz.htm" "/foo/bar" "baz.htm") + ("/foo/bar/baz.htm" "/foo/bar/" "baz.htm") + ("/foo/bar/baz.htm#foo" "/foo/bar/" "baz.htm#foo") + ("/foo/bar/baz.htm?bar#foo" "/foo/bar/" "baz.htm?bar#foo") + + ("http://www.dnai.com/~layer/foo.htm" + "http://www.known.net" + "http://www.dnai.com/~layer/foo.htm") + ("http://www.dnai.com/~layer/foo.htm" + "http://www.dnai.com:8000/~layer/" + "http://www.dnai.com/~layer/foo.htm") + ("http://www.dnai.com:8000/~layer/foo.htm" + "http://www.dnai.com/~layer/" + "http://www.dnai.com:8000/~layer/foo.htm") + ("http://www.franz.com" + "http://www.franz.com" + "/"))) + (push `(test (parse-uri ,(third x)) + (enough-uri (parse-uri ,(first x)) + (parse-uri ,(second x))) + :test 'uri=) + res)) + +;;;; urn tests, ideas of which are from rfc2141 + (let ((urn "urn:com:foo-the-bar")) + (push `(test "com" (urn-nid (parse-uri ,urn)) + :test #'string=) + res) + (push `(test "foo-the-bar" (urn-nss (parse-uri ,urn)) + :test #'string=) + res)) + (push `(test-error (parse-uri "urn:") + :condition-type 'uri-parse-error) + res) + (push `(test-error (parse-uri "urn:foo") + :condition-type 'uri-parse-error) + res) + (push `(test-error (parse-uri "urn:foo$") + :condition-type 'uri-parse-error) + res) + (push `(test-error (parse-uri "urn:foo_") + :condition-type 'uri-parse-error) + res) + (push `(test-error (parse-uri "urn:foo:foo&bar") + :condition-type 'uri-parse-error) + res) + (push `(test (parse-uri "URN:foo:a123,456") + (parse-uri "urn:foo:a123,456") + :test #'uri=) + res) + (push `(test (parse-uri "URN:foo:a123,456") + (parse-uri "urn:FOO:a123,456") + :test #'uri=) + res) + (push `(test (parse-uri "urn:foo:a123,456") + (parse-uri "urn:FOO:a123,456") + :test #'uri=) + res) + (push `(test (parse-uri "URN:FOO:a123%2c456") + (parse-uri "urn:foo:a123%2C456") + :test #'uri=) + res) + (push `(test + nil + (uri= (parse-uri "urn:foo:A123,456") + (parse-uri "urn:FOO:a123,456"))) + res) + (push `(test + nil + (uri= (parse-uri "urn:foo:A123,456") + (parse-uri "urn:foo:a123,456"))) + res) + (push `(test + nil + (uri= (parse-uri "urn:foo:A123,456") + (parse-uri "URN:foo:a123,456"))) + res) + (push `(test + nil + (uri= (parse-uri "urn:foo:a123%2C456") + (parse-uri "urn:FOO:a123,456"))) + res) + (push `(test + nil + (uri= (parse-uri "urn:foo:a123%2C456") + (parse-uri "urn:foo:a123,456"))) + res) + (push `(test + nil + (uri= (parse-uri "URN:FOO:a123%2c456") + (parse-uri "urn:foo:a123,456"))) + res) + (push `(test + nil + (uri= (parse-uri "urn:FOO:a123%2c456") + (parse-uri "urn:foo:a123,456"))) + res) + (push `(test + nil + (uri= (parse-uri "urn:foo:a123%2c456") + (parse-uri "urn:foo:a123,456"))) + res) + + (push `(test t + (uri= (parse-uri "foo") (parse-uri "foo#"))) + res) + + (push + '(let ((puri::*strict-parse* nil)) + (test-no-error + (puri:parse-uri + "http://foo.com/bar?a=zip|zop"))) + res) + (push + '(test-error + (puri:parse-uri "http://foo.com/bar?a=zip|zop") + :condition-type 'uri-parse-error) + res) + + (push + '(let ((puri::*strict-parse* nil)) + (test-no-error + (puri:parse-uri + "http://arc3.msn.com/ADSAdClient31.dll?GetAd?PG=NBCSBU?SC=D2?AN=1.0586041"))) + res) + (push + '(test-error + (puri:parse-uri + "http://arc3.msn.com/ADSAdClient31.dll?GetAd?PG=NBCSBU?SC=D2?AN=1.0586041") + :condition-type 'uri-parse-error) + res) + + (push + '(let ((puri::*strict-parse* nil)) + (test-no-error + (puri:parse-uri + "http://scbc.booksonline.com/cgi-bin/ndCGI.exe/Develop/pagClubHome.hrfTIOLI_onWebEvent(hrfTIOLI)?selGetClubOffer.TB_OFFER_ID_OFFER=344879%2e0&selGetClubOffer.TB_OFFER_ID_ITEM=34487%2e0&selGetClubOffer.TB_OFFER_ID_OFFER=344879%2e0&^CSpCommand.currRowNumber=5&hrfTIOLI=The+Visual+Basic+6+Programmer%27s+Toolkit&SPIDERSESSION=%3f%3f%3f%3f%3f%5f%3f%3f%3f%40%5b%3f%3f%3f%3fBOs%5cH%3f%3f%3f%3f%3f%3f%3f%3f%3fMMpXO%5f%40JG%7d%40%5c%5f%3f%3f%3fECK%5dt%3fLDT%3fTBD%3fDDTxPEToBS%40%5f%5dBDgXVoKBSDs%7cDT%3fK%3fd%3fTIb%7ceHbkeMfh%60LRpO%5cact%5eUC%7bMu%5fyWUGzLUhP%5ebpdWRka%5dFO%3f%5dBopW%3f%40HMrxbMRd%60LOpuMVga%3fv%3fTS%3fpODT%40O&%5euniqueValue=977933764843"))) + res) + (push + '(test-error + (puri:parse-uri + "http://scbc.booksonline.com/cgi-bin/ndCGI.exe/Develop/pagClubHome.hrfTIOLI_onWebEvent(hrfTIOLI)?selGetClubOffer.TB_OFFER_ID_OFFER=344879%2e0&selGetClubOffer.TB_OFFER_ID_ITEM=34487%2e0&selGetClubOffer.TB_OFFER_ID_OFFER=344879%2e0&^CSpCommand.currRowNumber=5&hrfTIOLI=The+Visual+Basic+6+Programmer%27s+Toolkit&SPIDERSESSION=%3f%3f%3f%3f%3f%5f%3f%3f%3f%40%5b%3f%3f%3f%3fBOs%5cH%3f%3f%3f%3f%3f%3f%3f%3f%3fMMpXO%5f%40JG%7d%40%5c%5f%3f%3f%3fECK%5dt%3fLDT%3fTBD%3fDDTxPEToBS%40%5f%5dBDgXVoKBSDs%7cDT%3fK%3fd%3fTIb%7ceHbkeMfh%60LRpO%5cact%5eUC%7bMu%5fyWUGzLUhP%5ebpdWRka%5dFO%3f%5dBopW%3f%40HMrxbMRd%60LOpuMVga%3fv%3fTS%3fpODT%40O&%5euniqueValue=977933764843") + :condition-type 'uri-parse-error) + res) + + `(progn ,@(nreverse res)))) + +(defun do-tests () + (let ((*break-on-test-failures* t)) + (with-tests (:name "puri") + (gen-test-forms))) + t) + + Added: branches/grin-neu/thirdparty/puri/uri.html =================================================================== --- branches/grin-neu/thirdparty/puri/uri.html 2006-12-01 10:37:34 UTC (rev 2093) +++ branches/grin-neu/thirdparty/puri/uri.html 2006-12-01 10:39:49 UTC (rev 2094) @@ -0,0 +1,406 @@ + + + +URI support in Allegro CL + + + + +

    URI support in Allegro CL

    + +

    This document contains the following sections:

    +

    1.0 Introduction
    +2.0 The URI API definition
    +3.0 Parsing, escape decoding/encoding and the path
    +4.0 Interning URIs
    +5.0 Allegro CL implementation notes
    +6.0 Examples
    +

    + +

    This version of the Allegro CL URI support documentation is for distribution with the +Open Source version of the URI code. Links to Allegro CL documentation other than +URI-specific files have been supressed. To see Allegro CL documentation, see http://www.franz.com/support/documentation/, +which is the Allegro CL documentation page of the franz inc. website. Links to Allegro CL +documentation can be found on that page.

    + +
    + +
    + +

    1.0 Introduction

    + +

    URI stands for Universal Resource Identifier. For a description of +URIs, see RFC2396, which can be found in several places, including the IETF web site (http://www.ietf.org/rfc/rfc2396.txt) and +the UCI/ICS web site (http://www.ics.uci.edu/pub/ietf/uri/rfc2396.txt). +We prefer the UCI/ICS one as it has more examples.

    + +

    URIs are a superset in functionality and syntax to URLs (Universal Resource Locators) +and URNs (Universal Resource Names). That is, RFC2396 updates and merges RFC1738 and +RFC1808 into a single syntax, called the URI. It does exclude some portions of RFC1738 +that define specific syntax of individual URL schemes.

    + +

    In URL slang, the scheme is usually called the `protocol', but it is called +scheme in RFC1738. A URL `host' corresponds to the URI `authority.' The URL slang +`bookmark' or `anchor' is `fragment' in URI lingo.

    + +

    The URI facility was available as a patch to Allegro CL 5.0.1 and is included with +release 6.0. the URI facility might not be in an Allegro CL image. Evaluate (require +:uri) to ensure the facility is loaded (that form returns nil if the +URI module is already loaded).

    + +

    Broadly, the URI facility creates a Lisp object that represents a URI, and provides +setters and accessors to fields in the URI object. The URI object can also be interned, +much like symbols in CL are. This document describes the facility and the related +operators.

    + +

    Aside from the obvious slots which are called out in the RFC, URIs also have a property +list. With interning, this is another similarity between URIs and CL symbols.

    + +
    + +
    + +

    2.0 The URI API definition

    + +

    Symbols naming objects (functions, variables, etc.) in the uri module are +exported from the net.uri package.

    + +

    URIs are represented by CLOS objects. Their slots are:

    + +
    +scheme 
    +host 
    +port 
    +path 
    +query
    +fragment 
    +plist 
    +
    + +

    The host and port slots together correspond to the authority +(see RFC2396). There is an accessor-like function, uri-authority, +that can be used to extract the authority from a URI. See the RFC2396 specifications +pointed to at the beginning of the 1.0 Introduction for details +of all the slots except plist. The plist slot contains a +standard Common Lisp property list.

    + +

    All symbols are external in the net.uri package, unless otherwise noted. +Brief descriptions are given in this document, with complete descriptions in the +individual pages. + +

      +
    • uri: the class of URI objects.
    • +
    • urn: the class of URN objects.
    • +
    • uri-p

      Arguments: object

      +

      Returns true if object is an instance of class uri. +

      +
    • +
    • copy-uri

      Arguments: uri &key + place scheme host port path query fragment plist

      +

      Copies the specified URI object. See the description page for information on the + keyword arguments.

      +
    • +
    • uri-scheme
      + uri-host
      + uri-port
      + uri-path
      + uri-query
      + uri-fragment
      + uri-plist
      +

      Arguments: uri-object

      +

      These accessors return the value of the associated slots of the uri-object

      +
    • +
    • uri-authority

      Arguments: uri-object +

      +

      Returns the authority of uri-object. The authority combines the host and port.

      +
    • +
    • render-uri

      Arguments: uri + stream

      +

      Print to stream the printed representation of uri.

      +
    • +
    • parse-uri

      Arguments: string &key + (class 'uri)

      +

      Parse string into a URI object.

      +
    • +
    • merge-uris

      Arguments: uri + base-uri &optional place

      +

      Return an absolute URI, based on uri, which can be relative, and base-uri + which must be absolute.

      +
    • +
    • enough-uri

      Arguments: uri + base

      +

      Converts uri into a relative URI using base as the base URI.

      +
    • +
    • uri-parsed-path

      Arguments: uri +

      +

      Return the parsed representation of the path.

      +
    • +
    • uri

      Arguments: object

      +

      Defined methods: if argument is a uri object, return it; create a uri object if + possible and return it, or error if not possible.

      +
    • +
    + +
    + +
    + +

    3.0 Parsing, escape decoding/encoding and the path

    + +

    The method uri-path returns the path +portion of the URI, in string form. The method uri-parsed-path +returns the path portion of the URI, in list form. This list form is discussed below, +after a discussion of decoding/encoding.

    + +

    RFC2396 lays out a method for inserting into URIs reserved characters. You do +this by escaping the character. An escaped character is defined like this:

    + +
    +escaped = "%" hex hex 
    +
    +hex = digit | "A" | "B" | "C" | "D" | "E" | "F" | "a" | "b" | "c" | "d" | "e" | "f" 
    +
    + +

    In addition, the RFC defines excluded characters:

    + +
    +"<" | ">" | "#" | "%" | <"> | "{" | "}" | "|" | "\" | "^" | "[" | "]" | "`" 
    +
    + +

    The set of reserved characters are:

    + +
    +";" | "/" | "?" | ":" | "@" | "&" | "=" | "+" | "$" | "," 
    +
    + +

    with the following exceptions: + +

      +
    • within the authority component, the characters ";", ":", + "@", "?", and "/" are reserved.
    • +
    • within a path segment, the characters "/", ";", "=", and + "?" are reserved.
    • +
    • within a query component, the characters ";", "/", "?", + ":", "@", "&", "=", "+", + ",", and "$" are reserved.
    • +
    + +

    From the RFC, there are two important rules about escaping and unescaping (encoding and +decoding): + +

      +
    • decoding should only happen when the URI is parsed into component parts;
    • +
    • encoding can only occur when a URI is made from component parts (ie, rendered for + printing).
    • +
    + +

    The implication of this is that to decode the URI, it must be in a parsed state. That +is, you can't convert %2f (the escaped form of +"/") until the path has been parsed into its component parts. Another important +desire is for the application viewing the component parts to see the decoded values of the +components. For example, consider:

    + +
    +http://www.franz.com/calculator/3%2f2 
    +
    + +

    This might be the implementation of a calculator, and how someone would execute 3/2. +Clearly, the application that implements this would want to see path components of +"calculator" and "3/2". "3%2f2" would not be useful to the +calculator application.

    + +

    For the reasons given above, a parsed version of the path is available and has the +following form:

    + +
    +([:absolute | :relative] component1 [component2...]) 
    +
    + +

    where components are:

    + +
    +element | (element param1 [param2 ...]) 
    +
    + +

    and element is a path element, and the param's are path element parameters. +For example, the result of

    + +
    +(uri-parsed-path (parse-uri "foo;10/bar:x;y;z/baz.htm")) 
    +
    + +

    is

    + +
    +(:relative ("foo" "10") ("bar:x" "y" "z") "baz.htm") 
    +
    + +

    There is a certain amount of canonicalization that occurs when parsing: + +

      +
    • A path of (:absolute) or (:absolute "") is + equivalent to a nil path. That is, http://a/ is parsed with a nil + path and printed as http://a.
    • +
    • Escaped characters that are not reserved are not escaped upon printing. For example, "foob%61r" + is parsed into "foobar" and appears as "foobar" + when the URI is printed.
    • +
    + +
    + +
    + +

    4.0 Interning URIs

    + +

    This section describes how to intern URIs. Interning is not mandatory. URIs can be used +perfectly well without interning them.

    + +

    Interned URIs in Allegro are like symbols. That is, a string representing a URI, when +parsed and interned, will always yield an eq object. For example:

    + +
    +(eq (intern-uri "http://www.franz.com") 
    +    (intern-uri "http://www.franz.com")) 
    +
    + +

    is always true. (Two strings with identical contents may or may not be eq +in Common Lisp, note.)

    + +

    The functions associated with interning are: + +

      +
    • make-uri-space

      Arguments: &key + size

      +

      Make a new hash-table object to contain interned URIs.

      +
    • +
    • uri-space

      Arguments:

      +

      Return the object into which URIs are currently being interned.

      +
    • +
    • uri=

      Arguments: uri1 uri2

      +

      Returns true if uri1 and uri2 are equivalent.

      +
    • +
    • intern-uri

      Arguments: uri-name + &optional uri-space

      +

      Intern the uri object specified in the uri-space specified. Methods exist for strings + and uri objects.

      +
    • +
    • unintern-uri

      Arguments: uri + &optional uri-space

      +

      Unintern the uri object specified or all uri objects (in uri-space if specified) + if uri is t.

      +
    • +
    • do-all-uris

      Arguments: (var &optional + uri-space result) &body body

      +

      Bind var to all currently defined uris (in uri-space if specified) and + evaluate body.

      +
    • +
    + +
    + +
    + +

    5.0 Allegro CL implementation notes

    + +
      +
    1. The following are true:
      + (uri= (parse-uri "http://www.franz.com/")
      +     (parse-uri "http://www.franz.com"))
      + (eq (intern-uri "http://www.franz.com/")
      +    (intern-uri "http://www.franz.com"))
      +
    2. +
    3. The following is true:
      + (eq (intern-uri "http://www.franz.com:80/foo/bar.htm")
      +     (intern-uri "http://www.franz.com/foo/bar.htm"))
      + (I.e. specifying the default port is the same as specifying no port at all. This is + specific in RFC2396.)
    4. +
    5. The scheme and authority are case-insensitive. In Allegro CL, the + scheme is a keyword that appears in the normal case for the Lisp in which you are + executing.
    6. +
    7. #u"..." is shorthand for (parse-uri "...") + but if an existing #u dispatch macro definition exists, it will not be + overridden.
    8. +
    9. The interaction between setting the scheme, host, port, path, query, and fragment slots + of URI objects, in conjunction with interning URIs will have very bad and unpredictable + results.
    10. +
    11. The printable representation of URIs is cached, for efficiency. This caching is undone + when the above slots are changed. That is, when you create a URI the printed + representation is cached. When you change one of the above mentioned slots, the printed + representation is cleared and calculated when the URI is next printed. For example:
    12. +
    + +
    +user(10): (setq u #u"http://foo.bar.com/foo/bar") 
    +#<uri http://foo.bar.com/foo/bar> 
    +user(11): (setf (net.uri:uri-host u) "foo.com") 
    +"foo.com" 
    +user(12): u 
    +#<uri http://foo.com/foo/bar> 
    +user(13): 
    +
    + +

    This allows URIs behavior to follow the principle of least surprise.

    + +
    + +
    + +

    6.0 Examples

    + +
    +uri(10): (use-package :net.uri)
    +t
    +uri(11): (parse-uri "foo")
    +#<uri foo>
    +uri(12): #u"foo"
    +#<uri foo>
    +uri(13): (setq base (intern-uri "http://www.franz.com/foo/bar/"))
    +#<uri http://www.franz.com/foo/bar/>
    +uri(14): (merge-uris (parse-uri "foo.htm") base)
    +#<uri http://www.franz.com/foo/bar/foo.htm>
    +uri(15): (merge-uris (parse-uri "?foo") base)
    +#<uri http://www.franz.com/foo/bar/?foo>
    +uri(16): (setq base (intern-uri "http://www.franz.com/foo/bar/baz.htm"))
    +#<uri http://www.franz.com/foo/bar/baz.htm>
    +uri(17): (merge-uris (parse-uri "foo.htm") base)
    +#<uri http://www.franz.com/foo/bar/foo.htm>
    +uri(18): (merge-uris #u"?foo" base)
    +#<uri http://www.franz.com/foo/bar/?foo>
    +uri(19): (describe #u"http://www.franz.com")
    +#<uri http://www.franz.com> is an instance of #<standard-class net.uri:uri>:
    + The following slots have :instance allocation:
    +  scheme        :http
    +  host          "www.franz.com"
    +  port          nil
    +  path          nil
    +  query         nil
    +  fragment      nil
    +  plist         nil
    +  escaped       nil
    +  string        "http://www.franz.com"
    +  parsed-path   nil
    +  hashcode      nil
    +uri(20): (describe #u"http://www.franz.com/")
    +#<uri http://www.franz.com> is an instance of #<standard-class net.uri:uri>:
    + The following slots have :instance allocation:
    +  scheme        :http
    +  host          "www.franz.com"
    +  port          nil
    +  path          nil
    +  query         nil
    +  fragment      nil
    +  plist         nil
    +  escaped       nil
    +  string        "http://www.franz.com"
    +  parsed-path   nil
    +  hashcode      nil
    +uri(21): #u"foobar#baz%23xxx"
    +#<uri foobar#baz#xxx>
    +
    + +

    Copyright (c) 1998-2001, Franz Inc. Berkeley, CA., USA. All rights reserved. +Created 2001.8.16.

    + + Added: branches/grin-neu/thirdparty/trivial-gray-streams/COPYING =================================================================== --- branches/grin-neu/thirdparty/trivial-gray-streams/COPYING 2006-12-01 10:37:34 UTC (rev 2093) +++ branches/grin-neu/thirdparty/trivial-gray-streams/COPYING 2006-12-01 10:39:49 UTC (rev 2094) @@ -0,0 +1,21 @@ + Copyright (c) 2005 David Lichteblau + + Permission is hereby granted, free of charge, to any person + obtaining a copy of this software and associated documentation files + (the "Software"), to deal in the Software without restriction, + including without limitation the rights to use, copy, modify, merge, + publish, distribute, sublicense, and/or sell copies of the Software, + and to permit persons to whom the Software is furnished to do so, + subject to the following conditions: + + The above copyright notice and this permission notice shall be + included in all copies or substantial portions of the Software. + + THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, + EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF + MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND + NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS + BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN + ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN + CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE + SOFTWARE. Added: branches/grin-neu/thirdparty/trivial-gray-streams/CVS/Entries =================================================================== --- branches/grin-neu/thirdparty/trivial-gray-streams/CVS/Entries 2006-12-01 10:37:34 UTC (rev 2093) +++ branches/grin-neu/thirdparty/trivial-gray-streams/CVS/Entries 2006-12-01 10:39:49 UTC (rev 2094) @@ -0,0 +1,7 @@ +/COPYING/1.1/Sun Dec 4 23:41:05 2005// +/Makefile/1.1.1.1/Wed Nov 9 22:11:00 2005// +/README/1.3/Thu Sep 14 17:45:36 2006// +/mixin.lisp/1.5/Thu Sep 14 17:45:36 2006// +/package.lisp/1.4/Thu Sep 14 17:45:36 2006// +/trivial-gray-streams.asd/1.1.1.1/Wed Nov 9 22:11:00 2005// +D Added: branches/grin-neu/thirdparty/trivial-gray-streams/CVS/Repository =================================================================== --- branches/grin-neu/thirdparty/trivial-gray-streams/CVS/Repository 2006-12-01 10:37:34 UTC (rev 2093) +++ branches/grin-neu/thirdparty/trivial-gray-streams/CVS/Repository 2006-12-01 10:39:49 UTC (rev 2094) @@ -0,0 +1 @@ +trivial-gray-streams Added: branches/grin-neu/thirdparty/trivial-gray-streams/CVS/Root =================================================================== --- branches/grin-neu/thirdparty/trivial-gray-streams/CVS/Root 2006-12-01 10:37:34 UTC (rev 2093) +++ branches/grin-neu/thirdparty/trivial-gray-streams/CVS/Root 2006-12-01 10:39:49 UTC (rev 2094) @@ -0,0 +1 @@ +:pserver:anonymous at common-lisp.net:/project/cl-plus-ssl/cvsroot Added: branches/grin-neu/thirdparty/trivial-gray-streams/CVS/Template =================================================================== Added: branches/grin-neu/thirdparty/trivial-gray-streams/Makefile =================================================================== --- branches/grin-neu/thirdparty/trivial-gray-streams/Makefile 2006-12-01 10:37:34 UTC (rev 2093) +++ branches/grin-neu/thirdparty/trivial-gray-streams/Makefile 2006-12-01 10:39:49 UTC (rev 2094) @@ -0,0 +1,3 @@ +.PHONY: clean +clean: + rm -f *.fasl *.x86f *.fas *.ufsl *.lib *.pfsl Property changes on: branches/grin-neu/thirdparty/trivial-gray-streams/Makefile ___________________________________________________________________ Name: svn:eol-style + native Added: branches/grin-neu/thirdparty/trivial-gray-streams/README =================================================================== --- branches/grin-neu/thirdparty/trivial-gray-streams/README 2006-12-01 10:37:34 UTC (rev 2093) +++ branches/grin-neu/thirdparty/trivial-gray-streams/README 2006-12-01 10:39:49 UTC (rev 2094) @@ -0,0 +1,37 @@ +trivial-gray-streams +==================== + +This system provides an extremely thin compatibility layer for gray +streams. It is nearly *too* trivial for a complete package, except that +I have copy&pasted this code into enough projects now that I decided to +factor it out once again now, and then *never* have to touch it again. + + +How to use it +============= + +1. Use the package TRIVIAL-GRAY-STREAMS instead of whatever + implementation-specific package you would have to use otherwise to + get at gray stream symbols. +2. For STREAM-READ-SEQUENCE and STREAM-WRITE-SEQUENCE, notice that we + use two required arguments and allow additional keyword arguments. + So the lambda list when defining a method on either function should look + like this: + (stream sequence start end &key) +3. In order for (2) to work on all Lisps, make sure to subclass all your + stream classes from TRIVIAL-GRAY-STREAM-MIXIN if you intend to define + methods on those two generic functions. + + +Extensions +========== + +Generic function STREAM-READ-SEQUENCE (stream sequence start end &key) +Generic function STREAM-WRITE-SEQUENCE (stream sequence start end &key) + + See above. + +Generic function STREAM-FILE-POSITION (stream) => file position +Generic function (SETF STREAM-FILE-POSITION) (position-spec stream) => successp + + Will only be called by LispWorks and CLISP. Added: branches/grin-neu/thirdparty/trivial-gray-streams/mixin.lisp =================================================================== --- branches/grin-neu/thirdparty/trivial-gray-streams/mixin.lisp 2006-12-01 10:37:34 UTC (rev 2093) +++ branches/grin-neu/thirdparty/trivial-gray-streams/mixin.lisp 2006-12-01 10:39:49 UTC (rev 2094) @@ -0,0 +1,117 @@ +(in-package :trivial-gray-streams) + +(defclass trivial-gray-stream-mixin () ()) + +(defgeneric stream-read-sequence + (stream sequence start end &key &allow-other-keys)) +(defgeneric stream-write-sequence + (stream sequence start end &key &allow-other-keys)) + +(defgeneric stream-file-position (stream)) +(defgeneric (setf stream-file-position) (newval stream)) + +(defmethod stream-write-string + ((stream trivial-gray-stream-mixin) seq &optional start end) + (stream-write-sequence stream seq (or start 0) (or end (length seq)))) + +;; Implementations should provide this default method, I believe, but +;; at least sbcl and allegro don't. +(defmethod stream-terpri ((stream trivial-gray-stream-mixin)) + (write-char #\newline stream)) + +(defmethod stream-file-position ((stream trivial-gray-stream-mixin)) + nil) + +(defmethod (setf stream-file-position) + (newval (stream trivial-gray-stream-mixin)) + (declare (ignore newval)) + nil) + +#+allegro +(progn + (defmethod excl:stream-read-sequence + ((s trivial-gray-stream-mixin) seq &optional start end) + (stream-read-sequence s seq (or start 0) (or end (length seq)))) + (defmethod stream:stream-write-sequence + ((s trivial-gray-stream-mixin) seq &optional start end) + (stream-write-sequence s seq (or start 0) (or end (length seq))))) + +#+cmu +(progn + (defmethod ext:stream-read-sequence + ((s trivial-gray-stream-mixin) seq &optional start end) + (stream-read-sequence s seq (or start 0) (or end (length seq)))) + (defmethod ext:stream-write-sequence + ((s trivial-gray-stream-mixin) seq &optional start end) + (stream-write-sequence s seq (or start 0) (or end (length seq))))) + +#+lispworks +(progn + (defmethod stream:stream-read-sequence + ((s trivial-gray-stream-mixin) seq start end) + (stream-read-sequence s seq start end)) + (defmethod stream:stream-write-sequence + ((s trivial-gray-stream-mixin) seq start end) + (stream-write-sequence s seq start end)) + + (defmethod stream:stream-file-position ((stream trivial-gray-stream-mixin)) + (stream-file-position stream)) + (defmethod (setf stream:stream-file-position) + (newval (stream trivial-gray-stream-mixin)) + (setf (stream-file-position stream) newval))) + +#+openmcl +(progn + (defmethod ccl:stream-read-vector + ((s trivial-gray-stream-mixin) seq start end) + (stream-read-sequence s seq start end)) + (defmethod ccl:stream-write-vector + ((s trivial-gray-stream-mixin) seq start end) + (stream-write-sequence s seq start end))) + +#+clisp +(progn + (defmethod gray:stream-read-byte-sequence + ((s trivial-gray-stream-mixin) + seq + &optional start end no-hang interactive) + (when no-hang + (error "this stream does not support the NO-HANG argument")) + (when interactive + (error "this stream does not support the INTERACTIVE argument")) + (stream-read-sequence s seq start end)) + + (defmethod gray:stream-write-byte-sequence + ((s trivial-gray-stream-mixin) + seq + &optional start end no-hang interactive) + (when no-hang + (error "this stream does not support the NO-HANG argument")) + (when interactive + (error "this stream does not support the INTERACTIVE argument")) + (stream-write-sequence s seq start end)) + + (defmethod gray:stream-read-char-sequence + ((s trivial-gray-stream-mixin) seq &optional start end) + (stream-read-sequence s seq start end)) + + (defmethod gray:stream-write-char-sequence + ((s trivial-gray-stream-mixin) seq &optional start end) + (stream-write-sequence s seq start end)) + + (defmethod gray:stream-position ((stream trivial-gray-stream-mixin) position) + (if position + (setf (stream-file-position stream) position) + (stream-file-position stream)))) + +#+sbcl +(progn + (defmethod sb-gray:stream-read-sequence + ((s trivial-gray-stream-mixin) seq &optional start end) + (stream-read-sequence s seq (or start 0) (or end (length seq)))) + (defmethod sb-gray:stream-write-sequence + ((s trivial-gray-stream-mixin) seq &optional start end) + (stream-write-sequence s seq (or start 0) (or end (length seq)))) + ;; SBCL extension: + (defmethod sb-gray:stream-line-length ((stream trivial-gray-stream-mixin)) + 80)) Added: branches/grin-neu/thirdparty/trivial-gray-streams/package.lisp =================================================================== --- branches/grin-neu/thirdparty/trivial-gray-streams/package.lisp 2006-12-01 10:37:34 UTC (rev 2093) +++ branches/grin-neu/thirdparty/trivial-gray-streams/package.lisp 2006-12-01 10:39:49 UTC (rev 2094) @@ -0,0 +1,44 @@ +(in-package :trivial-gray-streams-system) + +#+cmu +(eval-when (:compile-toplevel :load-toplevel :execute) + (require :gray-streams)) + +#+allegro +(eval-when (:compile-toplevel :load-toplevel :execute) + (unless (fboundp 'stream:stream-write-string) + (require "streamc.fasl"))) + +(macrolet + ((frob () + (let + ((common-symbols + '(#:fundamental-stream #:fundamental-input-stream + #:fundamental-output-stream #:fundamental-character-stream + #:fundamental-binary-stream #:fundamental-character-input-stream + #:fundamental-character-output-stream + #:fundamental-binary-input-stream + #:fundamental-binary-output-stream #:stream-read-char + #:stream-unread-char #:stream-read-char-no-hang + #:stream-peek-char #:stream-listen #:stream-read-line + #:stream-clear-input #:stream-write-char #:stream-line-column + #:stream-start-line-p #:stream-write-string #:stream-terpri + #:stream-fresh-line #:stream-finish-output #:stream-force-output + #:stream-clear-output #:stream-advance-to-column + #:stream-read-byte #:stream-write-byte))) + `(defpackage :trivial-gray-streams + (:use :cl) + (:import-from #+sbcl :sb-gray + #+allegro :excl + #+cmu :ext + #+clisp :gray + #+openmcl :ccl + #+lispworks :stream + #-(or sbcl allegro cmu clisp openmcl lispworks) ... + , at common-symbols) + (:export #:trivial-gray-stream-mixin + #:stream-read-sequence + #:stream-write-sequence + #:stream-file-position + , at common-symbols))))) + (frob)) Added: branches/grin-neu/thirdparty/trivial-gray-streams/trivial-gray-streams.asd =================================================================== --- branches/grin-neu/thirdparty/trivial-gray-streams/trivial-gray-streams.asd 2006-12-01 10:37:34 UTC (rev 2093) +++ branches/grin-neu/thirdparty/trivial-gray-streams/trivial-gray-streams.asd 2006-12-01 10:39:49 UTC (rev 2094) @@ -0,0 +1,9 @@ +;;; -*- mode: lisp -*- + +(defpackage :trivial-gray-streams-system +(:use :cl :asdf)) +(in-package :trivial-gray-streams-system) + +(defsystem :trivial-gray-streams + :serial t + :components ((:file "package") (:file "mixin"))) Modified: branches/grin-neu/thirdparty/uffi/src/corman/getenv-ccl.lisp =================================================================== --- branches/grin-neu/thirdparty/uffi/src/corman/getenv-ccl.lisp 2006-12-01 10:37:34 UTC (rev 2093) +++ branches/grin-neu/thirdparty/uffi/src/corman/getenv-ccl.lisp 2006-12-01 10:39:49 UTC (rev 2094) @@ -7,13 +7,8 @@ ;;;; Programmer: "Joe Marshall" ;;;; Date Started: Feb 2002 ;;;; -`;;;; $Id: getenv-ccl.lisp,v 1.1 2004/06/23 08:27:10 hans Exp $ +;;;; $Id$ ;;;; -;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg -;;;; -;;;; UFFI users are granted the rights to distribute and use this software -;;;; as governed by the terms of the Lisp Lesser GNU Public License -;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. ;;;; ************************************************************************* (in-package :cl-user) Modified: branches/grin-neu/thirdparty/uffi/tests/package.lisp =================================================================== --- branches/grin-neu/thirdparty/uffi/tests/package.lisp 2006-12-01 10:37:34 UTC (rev 2093) +++ branches/grin-neu/thirdparty/uffi/tests/package.lisp 2006-12-01 10:39:49 UTC (rev 2094) @@ -7,7 +7,9 @@ ;;;; Author: Kevin M. Rosenberg ;;;; Date Started: Apr 2003 ;;;; -;;;; $Id: package.lisp,v 1.1 2004/06/23 08:27:10 hans Exp $ +;;;; This file, part of UFFI, is Copyright (c) 2003-2005 by Kevin M. Rosenberg +;;;; +;;;; $Id$ ;;;; ************************************************************************* (defpackage #:uffi-tests Modified: branches/grin-neu/tools/make-core.lisp =================================================================== --- branches/grin-neu/tools/make-core.lisp 2006-12-01 10:37:34 UTC (rev 2093) +++ branches/grin-neu/tools/make-core.lisp 2006-12-01 10:39:49 UTC (rev 2094) @@ -1,6 +1,8 @@ (in-package :cl-user) +#+cmu (setf ext:*gc-verbose* nil) +#+cmu (setf ext:*bytes-consed-between-gcs* (* 12000000 3)) ;3x default (setf *compile-print* nil) From bknr at bknr.net Sun Dec 3 08:14:14 2006 From: bknr at bknr.net (bknr at bknr.net) Date: Sun, 3 Dec 2006 03:14:14 -0500 (EST) Subject: [bknr-cvs] r2095 - branches/grin-neu/thirdparty Message-ID: <20061203081414.8D66F68001@common-lisp.net> Author: hhubner Date: 2006-12-03 03:14:14 -0500 (Sun, 03 Dec 2006) New Revision: 2095 Removed: branches/grin-neu/thirdparty/ironclad/ Log: no longer in use From bknr at bknr.net Sun Dec 3 08:33:51 2006 From: bknr at bknr.net (bknr at bknr.net) Date: Sun, 3 Dec 2006 03:33:51 -0500 (EST) Subject: [bknr-cvs] r2096 - in branches/grin-neu/thirdparty: cl-gd portableaserve/acl-compat uffi/src Message-ID: <20061203083351.E07696D072@common-lisp.net> Author: hhubner Date: 2006-12-03 03:33:51 -0500 (Sun, 03 Dec 2006) New Revision: 2096 Modified: branches/grin-neu/thirdparty/cl-gd/packages.lisp branches/grin-neu/thirdparty/portableaserve/acl-compat/acl-excl-common.lisp branches/grin-neu/thirdparty/uffi/src/aggregates.lisp branches/grin-neu/thirdparty/uffi/src/strings.lisp Log: Further SBCL tweaks Modified: branches/grin-neu/thirdparty/cl-gd/packages.lisp =================================================================== --- branches/grin-neu/thirdparty/cl-gd/packages.lisp 2006-12-03 08:14:14 UTC (rev 2095) +++ branches/grin-neu/thirdparty/cl-gd/packages.lisp 2006-12-03 08:33:51 UTC (rev 2096) @@ -1,7 +1,9 @@ (in-package #:cl-user) (defpackage #:cl-gd - (:use #:cl #:uffi) + (:use #:cl + #-(or :clisp :openmcl) #:uffi + #+(or :clisp :openmcl) #:cffi-uffi-compat) (:export #:*default-image* #:*default-color* #:*default-font* Modified: branches/grin-neu/thirdparty/portableaserve/acl-compat/acl-excl-common.lisp =================================================================== --- branches/grin-neu/thirdparty/portableaserve/acl-compat/acl-excl-common.lisp 2006-12-03 08:14:14 UTC (rev 2095) +++ branches/grin-neu/thirdparty/portableaserve/acl-compat/acl-excl-common.lisp 2006-12-03 08:33:51 UTC (rev 2096) @@ -189,6 +189,7 @@ (array (signed-byte 8) 1))) (write-sequence sequence stream :start start :end end)) +#-sbcl (defun string-to-octets (string &key (null-terminate t) (start 0) end mb-vector make-mb-vector? (external-format :default)) Modified: branches/grin-neu/thirdparty/uffi/src/aggregates.lisp =================================================================== --- branches/grin-neu/thirdparty/uffi/src/aggregates.lisp 2006-12-03 08:14:14 UTC (rev 2095) +++ branches/grin-neu/thirdparty/uffi/src/aggregates.lisp 2006-12-03 08:33:51 UTC (rev 2096) @@ -224,28 +224,13 @@ (setf (aref a i) (uffi:deref-array s '(:array :unsigned-byte) i))))) #+sbcl -(eval-when (:compile-toplevel :load-toplevel :execute) - (sb-ext:without-package-locks - (defvar *system-copy-fn* (if (fboundp (intern "COPY-FROM-SYSTEM-AREA" "SB-KERNEL")) - (intern "COPY-FROM-SYSTEM-AREA" "SB-KERNEL") - (intern "COPY-UB8-FROM-SYSTEM-AREA" "SB-KERNEL"))) - (defconstant +system-copy-offset+ (if (fboundp (intern "COPY-FROM-SYSTEM-AREA" "SB-KERNEL")) - (* sb-vm:vector-data-offset sb-vm:n-word-bits) - 0)) - (defconstant +system-copy-multiplier+ (if (fboundp (intern "COPY-FROM-SYSTEM-AREA" "SB-KERNEL")) - sb-vm:n-byte-bits - 1)))) - - -#+sbcl (defun convert-from-foreign-usb8 (s len) (let ((sap (sb-alien:alien-sap s))) (declare (type sb-sys:system-area-pointer sap)) (locally (declare (optimize (speed 3) (safety 0))) (let ((result (make-array len :element-type '(unsigned-byte 8)))) - (funcall *system-copy-fn* sap 0 result +system-copy-offset+ - (* len +system-copy-multiplier+)) + (sb-kernel:copy-ub8-from-system-area sap 0 result 0 len) result)))) #+cmu Modified: branches/grin-neu/thirdparty/uffi/src/strings.lisp =================================================================== --- branches/grin-neu/thirdparty/uffi/src/strings.lisp 2006-12-03 08:14:14 UTC (rev 2095) +++ branches/grin-neu/thirdparty/uffi/src/strings.lisp 2006-12-03 08:33:51 UTC (rev 2096) @@ -207,6 +207,8 @@ :null-terminated-p ,null-terminated-p)))) #+sbcl + (declare (ignore locale)) + #+sbcl (let ((stored-obj (gensym))) `(let ((,stored-obj ,obj)) (if (null-pointer-p ,stored-obj) From bknr at bknr.net Sun Dec 3 10:46:56 2006 From: bknr at bknr.net (bknr at bknr.net) Date: Sun, 3 Dec 2006 05:46:56 -0500 (EST) Subject: [bknr-cvs] r2097 - in trunk/bknr/src: data utils web Message-ID: <20061203104656.0E6B1702F8@common-lisp.net> Author: hhubner Date: 2006-12-03 05:46:55 -0500 (Sun, 03 Dec 2006) New Revision: 2097 Modified: trunk/bknr/src/data/txn.lisp trunk/bknr/src/utils/acl-mp-compat.lisp trunk/bknr/src/utils/utils.lisp trunk/bknr/src/web/authorizer.lisp trunk/bknr/src/web/handlers.lisp trunk/bknr/src/web/sessions.lisp trunk/bknr/src/web/web-utils.lisp Log: Changes to make file uploads from forms work again. Small SBCL compatibility changes. Further change to properly generate UTF-8 on cmucl. This is really becoming too sick to be bearable. Modified: trunk/bknr/src/data/txn.lisp =================================================================== --- trunk/bknr/src/data/txn.lisp 2006-12-03 08:33:51 UTC (rev 2096) +++ trunk/bknr/src/data/txn.lisp 2006-12-03 10:46:55 UTC (rev 2097) @@ -42,13 +42,13 @@ (defclass mp-store (store) () (:default-initargs :guard (let ((lock (make-process-lock))) - #'(lambda (thunk) - (with-process-lock (lock) - (funcall thunk)))) + (lambda (thunk) + (mp-with-lock-held (lock) + (funcall thunk)))) :log-guard (let ((lock (make-process-lock))) - #'(lambda (thunk) - (with-process-lock (lock) - (funcall thunk))))) + (lambda (thunk) + (mp-with-lock-held (lock) + (funcall thunk))))) (:documentation "Store in which every transaction and operation is protected by a giant lock.")) Modified: trunk/bknr/src/utils/acl-mp-compat.lisp =================================================================== --- trunk/bknr/src/utils/acl-mp-compat.lisp 2006-12-03 08:33:51 UTC (rev 2096) +++ trunk/bknr/src/utils/acl-mp-compat.lisp 2006-12-03 10:46:55 UTC (rev 2097) @@ -1,6 +1,6 @@ (in-package :bknr.utils) -(defun mp-make-lock (name) +(defun mp-make-lock (&optional (name "Anonymous")) #+allegro (mp:make-process-lock :name name) #+sbcl Modified: trunk/bknr/src/utils/utils.lisp =================================================================== --- trunk/bknr/src/utils/utils.lisp 2006-12-03 08:33:51 UTC (rev 2096) +++ trunk/bknr/src/utils/utils.lisp 2006-12-03 10:46:55 UTC (rev 2097) @@ -364,7 +364,7 @@ (defun md5-string (input-string) (apply #'concatenate 'string (mapcar #'(lambda (c) (format nil "~2,'0X" c)) - (coerce (md5sum-sequence input-string) 'list)))) + (coerce (#+cmu md5sum-sequence #+sbcl md5sum-string input-string) 'list)))) #+(or) (defun md5-string (string) Modified: trunk/bknr/src/web/authorizer.lisp =================================================================== --- trunk/bknr/src/web/authorizer.lisp 2006-12-03 08:33:51 UTC (rev 2096) +++ trunk/bknr/src/web/authorizer.lisp 2006-12-03 10:46:55 UTC (rev 2097) @@ -71,7 +71,6 @@ (defmethod authorize ((authorizer bknr-authorizer) (req http-request) ent) - ;; Catch any errors that occur during request body processing (handler-case ;; first check session cookie or bknr-sessionid parameter. the Modified: trunk/bknr/src/web/handlers.lisp =================================================================== --- trunk/bknr/src/web/handlers.lisp 2006-12-03 08:33:51 UTC (rev 2096) +++ trunk/bknr/src/web/handlers.lisp 2006-12-03 10:46:55 UTC (rev 2097) @@ -465,8 +465,8 @@ (defgeneric object-list-handler-show-object-xml (handler object req)) (defmethod object-list-handler-show-object-xml ((handler xml-object-list-handler) object req) - (write-to-xml object - :string-rod-fn #'cxml::utf8-string-to-rod)) + (set-string-rod-fn #'cxml::utf8-string-to-rod) + (write-to-xml object)) (defmethod handle-object ((handler xml-object-list-handler) object req) (let ((element-name (xml-object-list-handler-toplevel-element-name handler))) Modified: trunk/bknr/src/web/sessions.lisp =================================================================== --- trunk/bknr/src/web/sessions.lisp 2006-12-03 08:33:51 UTC (rev 2096) +++ trunk/bknr/src/web/sessions.lisp 2006-12-03 10:46:55 UTC (rev 2097) @@ -166,6 +166,13 @@ (defmethod update-instance-for-different-class :before ((old http-request) (new bknr-request) &key session) + ;; Clear parsed parameters in request. During + ;; authorization, parameters are not completely parsed in + ;; order to save time. In particular, uploaded files are + ;; only parsed after authorization. This is accomplished by + ;; clearing the cache for the parsed parameters here. + (setf (getf (request-reply-plist old) 'bknr-parsed-parameters) nil) + (setf (getf (request-reply-plist old) 'bknr-parsed-body-parameters) nil) (setf (slot-value new 'session) session)) (defmethod bknr-request-user ((req bknr-request)) Modified: trunk/bknr/src/web/web-utils.lisp =================================================================== --- trunk/bknr/src/web/web-utils.lisp 2006-12-03 08:33:51 UTC (rev 2096) +++ trunk/bknr/src/web/web-utils.lisp 2006-12-03 10:46:55 UTC (rev 2097) @@ -117,8 +117,9 @@ "utf-8"))) (get-parameters-from-body request) (setf (getf (request-reply-plist request) 'bknr-parsed-parameters) - (mapcar (lambda (param) (cons (car param) - (iconv:iconv request-charset "utf-8" (cdr param)))) + (mapcar (lambda (param) + (cons (car param) + (iconv:iconv request-charset "utf-8" (cdr param)))) (remove "" (append (form-urlencoded-to-query (uri-query (request-uri request))) (getf (request-reply-plist request) 'bknr-parsed-body-parameters)) :key #'cdr :test #'string-equal))))) From bknr at bknr.net Sun Dec 3 10:47:40 2006 From: bknr at bknr.net (bknr at bknr.net) Date: Sun, 3 Dec 2006 05:47:40 -0500 (EST) Subject: [bknr-cvs] r2098 - in trunk/projects/bos: m2 worldpay-test Message-ID: <20061203104740.5A85172084@common-lisp.net> Author: hhubner Date: 2006-12-03 05:47:39 -0500 (Sun, 03 Dec 2006) New Revision: 2098 Modified: trunk/projects/bos/m2/bitmap.lisp trunk/projects/bos/m2/m2.lisp trunk/projects/bos/m2/packages.lisp trunk/projects/bos/worldpay-test/boi-handlers.lisp trunk/projects/bos/worldpay-test/map-handlers.lisp trunk/projects/bos/worldpay-test/packages.lisp trunk/projects/bos/worldpay-test/reports-xml-handler.lisp trunk/projects/bos/worldpay-test/tags.lisp Log: SBCL compatibility changes. Modified: trunk/projects/bos/m2/bitmap.lisp =================================================================== --- trunk/projects/bos/m2/bitmap.lisp 2006-12-03 10:46:55 UTC (rev 2097) +++ trunk/projects/bos/m2/bitmap.lisp 2006-12-03 10:47:39 UTC (rev 2098) @@ -150,7 +150,7 @@ :first-name "Otto" :last-name "Mustermann" :email-address "otto.mustermann at t-online.de")))) - (flet ((step () + (flet ((make-one-contract () (let* ((limit 0.0001) (n (max 1 (round (/ 0.5 (+ (random (- 1.0 limit)) limit)))))) @@ -159,9 +159,9 @@ (make-contract u n)))) (if limit (dotimes (x limit) - (step)) + (make-one-contract)) (loop - (step))))))) + (make-one-contract))))))) #+(or) (progn Modified: trunk/projects/bos/m2/m2.lisp =================================================================== --- trunk/projects/bos/m2/m2.lisp 2006-12-03 10:46:55 UTC (rev 2097) +++ trunk/projects/bos/m2/m2.lisp 2006-12-03 10:47:39 UTC (rev 2098) @@ -388,7 +388,9 @@ (excl:delete-directory-and-files pathname) #+cmu (unix:unix-rmdir (ext:unix-namestring pathname)) - #-(or allegro cmu) + #+sbcl + (sb-posix:rmdir (namestring pathname)) + #-(or allegro cmu sbcl) ...)) (defun reinit (&key delete directory website-url) Modified: trunk/projects/bos/m2/packages.lisp =================================================================== --- trunk/projects/bos/m2/packages.lisp 2006-12-03 10:46:55 UTC (rev 2097) +++ trunk/projects/bos/m2/packages.lisp 2006-12-03 10:47:39 UTC (rev 2098) @@ -189,6 +189,13 @@ #:*cert-download-directory*)) (defpackage :bos.m2.cert-generator - (:use :cl :extensions :bos.m2.config :bknr.utils :cl-ppcre :cl-interpol :cl-gd) + (:use :cl + #+cmu :extensions + #+sbcl :sb-ext + :bos.m2.config + :bknr.utils + :cl-ppcre + :cl-interpol + :cl-gd) (:shadowing-import-from :cl-interpol #:quote-meta-chars) (:export #:cert-daemon)) Modified: trunk/projects/bos/worldpay-test/boi-handlers.lisp =================================================================== --- trunk/projects/bos/worldpay-test/boi-handlers.lisp 2006-12-03 10:46:55 UTC (rev 2097) +++ trunk/projects/bos/worldpay-test/boi-handlers.lisp 2006-12-03 10:47:39 UTC (rev 2098) @@ -3,6 +3,8 @@ (enable-interpol-syntax) +(defvar *xml-sink*) + (defmacro with-xml-response (req &body body) `(with-http-response (,req *ent* :content-type "text/xml") (with-query-params (,req download) @@ -16,6 +18,7 @@ , at body)))))) (defmacro with-xml-error-handler (req &body body) + (declare (ignore req)) `(handler-case (progn , at body) (error (e) Modified: trunk/projects/bos/worldpay-test/map-handlers.lisp =================================================================== --- trunk/projects/bos/worldpay-test/map-handlers.lisp 2006-12-03 10:46:55 UTC (rev 2097) +++ trunk/projects/bos/worldpay-test/map-handlers.lisp 2006-12-03 10:47:39 UTC (rev 2098) @@ -54,6 +54,7 @@ (defmethod object-handler-get-object ((handler image-tile-handler) req) (destructuring-bind (x y &rest operations) (decoded-handler-path handler req) + (declare (ignore operations)) (setf x (parse-integer x)) (setf y (parse-integer y)) (ensure-map-tile x y))) Modified: trunk/projects/bos/worldpay-test/packages.lisp =================================================================== --- trunk/projects/bos/worldpay-test/packages.lisp 2006-12-03 10:46:55 UTC (rev 2097) +++ trunk/projects/bos/worldpay-test/packages.lisp 2006-12-03 10:47:39 UTC (rev 2098) @@ -3,7 +3,8 @@ (defpackage :worldpay-test (:use :cl :date-calc - :extensions + #+cmu :extensions + #+sbcl :sb-ext :cl-user :cl-interpol :cl-ppcre @@ -14,7 +15,6 @@ :puri #+(or) :mime :acl-compat.socket - :acl-compat.mp :bknr.web :bknr.datastore :bknr.indices Modified: trunk/projects/bos/worldpay-test/reports-xml-handler.lisp =================================================================== --- trunk/projects/bos/worldpay-test/reports-xml-handler.lisp 2006-12-03 10:46:55 UTC (rev 2097) +++ trunk/projects/bos/worldpay-test/reports-xml-handler.lisp 2006-12-03 10:47:39 UTC (rev 2098) @@ -16,6 +16,7 @@ (defun contract-year (contract) (multiple-value-bind (second minute hour date month year day-of-week is-dst tz) (decode-universal-time (contract-date contract)) + (declare (ignore second minute hour date month day-of-week is-dst tz)) year)) (defmethod handle ((handler reports-xml-handler) req) @@ -48,6 +49,7 @@ (defun week-of-contract (contract) "Return Week key (YYYY-WW) for given contract." (multiple-value-bind (second minute hour date month year day-of-week is-dst tz) (decode-universal-time (contract-date contract)) + (declare (ignore second minute hour day-of-week is-dst tz)) (multiple-value-bind (week-no week-year) (week-of-year year month date) (when (and (> week-no 50) @@ -61,6 +63,7 @@ (defun week-first-yday (contract) "Return the day-of year of the first day of the contract's date" (multiple-value-bind (second minute hour date month year day-of-week is-dst tz) (decode-universal-time (contract-date contract)) + (declare (ignore second minute hour day-of-week is-dst tz)) (max 0 (- (day-of-year year month date) (day-of-week year month date))))) (defreport contracts-by-week () Modified: trunk/projects/bos/worldpay-test/tags.lisp =================================================================== --- trunk/projects/bos/worldpay-test/tags.lisp 2006-12-03 10:46:55 UTC (rev 2097) +++ trunk/projects/bos/worldpay-test/tags.lisp 2006-12-03 10:47:39 UTC (rev 2098) @@ -6,7 +6,7 @@ ;; das ist fuer WPDISPLAY (let ((s (cxml::chained-handler *html-sink*))) (cxml::maybe-close-tag s) - (map nil (lambda (c) (cxml::write-rune (char-code c) s)) str))) + (map nil (lambda (c) (cxml::write-rune #+sbcl c #+cmu (char-code c) s)) str))) (defun language-options-1 (current-language) (loop for (language-symbol language-name) in (website-languages) From bknr at bknr.net Sun Dec 3 10:48:08 2006 From: bknr at bknr.net (bknr at bknr.net) Date: Sun, 3 Dec 2006 05:48:08 -0500 (EST) Subject: [bknr-cvs] r2099 - trunk/site Message-ID: <20061203104808.28C5751006@common-lisp.net> Author: hhubner Date: 2006-12-03 05:48:08 -0500 (Sun, 03 Dec 2006) New Revision: 2099 Modified: trunk/site/svn-config Log: ignore .fasl files for SBCL Modified: trunk/site/svn-config =================================================================== --- trunk/site/svn-config 2006-12-03 10:47:39 UTC (rev 2098) +++ trunk/site/svn-config 2006-12-03 10:48:08 UTC (rev 2099) @@ -61,7 +61,7 @@ [miscellany] ### Set global-ignores to a set of whitespace-delimited globs ### which Subversion will ignore in its 'status' output. -global-ignores = *.o *.lo *.la #*# .*.rej *.rej .*~ *~ .#* .DS_Store *.x86f datastore *.core datastore +global-ignores = *.o *.lo *.la #*# .*.rej *.rej .*~ *~ .#* .DS_Store *.x86f datastore *.core datastore *.fasl ### Set log-encoding to the default encoding for log messages log-encoding = latin1 ### Set use-commit-times to make checkout/update/switch/revert From bknr at bknr.net Sun Dec 3 10:48:27 2006 From: bknr at bknr.net (bknr at bknr.net) Date: Sun, 3 Dec 2006 05:48:27 -0500 (EST) Subject: [bknr-cvs] r2100 - in trunk/modules: mail track Message-ID: <20061203104827.02C8030AF@common-lisp.net> Author: hhubner Date: 2006-12-03 05:48:27 -0500 (Sun, 03 Dec 2006) New Revision: 2100 Modified: trunk/modules/mail/package.lisp trunk/modules/track/media.lisp trunk/modules/track/track.lisp Log: SBCL compatibility changes. Modified: trunk/modules/mail/package.lisp =================================================================== --- trunk/modules/mail/package.lisp 2006-12-03 10:48:08 UTC (rev 2099) +++ trunk/modules/mail/package.lisp 2006-12-03 10:48:27 UTC (rev 2100) @@ -40,8 +40,8 @@ #:mailinglist-send-mail)) (defpackage :bknr.mail.imap - (:use :lisp - :ext) + (:use :common-lisp + #+cmu :ext #+sbcl :sb-ext) (:export #:address-name #:address-additional Modified: trunk/modules/track/media.lisp =================================================================== --- trunk/modules/track/media.lisp 2006-12-03 10:48:08 UTC (rev 2099) +++ trunk/modules/track/media.lisp 2006-12-03 10:48:27 UTC (rev 2100) @@ -11,7 +11,7 @@ :length 0 :remain 0)) (queue :accessor player-queue :initform nil) - (lock :accessor player-lock :initform (mp:make-lock)))) + (lock :accessor player-lock :initform (mp-make-lock)))) (defgeneric player-play (player mp3)) (defgeneric player-stop (player)) @@ -24,12 +24,12 @@ (defmethod queue-command ((player player) command) (with-slots (queue lock) player - (mp:with-lock-held (lock) + (mp-with-lock-held (lock) (setf queue (append queue (list command)))))) (defmethod dequeue-command ((player player)) (with-slots (queue lock) player - (mp:with-lock-held (lock) + (mp-with-lock-held (lock) (pop queue)))) (defmethod player-play ((player player) mp3) @@ -49,28 +49,28 @@ (process :accessor mpg123-player-process :initform nil))) (defmethod start-mpg123 ((player mpg123-player)) - (let ((proc (ext:run-program "mpg123" '("-R") - :wait nil - :input :stream - :output :stream - :error :output - :status-hook #'(lambda (proc) - (declare (ignore proc)) - (mpg123-status-changed player))))) + (let ((proc (run-program "mpg123" '("-R") + :wait nil + :input :stream + :output :stream + :error :output + :status-hook #'(lambda (proc) + (declare (ignore proc)) + (mpg123-status-changed player))))) (when proc (with-slots (stream process state) player - (setf stream (make-two-way-stream (ext:process-output proc) - (ext:process-input proc)) + (setf stream (make-two-way-stream (process-output proc) + (process-input proc)) process proc))))) (defmethod mpg123-status-changed ((player mpg123-player)) (format t "status changed~%") (let ((proc (mpg123-player-process player))) - (case (ext:process-status proc) + (case (process-status proc) (:running) (:stopped (format t "mpg123 stopped~%")) (:signaled (format t "mpg123 stopped~%")) - (t (format t "mpg123 has status: ~a~%" (ext:process-status proc)))))) + (t (format t "mpg123 has status: ~a~%" (process-status proc)))))) (defmethod send-command ((player mpg123-player) command) (with-slots (process stream) player @@ -87,7 +87,7 @@ (defmethod actor-stop :before ((player mpg123-player)) (when (mpg123-player-process player) - (ext:process-kill (mpg123-player-process player) 9))) + (process-kill (mpg123-player-process player) 9))) (defmethod mpg123-player-parse-status ((player mpg123-player) msg) #+nil(format t "msg: ~a~%" msg) Modified: trunk/modules/track/track.lisp =================================================================== --- trunk/modules/track/track.lisp 2006-12-03 10:48:08 UTC (rev 2099) +++ trunk/modules/track/track.lisp 2006-12-03 10:48:27 UTC (rev 2100) @@ -103,7 +103,7 @@ ; (delete-file file) (when (directory-empty-p file-directory) #-allegro - (unix:unix-rmdir (namestring file-directory)) + (#+cmu unix:unix-rmdir #+sbcl sb-posix:rmdir (namestring file-directory)) #+allegro (delete-directory file-directory))) (cons file mp3)) From bknr at bknr.net Sun Dec 3 10:49:30 2006 From: bknr at bknr.net (bknr at bknr.net) Date: Sun, 3 Dec 2006 05:49:30 -0500 (EST) Subject: [bknr-cvs] r2101 - trunk/bknr/src/web Message-ID: <20061203104930.515A81703B@common-lisp.net> Author: hhubner Date: 2006-12-03 05:49:30 -0500 (Sun, 03 Dec 2006) New Revision: 2101 Modified: trunk/bknr/src/web/sessions.lisp Log: Slightly clearify comment Modified: trunk/bknr/src/web/sessions.lisp =================================================================== --- trunk/bknr/src/web/sessions.lisp 2006-12-03 10:48:27 UTC (rev 2100) +++ trunk/bknr/src/web/sessions.lisp 2006-12-03 10:49:30 UTC (rev 2101) @@ -166,11 +166,11 @@ (defmethod update-instance-for-different-class :before ((old http-request) (new bknr-request) &key session) - ;; Clear parsed parameters in request. During - ;; authorization, parameters are not completely parsed in - ;; order to save time. In particular, uploaded files are - ;; only parsed after authorization. This is accomplished by - ;; clearing the cache for the parsed parameters here. + ;; Clear parsed parameters in request. During authorization, + ;; parameters are not completely parsed in order to save time. In + ;; particular, uploaded files are only parsed after authorization. + ;; This is accomplished by clearing the cache for the parsed + ;; parameters when the session has been determined. (setf (getf (request-reply-plist old) 'bknr-parsed-parameters) nil) (setf (getf (request-reply-plist old) 'bknr-parsed-body-parameters) nil) (setf (slot-value new 'session) session)) From bknr at bknr.net Sun Dec 3 12:16:10 2006 From: bknr at bknr.net (bknr at bknr.net) Date: Sun, 3 Dec 2006 07:16:10 -0500 (EST) Subject: [bknr-cvs] r2102 - trunk/projects/bos/payment-website/templates/da Message-ID: <20061203121610.665CD58204@common-lisp.net> Author: hhubner Date: 2006-12-03 07:16:09 -0500 (Sun, 03 Dec 2006) New Revision: 2102 Modified: trunk/projects/bos/payment-website/templates/da/bestellung.xml trunk/projects/bos/payment-website/templates/da/profil_setup.xml trunk/projects/bos/payment-website/templates/da/quittung.xml trunk/projects/bos/payment-website/templates/da/ueberweisung.xml Log: Current danish language version. Modified: trunk/projects/bos/payment-website/templates/da/bestellung.xml =================================================================== --- trunk/projects/bos/payment-website/templates/da/bestellung.xml 2006-12-03 10:49:30 UTC (rev 2101) +++ trunk/projects/bos/payment-website/templates/da/bestellung.xml 2006-12-03 12:16:09 UTC (rev 2102) @@ -159,8 +159,10 @@
    Modified: trunk/projects/bos/payment-website/templates/da/profil_setup.xml =================================================================== --- trunk/projects/bos/payment-website/templates/da/profil_setup.xml 2006-12-03 10:49:30 UTC (rev 2101) +++ trunk/projects/bos/payment-website/templates/da/profil_setup.xml 2006-12-03 12:16:09 UTC (rev 2102) @@ -139,7 +139,7 @@
    - - + + + +
    - +
    Modified: trunk/projects/bos/payment-website/templates/da/quittung.xml =================================================================== --- trunk/projects/bos/payment-website/templates/da/quittung.xml 2006-12-03 10:49:30 UTC (rev 2101) +++ trunk/projects/bos/payment-website/templates/da/quittung.xml 2006-12-03 12:16:09 UTC (rev 2102) @@ -123,7 +123,7 @@ - + Modified: trunk/projects/bos/payment-website/templates/da/ueberweisung.xml =================================================================== --- trunk/projects/bos/payment-website/templates/da/ueberweisung.xml 2006-12-03 10:49:30 UTC (rev 2101) +++ trunk/projects/bos/payment-website/templates/da/ueberweisung.xml 2006-12-03 12:16:09 UTC (rev 2102) @@ -2,7 +2,7 @@ - + @@ -70,22 +70,22 @@ - + - + - + - +
    Ich m?chte meine Spende ?berweisen.Jeg vil overf?re mit bidrag til BOS Danmark via min bank!
    -Ich habe mich dazu entschieden einen Betrag von $(amount) Euro auf das Spendenkonto "Samboja Lestari" von BOS Deutschland e.V. zu ?berweisen. +Jeg har besluttet mig for at overf?re et bidrag p? $(amount) kroner til Samboja Lestari via BOS Danmark. - - - + + +
    Kontonummer:32 10 100
    Bank:Bank f?r Sozialwirtschaft
    BLZ:100 205 00
    Kontonummer:0001718891
    Bank:Merkur Bank
    Reg.Nr.: 8401
    - Bitte unbedingt den Verwendungszweck "SL ID $(contract-id)" auf dem ?berweisungsformular angeben! + Vigtigt! Du skal anf?re "SL ID $(contract-id)" p? bankoverf?rslen, s? vi kan genkende din betaling.

    - Meine ?berweisung muss ich bei meiner Bank eigenst?ndig veranlassen! + Meine Husk, at du selv st?r for overf?rslen via din bank til BOS Danmarks konto.
    Vorname:Fornavn:
    Name:Efternavn:
    Stra?e/Nr.:Gade/Nr.:
    PLZ/OrtKommune: @@ -107,7 +107,7 @@
    - +
    @@ -116,31 +116,28 @@
    - [Pers?nliche Daten] + [Personlige oplysninger]
    -Wir reservieren gerne die von Ihnen gew?nschten m?. F?r die Zusendung -der entsprechenden Informationen (Regenwaldurkunde, Sponsorenprofil, -Geokoordinaten, Spendenbescheinigung) ben?tigen wir unbedingt die -Angabe Ihrer Daten. Nach erfolgter ?berweisung erhalten Sie diese -Informationen schriftlich oder per E-Mail von uns. +Vi reserverer gerne det ?nskede antal m??. +Vi har brug for nogle personlige oplysninger for at kunne sende dig informationer om (regnskovsbevis, sponsorprofil, geografisk koordinater, bidragskvittering). +N?r vi har modtaget bidraget, sender vi dig alle ovenfor n?vnte informationer per brev eller e-mail.


    - [Dieses Formular] + [Denne formular]
    - Bitte senden Sie dieses Formular per E-Mail direkt an uns. Sie k?nnen es auch + Send os venligst denne formular direkte per e-mail, eller - ausdrucken + udskriv - und per Fax oder Post an unsere - Kontaktadresse schicken: + den og send den til os per fax eller post:

    - BOS Deutschland e.V. + BOS Danmark
    - Sch?neberger Ufer 69 + ?kologihuset, Blegdamsvej 4b
    - 10785 Berlin + 2200 K?benhavn N

    - Fax: (030) 2636 7815 + Fax: +45 3537 3636
    From bknr at bknr.net Sun Dec 3 12:17:00 2006 From: bknr at bknr.net (bknr at bknr.net) Date: Sun, 3 Dec 2006 07:17:00 -0500 (EST) Subject: [bknr-cvs] r2103 - trunk/projects/bos/payment-website/templates/da Message-ID: <20061203121700.DCACC60037@common-lisp.net> Author: hhubner Date: 2006-12-03 07:17:00 -0500 (Sun, 03 Dec 2006) New Revision: 2103 Modified: trunk/projects/bos/payment-website/templates/da/bestellung.xml Log: do not automatically make contracts download-only Modified: trunk/projects/bos/payment-website/templates/da/bestellung.xml =================================================================== --- trunk/projects/bos/payment-website/templates/da/bestellung.xml 2006-12-03 12:16:09 UTC (rev 2102) +++ trunk/projects/bos/payment-website/templates/da/bestellung.xml 2006-12-03 12:17:00 UTC (rev 2103) @@ -57,7 +57,6 @@
    - Modified: trunk/projects/bos/payment-website/templates/da/versand_info.xml =================================================================== --- trunk/projects/bos/payment-website/templates/da/versand_info.xml 2006-12-03 13:28:16 UTC (rev 2106) +++ trunk/projects/bos/payment-website/templates/da/versand_info.xml 2006-12-04 10:02:09 UTC (rev 2107) @@ -50,7 +50,7 @@ - +
    From bknr at bknr.net Sun Dec 3 13:26:33 2006 From: bknr at bknr.net (bknr at bknr.net) Date: Sun, 3 Dec 2006 08:26:33 -0500 (EST) Subject: [bknr-cvs] r2104 - in trunk/projects/bos: m2 worldpay-test Message-ID: <20061203132633.2B8D019006@common-lisp.net> Author: hhubner Date: 2006-12-03 08:26:32 -0500 (Sun, 03 Dec 2006) New Revision: 2104 Modified: trunk/projects/bos/m2/mail-generator.lisp trunk/projects/bos/m2/packages.lisp trunk/projects/bos/worldpay-test/sponsor-handlers.lisp Log: Send sponsor data mail for manually entered sponsors. Modified: trunk/projects/bos/m2/mail-generator.lisp =================================================================== --- trunk/projects/bos/m2/mail-generator.lisp 2006-12-03 12:17:00 UTC (rev 2103) +++ trunk/projects/bos/m2/mail-generator.lisp 2006-12-03 13:26:32 UTC (rev 2104) @@ -150,6 +150,40 @@ :email (param 'email) :tel (param 'tel))))) +(defun make-html-part (string) + (make-instance 'text-mime + :type "text" + :subtype "html" + :charset "utf-8" + :encoding :quoted-printable + :content string)) + +(defun make-contract-xml-part (id params) + (make-instance 'text-mime + :type "text" + :subtype (format nil "xml; name=\"contract-~A.xml\"" id) + :charset "utf-8" + :encoding :quoted-printable + :content (format nil " + + ~{<~A>~A~} + +" + (apply #'append (mapcar #'(lambda (cons) + (list (car cons) + (if (find #\Newline (cdr cons)) + (format nil "" (cdr cons)) + (cdr cons)) + (car cons))) + params))))) + +(defun make-vcard-part (id vcard) + (make-instance 'text-mime + :type "text" + :subtype (format nil "x-vcard; name=\"contract-~A.vcf\"" id) + :charset "utf-8" + :content vcard)) + (defun mail-contract-data (contract type mime-parts) (let ((parts mime-parts)) (unless (contract-download-only-p contract) @@ -175,16 +209,49 @@ (unless (contract-download-only-p contract) (delete-file (contract-pdf-pathname contract :print t)))) +(defun mail-backoffice-sponsor-data (contract req) + (with-query-params (req numsqm country email name address date language) + (let ((parts (list (make-html-part (format nil " + + +

    Manuell erfasste Sponsordate:

    + + + + + + +
    Contract-ID~@[~A~]
    Anzahl sqm~A
    Name~@[~A~]
    Adresse~@[~A~]
    Email~@[~A~]
    + +" + (store-object-id contract) + numsqm + name + address + email)) + (make-contract-xml-part (store-object-id contract) (all-request-params req)) + (make-vcard-part (store-object-id contract) + (make-vcard :sponsor-id (store-object-id (contract-sponsor contract)) + :note (format nil "Paid-by: Back office +Contract ID: ~A +Sponsor ID: ~A +Number of sqms: ~A +Amount: EUR~A.00 +" + (store-object-id contract) + (store-object-id (contract-sponsor contract)) + numsqm + (* 3 (parse-integer numsqm))) + :name name + :address address + :email email))))) + (mail-contract-data contract "Manuell erfasster Sponsor" parts)))) + (defun mail-manual-sponsor-data (req) (with-query-params (req contract-id vorname name strasse plz ort email telefon donationcert-yearly) (let* ((contract (store-object-with-id (parse-integer contract-id))) (sponsor-id (store-object-id (contract-sponsor contract))) - (parts (list (make-instance 'text-mime - :type "text" - :subtype "html" - :charset "utf-8" - :encoding :quoted-printable - :content (format nil " + (parts (list (make-html-part (format nil "

    Ueberweisungsformulardaten:

    @@ -205,52 +272,32 @@ " - contract-id - (length (contract-m2s contract)) - vorname name strasse plz ort email telefon - (if donationcert-yearly "ja" "nein") - *website-url* contract-id email)) - (make-instance 'text-mime - :type "text" - :subtype (format nil "xml; name=\"contract-~A.xml\"" contract-id) - :charset "utf-8" - :encoding :quoted-printable - :content (format nil " - - ~{<~A>~A~} - -" - (apply #'append (mapcar #'(lambda (cons) - (list (car cons) - (if (find #\Newline (cdr cons)) - (format nil "" (cdr cons)) - (cdr cons)) - (car cons))) - (all-request-params req))))) - (make-instance 'text-mime - :type "text" - :subtype (format nil "x-vcard; name=\"contract-~A.vcf\"" contract-id) - :charset "utf-8" - :content (make-vcard :sponsor-id sponsor-id - :note (format nil "Paid-by: Manual money transfer + contract-id + (length (contract-m2s contract)) + vorname name strasse plz ort email telefon + (if donationcert-yearly "ja" "nein") + *website-url* contract-id email)) + (make-contract-xml-part contract-id (all-request-params req)) + (make-vcard-part contract-id (make-vcard :sponsor-id sponsor-id + :note (format nil "Paid-by: Manual money transfer Contract ID: ~A Sponsor ID: ~A Number of sqms: ~A Amount: EUR~A.00 Donationcert yearly: ~A " - contract-id - sponsor-id - (length (contract-m2s contract)) - (* 3 (length (contract-m2s contract))) - (if donationcert-yearly "Yes" "No")) - :vorname vorname - :nachname name - :strasse strasse - :postcode plz - :ort ort - :email email - :tel telefon))))) + contract-id + sponsor-id + (length (contract-m2s contract)) + (* 3 (length (contract-m2s contract))) + (if donationcert-yearly "Yes" "No")) + :vorname vorname + :nachname name + :strasse strasse + :postcode plz + :ort ort + :email email + :tel telefon))))) (mail-contract-data contract "Ueberweisungsformular" parts)))) (defvar *worldpay-params-hash* (make-hash-table :test #'equal)) @@ -269,12 +316,7 @@ (with-query-params (req contract-id) (let* ((contract (store-object-with-id (parse-integer contract-id))) (params (get-worldpay-params contract-id)) - (parts (list (make-instance 'text-mime - :type "text" - :subtype "html" - :charset "utf-8" - :encoding :quoted-printable - :content (format nil " + (parts (list (make-html-part (format nil " @@ -283,30 +325,10 @@ ~{~}
    Parameter
    ~A~A
    " - (apply #'append (mapcar #'(lambda (cons) (list (car cons) (cdr cons))) - (sort (copy-list params) - #'string-lessp - :key #'car))))) - (make-instance 'text-mime - :type "text" - :subtype (format nil "xml; name=\"contract-~A.xml\"" (store-object-id contract)) - :charset "utf-8" - :encoding :quoted-printable - :content (format nil " - - ~{<~A>~A~} - -" - (apply #'append (mapcar #'(lambda (cons) - (list (car cons) - (if (find #\Newline (cdr cons)) - (format nil "" (cdr cons)) - (cdr cons)) - (car cons))) - params)))) - (make-instance 'text-mime - :type "text" - :subtype (format nil "x-vcard; name=\"contract-~A.vcf\"" (store-object-id contract)) - :charset "utf-8" - :content (worldpay-callback-params-to-vcard params))))) + (apply #'append (mapcar #'(lambda (cons) (list (car cons) (cdr cons))) + (sort (copy-list params) + #'string-lessp + :key #'car))))) + (make-contract-xml-part contract-id params) + (make-vcard-part contract-id (worldpay-callback-params-to-vcard params))))) (mail-contract-data contract "WorldPay" parts)))) Modified: trunk/projects/bos/m2/packages.lisp =================================================================== --- trunk/projects/bos/m2/packages.lisp 2006-12-03 12:17:00 UTC (rev 2103) +++ trunk/projects/bos/m2/packages.lisp 2006-12-03 13:26:32 UTC (rev 2104) @@ -184,6 +184,7 @@ #:mail-instructions-to-sponsor #:mail-info-request #:mail-manual-sponsor-data + #:mail-backoffice-sponsor-data #:mail-worldpay-sponsor-data #:*cert-download-directory*)) Modified: trunk/projects/bos/worldpay-test/sponsor-handlers.lisp =================================================================== --- trunk/projects/bos/worldpay-test/sponsor-handlers.lisp 2006-12-03 12:17:00 UTC (rev 2103) +++ trunk/projects/bos/worldpay-test/sponsor-handlers.lisp 2006-12-03 13:26:32 UTC (rev 2104) @@ -84,17 +84,18 @@ (:tr (:td "Name for certificate") (:td (text-field "name" :size 20))) (:tr (:td "Postal address for certificate" - (:td (textarea-field "postaladdress" :rows 5 :cols 40)))) + (:td (textarea-field "address" :rows 5 :cols 40)))) (:tr (:td (submit-button "create" "create" :formcheck "javascript:return check_complete_sale()")))))))) (defun date-to-universal (date-string) (apply #'encode-universal-time 0 0 0 (mapcar #'parse-integer (split #?r"\." date-string)))) (defmethod handle-object-form ((handler edit-sponsor-handler) (action (eql :create)) (sponsor (eql nil)) req) - (with-query-params (req numsqm country email name postaladdress date language) + (with-query-params (req numsqm country email name address date language) (let* ((sponsor (make-sponsor :email email :country country)) (contract (make-contract sponsor (parse-integer numsqm) :paidp t :date (date-to-universal date)))) - (contract-issue-cert contract name :address postaladdress :language language) + (contract-issue-cert contract name :address address :language language) + (mail-backoffice-sponsor-data contract req) (redirect (format nil "/edit-sponsor/~D" (store-object-id sponsor)) req)))) (defun contract-checkbox-name (contract) From bknr at bknr.net Sun Dec 3 13:27:47 2006 From: bknr at bknr.net (bknr at bknr.net) Date: Sun, 3 Dec 2006 08:27:47 -0500 (EST) Subject: [bknr-cvs] r2105 - trunk/bknr/src/xml-impex Message-ID: <20061203132747.78D07232B8@common-lisp.net> Author: hhubner Date: 2006-12-03 08:27:47 -0500 (Sun, 03 Dec 2006) New Revision: 2105 Modified: trunk/bknr/src/xml-impex/xml-export.lisp Log: Remove unmatched parenthesis Modified: trunk/bknr/src/xml-impex/xml-export.lisp =================================================================== --- trunk/bknr/src/xml-impex/xml-export.lisp 2006-12-03 13:26:32 UTC (rev 2104) +++ trunk/bknr/src/xml-impex/xml-export.lisp 2006-12-03 13:27:47 UTC (rev 2105) @@ -109,4 +109,4 @@ (slot-value object name))))))) (sax:end-element cxml::*sink* nil nil qname)))) - (t nil))))) + (t nil)))) From bknr at bknr.net Sun Dec 3 13:28:17 2006 From: bknr at bknr.net (bknr at bknr.net) Date: Sun, 3 Dec 2006 08:28:17 -0500 (EST) Subject: [bknr-cvs] r2106 - trunk/thirdparty/emacs/slime Message-ID: <20061203132817.8BDCA3200E@common-lisp.net> Author: hhubner Date: 2006-12-03 08:28:16 -0500 (Sun, 03 Dec 2006) New Revision: 2106 Removed: trunk/thirdparty/emacs/slime/swank-loader.x86f Log: Remove unwanted file Deleted: trunk/thirdparty/emacs/slime/swank-loader.x86f =================================================================== --- trunk/thirdparty/emacs/slime/swank-loader.x86f 2006-12-03 13:27:47 UTC (rev 2105) +++ trunk/thirdparty/emacs/slime/swank-loader.x86f 2006-12-03 13:28:16 UTC (rev 2106) @@ -1,66 +0,0 @@ -FASL FILE output from /usr/home/hans/bknr-svn/thirdparty/emacs/slime/swank-loader.lisp. -Compiled Wednesday, 11/15/06 07:15:22 am GMT on ibuprofen.huebner.org -Compiler 1.1, Lisp 19c Release (19C) -Targeted for Intel x86, FASL version 19C -???Q&KERNEL %DEFPACKAGE& SWANK-LOADER& COMMON-LISP QUOTE QUOTE QUOTE QUOTE QUOTE& COMMON-LISP QUOTE QUOTE QUOTE QUOTE 6RQ %IN-PACKAGE QUOTE& SWANK-LOADER6R?>#?B&lispNNAMENTYPE  MAKE-PATHNAME< *COMPILE-FILE-PATHNAME* MERGE-PATHNAMES< *LOAD-PATHNAME* *DEFAULT-PATHNAME-DEFAULTS*Q&C COMPILED-DEBUG-INFORQR($$-Q& -EXTENSIONS INSTANCER($$-Q STRUCTURE-OBJECTR($$- Q  -DEBUG-INFOR ("$$-#($$$-%&DEFUN MAKE-SWANK-PATHNAME&& SWANK-LOADER'Q COMPILED-DEBUG-FUNCTIONR Q DEBUG-FUNCTIONR (*$$-+(,$$ --Q& SWANK-LOADERR .MAKE-SWANK-PATHNAMENEXTERNAL+G2MG3?G4??1+&2$+$3NSTANDARD$'$$#?1 5$5-&NOPTIONAL+NAME?7+58$+94$'$$5#?1 :$A-/+NAMECTYPE COMMON-LISP?;+EA*<$$  OPTIONAL-ARGS$(>4$'$$A#?1 ?(@1AB; -?~?E??e???t??u?U??}??? -M?U???E???????}??5?E??C????k????P??? !?A?=?tH= ?(t???%??u??`? )?A?=?t#= ?(t?????-?x????t ??? -N? -N? -QNABSOLUTER??QNABSOLUTER??QNABSOLUTER??QNABSOLUTER?rQNABSOLUTER?]QNABSOLUTER?QQNABSOLUTER?HQNABSOLUTER?:=?K/&(name &optional (type "lisp"))L FUNCTION  &OPTIONALO PATHNAMEQ?/RJ?>S#B&nregexST&swank-source-path-parserU&swank-source-file-cacheV& swank-cmuclWX APPEND</< .*SYSDEP-PATHNAMES* CONS%&DEFPARAMETER *SYSDEP-PATHNAMES*\'-&Top-Level Form]N TOP-LEVEL+_+P{ W`$+a4$'$$#x1 b(c1de;~ ?E??e?? ?(?4?(??(?|?(;??(v??|?(?[???P??@ ?(??(?=4?(t? ???u??u????? ??=???k????P???u??????????}??u??V????? ???k????P???u??}??4?(??(?|?(;??(v??|?(?[???P??@ ?(??(?=4?(t? ???? ?(t>?_?v??$<u>??= ?(?c????E??@? !?A?? ?(?M??E??????????%? -!??? -??QNABSOLUTER?lQNABSOLUTER?OQNRELATIVER?alloc_overflow_ebx?QNABSOLUTER??QNABSOLUTER??QNABSOLUTER??QNABSOLUTER?QNRELATIVER?alloc_overflow_ebxE=?n]&()oM?/R&BReturn a pathname with name component NAME in the Slime directory.q PROCLAIM< SPECIALZt#]1uv;? !"?q#$?q0?w]$$Q SIMPLE-BYTE-FUNCTIONRQ FUNCTIONR(z$$-{Q FUNCALLABLE-INSTANCER{(}$$-~Q BYTE-FUNCTION-OR-CLOSURER{~(?$$-?Q BYTE-FUNCTIONR{~?(?$$-?(?$$-???8p8LSET-DEFVAR-SOURCE-LOCATION<ZQ FILE-SOURCE-LOCATIONR Q  FORM-NUMBERSR (?$$-?(?$$-?$&@/usr/home/hans/bknr-svn/thirdparty/emacs/slime/swank-loader.lisp?1?r<s .*IMPLEMENTATION-FEATURES*?NALLEGRON LISPWORKSNSBCLNOPENMCLNCMUNCLISPNCCLNCORMANN ARMEDBEARNGCLNECL ????$?1?s . *OS-FEATURES*?NMACOSXNLINUXNWINDOWSN MSWINDOWSNWIN32NSOLARISNDARWINNSUNOSNUNIX ???$?1?#]1??; !"?q#$?q%&? '(?q#)?q*+? +,?q0??]$$???8?>?$]B LISP-IMPLEMENTATION-VERSION<  -SUBSTITUTE<%&DEFUN LISP-VERSION-STRING?'- .LISP-VERSION-STRING0+G0M?+ ;?$+?4$'$$$X1 ?$"-?+?+"?$+?4$'$$"$]1 ?(?1??;]~?E??e???u6???? ?1??j????P??????-??/?? ?u??`??? -MQNABSOLUTER?GQNABSOLUTER?)=???oM SIMPLE-BASE-STRING????J?>?#&B?&&No implementation feature found in ~a.??&No os feature found in ~a.? .*ARCHITECTURE-FEATURES*&$No architecture feature found in ~a.??<&TDon't know how to get Lisp ~ - implementation version.?&~(~@{~a~^-~}~)? FORMAT<  -*FEATURES* FIND< WARN<&unknown?%&DEFUN UNIQUE-DIRECTORY-NAME?'- .UNIQUE-DIRECTORY-NAME0+G6M?+???$+?4$'$$#?1 ?$&-?+VALUE??+f&)?,?+?&+?3?$+?4$'$$&#?1 ?#?- FLET .FIRST-OF??+F? FEATURES???+C??F ??$+?+?$'$#?# 1 ?#M-? . -MAYBE-WARN??+ ARGS??FSTRINGcVALUEC?+4?M N "    <  ?$$$ REST-ARG$(?+?$'$#M#1 ?(?1??;&~?E??e?????? ?A?=????????? ???J????E???j????P???????4?(??(?|?(;??(v??|?(?[???P??@ ?(??(?=4?(t? ?????? ?q???Q??A????E?%?q?E?? ?A?=???????? ???J????E?V??????P???????4?(??(?|?(;??(v??|?(?[???P??@ ?(??(?=4?(t? ?????? ?q???Q??A????E?????E??!?X?????T?????? ?A????E??????!?P?????*?4?(??(?|?(;??(v??|?(?[???P??@ ?(??(?=4?(t? ?????? ?q??%?Q??A????E????E????? ?)1??j????P???????? ?Q??-?Q?? ?(?A????E????? ?(?=1?u??E??E??E??E??E??5??u??`? ?(??$<?<????? ?(?[?]??V??v??$<?!?u??9?x??????e??? ?]??=??k????P???]??u????? ?(u?? ?(u?? ?(?e??m?????}? ?(???]??A?x?? ?(???U???R?E????$<??????? ?(9?t?q??I??$<t?? -N??)??]?????)??S??{??s??? ?k????P???]??E?e??m???E?????? -M? -N? -? -N? -? -? -? -?? -??? -? -? -?QNABSOLUTER??QNABSOLUTER?_QNABSOLUTER?QNABSOLUTER??QNABSOLUTER??QNABSOLUTER??QNABSOLUTER??QNABSOLUTER?sQNABSOLUTER?WQNABSOLUTER?DQNABSOLUTER?5QNRELATIVER?alloc_overflow_ebx?QNABSOLUTER??QNABSOLUTER??QNABSOLUTER??QNABSOLUTER??QNABSOLUTER?}QNRELATIVER?alloc_overflow_ebxFQNABSOLUTER?QNABSOLUTER?QNABSOLUTER??QNABSOLUTER??QNABSOLUTER??QNRELATIVER?alloc_overflow_ebx?QNABSOLUTER?XQNABSOLUTER?KQNABSOLUTER?(=? ?oM OR  BASE-STRING NULL ??Jr<s?NPOWERPCNPPCNX86NX86-64NI686NPC386NIAPX386NSPARC??<??$?1???&?Return a name that can be used as a directory name that is -unique to a Lisp implementation, Lisp implementation version, -operating system, and hardware architecture.s .*SWANK-PATHNAME*/<&swank#]1 ;' !?q"#?$%&?q?'(0?q?)*+?q ,?q-.?/?0?!]$$??"8?>##?B FILE-WRITE-DATE<%&DEFUN FILE-NEWER-P$'- . FILE-NEWER-P0+G0MG1?G2??&+ {'$ -+$(4$'$$#?1 )$)-%+NEW-FILECOLD-FILEc*+4) -+$ -+,4$'$$)#?1 -(.1/0;?~?E??e???uu?U??}????? ?U????k????P???U????? ?U????k????P?????U?????? ?(u? ?(?M??E??????????'?(?????? -MQNRELATIVERQ&X86 2 GENERIC->R?lQNABSOLUTER?SQNABSOLUTER?3=?6%&(new-file old-file)7M8 MEMBER:;?%<J?>=#?B COMPILE-FILE-PATHNAME<?e#` B PARSE-UNKNOWN-TYPE-SPECIFIER< NOTE-UNDEFINED-REFERENCE?#?BD<&.swank?< #?B *LOAD-TRUENAME*& site-initNDEFAULTS<?u<%&DEFUN LOAD-SITE-INIT-FILE'- .LOAD-SITE-INIT-FILE0+G0M+ s$+4$'$$#?1 $"-++"L -$+4$'$$"#?1 (1; ?~?E??e???un? ?A?=?tc??????=?5? !?K?? %?K??C??)??k????P???=-? ?(?1? ?u??`?? -M? -NQNABSOLUTER??QNABSOLUTER?uQNABSOLUTER?`QNABSOLUTER?TQNABSOLUTER?KQNABSOLUTER?EQNABSOLUTER??QNABSOLUTER?9QNABSOLUTER?$=?&o??'J'<?<#]1();? !0?q"?`?#?q0?*]$$??+8Q  DEBUG-SOURCER (-$$ -.NFILE?"&??0" -=?1$+@\??k?? ? ~Lu\Qo21 345?)5?5?5??5??5?Q5?05? 5??5??5??5?v5?e5?B?>6@ \ No newline at end of file From bknr at bknr.net Mon Dec 4 10:02:10 2006 From: bknr at bknr.net (bknr at bknr.net) Date: Mon, 4 Dec 2006 05:02:10 -0500 (EST) Subject: [bknr-cvs] r2107 - trunk/projects/bos/payment-website/templates/da Message-ID: <20061204100210.CEEE660007@common-lisp.net> Author: hhubner Date: 2006-12-04 05:02:09 -0500 (Mon, 04 Dec 2006) New Revision: 2107 Modified: trunk/projects/bos/payment-website/templates/da/bestellung.xml trunk/projects/bos/payment-website/templates/da/versand_info.xml Log: Current version. Modified: trunk/projects/bos/payment-website/templates/da/bestellung.xml =================================================================== --- trunk/projects/bos/payment-website/templates/da/bestellung.xml 2006-12-03 13:28:16 UTC (rev 2106) +++ trunk/projects/bos/payment-website/templates/da/bestellung.xml 2006-12-04 10:02:09 UTC (rev 2107) @@ -159,9 +159,9 @@
    - + - +
    for din st??tte og for din tilld til BOS.

    The m?? du har sponseret er i gode h??nder.
    for din st?tte og for din tilld til BOS.

    The m? du har sponseret er i gode h?nder.
    @@ -98,7 +98,7 @@ - I hvilket navn skal vi udstede dit Regnskovs diplom? [Vi acceptere det intastede navn i dette felt. V??r venlig at ??ndre navnet om n??dvendigt. ] + I hvilket navn skal vi udstede dit Regnskovs diplom? [Vi acceptere det intastede navn i dette felt. V?r venlig at ?ndre navnet om n?dvendigt. ] @@ -156,8 +156,8 @@


    - [Betalings-bekr??ftigelse]
    - Denne betalings-bekr??ftigelse fra WorldPay er allerede undervejs til din indbox. I den uventede situation at du ikke skulle modtage nogen besked, venligst kontakt: + [Betalings-bekr?ftigelse]
    + Denne betalings-bekr?ftigelse fra WorldPay er allerede undervejs til din indbox. I den uventede situation at du ikke skulle modtage nogen besked, venligst kontakt:
    From bknr at bknr.net Mon Dec 4 10:43:01 2006 From: bknr at bknr.net (bknr at bknr.net) Date: Mon, 4 Dec 2006 05:43:01 -0500 (EST) Subject: [bknr-cvs] r2108 - trunk/projects/bos/worldpay-test Message-ID: <20061204104301.37C3F5832B@common-lisp.net> Author: hhubner Date: 2006-12-04 05:42:51 -0500 (Mon, 04 Dec 2006) New Revision: 2108 Modified: trunk/projects/bos/worldpay-test/tags.lisp Log: direkt bank transfer enabled for danish version. Modified: trunk/projects/bos/worldpay-test/tags.lisp =================================================================== --- trunk/projects/bos/worldpay-test/tags.lisp 2006-12-04 10:02:09 UTC (rev 2107) +++ trunk/projects/bos/worldpay-test/tags.lisp 2006-12-04 10:42:51 UTC (rev 2108) @@ -59,16 +59,17 @@ (define-bknr-tag buy-sqm (&key children) (with-template-vars (numsqm numsqm1 action gift donationcert-yearly download-only) (let* ((numsqm (parse-integer (or numsqm numsqm1))) - ;; Wer ueber dieses Formular bestellt, ist ein neuer Sponsor, - ;; also ein neues Sponsorenobjekt anlegen. Eine Profil-ID - ;; wird automatisch zugewiesen, sonstige Daten haben wir zu - ;; diesem Zeitpunkt noch nicht. - ;; XXX ?berweisung wird nur f?r die deutsche Website - ;; angeboten, was passenderweise durch die folgende + ;; Wer ueber dieses Formular bestellt, ist ein neuer + ;; Sponsor, also ein neues Sponsorenobjekt anlegen. Eine + ;; Profil-ID wird automatisch zugewiesen, sonstige Daten + ;; haben wir zu diesem Zeitpunkt noch nicht. XXX + ;; ?berweisung wird nur f?r die deutsche und d?nische + ;; Website angeboten, was passenderweise durch die folgende ;; ?berpr?fung auch sicher gestellt wurde. Sollte man aber ;; eventuell noch mal pr?fen und sicher stellen. (manual-transfer (or (scan #?r"rweisen" action) - (scan #?r"rweisung" action))) + (scan #?r"rweisung" action) + (scan #?r"overf" action))) (sponsor (make-sponsor)) (price (* numsqm 3)) (contract (make-contract sponsor numsqm From bknr at bknr.net Thu Dec 7 19:56:33 2006 From: bknr at bknr.net (bknr at bknr.net) Date: Thu, 7 Dec 2006 14:56:33 -0500 (EST) Subject: [bknr-cvs] r2109 - in trunk/projects/bos/payment-website: infosystem/da templates/da Message-ID: <20061207195633.2625C48144@common-lisp.net> Author: hhubner Date: 2006-12-07 14:56:32 -0500 (Thu, 07 Dec 2006) New Revision: 2109 Modified: trunk/projects/bos/payment-website/infosystem/da/messages.js trunk/projects/bos/payment-website/templates/da/archive.xml trunk/projects/bos/payment-website/templates/da/bestellung.xml trunk/projects/bos/payment-website/templates/da/certificat.xml trunk/projects/bos/payment-website/templates/da/privacy.xml trunk/projects/bos/payment-website/templates/da/quittung.xml trunk/projects/bos/payment-website/templates/da/ueberweisung.xml Log: Latest version of the danish site. Modified: trunk/projects/bos/payment-website/infosystem/da/messages.js =================================================================== --- trunk/projects/bos/payment-website/infosystem/da/messages.js 2006-12-04 10:42:51 UTC (rev 2108) +++ trunk/projects/bos/payment-website/infosystem/da/messages.js 2006-12-07 19:56:32 UTC (rev 2109) @@ -1,10 +1,11 @@ document.messages = { 'Anzahl Sponsoren': 'Antal sponsorer', 'Anzahl verkaufte m?': 'Antal solgte kvardratmeter ', - 'Das Laden des Panoramas dauert einen Moment und ben??tigt Java in Ihrem Browser.

    Klicken und Ziehen Sie mit der Maus, um sich im Panorama umzusehen!': 'Det tager lidt tid for oversigtskortet at loade og Java er n?dvendigt

    Klik og tr?k med din mus for at se dig omkring i billedet.', - 'Diese Anwendung ben??tigt Cookies, um zu funktionieren. Bitte schalten Sie Cookies in Ihrem Browser ein.': 'Denne funktion fores?tter at cookies er sl?et fra i din browser. Sl? venligst cookies-funktionen fra og pr?v igen.', + 'Das Laden des Panoramas dauert einen Moment und ben?tigt Java in Ihrem Browser.

    Klicken und Ziehen Sie mit der Maus, um sich im Panorama umzusehen!': 'Det tager lidt tid for oversigtskortet at loade og Java er n?dvendigt

    Klik og tr?k med din mus for at se dig omkring i billedet.', + 'Letzter Sponsor': 'Sidste sponsor' + 'Diese Anwendung ben?tigt Cookies, um zu funktionieren. Bitte schalten Sie Cookies in Ihrem Browser ein.': 'Denne funktion fores?tter at cookies er sl?et fra i din browser. Sl? venligst cookies-funktionen fra og pr?v igen.', 'Dieser m? wurde bisher noch nicht verkauft': 'Denne kvardratmeter er endnu ikke solgt.', - 'Fehler beim Laden der POI-Informationen, bitte probieren Sie es sp??ter noch einmal': 'Fejl ved loading af POI-information, pr?v venligst igen senere!', + 'Fehler beim Laden der POI-Informationen, bitte probieren Sie es sp?ter noch einmal': 'Fejl ved loading af POI-information, pr?v venligst igen senere!', 'Land': 'Land', 'Luftbild': 'Luftbillede', 'Name': 'Navn', @@ -12,11 +13,11 @@ 'Sat-Karte': 'Satellit billede', 'Sponsor-ID': 'Donor ID', 'Verkaufte m?': 'Solgte m?' , - 'Zu Verkaufen': 'For sale!', - 'gesponsort': 'donated', + 'Zu Verkaufen': 'Til Salg!', + 'gesponsort': 'doneret', 'meine m?': 'mine m?', - 'm?-Verkaufsgebiet': 'm? sale area', - 'noch nicht verkauft': 'not yet sold', - 'seit': 'since', - 'zu verkaufen!': 'For sale!' + 'm?-Verkaufsgebiet': 'Omr?de med m? til salg', + 'noch nicht verkauft': 'Endnu ikke solgt', + 'seit': 'siden', + 'zu verkaufen!': 'Til Salg!' }; Modified: trunk/projects/bos/payment-website/templates/da/archive.xml =================================================================== --- trunk/projects/bos/payment-website/templates/da/archive.xml 2006-12-04 10:42:51 UTC (rev 2108) +++ trunk/projects/bos/payment-website/templates/da/archive.xml 2006-12-07 19:56:32 UTC (rev 2109) @@ -1,7 +1,7 @@ -

    NEWS im ARCHIV

    +

    NYHEDSARKIV

    Modified: trunk/projects/bos/payment-website/templates/da/bestellung.xml =================================================================== --- trunk/projects/bos/payment-website/templates/da/bestellung.xml 2006-12-04 10:42:51 UTC (rev 2108) +++ trunk/projects/bos/payment-website/templates/da/bestellung.xml 2006-12-07 19:56:32 UTC (rev 2109) @@ -1,6 +1,11 @@ - +
    @@ -159,7 +164,7 @@ - + Modified: trunk/projects/bos/payment-website/templates/da/certificat.xml =================================================================== --- trunk/projects/bos/payment-website/templates/da/certificat.xml 2006-12-04 10:42:51 UTC (rev 2108) +++ trunk/projects/bos/payment-website/templates/da/certificat.xml 2006-12-07 19:56:32 UTC (rev 2109) @@ -3,6 +3,6 @@

    S?dan vil dit Regnskovs Diplom se ud:

    - +
    Modified: trunk/projects/bos/payment-website/templates/da/privacy.xml =================================================================== --- trunk/projects/bos/payment-website/templates/da/privacy.xml 2006-12-04 10:42:51 UTC (rev 2108) +++ trunk/projects/bos/payment-website/templates/da/privacy.xml 2006-12-07 19:56:32 UTC (rev 2109) @@ -10,30 +10,30 @@ Hvad sker der med dine personlige data?

    -N??r du har besluttet dig for at lave en donation online, vil du blive bedt om at give dine bank-oplysninger. Denne information vil blive behandlet egenh??ndigt af WorldPay. +N?r du har besluttet dig for at lave en donation online, vil du blive bedt om at give dine bank-oplysninger. Denne information vil blive behandlet egenh?ndigt af WorldPay. WorldPay er en anerkendt, international udbyder af online betalling. Din data vil blive sendt til WorldPay gennem en kodet SSL-forbindelse, og vil blive slettet straks efter en successfuld transaktion. BOS International har ellers ingen afgang til din bank-information.

    -Hver kvardratmeter du sponserer med din donation er linket til din personlige profil. Denne profil best??r af dit navn, hjemland, antal kvardratmeter du sponserer og datoen for din donation. -Det er desuden muligt at skrive en personlig hilsen. Alt profil-information (undtagen e-mail addresse og post addresse) vil v??re tilg??ngelig til bes??gende p?? vores website. P?? denne m??de promoveres kommunikation og menningsudveksling mellem vores sponsore. Profil information kan altid ??ndres ved at logge ind med dit password. Ved at g??re dette, er det ogs?? muligt at forblive anonym. +Hver kvardratmeter du sponserer med din donation er linket til din personlige profil. Denne profil best?r af dit navn, hjemland, antal kvardratmeter du sponserer og datoen for din donation. +Det er desuden muligt at skrive en personlig hilsen. Alt profil-information (undtagen e-mail addresse og post addresse) vil v?re tilg?ngelig til bes?gende p? vores website. P? denne m?de promoveres kommunikation og menningsudveksling mellem vores sponsore. Profil information kan altid ?ndres ved at logge ind med dit password. Ved at g?re dette, er det ogs? muligt at forblive anonym.

    For at kunne sende dig din personlige profil, indeholdende dit sponsor-ID og password, skal vi bruge din e-mail addresse. -For at kunne sende dit Regnskovs Diplom med normal post skal vi bruge din post addresse, og navnet p?? den person diplomet skal udstedes til. +For at kunne sende dit Regnskovs Diplom med normal post skal vi bruge din post addresse, og navnet p? den person diplomet skal udstedes til. For at kunne modtage vores nyhedsbrev/nyhedher, skal vi bruge din e-mail addresse.

    -Vi forsikre dig om at din data kun vil blive brugt til administrative og informative form??l for BOS international. -Hvis du p?? noget tidspunkt ikke l??ngere ??nsker at modtage mere information fra os, kan du til hver en tid slette din data fra vores system. In case you do not wish to receive any more information from us, you are able to +Vi forsikre dig om at din data kun vil blive brugt til administrative og informative form?l for BOS international. +Hvis du p? noget tidspunkt ikke l?ngere ?nsker at modtage mere information fra os, kan du til hver en tid slette din data fra vores system. In case you do not wish to receive any more information from us, you are able to delete your data from the system at any time. -Til dette form??l, v??r venlig altid at oplyse dit sponsor ID! +Til dette form?l, v?r venlig altid at oplyse dit sponsor ID!

    -Hvis du har flere sp??rgsm??I vedr??rende reglerne om Privacy policy for BOS International +Hvis du har flere sp?rgsm?I vedr?rende reglerne om Privacy policy for BOS International send venligst en e-mail til: bos at orangutang.dk

    Modified: trunk/projects/bos/payment-website/templates/da/quittung.xml =================================================================== --- trunk/projects/bos/payment-website/templates/da/quittung.xml 2006-12-04 10:42:51 UTC (rev 2108) +++ trunk/projects/bos/payment-website/templates/da/quittung.xml 2006-12-07 19:56:32 UTC (rev 2109) @@ -123,7 +123,7 @@ - + Modified: trunk/projects/bos/payment-website/templates/da/ueberweisung.xml =================================================================== --- trunk/projects/bos/payment-website/templates/da/ueberweisung.xml 2006-12-04 10:42:51 UTC (rev 2108) +++ trunk/projects/bos/payment-website/templates/da/ueberweisung.xml 2006-12-07 19:56:32 UTC (rev 2109) @@ -40,7 +40,7 @@ enctype="application/x-www-form-urlencoded" name="mailtransfer" id="mailtransfer" - onsubmit="YY_checkform('mailtransfer','vorname','#q','0','Bitte das Feld \'Vorname\' ausfuellen.','name','#q','0','Bitte das Feld \'Name\' ausfuellen.','strasse','#q','0','Bitte das Feld \'Strasse\' ausfuellen.','plz','#q','0','Bitte das Feld \'PLZ\' ausfuellen.','ort','#q','0','Bitte das Feld \'Ort\' ausfuellen.');return document.MM_returnValue"> + onsubmit="YY_checkform('mailtransfer','vorname','#q','0','Anuller venligst dette felt \'Fornavn\'.','name','#q','0','Anuller venligst dette felt \'Efternavn\'.','strasse','#q','0','Anuller venligst dette felt \'Gade/Nr.\'.','plz','#q','0','Anuller venligst dette felt \'Postnummer\'.','ort','#q','0','Anuller venligst dette felt \'Kommune\'.');return document.MM_returnValue"> @@ -133,7 +133,8 @@

    BOS Danmark
    - ?kologihuset, Blegdamsvej 4b + ?kologihuset,
    + Blegdamsvej 4b
    2200 K?benhavn N

    From bknr at bknr.net Thu Dec 7 20:01:23 2006 From: bknr at bknr.net (bknr at bknr.net) Date: Thu, 7 Dec 2006 15:01:23 -0500 (EST) Subject: [bknr-cvs] r2110 - trunk/projects/bos/payment-website/static Message-ID: <20061207200123.199DC4904C@common-lisp.net> Author: hhubner Date: 2006-12-07 15:01:22 -0500 (Thu, 07 Dec 2006) New Revision: 2110 Added: trunk/projects/bos/payment-website/static/bos_da.js trunk/projects/bos/payment-website/static/profil_da.js Log: Copy english versions of javascript files to a to-be danish version. Copied: trunk/projects/bos/payment-website/static/bos_da.js (from rev 2109, trunk/projects/bos/payment-website/static/bos_en.js) Copied: trunk/projects/bos/payment-website/static/profil_da.js (from rev 2109, trunk/projects/bos/payment-website/static/profil_en.js) From bknr at bknr.net Sun Dec 10 19:46:08 2006 From: bknr at bknr.net (bknr at bknr.net) Date: Sun, 10 Dec 2006 14:46:08 -0500 (EST) Subject: [bknr-cvs] r2111 - in trunk/projects/bos/payment-website: images infosystem/da static Message-ID: <20061210194608.6637F3001B@common-lisp.net> Author: hhubner Date: 2006-12-10 14:46:07 -0500 (Sun, 10 Dec 2006) New Revision: 2111 Added: trunk/projects/bos/payment-website/images/certificate_da.jpg Modified: trunk/projects/bos/payment-website/infosystem/da/messages.js trunk/projects/bos/payment-website/static/bos_da.js trunk/projects/bos/payment-website/static/profil_da.js Log: Current danish version. Added: trunk/projects/bos/payment-website/images/certificate_da.jpg =================================================================== (Binary files differ) Property changes on: trunk/projects/bos/payment-website/images/certificate_da.jpg ___________________________________________________________________ Name: svn:mime-type + application/octet-stream Modified: trunk/projects/bos/payment-website/infosystem/da/messages.js =================================================================== --- trunk/projects/bos/payment-website/infosystem/da/messages.js 2006-12-07 20:01:22 UTC (rev 2110) +++ trunk/projects/bos/payment-website/infosystem/da/messages.js 2006-12-10 19:46:07 UTC (rev 2111) @@ -2,7 +2,7 @@ 'Anzahl Sponsoren': 'Antal sponsorer', 'Anzahl verkaufte m?': 'Antal solgte kvardratmeter ', 'Das Laden des Panoramas dauert einen Moment und ben?tigt Java in Ihrem Browser.

    Klicken und Ziehen Sie mit der Maus, um sich im Panorama umzusehen!': 'Det tager lidt tid for oversigtskortet at loade og Java er n?dvendigt

    Klik og tr?k med din mus for at se dig omkring i billedet.', - 'Letzter Sponsor': 'Sidste sponsor' + 'Letzter Sponsor': 'Sidste sponsor', 'Diese Anwendung ben?tigt Cookies, um zu funktionieren. Bitte schalten Sie Cookies in Ihrem Browser ein.': 'Denne funktion fores?tter at cookies er sl?et fra i din browser. Sl? venligst cookies-funktionen fra og pr?v igen.', 'Dieser m? wurde bisher noch nicht verkauft': 'Denne kvardratmeter er endnu ikke solgt.', 'Fehler beim Laden der POI-Informationen, bitte probieren Sie es sp?ter noch einmal': 'Fejl ved loading af POI-information, pr?v venligst igen senere!', Modified: trunk/projects/bos/payment-website/static/bos_da.js =================================================================== --- trunk/projects/bos/payment-website/static/bos_da.js 2006-12-07 20:01:22 UTC (rev 2110) +++ trunk/projects/bos/payment-website/static/bos_da.js 2006-12-10 19:46:07 UTC (rev 2111) @@ -5,13 +5,13 @@ function check_profil_setup() { if (document.form.password.value == "") { - alert('Please enter your personal password.'); + alert('Indtast venligst dit personlige password.'); document.form.password.focus(); return false; } if (document.form.password.value != document.form.password1.value) { - alert('Please enter your personal password again.'); + alert('Tast venligst dit password ind to gange.'); document.form.password.focus(); return false; } @@ -23,10 +23,10 @@ function check_ueberweisung() { - // alert("numsqm: " + + " numsqm1: " + ); + // alert("numsqm: " + + " numsqm1: " + ) "Please read the waiver clause and confirm your agreement with a click to the check box."; if (!document.bestellformular.disclaimer_read.checked) { - alert("Please read the waiver clause and confirm your agreement with a click to the check box."); + alert("L?s venligst waiver klausulen og bekr?ft at du er enig med et klik i afkrydsnings-feltet."); return false; } @@ -47,12 +47,12 @@ function check_online() { if (!document.bestellformular.disclaimer_read.checked) { - alert("Please read the waiver clause and confirm your agreement with a click to the check box."); + alert("L?s venligst waiver klausulen og bekr?ft at du er enig med et klik i afkrydsnings-feltet."); return false; } if (document.bestellformular.numsqm[4].checked && !document.bestellformular.numsqm1.value.match(/^\d+/)) { - alert('Please enter the number of square meters that you want to "buy"!'); + alert('Indtast venligst det antal kvadratmeter du ?nsker at "k?be"!'); document.bestellformular.numsqm1.focus(); return false; } @@ -70,13 +70,13 @@ return true; } -// Formularcheck f?r Versandinformationen +// Formularcheck f?r Versandinformationen -- Please enter a name and address for your rainforest certificate. function check_versand_info() { if ((document.formular.name.value == '') || (document.formular.address.value == '')) { - alert("Please enter a name and address for your rainforest certificate."); + alert("Indtast venligst et navn og adresse til deres Regnskovs Diplom."); return false; } @@ -89,10 +89,10 @@ var address = document.form.email.value; if (!is_valid_email(address)) { - alert('The email address you entered "' + address + '" was not recogniced by our server. Please send your request to ' + alert('Den indtastede e-mail adresse "' + address + '" blev ikke genkendt af vores server. Send venligst deres foresp?rgsel til ' + 'service at createrainforest.org'); } else { - if (confirm('Would you like to receive informations about BOS and Samboja Lestari to "' + address + '"?')) { + if (confirm('Vil du gerne modtage yderligere information om BOS og Samboja Lestari til "' + address + '"?')) { document.form.email.value = ''; open("info-request?email=" + escape(address), "mailwin", "width=480,height=235,status=no,toolbar=no,menubar=no,resizable=yes,scrollbars=yes,left=100,top=100"); Modified: trunk/projects/bos/payment-website/static/profil_da.js =================================================================== --- trunk/projects/bos/payment-website/static/profil_da.js 2006-12-07 20:01:22 UTC (rev 2110) +++ trunk/projects/bos/payment-website/static/profil_da.js 2006-12-10 19:46:07 UTC (rev 2111) @@ -2,7 +2,7 @@ function anonymizecheck () { - if (confirm('Delete your personal data?')) { + if (confirm('Skal dine personlige data slettes?')) { document.form.name.value = ''; document.form.infotext.value = ''; return true; @@ -14,7 +14,7 @@ { if (!document.form.numsqm.value.match(/^\d+$/) || (document.form.numsqm.value.match(/^0+/))) { - alert("Invalid number of square metres."); + alert("Ugyldigt antal kvadratmeter."); document.form.numsqm.select(); document.form.numsqm.focus(); return false; @@ -25,13 +25,13 @@ function formcheck () { if (document.form.password.value != document.form.password1.value) { - alert('The passwords you have entered do not correspond'); + alert('De to indtastede kodeord stemmer ikke overens.'); document.form.password.select(); document.form.password.focus(); return false; } - alert('Your changes will be saved.'); + alert('Dine ?ndringer vil blive gemt.'); return true; } From bknr at bknr.net Tue Dec 12 19:37:55 2006 From: bknr at bknr.net (bknr at bknr.net) Date: Tue, 12 Dec 2006 14:37:55 -0500 (EST) Subject: [bknr-cvs] r2112 - trunk/projects/bos/payment-website/templates/en Message-ID: <20061212193755.33BE6A0F4@common-lisp.net> Author: hhubner Date: 2006-12-12 14:37:54 -0500 (Tue, 12 Dec 2006) New Revision: 2112 Modified: trunk/projects/bos/payment-website/templates/en/versand_geschenk.xml trunk/projects/bos/payment-website/templates/en/versand_info.xml Log: Fix button texts Modified: trunk/projects/bos/payment-website/templates/en/versand_geschenk.xml =================================================================== --- trunk/projects/bos/payment-website/templates/en/versand_geschenk.xml 2006-12-10 19:46:07 UTC (rev 2111) +++ trunk/projects/bos/payment-website/templates/en/versand_geschenk.xml 2006-12-12 19:37:54 UTC (rev 2112) @@ -76,7 +76,7 @@ - +
    Modified: trunk/projects/bos/payment-website/templates/en/versand_info.xml =================================================================== --- trunk/projects/bos/payment-website/templates/en/versand_info.xml 2006-12-10 19:46:07 UTC (rev 2111) +++ trunk/projects/bos/payment-website/templates/en/versand_info.xml 2006-12-12 19:37:54 UTC (rev 2112) @@ -77,7 +77,7 @@ - +
    Ihre Zahlung war erfolgreich:
    From bknr at bknr.net Fri Dec 15 12:23:56 2006 From: bknr at bknr.net (bknr at bknr.net) Date: Fri, 15 Dec 2006 07:23:56 -0500 (EST) Subject: [bknr-cvs] r2113 - trunk/projects/bos/payment-website/templates/da Message-ID: <20061215122356.8C09A30AD@common-lisp.net> Author: hhubner Date: 2006-12-15 07:23:52 -0500 (Fri, 15 Dec 2006) New Revision: 2113 Modified: trunk/projects/bos/payment-website/templates/da/bos.xml trunk/projects/bos/payment-website/templates/da/headline2.xml trunk/projects/bos/payment-website/templates/da/headline3.xml trunk/projects/bos/payment-website/templates/da/idea.xml trunk/projects/bos/payment-website/templates/da/idea_subtitle2.xml trunk/projects/bos/payment-website/templates/da/toplevel.xml trunk/projects/bos/payment-website/templates/da/toplevel_main.xml Log: Current danish version Modified: trunk/projects/bos/payment-website/templates/da/bos.xml =================================================================== --- trunk/projects/bos/payment-website/templates/da/bos.xml 2006-12-12 19:37:54 UTC (rev 2112) +++ trunk/projects/bos/payment-website/templates/da/bos.xml 2006-12-15 12:23:52 UTC (rev 2113) @@ -21,7 +21,7 @@



    • - Konfiskering af ulovligt tilfangetagende orangutanger, sol-bj?rne og andre arter + Konfiskering af ulovligt tilfangetagede orangutanger, sol-bj?rne og andre arter
    • Genuds?tning af orangutanger til "stationer" @@ -39,7 +39,7 @@ Skabelsen af alternativer til den lokale befolkning
    • - Ecological education of the local people + Udannellse i ?kologi til den lokale befolkning
    • Overv?gning af beskyttede omr?der @@ -48,7 +48,7 @@ Analyse af satelit fotos
    • - og mange andre. + og mange andre omr?der.


    Modified: trunk/projects/bos/payment-website/templates/da/headline2.xml =================================================================== --- trunk/projects/bos/payment-website/templates/da/headline2.xml 2006-12-12 19:37:54 UTC (rev 2112) +++ trunk/projects/bos/payment-website/templates/da/headline2.xml 2006-12-15 12:23:52 UTC (rev 2113) @@ -29,7 +29,7 @@ @@ -65,7 +65,7 @@ Modified: trunk/projects/bos/payment-website/templates/da/headline3.xml =================================================================== --- trunk/projects/bos/payment-website/templates/da/headline3.xml 2006-12-12 19:37:54 UTC (rev 2112) +++ trunk/projects/bos/payment-website/templates/da/headline3.xml 2006-12-15 12:23:52 UTC (rev 2113) @@ -25,14 +25,14 @@ Modified: trunk/projects/bos/payment-website/templates/da/idea.xml =================================================================== --- trunk/projects/bos/payment-website/templates/da/idea.xml 2006-12-12 19:37:54 UTC (rev 2112) +++ trunk/projects/bos/payment-website/templates/da/idea.xml 2006-12-15 12:23:52 UTC (rev 2113) @@ -27,15 +27,15 @@ Modified: trunk/projects/bos/payment-website/templates/da/idea_subtitle2.xml =================================================================== --- trunk/projects/bos/payment-website/templates/da/idea_subtitle2.xml 2006-12-12 19:37:54 UTC (rev 2112) +++ trunk/projects/bos/payment-website/templates/da/idea_subtitle2.xml 2006-12-15 12:23:52 UTC (rev 2113) @@ -29,7 +29,7 @@ @@ -40,9 +40,9 @@ Modified: trunk/projects/bos/payment-website/templates/da/headline3.xml =================================================================== --- trunk/projects/bos/payment-website/templates/da/headline3.xml 2006-12-15 13:27:05 UTC (rev 2114) +++ trunk/projects/bos/payment-website/templates/da/headline3.xml 2006-12-16 07:10:56 UTC (rev 2115) @@ -8,7 +8,7 @@ @@ -93,7 +93,7 @@ @@ -51,13 +51,13 @@
    Your payment has been successful: Naturbevarelse og befolkningens behov m? ikke st? i modstrid med hinanden.



    - Naturresevatet Samboja Lestari tilbyder en fast indkomst, sundhed og uddanelse til den lokale befolkning. Befolkningen vil blive inkluderet i alle faser af projektet. Landbrug, pleje, produktion af kompost, genplantning og skabelsen af infrastruktur og sikre arbejdspladser. + Naturresevatet Samboja Lestari tilbyder en fast indkomst, sundhed og uddannellse til den lokale befolkning. Befolkningen vil blive inkluderet i alle faser af projektet! Landbrug, pleje, produktion af kompost, genplantning, skabelse af infrastruktur og sikring af arbejdspladser.

    - Naturreservatets sikkerhed er garanteret igennem den Indonesiske befolkningens accept. Projektets success garanterer en bedre levestandard og vice versa. + Naturreservatets sikkerhed er garanteret igennem den Indonesiske befolknings accept. Projektets succes garanterer en bedre levestandard og vice versa.
    - Orangutanger, ogs? kaldet Skovmenneske, er st?rkt truede menneskeaber. + Orangutangen, ogs? kaldet Skovmenneske, er st?rkt truede menneskeaber.



    - Orangutanger er ikke kun vores n?rmeste sl?gtning i dyreriget; men er samtidig absolut uundv?rlige for regnskovens biologiske mangfoldighed i kraft af deres rolle som fr?spredere. De er en s?kaldt "paraplyart." Og beskyttelsen af disse fascinerende menneskeaber g?r det samtidig muligt at bevare regnskovens ?ko system. + Orangutangen er ikke kun vores n?rmeste sl?gtning i dyreriget; men er samtidig absolut uundv?rlig for regnskovens biologiske mangfoldighed i kraft af dens rolle som fr?spreder. Den er en s?kaldt "paraplyart." Og beskyttelsen af disse fascinerende menneskeaber g?r det samtidigt muligt at bevare regnskovens ?kosystem.



    - I dag lever orangutangerne kun p? Sumatra og Borneo. Og massive ?del?ggelser af regnskoven og skrupell?s k?ledyrshandel kan i sidste instands betyde enden for denne art. Solbj?rne er ogs? i fare for at miste deres naturlige levesteder. Her er naturreservatet Samboja Lestari et sidste tilflugtsted for flere forskellige dyr - en sidste chance for deres overlevelse. Solbj?rne lever allerede i reservatet i et omr?de, hvor orangutanger om et par ?r ogs? vil kunne leve i frihed. + I dag lever orangutangerne kun p? Sumatra og Borneo. Og massive ?del?ggelser af regnskoven og skrupell?s k?ledyrshandel kan i sidste instans betyde enden for denne art. Solbj?rne er ogs? i fare for at miste deres naturlige levesteder. Her er naturreservatet Samboja Lestari et sidste tilflugtsted for flere forskellige dyr - en sidste chance for deres overlevelse. Solbj?rne lever allerede i reservatet i et omr?de, hvor orangutanger om et par ?r ogs? vil kunne leve i frihed.



    - Sj?ldne arter som N?sehornsfuglen, dv?rdhjorten og konge kobraen kan allerede observeres i Samboja Lestari i dag. + Sj?ldne arter som N?sehornsfuglen, dv?rghjorten og kongekobraen kan allerede observeres i Samboja Lestari i dag.
    - Ved hj?lp af et unikt skovrejsnings koncept har BOS skabt et reservat for orangutanger, solbj?rne og andre truede dyrearter p? Borneo- m?ske det sidste af sin art. -Satelit fotos her p? internetet g?r det muligt at observere konceptets fremgang. + Ved hj?lp af et unikt skovrejsningskoncept har BOS skabt et reservat for orangutanger, solbj?rne og andre truede dyrearter p? Borneo- m?ske det sidste af sin art. +Satellit fotos her p? internettet g?r det muligt at observere konceptets fremgang.



    I l?bet af de sidste ?rtier er den engang s? artsrige regnskov i Samboja Lestari blevet n?desl?st f?ldet og nedbr?ndt. - N?ringsopslugende elefantgr?s tog over og hvad blev tilbage var en ?kologisk ?demark. I dag er det dog allerede tydeligt at dette ikke beh?ver forts?tte - siden 2001 har BOS skabt ny regnskov. -Et nyskabende skovrejsnings- og beskyttelses-koncept forandre dette over 16 mio sqm store omr?de til et naturligt levested igen. P? tropiske Borneo gror planter meget hurtigere end i Europa, og allerede indenfor f? ?r vil de f?rste orangutanger kunne blive set ud og dele friheden med andre dyr. Et naturreservat er blevet skabt til fremtidig brug for mennesker, dyr og planter i Samboja Lestari; ("et b?rerdygtigt Samboja"). + N?ringsopslugende elefantgr?s tog over, og hvad blev tilbage var en ?kologisk ?demark. I dag er det dog allerede tydeligt, at dette ikke beh?ver forts?tte - siden 2001 har BOS skabt ny regnskov. +Et nyskabende skovrejsnings- og beskyttelses-koncept forandre dette over 16 mio kvadratmeter store omr?de til et naturligt levested igen. P? tropiske Borneo gror planter meget hurtigere end i Europa, og allerede indenfor f? ?r vil de f?rste orangutanger kunne blive sat ud og dele friheden med andre dyr. Et naturreservat er blevet skabt til fremtidig brug for mennesker, dyr og planter i Samboja Lestari; "et b?rerdygtigt Samboja."
    Du hj?lper med at financere opk?bet af land, ?kologisk skovrejsning, en b?rnehave, ?kologisk landbrug, sukker-palme plantager, l?n til de Indonesiske ansatte, overv?gning og beskyttelse af omr?det, bek?mpelse af skovbr?nde, milj?-information, infrastruktur, research og arboret, orangutang ?er og omr?der til Sol-bj?rne.



    -Bidrag til en bedre fremtid og f?lg med i udviklingen af projektet i Samboja Lestari p? internetet. +Bidrag til en bedre fremtid og f?lg med i udviklingen af projektet i Samboja Lestari p? internettet.
    Modified: trunk/projects/bos/payment-website/templates/da/toplevel.xml =================================================================== --- trunk/projects/bos/payment-website/templates/da/toplevel.xml 2006-12-12 19:37:54 UTC (rev 2112) +++ trunk/projects/bos/payment-website/templates/da/toplevel.xml 2006-12-15 12:23:52 UTC (rev 2113) @@ -48,7 +48,7 @@
    l
    l
    Modified: trunk/projects/bos/payment-website/templates/da/toplevel_main.xml =================================================================== --- trunk/projects/bos/payment-website/templates/da/toplevel_main.xml 2006-12-12 19:37:54 UTC (rev 2112) +++ trunk/projects/bos/payment-website/templates/da/toplevel_main.xml 2006-12-15 12:23:52 UTC (rev 2113) @@ -44,7 +44,7 @@
    l
    l
    From bknr at bknr.net Fri Dec 15 13:27:07 2006 From: bknr at bknr.net (bknr at bknr.net) Date: Fri, 15 Dec 2006 08:27:07 -0500 (EST) Subject: [bknr-cvs] r2114 - trunk/projects/bos/worldpay-test Message-ID: <20061215132707.C1BF04D004@common-lisp.net> Author: hhubner Date: 2006-12-15 08:27:05 -0500 (Fri, 15 Dec 2006) New Revision: 2114 Modified: trunk/projects/bos/worldpay-test/tags.lisp Log: Danish product name for Worldpay payment added. Modified: trunk/projects/bos/worldpay-test/tags.lisp =================================================================== --- trunk/projects/bos/worldpay-test/tags.lisp 2006-12-15 12:23:52 UTC (rev 2113) +++ trunk/projects/bos/worldpay-test/tags.lisp 2006-12-15 13:27:05 UTC (rev 2114) @@ -91,9 +91,12 @@ (store-object-id contract) price language - (encode-urlencoded (format nil "~A ~A in Samboja Lestari" + (encode-urlencoded (format nil "~A ~A Samboja Lestari" numsqm - (if (string-equal language "de") "qm Regenwald" "sqm rain forest"))) + (case (make-keyword-from-string language) + (:de "qm Regenwald in") + (:da "sqm Regnskov i") + (t "sqm rain forest in")))) (store-object-id sponsor) (sponsor-master-code sponsor) (if donationcert-yearly "1" "0") From bknr at bknr.net Sat Dec 16 07:10:58 2006 From: bknr at bknr.net (bknr at bknr.net) Date: Sat, 16 Dec 2006 02:10:58 -0500 (EST) Subject: [bknr-cvs] r2115 - trunk/projects/bos/payment-website/templates/da Message-ID: <20061216071058.ABEBB51003@common-lisp.net> Author: hhubner Date: 2006-12-16 02:10:56 -0500 (Sat, 16 Dec 2006) New Revision: 2115 Modified: trunk/projects/bos/payment-website/templates/da/archive.xml trunk/projects/bos/payment-website/templates/da/bestellung.xml trunk/projects/bos/payment-website/templates/da/bos.xml trunk/projects/bos/payment-website/templates/da/certificat.xml trunk/projects/bos/payment-website/templates/da/contact.xml trunk/projects/bos/payment-website/templates/da/headline2.xml trunk/projects/bos/payment-website/templates/da/headline3.xml trunk/projects/bos/payment-website/templates/da/idea.xml trunk/projects/bos/payment-website/templates/da/idea_subtitle1.xml trunk/projects/bos/payment-website/templates/da/idea_subtitle2.xml trunk/projects/bos/payment-website/templates/da/index.xml trunk/projects/bos/payment-website/templates/da/privacy.xml trunk/projects/bos/payment-website/templates/da/profil.xml trunk/projects/bos/payment-website/templates/da/profil_setup.xml trunk/projects/bos/payment-website/templates/da/quittung.xml trunk/projects/bos/payment-website/templates/da/ueberweisung.xml trunk/projects/bos/payment-website/templates/da/versand_info.xml Log: Checking in danish files before going on line. Modified: trunk/projects/bos/payment-website/templates/da/archive.xml =================================================================== --- trunk/projects/bos/payment-website/templates/da/archive.xml 2006-12-15 13:27:05 UTC (rev 2114) +++ trunk/projects/bos/payment-website/templates/da/archive.xml 2006-12-16 07:10:56 UTC (rev 2115) @@ -1,7 +1,7 @@ -

    NYHEDSARKIV

    +

    Nyhedsarkiv

    Modified: trunk/projects/bos/payment-website/templates/da/bestellung.xml =================================================================== --- trunk/projects/bos/payment-website/templates/da/bestellung.xml 2006-12-15 13:27:05 UTC (rev 2114) +++ trunk/projects/bos/payment-website/templates/da/bestellung.xml 2006-12-16 07:10:56 UTC (rev 2115) @@ -1,11 +1,6 @@ - +
    @@ -33,9 +28,9 @@
    - Vi takker for din beslutning om st?tte til Indonesiens folk, natur og dyreliv. + Vi takker for din beslutning om st?tte til Indonesiens folk, natur og dyreliv.



    - Din st?tte er et vigtig bidrag i kampen hen mod at sikre et holdbart projektarbejde i Samboja Lestari.

    + Din st?tte er et vigtig bidrag i kampen hen mod at sikre et holdbart projektarbejde i Samboja Lestari.

    ... mere @@ -62,6 +57,7 @@
    + Modified: trunk/projects/bos/payment-website/templates/da/bos.xml =================================================================== --- trunk/projects/bos/payment-website/templates/da/bos.xml 2006-12-15 13:27:05 UTC (rev 2114) +++ trunk/projects/bos/payment-website/templates/da/bos.xml 2006-12-16 07:10:56 UTC (rev 2115) @@ -21,7 +21,7 @@



    • - Konfiskering af ulovligt tilfangetagede orangutanger, sol-bj?rne og andre arter + Konfiskering af ulovligt tilfangetagede orangutanger, solbj?rne og andre arter
    • Genuds?tning af orangutanger til "stationer" @@ -36,16 +36,16 @@ Genplantning og beskyttelse af regnskoven
    • - Skabelsen af alternativer til den lokale befolkning + Skabelse af alternativer til den lokale befolkning
    • - Udannellse i ?kologi til den lokale befolkning + Uddannelse i ?kologi til den lokale befolkning
    • Overv?gning af beskyttede omr?der
    • - Analyse af satelit fotos + Analyse af satellit fotos
    • og mange andre omr?der. Modified: trunk/projects/bos/payment-website/templates/da/certificat.xml =================================================================== --- trunk/projects/bos/payment-website/templates/da/certificat.xml 2006-12-15 13:27:05 UTC (rev 2114) +++ trunk/projects/bos/payment-website/templates/da/certificat.xml 2006-12-16 07:10:56 UTC (rev 2115) @@ -3,6 +3,6 @@

      S?dan vil dit Regnskovs Diplom se ud:

      - +
      Modified: trunk/projects/bos/payment-website/templates/da/contact.xml =================================================================== --- trunk/projects/bos/payment-website/templates/da/contact.xml 2006-12-15 13:27:05 UTC (rev 2114) +++ trunk/projects/bos/payment-website/templates/da/contact.xml 2006-12-16 07:10:56 UTC (rev 2115) @@ -54,7 +54,7 @@
    - -
    @@ -163,10 +159,8 @@
    - - - - + +
    Vil du vide mere om BOS's projekter? + Vil du vide mere om BOS projekter?



    @@ -69,7 +69,7 @@
    P? disse hjemmesider kan du finde information om BOS's partnere rundt om i verden. + P? disse hjemmesider kan du finde information om BOS partnere rundt om i verden.
    Modified: trunk/projects/bos/payment-website/templates/da/headline2.xml =================================================================== --- trunk/projects/bos/payment-website/templates/da/headline2.xml 2006-12-15 13:27:05 UTC (rev 2114) +++ trunk/projects/bos/payment-website/templates/da/headline2.xml 2006-12-16 07:10:56 UTC (rev 2115) @@ -29,7 +29,7 @@
    Naturbevarelse og befolkningens behov m? ikke st? i modstrid med hinanden.



    - Naturresevatet Samboja Lestari tilbyder en fast indkomst, sundhed og uddannellse til den lokale befolkning. Befolkningen vil blive inkluderet i alle faser af projektet! Landbrug, pleje, produktion af kompost, genplantning, skabelse af infrastruktur og sikring af arbejdspladser. + Naturreservatet Samboja Lestari tilbyder en fast indkomst, sundhed og uddannelse til den lokale befolkning. Befolkningen vil blive inkluderet i alle faser af projektet; Landbrug, pleje, produktion af kompost, genplantning, skabelse af infrastruktur og sikring af arbejdspladser.

    - "Dette tilbyder et alternativ til befolkningen, s? de ikke l?ngere beh?ver at f?lde regnskoven. En m?de hvorp? vi kan vise verden at naturen og menneskene kan eksisterer side om side, uden at den ene udelukker den anden." + "Dette tilbyder et alternativ til befolkningen, s? de ikke l?ngere beh?ver at f?lde regnskoven. En m?de hvorp? vi kan vise verden at naturen og menneskene kan eksistere side om side, uden at den ene udelukker den anden."

    - siger Dr. Willie Smits, Formand for BOS Indonesia. + siger Dr. Willie Smits, Formand for BOS Indonesien.

    - Orangutanger, Sol-bj?rne og N?sehornsfugle + Orangutanger, Solbj?rne og N?sehornsfugle @@ -25,9 +25,9 @@
    - Orangutangen, ogs? kaldet Skovmenneske, er st?rkt truede menneskeaber. + Orangutanger, ogs? kaldet Skovmenneske, er st?rkt truede menneskeaber.



    - Orangutangen er ikke kun vores n?rmeste sl?gtning i dyreriget; men er samtidig absolut uundv?rlig for regnskovens biologiske mangfoldighed i kraft af dens rolle som fr?spreder. Den er en s?kaldt "paraplyart." Og beskyttelsen af disse fascinerende menneskeaber g?r det samtidigt muligt at bevare regnskovens ?kosystem. + Orangutangen er ikke kun vores n?rmeste sl?gtning i dyreriget, men er samtidig absolut uundv?rlig for regnskovens biologiske mangfoldighed i kraft af dens rolle som fr?spreder. Den er en s?kaldt "paraplyart." Beskyttelsen af disse fascinerende menneskeaber g?r det samtidigt muligt at bevare regnskovens ?kosystem.



    I dag lever orangutangerne kun p? Sumatra og Borneo. Og massive ?del?ggelser af regnskoven og skrupell?s k?ledyrshandel kan i sidste instans betyde enden for denne art. Solbj?rne er ogs? i fare for at miste deres naturlige levesteder. Her er naturreservatet Samboja Lestari et sidste tilflugtsted for flere forskellige dyr - en sidste chance for deres overlevelse. Solbj?rne lever allerede i reservatet i et omr?de, hvor orangutanger om et par ?r ogs? vil kunne leve i frihed. Modified: trunk/projects/bos/payment-website/templates/da/idea.xml =================================================================== --- trunk/projects/bos/payment-website/templates/da/idea.xml 2006-12-15 13:27:05 UTC (rev 2114) +++ trunk/projects/bos/payment-website/templates/da/idea.xml 2006-12-16 07:10:56 UTC (rev 2115) @@ -27,15 +27,15 @@
    - Ved hj?lp af et unikt skovrejsningskoncept har BOS skabt et reservat for orangutanger, solbj?rne og andre truede dyrearter p? Borneo- m?ske det sidste af sin art. -Satellit fotos her p? internettet g?r det muligt at observere konceptets fremgang. + Ved hj?lp af et unikt skovrejsningsprogram har BOS skabt et reservat for orangutanger, solbj?rne og andre truede dyrearter p? Borneo- m?ske det sidste af sin art. +Satellit fotos her p? internettet g?r det muligt at observere programmets fremgang.



    I l?bet af de sidste ?rtier er den engang s? artsrige regnskov i Samboja Lestari blevet n?desl?st f?ldet og nedbr?ndt. - N?ringsopslugende elefantgr?s tog over, og hvad blev tilbage var en ?kologisk ?demark. I dag er det dog allerede tydeligt, at dette ikke beh?ver forts?tte - siden 2001 har BOS skabt ny regnskov. -Et nyskabende skovrejsnings- og beskyttelses-koncept forandre dette over 16 mio kvadratmeter store omr?de til et naturligt levested igen. P? tropiske Borneo gror planter meget hurtigere end i Europa, og allerede indenfor f? ?r vil de f?rste orangutanger kunne blive sat ud og dele friheden med andre dyr. Et naturreservat er blevet skabt til fremtidig brug for mennesker, dyr og planter i Samboja Lestari; "et b?rerdygtigt Samboja." + N?ringsopslugende elefantgr?s tog over, og hvad der blev tilbage var en ?kologisk ?demark. I dag er det dog allerede tydeligt, at dette ikke beh?ver forts?tte - siden 2001 har BOS skabt ny regnskov. +Et nyskabende skovrejsnings- og beskyttelsesprogram forandrer dette over 16 mio kvadratmeter store omr?de til et naturligt levested igen. P? tropiske Borneo gror planter meget hurtigere end i Europa, og allerede indenfor f? ?r vil de f?rste orangutanger kunne s?ttes ud og dele friheden med andre dyr. Et naturreservat er blevet skabt til fremtidig brug for mennesker, dyr og planter i Samboja Lestari; "et b?redygtigt Samboja."
    - Til at finansiere natur reservatet har BOS skabt et system med symbolske opk?b af land. + Til at finansiere naturreservatet har BOS skabt et system med symbolsk opk?b af land.

    ... Modified: trunk/projects/bos/payment-website/templates/da/idea_subtitle1.xml =================================================================== --- trunk/projects/bos/payment-website/templates/da/idea_subtitle1.xml 2006-12-15 13:27:05 UTC (rev 2114) +++ trunk/projects/bos/payment-website/templates/da/idea_subtitle1.xml 2006-12-16 07:10:56 UTC (rev 2115) @@ -26,11 +26,11 @@
    -I de tidlige stadier af skovrejsningen planter Indonesiske landm?nd overskydsgivende afgr?der imellem de nyplantede tr?er. +I de tidlige stadier af skovrejsningen planter Indonesiske landm?nd overskudsgivende afgr?der imellem de nyplantede tr?er.



    -Landbrug og skovrejsning p?virker hinanden p? mange positive m?der: afgr?derne beskytter de unge tr?er mod at blive overgroet af elefantgr?sser. Og tr?er g?der jorden og giver skygge. +Landbrug og skovrejsning p?virker hinanden p? mange positive m?der: afgr?derne beskytter de unge tr?er imod at blive overgroet af elefantgr?sser. Og tr?er g?der jorden og giver skygge.



    -BOS garanterer at k?be landm?ndenes frugt som papaya og ananas, putte dem p? det regionale marked eller bruge dem til egne forsyninger. Alene forsyningerne til orangutangerne p? rehabiliteringscenteret Wanariset er p? omkring 1000 kg. frugt dagligt. +BOS garanterer at k?be landm?ndenes frugt som papaya og ananas, afs?tte dem p? det regionale marked eller bruge dem til egne forsyninger. Alene forsyningerne til orangutangerne p? rehabiliteringscenteret Wanariset er p? omkring 1000 kg. frugt dagligt.
    - En cirkel af sukker-palme plantager bliver plantet hele vejen rundt om naturreservatet. Over 650 familier vil profitere fra hovedproduktet; sukker. Og cirklen skaber samtidig en barriere mod de meget frygtede skovbr?nde. + En cirkel af sukkerpalme plantager bliver plantet hele vejen rundt om naturreservatet. Over 650 familier vil profitere fra hovedproduktet; sukker. Og cirklen skaber samtidig en barriere mod de meget frygtede skovbr?nde.



    -At menneskene bryder ind i natur reservatet, eller orangutangerne ud er forhindret af en indre beskyttelses-v?g af tykt-voksende og stikkende, slibrige palmer. Ydermere er frugten fra disse palmer en velsmagende f?dekilde for b?de mennesker og dyr. +At menneskene bryder ind i natur reservatet, eller at orangutangerne bryder ud, er forhindret af en indre beskyttelsesv?g af tyktvoksende og stikkende, kl?brige palmer. Ydermere er frugten fra disse palmer en velsmagende f?dekilde for b?de mennesker og dyr.
    -Ultralyds fly og moderne satelit teknik st?tter den permanente overv?gning af BOS projekter, hvilket altsammen hj?lper til at bek?mpe "slash-and-burn" og ulovlig skovhugst mere effiktivt. +Ultralyds fly og moderne satellit teknik st?tter den permanente overv?gning af BOS projekter, hvilket altsammen hj?lper til at bek?mpe "slash-and-burn" og ulovlig skovhugst mere effektivt.
    Modified: trunk/projects/bos/payment-website/templates/da/idea_subtitle2.xml =================================================================== --- trunk/projects/bos/payment-website/templates/da/idea_subtitle2.xml 2006-12-15 13:27:05 UTC (rev 2114) +++ trunk/projects/bos/payment-website/templates/da/idea_subtitle2.xml 2006-12-16 07:10:56 UTC (rev 2115) @@ -17,17 +17,17 @@ - Til at finansiere natur reservatet har BOS skabt et system med symbolske opk?b af land. + Til at finansiere naturreservatet har BOS skabt et system med symbolsk opk?b af land.



    - For 3 Euros per m? kan du hj?lpe med at skabe ny regnskov. + For 3 Euro per m? kan du hj?lpe med at skabe ny regnskov.



    - Du hj?lper med at financere opk?bet af land, ?kologisk skovrejsning, en b?rnehave, ?kologisk landbrug, sukker-palme plantager, l?n til de Indonesiske ansatte, overv?gning og beskyttelse af omr?det, bek?mpelse af skovbr?nde, milj?-information, infrastruktur, research og arboret, orangutang ?er og omr?der til Sol-bj?rne. + Du hj?lper med at financiere opk?bet af land, ?kologisk skovrejsning, en b?rnehave, ?kologisk landbrug, sukkerpalme plantager, l?n til de Indonesiske ansatte, overv?gning og beskyttelse af omr?det, bek?mpelse af skovbr?nde, milj?information, infrastruktur, research og arboret, orangutang ?er samt omr?der til Solbj?rne.



    Bidrag til en bedre fremtid og f?lg med i udviklingen af projektet i Samboja Lestari p? internettet. @@ -38,12 +38,12 @@

    - Hver kvadratmeter som du symbolsk opk?ber vil blive overdraget til dig via en personlig profil. Via et password vil du s? nemt kunne genfinde dine kvadratmeter til hver en tid. Det er ogs? muligt at placerer korte informationer p? 'din' kvadratmeter og derved kommunikerer med andre Samboja Lestari-sponsorer. -Bes?gende p? denne website vil alts? have mulighed for at f? indsigt i samtlige m? and deres personlige profiler. + Hver kvadratmeter som du symbolsk opk?ber vil blive overdraget til dig via en personlig profil. Via et password vil du s? nemt kunne genfinde dine kvadratmeter til hver en tid. Det er ogs? muligt at placere korte informationer p? 'dine' kvadratmeter og derved kommunikere med andre Samboja Lestari-sponsorer. +Bes?gende p? denne website vil alts? have mulighed for at f? indsigt i samtlige m? og deres personlige profiler.



    - Observer udviklingen i 'dit' omr?de fra forskellige perspektiver. BOS giver en klar indsigt via satelit fotos, og giver regelm?ssige reporter om fremgangen i situ. + Observer udviklingen i 'dit' omr?de fra forskellige perspektiver. BOS giver en klar indsigt via satellit fotos og giver regelm?ssige reporter om fremgangen in situ.



    - St?t projektet og modtag et regnskovs Diplom. Du kan ogs? give regnskovs-kvadratmeter som en gave til venner, sl?gtninge og andre mennesker du kender. + St?t projektet og modtag et regnskovs Diplom. Du kan ogs? give regnskovskvadratmeter som en gave til venner, sl?gtninge og bekendte.



    Deltag, se regnskov gro - Og meget mere! Modified: trunk/projects/bos/payment-website/templates/da/index.xml =================================================================== --- trunk/projects/bos/payment-website/templates/da/index.xml 2006-12-15 13:27:05 UTC (rev 2114) +++ trunk/projects/bos/payment-website/templates/da/index.xml 2006-12-16 07:10:56 UTC (rev 2115) @@ -26,8 +26,8 @@ - Ved hj?lp af et unikt skovrejsnings koncept har BOS skabt et reservat for orangutanger, solbj?rne og andre truede dyrearter p? Borneo- m?ske det sidste. -Satelit fotos her p? internetet g?r det muligt at observere konceptets fremgang. + Ved hj?lp af et unikt skovrejsningsprogram har BOS skabt et reservat for orangutanger, solbj?rne og andre truede dyrearter p? Borneo- m?ske det sidste. +Satellit fotos her p? internettet g?r det muligt at observere programmets fremgang.

    ... mere Modified: trunk/projects/bos/payment-website/templates/da/privacy.xml =================================================================== --- trunk/projects/bos/payment-website/templates/da/privacy.xml 2006-12-15 13:27:05 UTC (rev 2114) +++ trunk/projects/bos/payment-website/templates/da/privacy.xml 2006-12-16 07:10:56 UTC (rev 2115) @@ -11,25 +11,24 @@

    N?r du har besluttet dig for at lave en donation online, vil du blive bedt om at give dine bank-oplysninger. Denne information vil blive behandlet egenh?ndigt af WorldPay. -WorldPay er en anerkendt, international udbyder af online betalling. -Din data vil blive sendt til WorldPay gennem en kodet SSL-forbindelse, +WorldPay er en anerkendt, international udbyder af online betaling. +Dine data vil blive sendt til WorldPay gennem en kodet SSL-forbindelse, og vil blive slettet straks efter en successfuld transaktion. -BOS International har ellers ingen afgang til din bank-information. +BOS International har ellers ingen adgang til din bank-information.

    -Hver kvardratmeter du sponserer med din donation er linket til din personlige profil. Denne profil best?r af dit navn, hjemland, antal kvardratmeter du sponserer og datoen for din donation. -Det er desuden muligt at skrive en personlig hilsen. Alt profil-information (undtagen e-mail addresse og post addresse) vil v?re tilg?ngelig til bes?gende p? vores website. P? denne m?de promoveres kommunikation og menningsudveksling mellem vores sponsore. Profil information kan altid ?ndres ved at logge ind med dit password. Ved at g?re dette, er det ogs? muligt at forblive anonym. +Hver kvadratmeter du sponsorerer med din donation er linket til din personlige profil. Denne profil best?r af dit navn, hjemland, antal kvadratmeter du sponsorerer og datoen for din donation. +Det er desuden muligt at skrive en personlig hilsen. Al profil-information (undtagen e-mail adresse og post adresse) vil v?re tilg?ngelig for bes?gende p? vores website. P? denne m?de promoveres kommunikation og menningsudveksling mellem vores sponsorer. Profil information kan altid ?ndres ved at logge ind med dit password. Ved at g?re dette, er det ogs? muligt at forblive anonym.

    For at kunne sende dig din personlige profil, indeholdende dit sponsor-ID og password, skal vi bruge din e-mail addresse. -For at kunne sende dit Regnskovs Diplom med normal post skal vi bruge din post addresse, og navnet p? den person diplomet skal udstedes til. -For at kunne modtage vores nyhedsbrev/nyhedher, skal vi bruge din e-mail addresse. +For at kunne sende dit Regnskovs Diplom med normal post skal vi bruge din post adresse, og navnet p? den person diplomet skal udstedes til. +For at kunne modtage vores nyhedsbrev/nyheder, skal vi ligeledes bruge din e-mail adresse.

    -Vi forsikre dig om at din data kun vil blive brugt til administrative og informative form?l for BOS international. -Hvis du p? noget tidspunkt ikke l?ngere ?nsker at modtage mere information fra os, kan du til hver en tid slette din data fra vores system. In case you do not wish to receive any more information from us, you are able to -delete your data from the system at any time. +Vi forsikrer dig om at dine data kun vil blive brugt til administrative og informative form?l for BOS international. +Hvis du p? noget tidspunkt ikke l?ngere ?nsker at modtage mere information fra os, kan du til hver en tid slette din data fra vores system. Til dette form?l, v?r venlig altid at oplyse dit sponsor ID!

    Modified: trunk/projects/bos/payment-website/templates/da/profil.xml =================================================================== --- trunk/projects/bos/payment-website/templates/da/profil.xml 2006-12-15 13:27:05 UTC (rev 2114) +++ trunk/projects/bos/payment-website/templates/da/profil.xml 2006-12-16 07:10:56 UTC (rev 2115) @@ -104,7 +104,7 @@ - + tilbage Modified: trunk/projects/bos/payment-website/templates/da/profil_setup.xml =================================================================== --- trunk/projects/bos/payment-website/templates/da/profil_setup.xml 2006-12-15 13:27:05 UTC (rev 2114) +++ trunk/projects/bos/payment-website/templates/da/profil_setup.xml 2006-12-16 07:10:56 UTC (rev 2115) @@ -139,7 +139,7 @@ - + Modified: trunk/projects/bos/payment-website/templates/da/quittung.xml =================================================================== --- trunk/projects/bos/payment-website/templates/da/quittung.xml 2006-12-15 13:27:05 UTC (rev 2114) +++ trunk/projects/bos/payment-website/templates/da/quittung.xml 2006-12-16 07:10:56 UTC (rev 2115) @@ -123,7 +123,7 @@ - + Modified: trunk/projects/bos/payment-website/templates/da/ueberweisung.xml =================================================================== --- trunk/projects/bos/payment-website/templates/da/ueberweisung.xml 2006-12-15 13:27:05 UTC (rev 2114) +++ trunk/projects/bos/payment-website/templates/da/ueberweisung.xml 2006-12-16 07:10:56 UTC (rev 2115) @@ -2,7 +2,7 @@ + onsubmit="YY_checkform('mailtransfer','vorname','#q','0','Bitte das Feld \'Vorname\' ausfuellen.','name','#q','0','Bitte das Feld \'Name\' ausfuellen.','strasse','#q','0','Bitte das Feld \'Strasse\' ausfuellen.','plz','#q','0','Bitte das Feld \'PLZ\' ausfuellen.','ort','#q','0','Bitte das Feld \'Ort\' ausfuellen.');return document.MM_returnValue"> - + @@ -70,22 +70,22 @@ - + - + - + - +
    Jeg vil overf?re mit bidrag til BOS Danmark via min bank!Ich m?chte meine Spende ?berweisen.
    -Jeg har besluttet mig for at overf?re et bidrag p? $(amount) kroner til Samboja Lestari via BOS Danmark. +Ich habe mich dazu entschieden einen Betrag von $(amount) Euro auf das Spendenkonto "Samboja Lestari" von BOS Deutschland e.V. zu ?berweisen. - - - + + +
    Kontonummer:0001718891
    Bank:Merkur Bank
    Reg.Nr.: 8401
    Kontonummer:32 10 100
    Bank:Bank f?r Sozialwirtschaft
    BLZ:100 205 00
    - Vigtigt! Du skal anf?re "SL ID $(contract-id)" p? bankoverf?rslen, s? vi kan genkende din betaling. + Bitte unbedingt den Verwendungszweck "SL ID $(contract-id)" auf dem ?berweisungsformular angeben!

    - Meine Husk, at du selv st?r for overf?rslen via din bank til BOS Danmarks konto. + Meine ?berweisung muss ich bei meiner Bank eigenst?ndig veranlassen!
    Fornavn:Vorname:
    Efternavn:Name:
    Gade/Nr.:Stra?e/Nr.:
    Kommune:PLZ/Ort @@ -107,7 +107,7 @@
    - +
    @@ -116,29 +116,31 @@

    - [Personlige oplysninger] + [Pers?nliche Daten]
    -Vi reserverer gerne det ?nskede antal m??. -Vi har brug for nogle personlige oplysninger for at kunne sende dig informationer om (regnskovsbevis, sponsorprofil, geografisk koordinater, bidragskvittering). -N?r vi har modtaget bidraget, sender vi dig alle ovenfor n?vnte informationer per brev eller e-mail. +Wir reservieren gerne die von Ihnen gew?nschten m?. F?r die Zusendung +der entsprechenden Informationen (Regenwaldurkunde, Sponsorenprofil, +Geokoordinaten, Spendenbescheinigung) ben?tigen wir unbedingt die +Angabe Ihrer Daten. Nach erfolgter ?berweisung erhalten Sie diese +Informationen schriftlich oder per E-Mail von uns.


    - [Denne formular] + [Dieses Formular]
    - Send os venligst denne formular direkte per e-mail, eller + Bitte senden Sie dieses Formular per E-Mail direkt an uns. Sie k?nnen es auch - udskriv + ausdrucken - den og send den til os per fax eller post: + und per Fax oder Post an unsere + Kontaktadresse schicken:

    - BOS Danmark + BOS Deutschland e.V.
    - ?kologihuset,
    - Blegdamsvej 4b + Sch?neberger Ufer 69
    - 2200 K?benhavn N + 10785 Berlin

    - Fax: +45 3537 3636 + Fax: (030) 2636 7815
    Modified: trunk/projects/bos/payment-website/templates/da/versand_info.xml =================================================================== --- trunk/projects/bos/payment-website/templates/da/versand_info.xml 2006-12-15 13:27:05 UTC (rev 2114) +++ trunk/projects/bos/payment-website/templates/da/versand_info.xml 2006-12-16 07:10:56 UTC (rev 2115) @@ -50,7 +50,7 @@ - for din st?tte og for din tilld til BOS.

    The m? du har sponseret er i gode h?nder. + for din st??tte og for din tilld til BOS.

    The m?? du har sponseret er i gode h??nder. @@ -98,7 +98,7 @@ - I hvilket navn skal vi udstede dit Regnskovs diplom? [Vi acceptere det intastede navn i dette felt. V?r venlig at ?ndre navnet om n?dvendigt. ] + I hvilket navn skal vi udstede dit Regnskovs diplom? [Vi acceptere det intastede navn i dette felt. V??r venlig at ??ndre navnet om n??dvendigt. ] @@ -156,8 +156,8 @@


    - [Betalings-bekr?ftigelse]
    - Denne betalings-bekr?ftigelse fra WorldPay er allerede undervejs til din indbox. I den uventede situation at du ikke skulle modtage nogen besked, venligst kontakt: + [Betalings-bekr??ftigelse]
    + Denne betalings-bekr??ftigelse fra WorldPay er allerede undervejs til din indbox. I den uventede situation at du ikke skulle modtage nogen besked, venligst kontakt:
    From bknr at bknr.net Sat Dec 16 07:40:30 2006 From: bknr at bknr.net (bknr at bknr.net) Date: Sat, 16 Dec 2006 02:40:30 -0500 (EST) Subject: [bknr-cvs] r2116 - trunk/projects/bos/payment-website/templates/da Message-ID: <20061216074030.B72D219007@common-lisp.net> Author: hhubner Date: 2006-12-16 02:40:30 -0500 (Sat, 16 Dec 2006) New Revision: 2116 Modified: trunk/projects/bos/payment-website/templates/da/bestellung.xml Log: Remove download-only parameter for danish version _again_. Modified: trunk/projects/bos/payment-website/templates/da/bestellung.xml =================================================================== --- trunk/projects/bos/payment-website/templates/da/bestellung.xml 2006-12-16 07:10:56 UTC (rev 2115) +++ trunk/projects/bos/payment-website/templates/da/bestellung.xml 2006-12-16 07:40:30 UTC (rev 2116) @@ -57,7 +57,6 @@
    - Modified: trunk/projects/bos/payment-website/templates/da/certificat.xml =================================================================== --- trunk/projects/bos/payment-website/templates/da/certificat.xml 2006-12-16 07:40:30 UTC (rev 2116) +++ trunk/projects/bos/payment-website/templates/da/certificat.xml 2006-12-18 19:15:59 UTC (rev 2117) @@ -3,6 +3,6 @@

    S?dan vil dit Regnskovs Diplom se ud:

    - +
    Added: trunk/projects/bos/payment-website/templates/da/certificate.xml =================================================================== --- trunk/projects/bos/payment-website/templates/da/certificate.xml 2006-12-16 07:40:30 UTC (rev 2116) +++ trunk/projects/bos/payment-website/templates/da/certificate.xml 2006-12-18 19:15:59 UTC (rev 2117) @@ -0,0 +1,8 @@ + + + +

    S?dan vil dit Regnskovs Diplom se ud:

    +
    + +
    +
    Modified: trunk/projects/bos/payment-website/templates/da/profil_setup.xml =================================================================== --- trunk/projects/bos/payment-website/templates/da/profil_setup.xml 2006-12-16 07:40:30 UTC (rev 2116) +++ trunk/projects/bos/payment-website/templates/da/profil_setup.xml 2006-12-18 19:15:59 UTC (rev 2117) @@ -139,7 +139,7 @@
    From bknr at bknr.net Mon Dec 18 19:16:01 2006 From: bknr at bknr.net (bknr at bknr.net) Date: Mon, 18 Dec 2006 14:16:01 -0500 (EST) Subject: [bknr-cvs] r2117 - in trunk/projects: bos/payment-website/templates/da bos/worldpay-test quickhoney/src Message-ID: <20061218191601.915F26D06E@common-lisp.net> Author: hhubner Date: 2006-12-18 14:15:59 -0500 (Mon, 18 Dec 2006) New Revision: 2117 Added: trunk/projects/bos/payment-website/templates/da/certificate.xml Modified: trunk/projects/bos/payment-website/templates/da/bestellung.xml trunk/projects/bos/payment-website/templates/da/certificat.xml trunk/projects/bos/payment-website/templates/da/profil_setup.xml trunk/projects/bos/payment-website/templates/da/quittung.xml trunk/projects/bos/payment-website/templates/da/versand_info.xml trunk/projects/bos/payment-website/templates/da/versand_quittung.xml trunk/projects/bos/worldpay-test/tags.lisp trunk/projects/quickhoney/src/webserver.lisp Log: Current danish version and small last-minute fixes. Modified: trunk/projects/bos/payment-website/templates/da/bestellung.xml =================================================================== --- trunk/projects/bos/payment-website/templates/da/bestellung.xml 2006-12-16 07:40:30 UTC (rev 2116) +++ trunk/projects/bos/payment-website/templates/da/bestellung.xml 2006-12-18 19:15:59 UTC (rev 2117) @@ -158,8 +158,8 @@
    - - + +
    - +
    Modified: trunk/projects/bos/payment-website/templates/da/quittung.xml =================================================================== --- trunk/projects/bos/payment-website/templates/da/quittung.xml 2006-12-16 07:40:30 UTC (rev 2116) +++ trunk/projects/bos/payment-website/templates/da/quittung.xml 2006-12-18 19:15:59 UTC (rev 2117) @@ -123,7 +123,7 @@ - + Modified: trunk/projects/bos/payment-website/templates/da/versand_info.xml =================================================================== --- trunk/projects/bos/payment-website/templates/da/versand_info.xml 2006-12-16 07:40:30 UTC (rev 2116) +++ trunk/projects/bos/payment-website/templates/da/versand_info.xml 2006-12-18 19:15:59 UTC (rev 2117) @@ -1,16 +1,10 @@ - - + + - - - + + + @@ -22,7 +16,7 @@