feat(third_party/lisp/s-xml): Check in sources & derivation
Checked in the sources for this because it is tracked upstream in CVS and I can't be bothered to deal with that right now.
This commit is contained in:
Vincent Ambo
parent
fe3ea06cbc
commit
437efa7686
23 changed files with 2389 additions and 0 deletions
28
third_party/lisp/s-xml/.gitignore
vendored
Normal file
28
third_party/lisp/s-xml/.gitignore
vendored
Normal file
|
|
@ -0,0 +1,28 @@
|
|||
# CVS default ignores begin
|
||||
tags
|
||||
TAGS
|
||||
.make.state
|
||||
.nse_depinfo
|
||||
*~
|
||||
#*
|
||||
.#*
|
||||
,*
|
||||
_$*
|
||||
*$
|
||||
*.old
|
||||
*.bak
|
||||
*.BAK
|
||||
*.orig
|
||||
*.rej
|
||||
.del-*
|
||||
*.a
|
||||
*.olb
|
||||
*.o
|
||||
*.obj
|
||||
*.so
|
||||
*.exe
|
||||
*.Z
|
||||
*.elc
|
||||
*.ln
|
||||
core
|
||||
# CVS default ignores end
|
||||
66
third_party/lisp/s-xml/ChangeLog
vendored
Normal file
66
third_party/lisp/s-xml/ChangeLog
vendored
Normal file
|
|
@ -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.5 2005/11/20 14:24:33 scaekenberghe Exp $
|
||||
35
third_party/lisp/s-xml/Makefile
vendored
Normal file
35
third_party/lisp/s-xml/Makefile
vendored
Normal file
|
|
@ -0,0 +1,35 @@
|
|||
# $Id: Makefile,v 1.2 2004/06/11 13:46:48 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
|
||||
17
third_party/lisp/s-xml/default.nix
vendored
Normal file
17
third_party/lisp/s-xml/default.nix
vendored
Normal file
|
|
@ -0,0 +1,17 @@
|
|||
# XML serialiser for Common Lisp.
|
||||
#
|
||||
# This system was imported from a Quicklisp tarball at 's-xml-20150608'.
|
||||
{ pkgs, ... }:
|
||||
|
||||
pkgs.nix.buildLisp.library {
|
||||
name = "s-xml";
|
||||
|
||||
srcs = [
|
||||
./src/package.lisp
|
||||
./src/xml.lisp
|
||||
./src/dom.lisp
|
||||
./src/lxml-dom.lisp
|
||||
./src/sxml-dom.lisp
|
||||
./src/xml-struct-dom.lisp
|
||||
];
|
||||
}
|
||||
47
third_party/lisp/s-xml/examples/counter.lisp
vendored
Normal file
47
third_party/lisp/s-xml/examples/counter.lisp
vendored
Normal file
|
|
@ -0,0 +1,47 @@
|
|||
;;;; -*- mode: lisp -*-
|
||||
;;;;
|
||||
;;;; $Id: counter.lisp,v 1.2 2004/06/11 11:14:43 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
|
||||
64
third_party/lisp/s-xml/examples/echo.lisp
vendored
Normal file
64
third_party/lisp/s-xml/examples/echo.lisp
vendored
Normal file
|
|
@ -0,0 +1,64 @@
|
|||
;;;; -*- mode: lisp -*-
|
||||
;;;;
|
||||
;;;; $Id: echo.lisp,v 1.1 2005/08/17 13:44:30 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
|
||||
21
third_party/lisp/s-xml/examples/remove-markup.lisp
vendored
Normal file
21
third_party/lisp/s-xml/examples/remove-markup.lisp
vendored
Normal file
|
|
@ -0,0 +1,21 @@
|
|||
;;;; -*- mode: lisp -*-
|
||||
;;;;
|
||||
;;;; $Id: remove-markup.lisp,v 1.1 2004/06/11 11:14:43 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
|
||||
57
third_party/lisp/s-xml/examples/tracer.lisp
vendored
Normal file
57
third_party/lisp/s-xml/examples/tracer.lisp
vendored
Normal file
|
|
@ -0,0 +1,57 @@
|
|||
;;;; -*- mode: lisp -*-
|
||||
;;;;
|
||||
;;;; $Id: tracer.lisp,v 1.2 2004/06/11 11:14:43 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
|
||||
49
third_party/lisp/s-xml/s-xml.asd
vendored
Normal file
49
third_party/lisp/s-xml/s-xml.asd
vendored
Normal file
|
|
@ -0,0 +1,49 @@
|
|||
;;;; -*- Mode: LISP -*-
|
||||
;;;;
|
||||
;;;; $Id: s-xml.asd,v 1.2 2005/12/14 21:49:04 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
|
||||
75
third_party/lisp/s-xml/src/dom.lisp
vendored
Normal file
75
third_party/lisp/s-xml/src/dom.lisp
vendored
Normal file
|
|
@ -0,0 +1,75 @@
|
|||
;;;; -*- mode: lisp -*-
|
||||
;;;;
|
||||
;;;; $Id: dom.lisp,v 1.1.1.1 2004/06/07 18:49:56 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
|
||||
83
third_party/lisp/s-xml/src/lxml-dom.lisp
vendored
Normal file
83
third_party/lisp/s-xml/src/lxml-dom.lisp
vendored
Normal file
|
|
@ -0,0 +1,83 @@
|
|||
;;;; -*- mode: lisp -*-
|
||||
;;;;
|
||||
;;;; $Id: lxml-dom.lisp,v 1.5 2005/09/20 09:57:44 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
|
||||
46
third_party/lisp/s-xml/src/package.lisp
vendored
Normal file
46
third_party/lisp/s-xml/src/package.lisp
vendored
Normal file
|
|
@ -0,0 +1,46 @@
|
|||
;;;; -*- mode: lisp -*-
|
||||
;;;;
|
||||
;;;; $Id: package.lisp,v 1.7 2006/01/19 20:00:06 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
|
||||
76
third_party/lisp/s-xml/src/sxml-dom.lisp
vendored
Normal file
76
third_party/lisp/s-xml/src/sxml-dom.lisp
vendored
Normal file
|
|
@ -0,0 +1,76 @@
|
|||
;;;; -*- mode: lisp -*-
|
||||
;;;;
|
||||
;;;; $Id: sxml-dom.lisp,v 1.4 2005/09/20 09:57:48 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
|
||||
125
third_party/lisp/s-xml/src/xml-struct-dom.lisp
vendored
Normal file
125
third_party/lisp/s-xml/src/xml-struct-dom.lisp
vendored
Normal file
|
|
@ -0,0 +1,125 @@
|
|||
;;;; -*- mode: lisp -*-
|
||||
;;;;
|
||||
;;;; $Id: xml-struct-dom.lisp,v 1.2 2005/08/29 15:01:47 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
|
||||
702
third_party/lisp/s-xml/src/xml.lisp
vendored
Normal file
702
third_party/lisp/s-xml/src/xml.lisp
vendored
Normal file
|
|
@ -0,0 +1,702 @@
|
|||
;;;; -*- mode: lisp -*-
|
||||
;;;;
|
||||
;;;; $Id: xml.lisp,v 1.15 2006/01/19 20:00:06 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)
|
||||
|
||||
;;; (tazjin): moved up here because something was wonky with the
|
||||
;;; definition order
|
||||
(defvar *ignore-namespaces* nil
|
||||
"When t, namespaces are ignored like in the old version of 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
|
||||
|
||||
(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
|
||||
252
third_party/lisp/s-xml/test/ant-build-file.xml
vendored
Normal file
252
third_party/lisp/s-xml/test/ant-build-file.xml
vendored
Normal file
|
|
@ -0,0 +1,252 @@
|
|||
<!-- $Id: ant-build-file.xml,v 1.1 2003/03/18 08:22:09 sven 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>
|
||||
|
||||
|
||||
|
||||
|
||||
38
third_party/lisp/s-xml/test/plist.xml
vendored
Normal file
38
third_party/lisp/s-xml/test/plist.xml
vendored
Normal file
|
|
@ -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>
|
||||
5
third_party/lisp/s-xml/test/simple.xml
vendored
Normal file
5
third_party/lisp/s-xml/test/simple.xml
vendored
Normal file
|
|
@ -0,0 +1,5 @@
|
|||
<?xml version="1.0"?>
|
||||
<!-- This is a very simple XML document -->
|
||||
<root id="123">
|
||||
<text>Hello World!</text>
|
||||
</root>
|
||||
86
third_party/lisp/s-xml/test/test-lxml-dom.lisp
vendored
Normal file
86
third_party/lisp/s-xml/test/test-lxml-dom.lisp
vendored
Normal file
|
|
@ -0,0 +1,86 @@
|
|||
;;;; -*- mode: lisp -*-
|
||||
;;;;
|
||||
;;;; $Id: test-lxml-dom.lisp,v 1.2 2005/11/06 12:44:48 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
|
||||
76
third_party/lisp/s-xml/test/test-sxml-dom.lisp
vendored
Normal file
76
third_party/lisp/s-xml/test/test-sxml-dom.lisp
vendored
Normal file
|
|
@ -0,0 +1,76 @@
|
|||
;;;; -*- mode: lisp -*-
|
||||
;;;;
|
||||
;;;; $Id: test-sxml-dom.lisp,v 1.1.1.1 2004/06/07 18:49:59 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
|
||||
84
third_party/lisp/s-xml/test/test-xml-struct-dom.lisp
vendored
Normal file
84
third_party/lisp/s-xml/test/test-xml-struct-dom.lisp
vendored
Normal file
|
|
@ -0,0 +1,84 @@
|
|||
;;;; -*- mode: lisp -*-
|
||||
;;;;
|
||||
;;;; $Id: test-xml-struct-dom.lisp,v 1.2 2005/08/29 15:01:49 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
|
||||
86
third_party/lisp/s-xml/test/test-xml.lisp
vendored
Normal file
86
third_party/lisp/s-xml/test/test-xml.lisp
vendored
Normal file
|
|
@ -0,0 +1,86 @@
|
|||
;;;; -*- mode: lisp -*-
|
||||
;;;;
|
||||
;;;; $Id: test-xml.lisp,v 1.3 2005/11/06 12:44:48 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
|
||||
271
third_party/lisp/s-xml/test/xhtml-page.xml
vendored
Normal file
271
third_party/lisp/s-xml/test/xhtml-page.xml
vendored
Normal file
|
|
@ -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>
|
||||
Loading…
Reference in a new issue