diff options
Diffstat (limited to 'third-party/s-xml')
22 files changed, 2342 insertions, 0 deletions
diff --git a/third-party/s-xml/.clbuild-skip-update b/third-party/s-xml/.clbuild-skip-update new file mode 100644 index 0000000..e69de29 --- /dev/null +++ b/third-party/s-xml/.clbuild-skip-update diff --git a/third-party/s-xml/ChangeLog b/third-party/s-xml/ChangeLog new file mode 100644 index 0000000..7c9ab49 --- /dev/null +++ b/third-party/s-xml/ChangeLog @@ -0,0 +1,66 @@ +2006-01-19 Sven Van Caekenberghe <svc@mac.com> + + * added a set of patches contributed by David Tolpin dvd@davidashen.net : we're now using char of type + Character and #\Null instead of null, read/unread instead of peek/read and some more declarations for + more efficiency - added hooks for customizing parsing attribute names and values + +2005-11-20 Sven Van Caekenberghe <svc@mac.com> + + * added xml prefix namespace as per REC-xml-names-19990114 (by Rudi Schlatte) + +2005-11-06 Sven Van Caekenberghe <svc@mac.com> + + * removed Debian packaging directory (on Luca's request) + * added CDATA support (patch contributed by Peter Van Eynde pvaneynd@mailworks.org) + +2005-08-30 Sven Van Caekenberghe <svc@mac.com> + + * added Debian packaging directory (contributed by Luca Capello luca@pca.it) + * added experimental XML namespace support + +2005-02-03 Sven Van Caekenberghe <svc@mac.com> + + * release 5 (cvs tag RELEASE_5) + * added :start and :end keywords to print-string-xml + * fixed a bug: in a tag containing whitespace, like <foo> </foo> the parser collapsed + and ingnored all whitespace and considered the tag to be empty! + this is now fixed and a unit test has been added + * cleaned up xml character escaping a bit: single quotes and all normal whitespace + (newline, return and tab) is preserved a unit test for this has been added + * IE doesn't understand the ' XML entity, so I've commented that out for now. + Also, using actual newlines for newlines is probably better than using #xA, + which won't get any end of line conversion by the server or user agent. + +June 2004 Sven Van Caekenberghe <svc@mac.com> + + * release 4 + * project moved to common-lisp.net, renamed to s-xml, + * added examples counter, tracer and remove-markup, improved documentation + +13 Jan 2004 Sven Van Caekenberghe <svc@mac.com> + + * release 3 + * added ASDF systems + * optimized print-string-xml + +10 Jun 2003 Sven Van Caekenberghe <svc@mac.com> + + * release 2 + * added echo-xml function: we are no longer taking the car when + the last seed is returned from start-parse-xml + +25 May 2003 Sven Van Caekenberghe <svc@mac.com> + + * release 1 + * first public release of working code + * tested on OpenMCL + * rewritten to be event-based, to improve efficiency and + to optionally use different DOM representations + * more documentation + +end of 2002 Sven Van Caekenberghe <svc@mac.com> + + * release 0 + * as part of an XML-RPC implementation + +$Id: ChangeLog,v 1.6 2006-01-19 20:00:05 scaekenberghe Exp $ diff --git a/third-party/s-xml/Makefile b/third-party/s-xml/Makefile new file mode 100644 index 0000000..bd17b3c --- /dev/null +++ b/third-party/s-xml/Makefile @@ -0,0 +1,35 @@ +# $Id: Makefile,v 1.3 2004-07-08 19:31:22 scaekenberghe Exp $ + +default: + @echo Possible targets: + @echo clean-openmcl --- remove all '*.dfsl' recursively + @echo clean-lw --- remove all '*.nfasl' recursively + @echo clean-emacs --- remove all '*~' recursively + @echo clean --- all of the above + +clean-openmcl: + find . -name "*.dfsl" | xargs rm + +clean-lw: + find . -name "*.nfasl" | xargs rm + +clean-emacs: + find . -name "*~" | xargs rm + +clean: clean-openmcl clean-lw clean-emacs + +# +# This can obviously only be done by a specific person in a very specific context ;-) +# + +PRJ=s-xml +ACCOUNT=scaekenberghe +CVSRT=:ext:$(ACCOUNT)@common-lisp.net:/project/$(PRJ)/cvsroot + +release: + rm -rf /tmp/$(PRJ) /tmp/public_html /tmp/$(PRJ).tgz /tmp/$(PRJ).tgz.asc + cd /tmp; cvs -d$(CVSRT) export -r HEAD $(PRJ); cvs -d$(CVSRT) export -r HEAD public_html + mv /tmp/public_html /tmp/$(PRJ)/doc + cd /tmp; gnutar cvfz $(PRJ).tgz $(PRJ); gpg -a -b $(PRJ).tgz + scp /tmp/$(PRJ).tgz $(ACCOUNT)@common-lisp.net:/project/$(PRJ)/public_html + scp /tmp/$(PRJ).tgz.asc $(ACCOUNT)@common-lisp.net:/project/$(PRJ)/public_html diff --git a/third-party/s-xml/examples/counter.lisp b/third-party/s-xml/examples/counter.lisp new file mode 100644 index 0000000..0154166 --- /dev/null +++ b/third-party/s-xml/examples/counter.lisp @@ -0,0 +1,47 @@ +;;;; -*- mode: lisp -*- +;;;; +;;;; $Id: counter.lisp,v 1.1 2008-02-15 13:54:57 scaekenberghe Exp $ +;;;; +;;;; A simple SSAX counter example that can be used as a performance test +;;;; +;;;; Copyright (C) 2004 Sven Van Caekenberghe, Beta Nine BVBA. +;;;; +;;;; You are granted the rights to distribute and use this software +;;;; as governed by the terms of the Lisp Lesser General Public License +;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. + +(in-package :s-xml) + +(defclass count-xml-seed () + ((elements :initform 0) + (attributes :initform 0) + (characters :initform 0))) + +(defun count-xml-new-element-hook (name attributes seed) + (declare (ignore name)) + (incf (slot-value seed 'elements)) + (incf (slot-value seed 'attributes) (length attributes)) + seed) + +(defun count-xml-text-hook (string seed) + (incf (slot-value seed 'characters) (length string)) + seed) + +(defun count-xml (in) + "Parse a toplevel XML element from stream in, counting elements, attributes and characters" + (start-parse-xml in + (make-instance 'xml-parser-state + :seed (make-instance 'count-xml-seed) + :new-element-hook #'count-xml-new-element-hook + :text-hook #'count-xml-text-hook))) + +(defun count-xml-file (pathname) + "Parse XMl from the file at pathname, counting elements, attributes and characters" + (with-open-file (in pathname) + (let ((result (count-xml in))) + (with-slots (elements attributes characters) result + (format t + "~a contains ~d XML elements, ~d attributes and ~d characters.~%" + pathname elements attributes characters))))) + +;;;; eof diff --git a/third-party/s-xml/examples/echo.lisp b/third-party/s-xml/examples/echo.lisp new file mode 100644 index 0000000..84e7ea1 --- /dev/null +++ b/third-party/s-xml/examples/echo.lisp @@ -0,0 +1,64 @@ +;;;; -*- mode: lisp -*- +;;;; +;;;; $Id: echo.lisp,v 1.1 2008-02-15 13:54:57 scaekenberghe Exp $ +;;;; +;;;; A simple example as well as a useful tool: parse, echo and pretty print XML +;;;; +;;;; Copyright (C) 2002, 2004 Sven Van Caekenberghe, Beta Nine BVBA. +;;;; +;;;; You are granted the rights to distribute and use this software +;;;; as governed by the terms of the Lisp Lesser General Public License +;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. + +(in-package :s-xml) + +(defun indent (stream count) + (loop :repeat (* count 2) :do (write-char #\space stream))) + +(defclass echo-xml-seed () + ((stream :initarg :stream) + (level :initarg :level :initform 0))) + +#+NIL +(defmethod print-object ((seed echo-xml-seed) stream) + (with-slots (stream level) seed + (print-unreadable-object (seed stream :type t) + (format stream "level=~d" level)))) + +(defun echo-xml-new-element-hook (name attributes seed) + (with-slots (stream level) seed + (indent stream level) + (format stream "<~a" name) + (dolist (attribute (reverse attributes)) + (format stream " ~a=\'" (car attribute)) + (print-string-xml (cdr attribute) stream) + (write-char #\' stream)) + (format stream ">~%") + (incf level) + seed)) + +(defun echo-xml-finish-element-hook (name attributes parent-seed seed) + (declare (ignore attributes parent-seed)) + (with-slots (stream level) seed + (decf level) + (indent stream level) + (format stream "</~a>~%" name) + seed)) + +(defun echo-xml-text-hook (string seed) + (with-slots (stream level) seed + (indent stream level) + (print-string-xml string stream) + (terpri stream) + seed)) + +(defun echo-xml (in out) + "Parse a toplevel XML element from stream in, echoing and pretty printing the result to stream out" + (start-parse-xml in + (make-instance 'xml-parser-state + :seed (make-instance 'echo-xml-seed :stream out) + :new-element-hook #'echo-xml-new-element-hook + :finish-element-hook #'echo-xml-finish-element-hook + :text-hook #'echo-xml-text-hook))) + +;;;; eof diff --git a/third-party/s-xml/examples/remove-markup.lisp b/third-party/s-xml/examples/remove-markup.lisp new file mode 100644 index 0000000..95c13b1 --- /dev/null +++ b/third-party/s-xml/examples/remove-markup.lisp @@ -0,0 +1,21 @@ +;;;; -*- mode: lisp -*- +;;;; +;;;; $Id: remove-markup.lisp,v 1.1 2008-02-15 13:54:57 scaekenberghe Exp $ +;;;; +;;;; Remove markup from an XML document using the SSAX interface +;;;; +;;;; Copyright (C) 2004 Sven Van Caekenberghe, Beta Nine BVBA. +;;;; +;;;; You are granted the rights to distribute and use this software +;;;; as governed by the terms of the Lisp Lesser General Public License +;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. + +(in-package :s-xml) + +(defun remove-xml-markup (in) + (let* ((state (make-instance 'xml-parser-state + :text-hook #'(lambda (string seed) (cons string seed)))) + (result (start-parse-xml in state))) + (apply #'concatenate 'string (nreverse result)))) + +;;;; eof
\ No newline at end of file diff --git a/third-party/s-xml/examples/tracer.lisp b/third-party/s-xml/examples/tracer.lisp new file mode 100644 index 0000000..44782f5 --- /dev/null +++ b/third-party/s-xml/examples/tracer.lisp @@ -0,0 +1,57 @@ +;;;; -*- mode: lisp -*- +;;;; +;;;; $Id: tracer.lisp,v 1.1 2008-02-15 13:54:57 scaekenberghe Exp $ +;;;; +;;;; A simple SSAX tracer example that can be used to understand how the hooks are called +;;;; +;;;; Copyright (C) 2004 Sven Van Caekenberghe, Beta Nine BVBA. +;;;; +;;;; You are granted the rights to distribute and use this software +;;;; as governed by the terms of the Lisp Lesser General Public License +;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. + +(in-package :s-xml) + +(defun trace-xml-log (level msg &rest args) + (indent *standard-output* level) + (apply #'format *standard-output* msg args) + (terpri *standard-output*)) + +(defun trace-xml-new-element-hook (name attributes seed) + (let ((new-seed (cons (1+ (car seed)) (1+ (cdr seed))))) + (trace-xml-log (car seed) + "(new-element :name ~s :attributes ~:[()~;~:*~s~] :seed ~s) => ~s" + name attributes seed new-seed) + new-seed)) + +(defun trace-xml-finish-element-hook (name attributes parent-seed seed) + (let ((new-seed (cons (1- (car seed)) (1+ (cdr seed))))) + (trace-xml-log (car parent-seed) + "(finish-element :name ~s :attributes ~:[()~;~:*~s~] :parent-seed ~s :seed ~s) => ~s" + name attributes parent-seed seed new-seed) + new-seed)) + +(defun trace-xml-text-hook (string seed) + (let ((new-seed (cons (car seed) (1+ (cdr seed))))) + (trace-xml-log (car seed) + "(text :string ~s :seed ~s) => ~s" + string seed new-seed) + new-seed)) + +(defun trace-xml (in) + "Parse and trace a toplevel XML element from stream in" + (start-parse-xml in + (make-instance 'xml-parser-state + :seed (cons 0 0) + ;; seed car is xml element nesting level + ;; seed cdr is ever increasing from element to element + :new-element-hook #'trace-xml-new-element-hook + :finish-element-hook #'trace-xml-finish-element-hook + :text-hook #'trace-xml-text-hook))) + +(defun trace-xml-file (pathname) + "Parse and trace XMl from the file at pathname" + (with-open-file (in pathname) + (trace-xml in))) + +;;;; eof diff --git a/third-party/s-xml/s-xml.asd b/third-party/s-xml/s-xml.asd new file mode 100644 index 0000000..d7ceb86 --- /dev/null +++ b/third-party/s-xml/s-xml.asd @@ -0,0 +1,49 @@ +;;;; -*- Mode: LISP -*- +;;;; +;;;; $Id: s-xml.asd,v 1.3 2008-02-15 13:54:57 scaekenberghe Exp $ +;;;; +;;;; The S-XML ASDF system definition +;;;; +;;;; Copyright (C) 2002, 2004 Sven Van Caekenberghe, Beta Nine BVBA. +;;;; +;;;; You are granted the rights to distribute and use this software +;;;; as governed by the terms of the Lisp Lesser General Public License +;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. + +(in-package :asdf) + +(defsystem :s-xml + :name "S-XML" + :author "Sven Van Caekenberghe <svc@mac.com>" + :version "3" + :maintainer "Sven Van Caekenberghe <svc@mac.com>, Brian Mastenbrook <>, Rudi Schlatte <>" + :licence "Lisp Lesser General Public License (LLGPL)" + :description "Simple Common Lisp XML Parser" + :long-description "S-XML is a Common Lisp implementation of a simple XML parser, with a SAX-like and DOM interface" + + :components + ((:module + :src + :components ((:file "package") + (:file "xml" :depends-on ("package")) + (:file "dom" :depends-on ("package" "xml")) + (:file "lxml-dom" :depends-on ("dom")) + (:file "sxml-dom" :depends-on ("dom")) + (:file "xml-struct-dom" :depends-on ("dom")))))) + +(defsystem :s-xml.test + :depends-on (:s-xml) + :components ((:module :test + :components ((:file "test-xml") + (:file "test-xml-struct-dom") + (:file "test-lxml-dom") + (:file "test-sxml-dom"))))) + +(defsystem :s-xml.examples + :depends-on (:s-xml) + :components ((:module :examples + :components ((:file "counter") + (:file "echo") + (:file "remove-markup") + (:file "tracer"))))) +;;;; eof diff --git a/third-party/s-xml/src/dom.lisp b/third-party/s-xml/src/dom.lisp new file mode 100644 index 0000000..dcf6e82 --- /dev/null +++ b/third-party/s-xml/src/dom.lisp @@ -0,0 +1,75 @@ +;;;; -*- mode: lisp -*- +;;;; +;;;; $Id: dom.lisp,v 1.2 2005-08-29 15:01:47 scaekenberghe Exp $ +;;;; +;;;; This is the generic simple DOM parser and printer interface. +;;;; +;;;; Copyright (C) 2002, 2004 Sven Van Caekenberghe, Beta Nine BVBA. +;;;; +;;;; You are granted the rights to distribute and use this software +;;;; as governed by the terms of the Lisp Lesser General Public License +;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. + +(in-package :s-xml) + +;;; top level DOM parser interface + +(defgeneric parse-xml-dom (stream output-type) + (:documentation "Parse a character stream as XML and generate a DOM of output-type")) + +(defun parse-xml (stream &key (output-type :lxml)) + "Parse a character stream as XML and generate a DOM of output-type, defaulting to :lxml" + (parse-xml-dom stream output-type)) + +(defun parse-xml-string (string &key (output-type :lxml)) + "Parse a string as XML and generate a DOM of output-type, defaulting to :lxml" + (with-input-from-string (stream string) + (parse-xml-dom stream output-type))) + +(defun parse-xml-file (filename &key (output-type :lxml)) + "Parse a character file as XML and generate a DOM of output-type, defaulting to :lxml" + (with-open-file (in filename :direction :input) + (parse-xml-dom in output-type))) + +;;; top level DOM printer interface + +(defgeneric print-xml-dom (dom input-type stream pretty level) + (:documentation "Generate XML output on a character stream from a DOM of input-type, optionally pretty printing using level")) + +(defun print-xml (dom &key (stream t) (pretty nil) (input-type :lxml) (header)) + "Generate XML output on a character stream (t by default) from a DOM of input-type (:lxml by default), optionally pretty printing (off by default), or adding a header (none by default)" + (when header (format stream header)) + (when pretty (terpri stream)) + (print-xml-dom dom input-type stream pretty 1)) + +(defun print-xml-string (dom &key (pretty nil) (input-type :lxml)) + "Generate XML output to a string from a DOM of input-type (:lxml by default), optionally pretty printing (off by default)" + (with-output-to-string (stream) + (print-xml dom :stream stream :pretty pretty :input-type input-type))) + +;;; shared/common support functions + +(defun print-spaces (n stream &optional (preceding-newline t)) + (when preceding-newline + (terpri stream)) + (loop :repeat n + :do (write-char #\Space stream))) + +(defun print-solitary-tag (tag stream) + (write-char #\< stream) + (print-identifier tag stream) + (write-string "/>" stream)) + +(defun print-closing-tag (tag stream) + (write-string "</" stream) + (print-identifier tag stream) + (write-char #\> stream)) + +(defun print-attribute (name value stream) + (write-char #\space stream) + (print-identifier name stream t) + (write-string "=\"" stream) + (print-string-xml value stream) + (write-char #\" stream)) + +;;;; eof diff --git a/third-party/s-xml/src/lxml-dom.lisp b/third-party/s-xml/src/lxml-dom.lisp new file mode 100644 index 0000000..449fea3 --- /dev/null +++ b/third-party/s-xml/src/lxml-dom.lisp @@ -0,0 +1,83 @@ +;;;; -*- mode: lisp -*- +;;;; +;;;; $Id: lxml-dom.lisp,v 1.6 2005-11-20 14:34:15 scaekenberghe Exp $ +;;;; +;;;; LXML implementation of the generic DOM parser and printer. +;;;; +;;;; Copyright (C) 2002, 2004 Sven Van Caekenberghe, Beta Nine BVBA. +;;;; +;;;; You are granted the rights to distribute and use this software +;;;; as governed by the terms of the Lisp Lesser General Public License +;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. + +(in-package :s-xml) + +;;; the lxml hooks to generate lxml + +(defun lxml-new-element-hook (name attributes seed) + (declare (ignore name attributes seed)) + '()) + +(defun lxml-finish-element-hook (name attributes parent-seed seed) + (let ((xml-element + (cond ((and (null seed) (null attributes)) + name) + (attributes + `((,name ,@(let (list) + (dolist (attribute attributes list) + (push (cdr attribute) list) + (push (car attribute) list)))) + ,@(nreverse seed))) + (t + `(,name ,@(nreverse seed)))))) + (cons xml-element parent-seed))) + +(defun lxml-text-hook (string seed) + (cons string seed)) + +;;; standard DOM interfaces + +(defmethod parse-xml-dom (stream (output-type (eql :lxml))) + (car (start-parse-xml stream + (make-instance 'xml-parser-state + :new-element-hook #'lxml-new-element-hook + :finish-element-hook #'lxml-finish-element-hook + :text-hook #'lxml-text-hook)))) + +(defun plist->alist (plist) + (when plist + (cons (cons (first plist) (second plist)) + (plist->alist (rest (rest plist)))))) + +(defmethod print-xml-dom (dom (input-type (eql :lxml)) stream pretty level) + (declare (special *namespaces*)) + (cond ((symbolp dom) (print-solitary-tag dom stream)) + ((stringp dom) (print-string-xml dom stream)) + ((consp dom) + (let (tag attributes) + (cond ((symbolp (first dom)) (setf tag (first dom))) + ((consp (first dom)) (setf tag (first (first dom)) + attributes (plist->alist (rest (first dom))))) + (t (error "Input not recognized as LXML ~s" dom))) + (let ((*namespaces* (extend-namespaces attributes *namespaces*))) + (write-char #\< stream) + (print-identifier tag stream) + (loop :for (name . value) :in attributes + :do (print-attribute name value stream)) + (if (rest dom) + (let ((children (rest dom))) + (write-char #\> stream) + (if (and (= (length children) 1) (stringp (first children))) + (print-string-xml (first children) stream) + (progn + (dolist (child children) + (when pretty (print-spaces (* 2 level) stream)) + (if (stringp child) + (print-string-xml child stream) + (print-xml-dom child input-type stream pretty (1+ level)))) + (when pretty (print-spaces (* 2 (1- level)) stream)))) + (print-closing-tag tag stream)) + (write-string "/>" stream))))) + (t (error "Input not recognized as LXML ~s" dom)))) + +;;;; eof
\ No newline at end of file diff --git a/third-party/s-xml/src/package.lisp b/third-party/s-xml/src/package.lisp new file mode 100644 index 0000000..1fc0cca --- /dev/null +++ b/third-party/s-xml/src/package.lisp @@ -0,0 +1,46 @@ +;;;; -*- mode: lisp -*- +;;;; +;;;; $Id: package.lisp,v 1.8 2006-01-31 11:44:15 scaekenberghe Exp $ +;;;; +;;;; This is a Common Lisp implementation of a very basic XML parser. +;;;; The parser is non-validating. +;;;; The API into the parser is pure functional parser hook model that comes from SSAX, +;;;; see also http://pobox.com/~oleg/ftp/Scheme/xml.html or http://ssax.sourceforge.net +;;;; Different DOM models are provided, an XSML, an LXML and a xml-element struct based one. +;;;; +;;;; Copyright (C) 2002, 2003, 2004, 2005, 2006 Sven Van Caekenberghe, Beta Nine BVBA. +;;;; +;;;; You are granted the rights to distribute and use this software +;;;; as governed by the terms of the Lisp Lesser General Public License +;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. + +(defpackage s-xml + (:use common-lisp) + (:export + ;; main parser interface + #:start-parse-xml + #:print-string-xml + #:xml-parser-error #:xml-parser-error-message #:xml-parser-error-args #:xml-parser-error-stream + #:xml-parser-state #:get-entities #:get-seed + #:get-new-element-hook #:get-finish-element-hook #:get-text-hook + ;; callbacks + #:*attribute-name-parser* + #:*attribute-value-parser* + #:parse-attribute-name + #:parse-attribute-value + ;; dom parser and printer + #:parse-xml-dom #:parse-xml #:parse-xml-string #:parse-xml-file + #:print-xml-dom #:print-xml #:print-xml-string + ;; xml-element structure + #:make-xml-element #:xml-element-children #:xml-element-name + #:xml-element-attribute #:xml-element-attributes + #:xml-element-p #:new-xml-element #:first-xml-element-child + ;; namespaces + #:*ignore-namespaces* #:*local-namespace* #:*namespaces* + #:*require-existing-symbols* #:*auto-export-symbols* #:*auto-create-namespace-packages* + #:find-namespace #:register-namespace #:get-prefix #:get-uri #:get-package + #:resolve-identifier #:extend-namespaces #:print-identifier #:split-identifier) + (:documentation + "A simple XML parser with an efficient, purely functional, event-based interface as well as a DOM interface")) + +;;;; eof diff --git a/third-party/s-xml/src/sxml-dom.lisp b/third-party/s-xml/src/sxml-dom.lisp new file mode 100644 index 0000000..dee3de8 --- /dev/null +++ b/third-party/s-xml/src/sxml-dom.lisp @@ -0,0 +1,76 @@ +;;;; -*- mode: lisp -*- +;;;; +;;;; $Id: sxml-dom.lisp,v 1.5 2005-11-20 14:34:15 scaekenberghe Exp $ +;;;; +;;;; LXML implementation of the generic DOM parser and printer. +;;;; +;;;; Copyright (C) 2003, 2004 Sven Van Caekenberghe, Beta Nine BVBA. +;;;; +;;;; You are granted the rights to distribute and use this software +;;;; as governed by the terms of the Lisp Lesser General Public License +;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. + +(in-package :s-xml) + +;;; the sxml hooks to generate sxml + +(defun sxml-new-element-hook (name attributes seed) + (declare (ignore name attributes seed)) + '()) + +(defun sxml-finish-element-hook (name attributes parent-seed seed) + (let ((xml-element (append (list name) + (when attributes + (list (let (list) + (dolist (attribute attributes (cons :@ list)) + (push (list (car attribute) (cdr attribute)) list))))) + (nreverse seed)))) + (cons xml-element parent-seed))) + +(defun sxml-text-hook (string seed) + (cons string seed)) + +;;; the standard DOM interfaces + +(defmethod parse-xml-dom (stream (output-type (eql :sxml))) + (car (start-parse-xml stream + (make-instance 'xml-parser-state + :new-element-hook #'sxml-new-element-hook + :finish-element-hook #'sxml-finish-element-hook + :text-hook #'sxml-text-hook)))) + +(defmethod print-xml-dom (dom (input-type (eql :sxml)) stream pretty level) + (declare (special *namespaces*)) + (cond ((stringp dom) (print-string-xml dom stream)) + ((consp dom) + (let ((tag (first dom)) + attributes + children) + (if (and (consp (second dom)) (eq (first (second dom)) :@)) + (setf attributes (rest (second dom)) + children (rest (rest dom))) + (setf children (rest dom))) + (let ((*namespaces* (extend-namespaces (loop :for (name value) :in attributes + :collect (cons name value)) + *namespaces*))) + (write-char #\< stream) + (print-identifier tag stream) + (loop :for (name value) :in attributes + :do (print-attribute name value stream)) + (if children + (progn + (write-char #\> stream) + (if (and (= (length children) 1) (stringp (first children))) + (print-string-xml (first children) stream) + (progn + (dolist (child children) + (when pretty (print-spaces (* 2 level) stream)) + (if (stringp child) + (print-string-xml child stream) + (print-xml-dom child input-type stream pretty (1+ level)))) + (when pretty (print-spaces (* 2 (1- level)) stream)))) + (print-closing-tag tag stream)) + (write-string "/>" stream))))) + (t (error "Input not recognized as SXML ~s" dom)))) + +;;;; eof diff --git a/third-party/s-xml/src/xml-struct-dom.lisp b/third-party/s-xml/src/xml-struct-dom.lisp new file mode 100644 index 0000000..916f747 --- /dev/null +++ b/third-party/s-xml/src/xml-struct-dom.lisp @@ -0,0 +1,125 @@ +;;;; -*- mode: lisp -*- +;;;; +;;;; $Id: xml-struct-dom.lisp,v 1.3 2005-09-20 09:57:48 scaekenberghe Exp $ +;;;; +;;;; XML-STRUCT implementation of the generic DOM parser and printer. +;;;; +;;;; Copyright (C) 2002, 2004 Sven Van Caekenberghe, Beta Nine BVBA. +;;;; +;;;; You are granted the rights to distribute and use this software +;;;; as governed by the terms of the Lisp Lesser General Public License +;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. + +(in-package :s-xml) + +;;; xml-element struct datastructure and API + +(defstruct xml-element + name ; :tag-name + attributes ; a assoc list of (:attribute-name . "attribute-value") + children ; a list of children/content either text strings or xml-elements + ) + +(setf (documentation 'xml-element-p 'function) + "Return T when the argument is an xml-element struct" + (documentation 'xml-element-attributes 'function) + "Return the alist of attribute names and values dotted pairs from an xml-element struct" + (documentation 'xml-element-children 'function) + "Return the list of children from an xml-element struct" + (documentation 'xml-element-name 'function) + "Return the name from an xml-element struct" + (documentation 'make-xml-element 'function) + "Make and return a new xml-element struct") + +(defun xml-element-attribute (xml-element key) + "Return the string value of the attribute with name the keyword :key + of xml-element if any, return null if not found" + (let ((pair (assoc key (xml-element-attributes xml-element) :test #'eq))) + (when pair (cdr pair)))) + +(defun (setf xml-element-attribute) (value xml-element key) + "Set the string value of the attribute with name the keyword :key of + xml-element, creating a new attribute if necessary or overwriting an + existing one, returning the value" + (let ((attributes (xml-element-attributes xml-element))) + (if (null attributes) + (push (cons key value) (xml-element-attributes xml-element)) + (let ((pair (assoc key attributes :test #'eq))) + (if pair + (setf (cdr pair) value) + (push (cons key value) (xml-element-attributes xml-element))))) + value)) + +(defun new-xml-element (name &rest children) + "Make a new xml-element with name and children" + (make-xml-element :name name :children children)) + +(defun first-xml-element-child (xml-element) + "Get the first child of an xml-element" + (first (xml-element-children xml-element))) + +(defun xml-equal (xml-1 xml-2) + (and (xml-element-p xml-1) + (xml-element-p xml-2) + (eq (xml-element-name xml-1) + (xml-element-name xml-2)) + (equal (xml-element-attributes xml-1) + (xml-element-attributes xml-2)) + (reduce #'(lambda (&optional (x t) (y t)) (and x y)) + (mapcar #'(lambda (x y) + (or (and (stringp x) (stringp y) (string= x y)) + (xml-equal x y))) + (xml-element-children xml-1) + (xml-element-children xml-2))))) + +;;; printing xml structures + +(defmethod print-xml-dom (xml-element (input-type (eql :xml-struct)) stream pretty level) + (declare (special *namespaces*)) + (let ((*namespaces* (extend-namespaces (xml-element-attributes xml-element) + *namespaces*))) + (write-char #\< stream) + (print-identifier (xml-element-name xml-element) stream) + (loop :for (name . value) :in (xml-element-attributes xml-element) + :do (print-attribute name value stream)) + (let ((children (xml-element-children xml-element))) + (if children + (progn + (write-char #\> stream) + (if (and (= (length children) 1) (stringp (first children))) + (print-string-xml (first children) stream) + (progn + (dolist (child children) + (when pretty (print-spaces (* 2 level) stream)) + (if (stringp child) + (print-string-xml child stream) + (print-xml-dom child input-type stream pretty (1+ level)))) + (when pretty (print-spaces (* 2 (1- level)) stream)))) + (print-closing-tag (xml-element-name xml-element) stream)) + (write-string "/>" stream))))) + +;;; the standard hooks to generate xml-element structs + +(defun standard-new-element-hook (name attributes seed) + (declare (ignore name attributes seed)) + '()) + +(defun standard-finish-element-hook (name attributes parent-seed seed) + (let ((xml-element (make-xml-element :name name + :attributes attributes + :children (nreverse seed)))) + (cons xml-element parent-seed))) + +(defun standard-text-hook (string seed) + (cons string seed)) + +;;; top level standard parser interfaces + +(defmethod parse-xml-dom (stream (output-type (eql :xml-struct))) + (car (start-parse-xml stream + (make-instance 'xml-parser-state + :new-element-hook #'standard-new-element-hook + :finish-element-hook #'standard-finish-element-hook + :text-hook #'standard-text-hook)))) + +;;;; eof diff --git a/third-party/s-xml/src/xml.lisp b/third-party/s-xml/src/xml.lisp new file mode 100644 index 0000000..8df61c6 --- /dev/null +++ b/third-party/s-xml/src/xml.lisp @@ -0,0 +1,700 @@ +;;;; -*- mode: lisp -*- +;;;; +;;;; $Id: xml.lisp,v 1.16 2006-01-31 11:44:15 scaekenberghe Exp $ +;;;; +;;;; This is a Common Lisp implementation of a basic but usable XML parser. +;;;; The parser is non-validating and not complete (no PI). +;;;; Namespace and entities are handled. +;;;; The API into the parser is a pure functional parser hook model that comes from SSAX, +;;;; see also http://pobox.com/~oleg/ftp/Scheme/xml.html or http://ssax.sourceforge.net +;;;; Different DOM models are provided, an XSML, an LXML and a xml-element struct based one. +;;;; +;;;; Copyright (C) 2002, 2003, 2004, 2005, 2006 Sven Van Caekenberghe, Beta Nine BVBA. +;;;; +;;;; You are granted the rights to distribute and use this software +;;;; as governed by the terms of the Lisp Lesser General Public License +;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. + +(in-package :s-xml) + +;;; error reporting + +(define-condition xml-parser-error (error) + ((message :initarg :message :reader xml-parser-error-message) + (args :initarg :args :reader xml-parser-error-args) + (stream :initarg :stream :reader xml-parser-error-stream :initform nil)) + (:report (lambda (condition stream) + (format stream + "XML parser ~?~@[ near stream position ~d~]." + (xml-parser-error-message condition) + (xml-parser-error-args condition) + (and (xml-parser-error-stream condition) + (file-position (xml-parser-error-stream condition)))))) + (:documentation "Thrown by the XML parser to indicate errorneous input")) + +(setf (documentation 'xml-parser-error-message 'function) + "Get the message from an XML parser error" + (documentation 'xml-parser-error-args 'function) + "Get the error arguments from an XML parser error" + (documentation 'xml-parser-error-stream 'function) + "Get the stream from an XML parser error") + +(defun parser-error (message &optional args stream) + (make-condition 'xml-parser-error + :message message + :args args + :stream stream)) + +;; attribute parsing hooks +;; this is a bit complicated, refer to the mailing lists for a more detailed explanation + +(defun parse-attribute-name (string) + "Default parser for the attribute name" + (declare (special *namespaces*)) + (resolve-identifier string *namespaces* t)) + +(defun parse-attribute-value (name string) + "Default parser for the attribute value" + (declare (ignore name) + (special *ignore-namespace*)) + (if *ignore-namespaces* + (copy-seq string) + string)) + +(defparameter *attribute-name-parser* #'parse-attribute-name + "Called to compute interned attribute name from a buffer that will be reused") + +(defparameter *attribute-value-parser* #'parse-attribute-value + "Called to compute an element of an attribute list from a buffer that will be reused") + +;;; utilities + +(defun whitespace-char-p (char) + "Is char an XML whitespace character ?" + (declare (type character char)) + (or (char= char #\space) + (char= char #\tab) + (char= char #\return) + (char= char #\linefeed))) + +(defun identifier-char-p (char) + "Is char an XML identifier character ?" + (declare (type character char)) + (or (and (char<= #\A char) (char<= char #\Z)) + (and (char<= #\a char) (char<= char #\z)) + (and (char<= #\0 char) (char<= char #\9)) + (char= char #\-) + (char= char #\_) + (char= char #\.) + (char= char #\:))) + +(defun skip-whitespace (stream) + "Skip over XML whitespace in stream, return first non-whitespace + character which was peeked but not read, return nil on eof" + (loop + (let ((char (peek-char nil stream nil #\Null))) + (declare (type character char)) + (if (whitespace-char-p char) + (read-char stream) + (return char))))) + +(defun make-extendable-string (&optional (size 10)) + "Make an extendable string which is a one-dimensional character + array which is adjustable and has a fill pointer" + (make-array size + :element-type 'character + :adjustable t + :fill-pointer 0)) + +(defun print-string-xml (string stream &key (start 0) end) + "Write the characters of string to stream using basic XML conventions" + (loop for offset upfrom start below (or end (length string)) + for char = (char string offset) + do (case char + (#\& (write-string "&" stream)) + (#\< (write-string "<" stream)) + (#\> (write-string ">" stream)) + (#\" (write-string """ stream)) + ((#\newline #\return #\tab) (write-char char stream)) + (t (if (and (<= 32 (char-code char)) + (<= (char-code char) 126)) + (write-char char stream) + (progn + (write-string "&#x" stream) + (write (char-code char) :stream stream :base 16) + (write-char #\; stream))))))) + +(defun make-standard-entities () + "A hashtable mapping XML entity names to their replacement strings, + filled with the standard set" + (let ((entities (make-hash-table :test #'equal))) + (setf (gethash "amp" entities) (string #\&) + (gethash "quot" entities) (string #\") + (gethash "apos" entities) (string #\') + (gethash "lt" entities) (string #\<) + (gethash "gt" entities) (string #\>) + (gethash "nbsp" entities) (string #\space)) + entities)) + +(defun resolve-entity (stream extendable-string entities entity) + "Read and resolve an XML entity from stream, positioned after the '&' entity marker, + accepting &name; &#DEC; and &#xHEX; formats, + destructively modifying string, which is also returned, + destructively modifying entity, incorrect entity formats result in errors" + (declare (type (vector character) entity)) + (loop + (let ((char (read-char stream nil #\Null))) + (declare (type character char)) + (cond ((char= char #\Null) (error (parser-error "encountered eof before end of entity"))) + ((char= #\; char) (return)) + (t (vector-push-extend char entity))))) + (if (char= (char entity 0) #\#) + (let ((code (if (char= (char entity 1) #\x) + (parse-integer entity :start 2 :radix 16 :junk-allowed t) + (parse-integer entity :start 1 :radix 10 :junk-allowed t)))) + (when (null code) + (error (parser-error "encountered incorrect entity &~s;" (list entity) stream))) + (vector-push-extend (code-char code) extendable-string)) + (let ((value (gethash entity entities))) + (if value + (loop :for char :across value + :do (vector-push-extend char extendable-string)) + (error (parser-error "encountered unknown entity &~s;" (list entity) stream))))) + extendable-string) + +;;; namespace support + +(defvar *ignore-namespaces* nil + "When t, namespaces are ignored like in the old version of S-XML") + +(defclass xml-namespace () + ((uri :documentation "The URI used to identify this namespace" + :accessor get-uri + :initarg :uri) + (prefix :documentation "The preferred prefix assigned to this namespace" + :accessor get-prefix + :initarg :prefix + :initform nil) + (package :documentation "The Common Lisp package where this namespace's symbols are interned" + :accessor get-package + :initarg :package + :initform nil)) + (:documentation "Describes an XML namespace and how it is handled")) + +(setf (documentation 'get-uri 'function) + "The URI used to identify this namespace" + (documentation 'get-prefix 'function) + "The preferred prefix assigned to this namespace" + (documentation 'get-package 'function) + "The Common Lisp package where this namespace's symbols are interned") + +(defmethod print-object ((object xml-namespace) stream) + (print-unreadable-object (object stream :type t :identity t) + (format stream "~A - ~A" (get-prefix object) (get-uri object)))) + +(defvar *local-namespace* (make-instance 'xml-namespace + :uri "local" + :prefix "" + :package (find-package :keyword)) + "The local (global default) XML namespace") + +(defvar *xml-namespace* (make-instance 'xml-namespace + :uri "http://www.w3.org/XML/1998/namespace" + :prefix "xml" + :package (or (find-package :xml) + (make-package :xml :nicknames '("XML")))) + "REC-xml-names-19990114 says the prefix xml is bound to the namespace http://www.w3.org/XML/1998/namespace.") + +(defvar *known-namespaces* (list *local-namespace* *xml-namespace*) + "The list of known/defined namespaces") + +(defvar *namespaces* `(("xml" . ,*xml-namespace*) ("" . ,*local-namespace*)) + "Ordered list of (prefix . XML-namespace) bindings currently in effect - special variable") + +(defun find-namespace (uri) + "Find a registered XML namespace identified by uri" + (find uri *known-namespaces* :key #'get-uri :test #'string-equal)) + +(defun register-namespace (uri prefix package) + "Register a new or redefine an existing XML namespace defined by uri with prefix and package" + (let ((namespace (find-namespace uri))) + (if namespace + (setf (get-prefix namespace) prefix + (get-package namespace) (find-package package)) + (push (setf namespace (make-instance 'xml-namespace + :uri uri + :prefix prefix + :package (find-package package))) + *known-namespaces*)) + namespace)) + +(defun find-namespace-binding (prefix namespaces) + "Find the XML namespace currently bound to prefix in the namespaces bindings" + (cdr (assoc prefix namespaces :test #'string-equal))) + +(defun split-identifier (identifier) + "Split an identifier 'prefix:name' and return (values prefix name)" + (when (symbolp identifier) + (setf identifier (symbol-name identifier))) + (let ((colon-position (position #\: identifier :test #'char=))) + (if colon-position + (values (subseq identifier 0 colon-position) + (subseq identifier (1+ colon-position))) + (values nil identifier)))) + +(defvar *require-existing-symbols* nil + "If t, each XML identifier must exist as symbol already") + +(defvar *auto-export-symbols* t + "If t, export newly interned symbols form their packages") + +(defun resolve-identifier (identifier namespaces &optional as-attribute) + "Resolve the string identifier in the list of namespace bindings" + (if *ignore-namespaces* + (intern identifier :keyword) + (flet ((intern-symbol (string package) ; intern string as a symbol in package + (if *require-existing-symbols* + (let ((symbol (find-symbol string package))) + (or symbol + (error "Symbol ~s does not exist in ~s" string package))) + (let ((symbol (intern string package))) + (when (and *auto-export-symbols* + (not (eql package (find-package :keyword)))) + (export symbol package)) + symbol)))) + (multiple-value-bind (prefix name) + (split-identifier identifier) + (if (or (null prefix) (string= prefix "xmlns")) + (if as-attribute + (intern (if (string= prefix "xmlns") identifier name) (get-package *local-namespace*)) + (let ((default-namespace (find-namespace-binding "" namespaces))) + (intern-symbol name (get-package default-namespace)))) + (let ((namespace (find-namespace-binding prefix namespaces))) + (if namespace + (intern-symbol name (get-package namespace)) + (error "namespace not found for prefix ~s" prefix)))))))) + +(defvar *auto-create-namespace-packages* t + "If t, new packages will be created for namespaces, if needed, named by the prefix") + +(defun new-namespace (uri &optional prefix) + "Register a new namespace for uri and prefix, creating a package if necessary" + (if prefix + (register-namespace uri + prefix + (or (find-package prefix) + (if *auto-create-namespace-packages* + (make-package prefix :nicknames `(,(string-upcase prefix))) + (error "Cannot find or create package ~s" prefix)))) + (let ((unique-name (loop :for i :upfrom 0 + :do (let ((name (format nil "ns-~d" i))) + (when (not (find-package name)) + (return name)))))) + (register-namespace uri + unique-name + (if *auto-create-namespace-packages* + (make-package (string-upcase unique-name) :nicknames `(,unique-name)) + (error "Cannot create package ~s" unique-name)))))) + +(defun extend-namespaces (attributes namespaces) + "Given possible 'xmlns[:prefix]' attributes, extend the namespaces bindings" + (unless *ignore-namespaces* + (let (default-namespace-uri) + (loop :for (key . value) :in attributes + :do (if (string= key "xmlns") + (setf default-namespace-uri value) + (multiple-value-bind (prefix name) + (split-identifier key) + (when (string= prefix "xmlns") + (let* ((uri value) + (prefix name) + (namespace (find-namespace uri))) + (unless namespace + (setf namespace (new-namespace uri prefix))) + (push `(,prefix . ,namespace) namespaces)))))) + (when default-namespace-uri + (let ((namespace (find-namespace default-namespace-uri))) + (unless namespace + (setf namespace (new-namespace default-namespace-uri))) + (push `("" . ,namespace) namespaces))))) + namespaces) + +(defun print-identifier (identifier stream &optional as-attribute) + "Print identifier on stream using namespace conventions" + (declare (ignore as-attribute) (special *namespaces*)) + (if *ignore-namespaces* + (princ identifier stream) + (if (symbolp identifier) + (let ((package (symbol-package identifier)) + (name (symbol-name identifier))) + (let* ((namespace (find package *known-namespaces* :key #'get-package)) + (prefix (or (car (find namespace *namespaces* :key #'cdr)) + (get-prefix namespace)))) + (if (string= prefix "") + (princ name stream) + (format stream "~a:~a" prefix name)))) + (princ identifier stream)))) + +;;; the parser state + +(defclass xml-parser-state () + ((entities :documentation "A hashtable mapping XML entity names to their replacement stings" + :accessor get-entities + :initarg :entities + :initform (make-standard-entities)) + (seed :documentation "The user seed object" + :accessor get-seed + :initarg :seed + :initform nil) + (buffer :documentation "The main reusable character buffer" + :accessor get-buffer + :initform (make-extendable-string)) + (mini-buffer :documentation "The secondary, smaller reusable character buffer" + :accessor get-mini-buffer + :initform (make-extendable-string)) + (new-element-hook :documentation "Called when new element starts" + ;; Handle the start of a new xml element with name and attributes, + ;; receiving seed from previous element (sibling or parent) + ;; return seed to be used for first child (content) + ;; or directly to finish-element-hook + :accessor get-new-element-hook + :initarg :new-element-hook + :initform #'(lambda (name attributes seed) + (declare (ignore name attributes)) + seed)) + (finish-element-hook :documentation "Called when element ends" + ;; Handle the end of an xml element with name and attributes, + ;; receiving parent-seed, the seed passed to us when this element started, + ;; i.e. passed to our corresponding new-element-hook + ;; and receiving seed from last child (content) + ;; or directly from new-element-hook + ;; return final seed for this element to next element (sibling or parent) + :accessor get-finish-element-hook + :initarg :finish-element-hook + :initform #'(lambda (name attributes parent-seed seed) + (declare (ignore name attributes parent-seed)) + seed)) + (text-hook :documentation "Called when text is found" + ;; Handle text in string, found as contents, + ;; receiving seed from previous element (sibling or parent), + ;; return final seed for this element to next element (sibling or parent) + :accessor get-text-hook + :initarg :text-hook + :initform #'(lambda (string seed) + (declare (ignore string)) + seed))) + (:documentation "The XML parser state passed along all code making up the parser")) + +(setf (documentation 'get-seed 'function) + "Get the initial user seed of an XML parser state" + (documentation 'get-entities 'function) + "Get the entities hashtable of an XML parser state" + (documentation 'get-new-element-hook 'function) + "Get the new element hook of an XML parser state" + (documentation 'get-finish-element-hook 'function) + "Get the finish element hook of an XML parser state" + (documentation 'get-text-hook 'function) + "Get the text hook of an XML parser state") + +#-allegro +(setf (documentation '(setf get-seed) 'function) + "Set the initial user seed of an XML parser state" + (documentation '(setf get-entities) 'function) + "Set the entities hashtable of an XML parser state" + (documentation '(setf get-new-element-hook) 'function) + "Set the new element hook of an XML parser state" + (documentation '(setf get-finish-element-hook) 'function) + "Set the finish element hook of an XML parser state" + (documentation '(setf get-text-hook) 'function) + "Set the text hook of an XML parser state") + +(defmethod get-mini-buffer :after ((state xml-parser-state)) + "Reset and return the reusable mini buffer" + (with-slots (mini-buffer) state + (setf (fill-pointer mini-buffer) 0))) + +(defmethod get-buffer :after ((state xml-parser-state)) + "Reset and return the main reusable buffer" + (with-slots (buffer) state + (setf (fill-pointer buffer) 0))) + +;;; parser support + +(defun parse-whitespace (stream extendable-string) + "Read and collect XML whitespace from stream in string which is + destructively modified, return first non-whitespace character which + was peeked but not read, return #\Null on eof" + (declare (type (vector character) extendable-string)) + (loop + (let ((char (peek-char nil stream nil #\Null))) + (declare (type character char)) + (if (whitespace-char-p char) + (vector-push-extend (read-char stream) extendable-string) + (return char))))) + +(defun parse-string (stream state string) + "Read and return an XML string from stream, delimited by either + single or double quotes, the stream is expected to be on the opening + delimiter, at the end the closing delimiter is also read, entities + are resolved, eof before end of string is an error" + (declare (type (vector character) string)) + (let ((delimiter (read-char stream nil #\Null)) + (char #\Null)) + (declare (type character delimiter char)) + (unless (or (char= delimiter #\') (char= delimiter #\")) + (error (parser-error "expected string delimiter" nil stream))) + (loop + (setf char (read-char stream nil #\Null)) + (cond ((char= char #\Null) (error (parser-error "encountered eof before end of string"))) + ((char= char delimiter) (return)) + ((char= char #\&) (resolve-entity stream string (get-entities state) (get-mini-buffer state))) + (t (vector-push-extend char string)))) + string)) + +(defun parse-text (stream state extendable-string) + "Read and collect XML text from stream in string which is + destructively modified, the text ends with a '<', which is peeked and + returned, entities are resolved, eof is considered an error" + (declare (type (vector character) extendable-string)) + (let ((char #\Null)) + (declare (type character char)) + (loop + (setf char (peek-char nil stream nil #\Null)) + (when (char= char #\Null) (error (parser-error "encountered unexpected eof in text"))) + (when (char= char #\<) (return)) + (read-char stream) + (if (char= char #\&) + (resolve-entity stream extendable-string (get-entities state) (get-mini-buffer state)) + (vector-push-extend char extendable-string))) + char)) + +(defun parse-identifier (stream identifier) + "Read and returns an XML identifier from stream, positioned at the + start of the identifier, ending with the first non-identifier + character, which is peeked, the identifier is written destructively + into identifier which is also returned" + (declare (type (vector character) identifier)) + (loop + (let ((char (read-char stream nil #\Null))) + (declare (type character char)) + (cond ((identifier-char-p char) + (vector-push-extend char identifier)) + (t + (when (char/= char #\Null) (unread-char char stream)) + (return identifier)))))) + +(defun skip-comment (stream) + "Skip an XML comment in stream, positioned after the opening '<!--', + consumes the closing '-->' sequence, unexpected eof or a malformed + closing sequence result in a error" + (let ((dashes-to-read 2)) + (loop + (if (zerop dashes-to-read) (return)) + (let ((char (read-char stream nil #\Null))) + (declare (type character char)) + (if (char= char #\Null) + (error (parser-error "encountered unexpected eof for comment"))) + (if (char= char #\-) + (decf dashes-to-read) + (setf dashes-to-read 2))))) + (if (char/= (read-char stream nil #\Null) #\>) + (error (parser-error "expected > ending comment" nil stream)))) + +(defun read-cdata (stream state string) + "Reads in the CDATA and calls the callback for CDATA if it exists" + ;; we already read the <![CDATA[ stuff + ;; continue to read until we hit ]]> + (let ((char #\space) + (last-3-characters (list #\[ #\A #\T)) + (pattern (list #\> #\] #\]))) + (declare (type character char)) + (loop + (setf char (read-char stream nil #\Null)) + (when (char= char #\Null) (error (parser-error "encountered unexpected eof in text"))) + (push char last-3-characters) + (setf (cdddr last-3-characters) nil) + (cond + ((equal last-3-characters + pattern) + (setf (fill-pointer string) + (- (fill-pointer string) 2)) + (setf (get-seed state) + (funcall (get-text-hook state) + (copy-seq string) + (get-seed state))) + (return-from read-cdata)) + (t + (vector-push-extend char string)))))) + +(defun skip-special-tag (stream state) + "Skip an XML special tag (comments and processing instructions) in + stream, positioned after the opening '<', unexpected eof is an error" + ;; opening < has been read, consume ? or ! + (read-char stream) + (let ((char (read-char stream nil #\Null))) + (declare (type character char)) + ;; see if we are dealing with a comment + (when (char= char #\-) + (setf char (read-char stream nil #\Null)) + (when (char= char #\-) + (skip-comment stream) + (return-from skip-special-tag))) + ;; maybe we are dealing with CDATA? + (when (and (char= char #\[) + (loop :for pattern :across "CDATA[" + :for char = (read-char stream nil #\Null) + :when (char= char #\Null) :do + (error (parser-error "encountered unexpected eof in cdata")) + :always (char= char pattern))) + (read-cdata stream state (get-buffer state)) + (return-from skip-special-tag)) + ;; loop over chars, dealing with strings (skipping their content) + ;; and counting opening and closing < and > chars + (let ((taglevel 1) + (string-delimiter #\Null)) + (declare (type character string-delimiter)) + (loop + (when (zerop taglevel) (return)) + (setf char (read-char stream nil #\Null)) + (when (char= char #\Null) + (error (parser-error "encountered unexpected eof for special (! or ?) tag" nil stream))) + (if (char/= string-delimiter #\Null) + ;; inside a string we only look for a closing string delimiter + (when (char= char string-delimiter) + (setf string-delimiter #\Null)) + ;; outside a string we count < and > and watch out for strings + (cond ((or (char= char #\') (char= char #\")) (setf string-delimiter char)) + ((char= char #\<) (incf taglevel)) + ((char= char #\>) (decf taglevel)))))))) + +;;; the XML parser proper + +(defun parse-xml-element-attributes (stream state) + "Parse XML element attributes from stream positioned after the tag + identifier, returning the attributes as an assoc list, ending at + either a '>' or a '/' which is peeked and also returned" + (declare (special *namespaces*)) + (let ((char #\Null) attributes) + (declare (type character char)) + (loop + ;; skip whitespace separating items + (setf char (skip-whitespace stream)) + ;; start tag attributes ends with > or /> + (when (or (char= char #\>) (char= char #\/)) (return)) + ;; read the attribute key + (let ((key (let ((string (parse-identifier stream (get-mini-buffer state)))) + (if *ignore-namespaces* + (funcall *attribute-name-parser* string) + (copy-seq string))))) + ;; skip separating whitespace + (setf char (skip-whitespace stream)) + ;; require = sign (and consume it if present) + (if (char= char #\=) + (read-char stream) + (error (parser-error "expected =" nil stream))) + ;; skip separating whitespace + (skip-whitespace stream) + ;; read the attribute value as a string + (push (cons key (let ((string (parse-string stream state (get-buffer state)))) + (if *ignore-namespaces* + (funcall *attribute-value-parser* key string) + (copy-seq string)))) + attributes))) + ;; return attributes peek char ending loop + (values attributes char))) + +(defun parse-xml-element (stream state) + "Parse and return an XML element from stream, positioned after the opening '<'" + (declare (special *namespaces*)) + ;; opening < has been read + (when (char= (peek-char nil stream nil #\Null) #\!) + (skip-special-tag stream state) + (return-from parse-xml-element)) + (let ((char #\Null) buffer open-tag parent-seed has-children) + (declare (type character char)) + (setf parent-seed (get-seed state)) + ;; read tag name (no whitespace between < and name ?) + (setf open-tag (copy-seq (parse-identifier stream (get-mini-buffer state)))) + ;; tag has been read, read attributes if any + (multiple-value-bind (attributes peeked-char) + (parse-xml-element-attributes stream state) + (let ((*namespaces* (extend-namespaces attributes *namespaces*))) + (setf open-tag (resolve-identifier open-tag *namespaces*)) + (unless *ignore-namespaces* + (dolist (attribute attributes) + (setf (car attribute) (funcall *attribute-name-parser* (car attribute)) + (cdr attribute) (funcall *attribute-value-parser* (car attribute) (cdr attribute))))) + (setf (get-seed state) (funcall (get-new-element-hook state) + open-tag attributes (get-seed state))) + (setf char peeked-char) + (when (char= char #\/) + ;; handle solitary tag of the form <tag .. /> + (read-char stream) + (setf char (read-char stream nil #\Null)) + (if (char= #\> char) + (progn + (setf (get-seed state) (funcall (get-finish-element-hook state) + open-tag attributes parent-seed (get-seed state))) + (return-from parse-xml-element)) + (error (parser-error "expected >" nil stream)))) + ;; consume > + (read-char stream) + (loop + (setf buffer (get-buffer state)) + ;; read whitespace into buffer + (setf char (parse-whitespace stream buffer)) + ;; see what ended the whitespace scan + (cond ((char= char #\Null) (error (parser-error "encountered unexpected eof handling ~a" + (list open-tag)))) + ((char= char #\<) + ;; consume the < + (read-char stream) + (if (char= (peek-char nil stream nil #\Null) #\/) + (progn + ;; handle the matching closing tag </tag> and done + ;; if we read whitespace as this (leaf) element's contents, it is significant + (when (and (not has-children) (plusp (length buffer))) + (setf (get-seed state) (funcall (get-text-hook state) + (copy-seq buffer) (get-seed state)))) + (read-char stream) + (let ((close-tag (resolve-identifier (parse-identifier stream (get-mini-buffer state)) + *namespaces*))) + (unless (eq open-tag close-tag) + (error (parser-error "found <~a> not matched by </~a> but by <~a>" + (list open-tag open-tag close-tag) stream))) + (unless (char= (read-char stream nil #\Null) #\>) + (error (parser-error "expected >" nil stream))) + (setf (get-seed state) (funcall (get-finish-element-hook state) + open-tag attributes parent-seed (get-seed state)))) + (return)) + ;; handle child tag and loop, no hooks to call here + ;; whitespace between child elements is skipped + (progn + (setf has-children t) + (parse-xml-element stream state)))) + (t + ;; no child tag, concatenate text to whitespace in buffer + ;; handle text content and loop + (setf char (parse-text stream state buffer)) + (setf (get-seed state) (funcall (get-text-hook state) + (copy-seq buffer) (get-seed state)))))))))) + +(defun start-parse-xml (stream &optional (state (make-instance 'xml-parser-state))) + "Parse and return a toplevel XML element from stream, using parser state" + (loop + (let ((char (skip-whitespace stream))) + (when (char= char #\Null) (return-from start-parse-xml)) + ;; skip whitespace until start tag + (unless (char= char #\<) + (error (parser-error "expected <" nil stream))) + (read-char stream) ; consume peeked char + (setf char (peek-char nil stream nil #\Null)) + (if (or (char= char #\!) (char= char #\?)) + ;; deal with special tags + (skip-special-tag stream state) + (progn + ;; read the main element + (parse-xml-element stream state) + (return-from start-parse-xml (get-seed state))))))) + +;;;; eof diff --git a/third-party/s-xml/test/ant-build-file.xml b/third-party/s-xml/test/ant-build-file.xml new file mode 100644 index 0000000..8aef4cc --- /dev/null +++ b/third-party/s-xml/test/ant-build-file.xml @@ -0,0 +1,252 @@ +<!-- $Id: ant-build-file.xml,v 1.1.1.1 2004-06-07 18:49:59 scaekenberghe Exp $ --> +<!-- Ant 1.2 build file --> + +<project name="Libretto" default="compile" basedir="."> + + <!-- set global properties for this build --> + <property name="src" value="${basedir}/src" /> + <property name="rsrc" value="${basedir}/rsrc" /> + <property name="build" value="${basedir}/bin" /> + <property name="api" value="${basedir}/api" /> + <property name="lib" value="${basedir}/lib" /> + <property name="junit" value="${basedir}/junit" /> + <property name="rsrc" value="${basedir}/rsrc" /> + + <target name="prepare"> + <!-- Create the time stamp --> + <tstamp/> + <!-- Create the build directory structure used by compile --> + <mkdir dir="${build}" /> + <mkdir dir="${api}" /> + <mkdir dir="${junit}" /> + <copy file="${rsrc}/build/build.version" tofile="${build}/build.properties"/> + <replace file="${build}/build.properties" token="@@@BUILD_ID@@@" value="${DSTAMP}-${TSTAMP}"/> + </target> + + <target name="compile" depends="copy-rsrc"> + <!-- Compile the java code from ${src} into ${build} --> + <javac srcdir="${src}" destdir="${build}" debug="on"> + <classpath> + <fileset dir="${lib}"> + <include name="log4j-core.jar" /> + <include name="jaxp.jar" /> + <include name="crimson.jar" /> + <include name="jdom.jar" /> + <include name="beanshell.jar" /> + </fileset> + </classpath> + </javac> + </target> + + <target name="compile-junit" depends="copy-rsrc"> + <!-- Compile the java code from ${src} into ${build} --> + <javac srcdir="${junit}" destdir="${build}" debug="on"> + <classpath> + <fileset dir="${lib}"> + <include name="*.jar" /> + </fileset> + </classpath> + </javac> + </target> + + <target name="copy-rsrc" depends="prepare"> + <!-- Copy various resource files into ${build} --> + <copy todir="${build}"> + <fileset + dir="${basedir}" + includes="images/*.gif, images/*.jpg" /> + </copy> + <copy todir="${build}"> + <fileset + dir="${src}" + includes="be/beta9/libretto/data/*.txt" /> + </copy> + <copy todir="${build}"> + <fileset + dir="${rsrc}/log4j" + includes="log4j.properties" /> + </copy> + </target> + + <target name="c-header" depends="compile"> + <javah destdir="${rsrc}/VC_source" class="be.beta9.libretto.io.ParallelPort"> + <classpath> + <pathelement location="${build}" /> + </classpath> + </javah> + </target> + + <target name="test-parport" depends="compile"> + <java + classname="be.beta9.libretto.io.ParallelPortWriter" + fork="yes"> + <classpath> + <pathelement location="${build}" /> + <fileset dir="${lib}"> + <include name="*.jar" /> + </fileset> + </classpath> + </java> + </target> + + <target name="jar-simple" depends="compile"> + <!-- Put everything in ${build} into the a jar file --> + <jar + jarfile="${basedir}/libretto.jar" + basedir="${build}" + manifest="${rsrc}/manifest/libretto.mf"/> + </target> + + <target name="jar" depends="compile"> + <!-- Put everything in ${build} into the a jar file including all dependecies --> + <unjar src="${lib}/jaxp.jar" dest="${build}" /> + <unjar src="${lib}/crimson.jar" dest="${build}" /> + <unjar src="${lib}/jdom.jar" dest="${build}" /> + <unjar src="${lib}/log4j-core.jar" dest="${build}" /> + <jar + jarfile="${basedir}/libretto.jar" + basedir="${build}" + manifest="${rsrc}/manifest/libretto.mf"/> + </target> + + <target name="client-jar" depends="background-jar"> + <!-- Put everything in ${build} into the a jar file including all dependecies --> + <unjar src="${lib}/log4j-core.jar" dest="${build}" /> + <jar jarfile="${basedir}/libretto-client.jar" manifest="${rsrc}/manifest/libretto-client.mf"> + <fileset dir="${build}"> + <include name="build.properties"/> + <include name="log4j.properties"/> + <include name="be/beta9/libretto/io/*.class"/> + <include name="be/beta9/libretto/application/Build.class"/> + <include name="be/beta9/libretto/net/LibrettoTextClient*.class"/> + <include name="be/beta9/libretto/net/TestClientMessage.class"/> + <include name="be/beta9/libretto/net/ClientStatusMessageResult.class"/> + <include name="be/beta9/libretto/net/Client*.class"/> + <include name="be/beta9/libretto/net/Constants.class"/> + <include name="be/beta9/libretto/net/TextMessage.class"/> + <include name="be/beta9/libretto/net/MessageResult.class"/> + <include name="be/beta9/libretto/net/MessageException.class"/> + <include name="be/beta9/libretto/net/SingleTextMessage.class"/> + <include name="be/beta9/libretto/net/Message.class"/> + <include name="be/beta9/libretto/net/Util.class"/> + <include name="be/beta9/libretto/gui/ShowSingleTextFrame*.class"/> + <include name="be/beta9/libretto/gui/AWTTextView*.class"/> + <include name="be/beta9/libretto/model/AttributedString*.class"/> + <include name="be/beta9/libretto/model/AWTTextStyle.class"/> + <include name="be/beta9/libretto/model/LTextStyle.class"/> + <include name="be/beta9/libretto/model/AWTCharacterAttributes.class"/> + <include name="be/beta9/libretto/model/Java2DTextStyle.class"/> + <include name="be/beta9/libretto/model/LCharacterAttributes.class"/> + <include name="be/beta9/libretto/model/Java2DCharacterAttributes.class"/> + <include name="be/beta9/libretto/util/TextStyleManager.class"/> + <include name="be/beta9/libretto/util/Bean.class"/> + <include name="be/beta9/libretto/util/LibrettoSaxReader.class"/> + <include name="be/beta9/libretto/util/Preferences.class"/> + <include name="be/beta9/libretto/util/Utilities.class"/> + <include name="org/apache/log4j/**"/> + </fileset> + </jar> + </target> + + <target name="background-jar" depends="compile"> + <!-- Put everything in ${build} into the a jar file including all dependecies --> + <jar jarfile="${basedir}/background.jar" manifest="${rsrc}/manifest/background-black-window.mf"> + <fileset dir="${build}"> + <include name="be/beta9/libretto/gui/BackgroundBlackWindow.class"/> + </fileset> + </jar> + </target> + + <target name="run" depends="compile"> + <!-- Execute the main application --> + <java + classname="be.beta9.libretto.application.Libretto" + fork="yes"> + <classpath> + <pathelement location="${build}" /> + <fileset dir="${lib}"> + <include name="log4j-core.jar" /> + <include name="jaxp.jar" /> + <include name="crimson.jar" /> + <include name="jdom.jar" /> + </fileset> + </classpath> + </java> + </target> + + <target name="debug" depends="compile"> + <!-- Execute the main application in debug mode --> + <java + classname="be.beta9.libretto.application.LibrettoDebug" + fork="yes"> + <classpath> + <pathelement location="${build}" /> + <fileset dir="${lib}"> + <include name="*.jar" /> + </fileset> + </classpath> + </java> + </target> + + <target name="junit" depends="compile-junit"> + <!-- Execute all junit tests --> + <java + classname="be.beta9.libretto.AllTests" + fork="yes"> + <classpath> + <pathelement location="${build}" /> + <fileset dir="${lib}"> + <include name="*.jar" /> + </fileset> + </classpath> + </java> + </target> + + <target name="clean"> + <!-- Delete the ${build} directory trees --> + <delete dir="${build}" /> + <delete dir="${api}" /> + </target> + + <target name="api" depends="prepare"> + <!-- Generate javadoc --> + <javadoc + packagenames="be.beta9.libretto.*" + sourcepath="${src}" + destdir="${api}" + windowtitle="Libretto" + author="true" + version="true" + use="true"/> + </target> + + <target name="zip-all" depends="jar, client-jar"> + <zip zipfile="libretto.zip"> + <fileset dir="${basedir}"> + <include name="libretto.jar"/> + <include name="libretto-client.jar"/> + </fileset> + </zip> + </target> + + <target name="upload" depends="clean, zip-all"> + <ftp + server="users.pandora.be" + userid="a002458" + password="bast0s" + remotedir="libretto" + verbose="true" + passive="true"> + <fileset dir="${basedir}"> + <include name="libretto.jar" /> + <include name="libretto-client.jar" /> + <include name="libretto.zip" /> + </fileset> + </ftp> + </target> + +</project> + + + + diff --git a/third-party/s-xml/test/plist.xml b/third-party/s-xml/test/plist.xml new file mode 100644 index 0000000..910e632 --- /dev/null +++ b/third-party/s-xml/test/plist.xml @@ -0,0 +1,38 @@ +<?xml version="1.0" encoding="UTF-8"?> +<!DOCTYPE plist PUBLIC "-//Apple Computer//DTD PLIST 1.0//EN" "http://www.apple.com/DTDs/PropertyList-1.0.dtd"> +<plist version="1.0"> +<dict> + <key>AppleDockIconEnabled</key> + <true/> + <key>AppleNavServices:GetFile:0:Path</key> + <string>file://localhost/Users/sven/Pictures/</string> + <key>AppleNavServices:GetFile:0:Position</key> + <data> + AOUBXw== + </data> + <key>AppleNavServices:GetFile:0:Size</key> + <data> + AAAAAAFeAcI= + </data> + <key>AppleNavServices:PutFile:0:Disclosure</key> + <data> + AQ== + </data> + <key>AppleNavServices:PutFile:0:Path</key> + <string>file://localhost/Users/sven/Desktop/</string> + <key>AppleNavServices:PutFile:0:Position</key> + <data> + AUIBVQ== + </data> + <key>AppleNavServices:PutFile:0:Size</key> + <data> + AAAAAACkAdY= + </data> + <key>AppleSavePanelExpanded</key> + <string>YES</string> + <key>NSDefaultOpenDirectory</key> + <string>~/Desktop</string> + <key>NSNoBigString</key> + <true/> +</dict> +</plist> diff --git a/third-party/s-xml/test/simple.xml b/third-party/s-xml/test/simple.xml new file mode 100644 index 0000000..08ad942 --- /dev/null +++ b/third-party/s-xml/test/simple.xml @@ -0,0 +1,5 @@ +<?xml version="1.0"?> +<!-- This is a very simple XML document --> +<root id="123"> + <text>Hello World!</text> +</root> diff --git a/third-party/s-xml/test/test-lxml-dom.lisp b/third-party/s-xml/test/test-lxml-dom.lisp new file mode 100644 index 0000000..f7aadbe --- /dev/null +++ b/third-party/s-xml/test/test-lxml-dom.lisp @@ -0,0 +1,86 @@ +;;;; -*- mode: lisp -*- +;;;; +;;;; $Id: test-lxml-dom.lisp,v 1.3 2008-02-15 13:54:57 scaekenberghe Exp $ +;;;; +;;;; Unit and functional tests for lxml-dom.lisp +;;;; +;;;; Copyright (C) 2002, 2004 Sven Van Caekenberghe, Beta Nine BVBA. +;;;; +;;;; You are granted the rights to distribute and use this software +;;;; as governed by the terms of the Lisp Lesser General Public License +;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. + +(in-package :s-xml) + +(assert + (equal (with-input-from-string (stream " <foo/>") + (parse-xml stream :output-type :lxml)) + :|foo|)) + +(assert + (equal (parse-xml-string "<tag1><tag2 att1='one'/>this is some text</tag1>" + :output-type :lxml) + '(:|tag1| + ((:|tag2| :|att1| "one")) + "this is some text"))) + +(assert + (equal (parse-xml-string "<TAG><foo></TAG>" + :output-type :lxml) + '(:TAG "<foo>"))) + +(assert + (equal (parse-xml-string + "<P><INDEX ITEM='one'/> This is some <B>bold</B> text, with a leading & trailing space </P>" + :output-type :lxml) + '(:p + ((:index :item "one")) + " This is some " + (:b "bold") + " text, with a leading & trailing space "))) + +(assert + (consp (parse-xml-file (merge-pathnames "test/xhtml-page.xml" + (asdf:component-pathname + (asdf:find-system :s-xml.test))) + :output-type :lxml))) + +(assert + (consp (parse-xml-file (merge-pathnames "test/ant-build-file.xml" + (asdf:component-pathname + (asdf:find-system :s-xml.test))) + :output-type :lxml))) + +(assert + (consp (parse-xml-file (merge-pathnames "test/plist.xml" + (asdf:component-pathname + (asdf:find-system :s-xml.test))) + :output-type :lxml))) + +(assert + (string-equal (print-xml-string :|foo| :input-type :lxml) + "<foo/>")) + +(assert + (string-equal (print-xml-string '((:|foo| :|bar| "1")) :input-type :lxml) + "<foo bar=\"1\"/>")) + +(assert + (string-equal (print-xml-string '(:foo "some text") :input-type :lxml) + "<FOO>some text</FOO>")) + +(assert + (string-equal (print-xml-string '(:|foo| :|bar|) :input-type :lxml) + "<foo><bar/></foo>")) + +(assert (string-equal (second + (with-input-from-string (stream "<foo><![CDATA[<greeting>Hello, world!</greeting>]]></foo>") + (parse-xml stream :output-type :lxml))) + "<greeting>Hello, world!</greeting>")) + +(assert (string-equal (second + (with-input-from-string (stream "<foo><![CDATA[<greeting>Hello, < world!</greeting>]]></foo>") + (parse-xml stream :output-type :lxml))) + "<greeting>Hello, < world!</greeting>")) + +;;;; eof diff --git a/third-party/s-xml/test/test-sxml-dom.lisp b/third-party/s-xml/test/test-sxml-dom.lisp new file mode 100644 index 0000000..41cf72f --- /dev/null +++ b/third-party/s-xml/test/test-sxml-dom.lisp @@ -0,0 +1,76 @@ +;;;; -*- mode: lisp -*- +;;;; +;;;; $Id: test-sxml-dom.lisp,v 1.2 2008-02-15 13:54:57 scaekenberghe Exp $ +;;;; +;;;; Unit and functional tests for sxml-dom.lisp +;;;; +;;;; Copyright (C) 2002, 2004 Sven Van Caekenberghe, Beta Nine BVBA. +;;;; +;;;; You are granted the rights to distribute and use this software +;;;; as governed by the terms of the Lisp Lesser General Public License +;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. + +(in-package :s-xml) + +(assert + (equal (with-input-from-string (stream " <foo/>") + (parse-xml stream :output-type :sxml)) + '(:|foo|))) + +(assert + (equal (parse-xml-string "<tag1><tag2 att1='one'/>this is some text</tag1>" + :output-type :sxml) + '(:|tag1| + (:|tag2| (:@ (:|att1| "one"))) + "this is some text"))) + +(assert + (equal (parse-xml-string "<TAG><foo></TAG>" + :output-type :sxml) + '(:TAG "<foo>"))) + +(assert + (equal (parse-xml-string + "<P><INDEX ITEM='one'/> This is some <B>bold</B> text, with a leading & trailing space </P>" + :output-type :sxml) + '(:p + (:index (:@ (:item "one"))) + " This is some " + (:b "bold") + " text, with a leading & trailing space "))) + +(assert + (consp (parse-xml-file (merge-pathnames "test/xhtml-page.xml" + (asdf:component-pathname + (asdf:find-system :s-xml.test))) + :output-type :sxml))) + +(assert + (consp (parse-xml-file (merge-pathnames "test/ant-build-file.xml" + (asdf:component-pathname + (asdf:find-system :s-xml.test))) + :output-type :sxml))) + +(assert + (consp (parse-xml-file (merge-pathnames "test/plist.xml" + (asdf:component-pathname + (asdf:find-system :s-xml.test))) + :output-type :sxml))) + +(assert + (string-equal (print-xml-string '(:|foo|) :input-type :sxml) + "<foo/>")) + +(assert + (string-equal (print-xml-string '(:|foo| (:@ (:|bar| "1"))) :input-type :sxml) + "<foo bar=\"1\"/>")) + +(assert + (string-equal (print-xml-string '(:foo "some text") :input-type :sxml) + "<FOO>some text</FOO>")) + +(assert + (string-equal (print-xml-string '(:|foo| (:|bar|)) :input-type :sxml) + "<foo><bar/></foo>")) + +;;;; eof
\ No newline at end of file diff --git a/third-party/s-xml/test/test-xml-struct-dom.lisp b/third-party/s-xml/test/test-xml-struct-dom.lisp new file mode 100644 index 0000000..607402b --- /dev/null +++ b/third-party/s-xml/test/test-xml-struct-dom.lisp @@ -0,0 +1,84 @@ +;;;; -*- mode: lisp -*- +;;;; +;;;; $Id: test-xml-struct-dom.lisp,v 1.3 2008-02-15 13:54:57 scaekenberghe Exp $ +;;;; +;;;; Unit and functional tests for xml-struct-dom.lisp +;;;; +;;;; Copyright (C) 2002, 2004 Sven Van Caekenberghe, Beta Nine BVBA. +;;;; +;;;; You are granted the rights to distribute and use this software +;;;; as governed by the terms of the Lisp Lesser General Public License +;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. + +(in-package :s-xml) + +(assert + (xml-equal (with-input-from-string (stream " <foo/>") + (parse-xml stream :output-type :xml-struct)) + (make-xml-element :name :|foo|))) + +(assert + (xml-equal (parse-xml-string "<tag1><tag2 att1='one'/>this is some text</tag1>" + :output-type :xml-struct) + (make-xml-element :name :|tag1| + :children (list (make-xml-element :name :|tag2| + :attributes '((:|att1| . "one"))) + "this is some text")))) + +(assert + (xml-equal (parse-xml-string "<tag><foo></tag>" + :output-type :xml-struct) + (make-xml-element :name :|tag| + :children (list "<foo>")))) + +(assert + (xml-equal (parse-xml-string + "<P><INDEX ITEM='one'/> This is some <B>bold</B> text, with a leading & trailing space </P>" + :output-type :xml-struct) + (make-xml-element :name :p + :children (list (make-xml-element :name :index + :attributes '((:item . "one"))) + " This is some " + (make-xml-element :name :b + :children (list "bold")) + " text, with a leading & trailing space ")))) + +(assert + (xml-element-p (parse-xml-file (merge-pathnames "test/xhtml-page.xml" + (asdf:component-pathname + (asdf:find-system :s-xml.test))) + :output-type :xml-struct))) + +(assert + (xml-element-p (parse-xml-file (merge-pathnames "test/ant-build-file.xml" + (asdf:component-pathname + (asdf:find-system :s-xml.test))) + :output-type :xml-struct))) + +(assert + (xml-element-p (parse-xml-file (merge-pathnames "test/plist.xml" + (asdf:component-pathname + (asdf:find-system :s-xml.test))) + :output-type :xml-struct))) + +(assert + (string-equal (print-xml-string (make-xml-element :name "foo") + :input-type :xml-struct) + "<foo/>")) + +(assert + (string-equal (print-xml-string (make-xml-element :name "foo" :attributes '((:|bar| . "1"))) + :input-type :xml-struct) + "<foo bar=\"1\"/>")) + +(assert + (string-equal (print-xml-string (make-xml-element :name "foo" :children (list "some text")) + :input-type :xml-struct) + "<foo>some text</foo>")) + +(assert + (string-equal (print-xml-string (make-xml-element :name "foo" :children (list (make-xml-element :name "bar"))) + :input-type :xml-struct) + "<foo><bar/></foo>")) + +;;;; eof
\ No newline at end of file diff --git a/third-party/s-xml/test/test-xml.lisp b/third-party/s-xml/test/test-xml.lisp new file mode 100644 index 0000000..6d636a8 --- /dev/null +++ b/third-party/s-xml/test/test-xml.lisp @@ -0,0 +1,86 @@ +;;;; -*- mode: lisp -*- +;;;; +;;;; $Id: test-xml.lisp,v 1.4 2006-01-19 20:00:06 scaekenberghe Exp $ +;;;; +;;;; Unit and functional tests for xml.lisp +;;;; +;;;; Copyright (C) 2002, 2004 Sven Van Caekenberghe, Beta Nine BVBA. +;;;; +;;;; You are granted the rights to distribute and use this software +;;;; as governed by the terms of the Lisp Lesser General Public License +;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. + +(in-package :s-xml) + +(assert + (whitespace-char-p (character " "))) + +(assert + (whitespace-char-p (character " "))) + +(assert + (whitespace-char-p (code-char 10))) + +(assert + (whitespace-char-p (code-char 13))) + +(assert + (not (whitespace-char-p #\A))) + +(assert + (char= (with-input-from-string (stream " ABC") + (skip-whitespace stream)) + #\A)) + +(assert + (char= (with-input-from-string (stream "ABC") + (skip-whitespace stream)) + #\A)) + +(assert + (string-equal (with-output-to-string (stream) (print-string-xml "<foo>" stream)) + "<foo>")) + +(assert + (string-equal (with-output-to-string (stream) (print-string-xml "' '" stream)) + "' '")) + +(assert + (let ((string (map 'string #'identity '(#\return #\tab #\newline)))) + (string-equal (with-output-to-string (stream) (print-string-xml string stream)) + string))) + +(defun simple-echo-xml (in out) + (start-parse-xml + in + (make-instance 'xml-parser-state + :new-element-hook #'(lambda (name attributes seed) + (declare (ignore seed)) + (format out "<~a~:{ ~a='~a'~}>" + name + (mapcar #'(lambda (p) (list (car p) (cdr p))) + (reverse attributes)))) + :finish-element-hook #'(lambda (name attributes parent-seed seed) + (declare (ignore attributes parent-seed seed)) + (format out "</~a>" name)) + :text-hook #'(lambda (string seed) + (declare (ignore seed)) + (princ string out))))) + +(defun simple-echo-xml-string (string) + (with-input-from-string (in string) + (with-output-to-string (out) + (simple-echo-xml in out)))) + +(dolist (*ignore-namespaces* '(nil t)) + (assert + (let ((xml "<FOO ATT1='1' ATT2='2'><B>Text</B><EMPTY></EMPTY>More text!<SUB><SUB></SUB></SUB></FOO>")) + (equal (simple-echo-xml-string xml) + xml)))) + +(assert + (let ((xml "<p> </p>")) + (equal (simple-echo-xml-string xml) + xml))) + +;;;; eof
\ No newline at end of file diff --git a/third-party/s-xml/test/xhtml-page.xml b/third-party/s-xml/test/xhtml-page.xml new file mode 100644 index 0000000..79f3ae3 --- /dev/null +++ b/third-party/s-xml/test/xhtml-page.xml @@ -0,0 +1,271 @@ +<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
+
+<html>
+<head>
+
+<title>XHTML Tutorial</title>
+<meta http-equiv="Content-Type" content="text/html; charset=windows-1252" />
+<meta name="Keywords" content="XML,tutorial,HTML,DHTML,CSS,XSL,XHTML,JavaScript,ASP,ADO,VBScript,DOM,authoring,programming,learning,beginner's guide,primer,lessons,school,howto,reference,examples,samples,source code,demos,tips,links,FAQ,tag list,forms,frames,color table,W3C,Cascading Style Sheets,Active Server Pages,Dynamic HTML,Internet database development,Webbuilder,Sitebuilder,Webmaster,HTMLGuide,SiteExpert" />
+<meta name="Description" content="HTML,CSS,JavaScript,DHTML,XML,XHTML,ASP,ADO and VBScript tutorial from W3Schools." />
+<meta http-equiv="pragma" content="no-cache" />
+<meta http-equiv="cache-control" content="no-cache" />
+
+<link rel="stylesheet" type="text/css" href="../stdtheme.css" />
+
+</head>
+<body>
+
+<table border="0" cellpadding="0" cellspacing="0" width="775">
+<tr>
+<td width="140" class="content" valign="top">
+<br />
+<a class="left" href="../default.asp" target="_top"><b>HOME</b></a><br />
+<br />
+<b>XHTML Tutorial</b><br />
+<a class="left" target="_top" href="default.asp" style='font-weight:bold;color:#000000;background-color:transparent;'>XHTML HOME</a><br />
+<a class="left" target="_top" href="xhtml_intro.asp" >XHTML Introduction</a><br />
+<a class="left" target="_top" href="xhtml_why.asp" >XHTML Why</a><br />
+<a class="left" target="_top" href="xhtml_html.asp" >XHTML v HTML</a><br />
+<a class="left" target="_top" href="xhtml_syntax.asp" >XHTML Syntax</a><br />
+<a class="left" target="_top" href="xhtml_dtd.asp" >XHTML DTD</a><br />
+<a class="left" target="_top" href="xhtml_howto.asp" >XHTML HowTo</a><br />
+<a class="left" target="_top" href="xhtml_validate.asp" >XHTML Validation</a><br />
+<br />
+<b>Quiz</b>
+<br />
+<a class="left" target="_top" href="xhtml_quiz.asp" >XHTML Quiz</a><br />
+<br />
+<b>References</b>
+<br />
+<a class="left" target="_top" href="xhtml_reference.asp" >XHTML Tag List</a><br />
+<a class="left" target="_top" href="xhtml_standardattributes.asp" >XHTML Attributes</a><br />
+<a class="left" target="_top" href="xhtml_eventattributes.asp" >XHTML Events</a><br />
+</td>
+<td width="490" valign="top">
+<table width="100%" bgcolor="#FFFFFF" border="1" cellpadding="7" cellspacing="0">
+<tr>
+<td>
+<center>
+<a href="http://ad.doubleclick.net/jump/N1951.w3schools/B1097963;sz=468x60;ord=[timestamp]?" target="_new">
+<img src="http://ad.doubleclick.net/ad/N1951.w3schools/B1097963;sz=468x60;ord=[timestamp]?"
+border="0" width="468" height="60" alt="Corel XMetal 3" /></a>
+
+
+<br />Please Visit Our Sponsors !
+</center>
+<h1>XHTML Tutorial</h1>
+<a href="../default.asp"><img border="0" src="../images/btn_previous.gif" alt="Previous" /></a>
+<a href="xhtml_intro.asp"><img border="0" src="../images/btn_next.gif" width="100" height="20" alt="Next" /></a>
+
+<hr />
+
+<h2>XHTML Tutorial</h2>
+<p>XHTML is the next generation of HTML! In our XHTML tutorial you will learn the difference between HTML and XHTML, and how to use XHTML in your future
+applications. You will also see how we converted this Web site into XHTML. <a href="xhtml_intro.asp">Start Learning
+XHTML!</a></p>
+
+<h2>XHTML Quiz Test</h2>
+<p>Test your XHTML skills at W3Schools! <a href="xhtml_quiz.asp">Start XHTML
+Quiz!</a> </p>
+
+<h2>XHTML References</h2>
+<p>At W3Schools you will find complete XHTML references about tags, attributes
+and events. <a href="xhtml_reference.asp">XHTML 1.0 References</a>.</p>
+<hr />
+<h2>Table of Contents</h2>
+<p><a href="xhtml_intro.asp">Introduction to XHTML</a><br />
+This chapter gives a brief introduction to XHTML and explains what XHTML is.</p>
+<p><a href="xhtml_why.asp">XHTML - Why?</a><br />
+This chapter explains why we needed a new language like XHTML.</p>
+<p><a href="xhtml_html.asp">Differences between XHTML and HTML</a><br />
+This chapter explains the main differences in syntax between XHTML and HTML.</p>
+<p><a href="xhtml_syntax.asp">XHTML Syntax</a> <br />
+This chapter explains the basic syntax of XHTML.</p>
+<p><a href="xhtml_dtd.asp">XHTML DTD</a> <br />
+This chapter explains the three different XHTML Document Type Definitions.</p>
+<p><a href="xhtml_howto.asp">XHTML HowTo</a><br />
+This chapter explains how this web site was converted from HTML to XHTML.</p>
+<p><a href="xhtml_validate.asp">XHTML Validation</a><br />
+This chapter explains how to validate XHTML documents.</p>
+<hr />
+<h2>XHTML References</h2>
+<p><a href="xhtml_reference.asp">XHTML 1.0 Reference<br />
+</a>Our complete XHTML 1.0 reference is an alphabetical list of all XHTML tags
+with lots of examples and tips.</p>
+<p><a href="xhtml_standardattributes.asp">XHTML 1.0 Standard Attributes<br />
+</a>All the tags have attributes. The attributes for each tag are listed in the
+examples in the "XHTML 1.0 Reference" page. The attributes listed here
+are the core and language attributes all the tags has as standard (with
+few exceptions). This reference describes the attributes, and shows possible
+values for each.</p>
+<p><a href="xhtml_eventattributes.asp">XHTML 1.0 Event Attributes<br />
+</a>All the standard event attributes of the tags. This reference describes the attributes, and shows possible
+values for each.</p>
+<hr />
+<a href="../default.asp"><img border="0" src="../images/btn_previous.gif" width="100" height="20" alt="Previous" /></a>
+<a href="xhtml_intro.asp"><img border="0" src="../images/btn_next.gif" width="100" height="20" alt="Next" /></a>
+
+
+<hr />
+<p>
+Jump to: <a href="#top" target="_top"><b>Top of Page</b></a>
+or <a href="/" target="_top"><b>HOME</b></a> or
+<a href='/xhtml/default.asp?output=print' target="_blank">
+<img src="../images/print.gif" alt="Printer Friendly" border="0" />
+<b>Printer friendly page</b></a>
+</p>
+<hr />
+
+<h2>Search W3Schools:</h2>
+<form method="get" name="searchform" action="http://www.google.com/search" target="_blank">
+<input type="hidden" name="as_sitesearch" value="www.w3schools.com" />
+<input type="text" size="30" name="as_q" />
+<input type="submit" value=" Go! " />
+</form>
+
+<hr />
+<h2>What Others Say About Us</h2>
+<p>Does the world know about us? Check out these places:</p>
+<p>
+<a href="http://search.dogpile.com/texis/search?q=W3schools" target="_blank">Dogpile</a>
+<a href="http://www.altavista.com/cgi-bin/query?q=W3Schools" target="_blank">Alta Vista</a>
+<a href="http://search.msn.com/results.asp?q=W3Schools" target="_blank">MSN</a>
+<a href="http://www.google.com/search?q=W3Schools" target="_blank">Google</a>
+<a href="http://search.excite.com/search.gw?search=W3Schools" target="_blank">Excite</a>
+<a href="http://search.lycos.com/main/?query=W3Schools" target="_blank">Lycos</a>
+<a href="http://search.yahoo.com/search?p=w3schools" target="_blank">Yahoo</a>
+<a href="http://www.ask.com/main/askJeeves.asp?ask=W3Schools" target="_blank">Ask Jeeves</a>
+</p>
+<hr />
+<h2>We Help You For Free. You Can Help Us!</h2>
+<ul>
+<li><a href="../tellyourgroup.htm" target="blank">Tell your newsgroup or mailing list</a></li>
+<li><a href="../about/about_linking.asp">Link to us from your pages</a></li>
+<li><a href="../about/about_helpers.asp">Help us correct errors and broken links</a></li>
+<li><a href="../about/about_helpers.asp">Help us with spelling and grammar</a></li>
+<li><a href="http://validator.w3.org/check/referer" target="_blank">Validate the XHTML code of this page</a></li>
+</ul>
+
+<hr />
+<p>
+W3Schools is for training only. We do not warrant its correctness or its fitness for use.
+The risk of using it remains entirely with the user. While using this site, you agree to have read and accepted our
+<a href="../about/about_copyright.asp">terms of use</a> and
+<a href="../about/about_privacy.asp">privacy policy</a>.</p>
+<p>
+<a href="../about/about_copyright.asp">Copyright 1999-2002</a> by Refsnes Data. All Rights Reserved</p>
+<hr />
+<table border="0" width="100%" cellspacing="0" cellpadding="0"><tr>
+<td width="25%" align="left">
+<a href="http://validator.w3.org/check/referer" target="_blank">
+<img src="../images/vxhtml.gif" alt="Validate" width="88" height="31" border="0" /></a>
+</td>
+<td width="50%" align="center">
+<a href="../xhtml/" target="_top">How we converted to XHTML</a>
+</td>
+<td width="25%" align="right">
+<a href="http://jigsaw.w3.org/css-validator/check/referer" target="_blank">
+<img src="../images/vcss.gif" alt="Validate" width="88" height="31" border="0" /></a>
+</td>
+</tr></table>
+</td>
+</tr>
+</table>
+</td>
+
+
+
+<td width="144" align="center" valign="top">
+
+<table border="1" width="100%" bgcolor="#ffffff" cellpadding="0" cellspacing="0"><tr>
+<td align="center" class="right"><br />
+
+<a href="http://www.dotnetcharting.com" target="_blank"><img src="../images/dnc-icon.gif" alt="Web charting" border="0" /></a>
+<br />
+<a class="right" href="http://www.dotnetcharting.com" target="_blank">Web based charting<br />for ASP.NET</a>
+
+<br /><br />
+</td></tr></table>
+
+<table border="1" width="100%" bgcolor="#ffffff" cellpadding="0" cellspacing="0"><tr>
+<td align="center" class="right">
+<br />
+<a href="../hosting/default.asp">
+Your own Web Site?<br />
+<br />Read W3Schools
+<br />Hosting Tutorial</a>
+<br />
+<br />
+</td></tr></table>
+
+<table border="1" width="100%" bgcolor="#ffffff" cellpadding="0" cellspacing="0"><tr>
+<td align="center" class="right">
+<br />
+<a class="red" href="http://www.dotdnr.com" target="_blank">$15 Domain Name<br />Registration<br />Save $20 / year!</a>
+<br />
+<br />
+</td></tr></table>
+
+
+
+<table border="1" width="100%" bgcolor="#ffffff" cellpadding="0" cellspacing="0">
+<tr><td align="center" class="right">
+<br />
+<b>SELECTED LINKS</b>
+<br /><br />
+<a class="right" href="http://opogee.com/clk/dangtingcentiaonie" target="_blank">University Online<br />
+Master Degree<br />Bachelor Degree</a>
+<br /><br />
+<a class="right" href="../software/default.asp" target="_top">Web Software</a>
+<br /><br />
+<a class="right" href="../appml/default.asp" target="_top">The Future of<br />Web Development</a>
+<br /><br />
+<a class="right" href="../careers/default.asp" target="_top">Jobs and Careers</a>
+<br /><br />
+<a class="right" href="../site/site_security.asp" target="_top">Web Security</a>
+<br />
+<a class="right" href="../browsers/browsers_stats.asp" target="_top">Web Statistics</a>
+<br />
+<a class="right" href="../w3c" target="_top">Web Standards</a>
+<br /><br />
+</td></tr></table>
+
+
+<table border="1" width="100%" bgcolor="#ffffff" cellpadding="0" cellspacing="0"><tr>
+<td align="center" class="right">
+<br />
+
+<b>Recommended<br />
+Reading:</b><br /><br />
+
+<a class="right" target="_blank"
+href="http://www.amazon.com/exec/obidos/ASIN/059600026X/w3schools03">
+<img src="../images/book_amazon_xhtml.jpg" border="0" alt="HTML XHTML" /></a>
+
+
+<br /><br /></td>
+</tr></table>
+
+<table border="1" width="100%" bgcolor="#ffffff" cellpadding="0" cellspacing="0"><tr>
+<td align="center" class="right">
+<br />
+<b>PARTNERS</b><br />
+<br />
+<a class="right" href="http://www.W3Schools.com" target="_blank">W3Schools</a><br />
+<a class="right" href="http://www.topxml.com" target="_blank">TopXML</a><br />
+<a class="right" href="http://www.visualbuilder.com" target="_blank">VisualBuilder</a><br />
+<a class="right" href="http://www.xmlpitstop.com" target="_blank">XMLPitstop</a><br />
+<a class="right" href="http://www.developersdex.com" target="_blank">DevelopersDex</a><br />
+<a class="right" href="http://www.devguru.com" target="_blank">DevGuru</a><br />
+<a class="right" href="http://www.programmersheaven.com/" target="_blank">Programmers Heaven</a><br />
+<a class="right" href="http://www.codeproject.com" target="_blank">The Code Project</a><br />
+<a class="right" href="http://www.tek-tips.com" target="_blank">Tek Tips Forum</a><br />
+<a class="right" href="http://www.zvon.ORG/" target="_blank">ZVON.ORG</a><br />
+<a class="right" href="http://www.topxml.com/search.asp" target="_blank">TopXML Search</a><br />
+<br />
+</td>
+</tr></table>
+</td></tr></table>
+
+</body>
+</html>
|