summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorMatthias Benkard <code@mail.matthias.benkard.de>2009-10-30 20:52:07 +0100
committerMatthias Benkard <code@mail.matthias.benkard.de>2009-10-30 20:52:07 +0100
commitddb83b1fb2d305e0c06fc067d82d6bab5458b0fd (patch)
tree8f9003926f0b5295c7a04b2ca257c0a2155ce841
parent15937a1a4f1cf40bc55aa34eb71c67b88466ff57 (diff)
Add third-party XML processing libraries.
Ignore-this: 5ca28497555bf944858ca2f58bc8a62b darcs-hash:a0b0f9baa7c9b1259e755435db1fb17123630a6c
-rw-r--r--third-party/s-base64/.clbuild-skip-update0
-rw-r--r--third-party/s-base64/Makefile82
-rw-r--r--third-party/s-base64/README.txt1
-rw-r--r--third-party/s-base64/doc/API.html11
-rw-r--r--third-party/s-base64/doc/index.html266
-rw-r--r--third-party/s-base64/s-base64.asd30
-rw-r--r--third-party/s-base64/src/base64.lisp152
-rw-r--r--third-party/s-base64/src/package.lisp22
-rw-r--r--third-party/s-base64/test/all-tests.lisp15
-rw-r--r--third-party/s-base64/test/test-base64.lisp140
-rw-r--r--third-party/s-base64/test/test.b641
-rw-r--r--third-party/s-sysdeps/.clbuild-skip-update0
-rw-r--r--third-party/s-sysdeps/Makefile82
-rw-r--r--third-party/s-sysdeps/README.txt1
-rw-r--r--third-party/s-sysdeps/doc/API.html19
-rw-r--r--third-party/s-sysdeps/doc/index.html203
-rw-r--r--third-party/s-sysdeps/s-sysdeps.asd31
-rw-r--r--third-party/s-sysdeps/src/bivalent-streams.lisp107
-rw-r--r--third-party/s-sysdeps/src/package.lisp28
-rw-r--r--third-party/s-sysdeps/src/sysdeps.lisp281
-rw-r--r--third-party/s-sysdeps/test/all-tests.lisp15
-rw-r--r--third-party/s-sysdeps/test/test-sysdeps.lisp19
-rw-r--r--third-party/s-xml-rpc/.clbuild-skip-update0
-rw-r--r--third-party/s-xml-rpc/ChangeLog63
-rw-r--r--third-party/s-xml-rpc/Makefile33
-rw-r--r--third-party/s-xml-rpc/s-xml-rpc.asd32
-rw-r--r--third-party/s-xml-rpc/src/aserve.lisp79
-rw-r--r--third-party/s-xml-rpc/src/define-xmlrpc-method.lisp30
-rw-r--r--third-party/s-xml-rpc/src/extensions.lisp107
-rw-r--r--third-party/s-xml-rpc/src/package.lisp49
-rw-r--r--third-party/s-xml-rpc/src/validator1-client.lisp182
-rw-r--r--third-party/s-xml-rpc/src/validator1-server.lisp90
-rw-r--r--third-party/s-xml-rpc/src/xml-rpc.lisp586
-rw-r--r--third-party/s-xml-rpc/test/all-tests.lisp17
-rw-r--r--third-party/s-xml-rpc/test/test-base64.lisp123
-rw-r--r--third-party/s-xml-rpc/test/test-extensions.lisp53
-rw-r--r--third-party/s-xml-rpc/test/test-xml-rpc.lisp176
-rw-r--r--third-party/s-xml-rpc/test/test.b641
-rw-r--r--third-party/s-xml/.clbuild-skip-update0
-rw-r--r--third-party/s-xml/ChangeLog66
-rw-r--r--third-party/s-xml/Makefile35
-rw-r--r--third-party/s-xml/examples/counter.lisp47
-rw-r--r--third-party/s-xml/examples/echo.lisp64
-rw-r--r--third-party/s-xml/examples/remove-markup.lisp21
-rw-r--r--third-party/s-xml/examples/tracer.lisp57
-rw-r--r--third-party/s-xml/s-xml.asd49
-rw-r--r--third-party/s-xml/src/dom.lisp75
-rw-r--r--third-party/s-xml/src/lxml-dom.lisp83
-rw-r--r--third-party/s-xml/src/package.lisp46
-rw-r--r--third-party/s-xml/src/sxml-dom.lisp76
-rw-r--r--third-party/s-xml/src/xml-struct-dom.lisp125
-rw-r--r--third-party/s-xml/src/xml.lisp700
-rw-r--r--third-party/s-xml/test/ant-build-file.xml252
-rw-r--r--third-party/s-xml/test/plist.xml38
-rw-r--r--third-party/s-xml/test/simple.xml5
-rw-r--r--third-party/s-xml/test/test-lxml-dom.lisp86
-rw-r--r--third-party/s-xml/test/test-sxml-dom.lisp76
-rw-r--r--third-party/s-xml/test/test-xml-struct-dom.lisp84
-rw-r--r--third-party/s-xml/test/test-xml.lisp86
-rw-r--r--third-party/s-xml/test/xhtml-page.xml271
60 files changed, 5469 insertions, 0 deletions
diff --git a/third-party/s-base64/.clbuild-skip-update b/third-party/s-base64/.clbuild-skip-update
new file mode 100644
index 0000000..e69de29
--- /dev/null
+++ b/third-party/s-base64/.clbuild-skip-update
diff --git a/third-party/s-base64/Makefile b/third-party/s-base64/Makefile
new file mode 100644
index 0000000..93fccc9
--- /dev/null
+++ b/third-party/s-base64/Makefile
@@ -0,0 +1,82 @@
+#
+# This makefile contains command line tools to maintain this project
+# Please consult the documentation in doc/index.html for more user oriented information
+# Portability at this level is accidental, only LispWorks on Mac OS X is supported here
+# For some operations, edit the necessary variables to suit your environment
+# Some operations can obviously only be done by a specific person in a very specific context ;-)
+#
+
+default:
+ @echo Welcome to S-BASE64, a Common Lisp implementation of Base64 Encoding/Decoding
+ @echo
+ @echo Possible makefile targets:
+ @echo
+ @echo clean-fasl --- remove all known lisp compiled fasl files recursively
+ @echo clean-emacs --- remove all '*~' recursively
+ @echo clean --- all of the above
+ @echo dist-clean --- remove all generated files and archives
+ @echo compile --- compile the project through ASDF
+ @echo check --- run all unit and functional tests for this project
+ @echo test --- run all unit and functional tests for this project
+ @echo dist --- create a source tarball for distribution
+ @echo release --- make a formal, public release
+ @echo sync-darcs --- synchronize local and remote darcs repositories
+ @echo metrics --- calculate some loc metrics
+ @echo
+ @echo Please consult the documentation in doc/index.html for more information
+
+clean-fasl:
+ find . -name "*.fas" | xargs rm
+ find . -name "*.lib" | xargs rm
+ find . -name "*.nfasl" | xargs rm
+ find . -name "*.dfsl" | xargs rm
+ find . -name "*.fasl" | xargs rm
+
+clean-emacs:
+ find . -name "*~" | xargs rm
+
+clean: clean-fasl clean-emacs
+
+dist-clean: clean
+ rm -rf *.tar.gz
+ rm -rf *.asc
+
+metrics:
+ find src -name "*.lisp" | xargs wc -l
+ find test -name "*.lisp" | xargs wc -l
+
+LISP=/Applications/LispWorks/lispworks-tty
+PRJ=s-base64
+
+compile:
+ echo "(asdf:oos 'asdf:compile-op :$(PRJ)) :ok" | $(LISP)
+
+DIR=`pwd`/
+SRCDIR=$(DIR)src/
+TESTDIR=$(DIR)test/
+
+test: check
+
+check:
+ echo "(asdf:oos 'asdf:load-op :$(PRJ)) (load \"$(TESTDIR)all-tests.lisp\") :ok" | $(LISP)
+
+dist:
+ darcs dist
+
+IDISK=/Volumes/svc
+
+release: test dist clean
+ gpg -a -b $(PRJ).tar.gz
+ mkdir -p $(IDISK)/Sites/$(PRJ)/
+ cp $(PRJ).tar.gz $(IDISK)/Sites/$(PRJ)/
+ cp $(PRJ).tar.gz.asc $(IDISK)/Sites/$(PRJ)/
+ cp doc/* $(IDISK)/Sites/$(PRJ)/
+
+USER=
+HOST=
+RPATH=~/Sites/website/darcs/
+
+sync-darcs: clean
+ cd ..; rsync -va -e ssh $(PRJ) $(USER)@$(HOST):$(RPATH)
+
+# EOF
diff --git a/third-party/s-base64/README.txt b/third-party/s-base64/README.txt
new file mode 100644
index 0000000..c4fb71a
--- /dev/null
+++ b/third-party/s-base64/README.txt
@@ -0,0 +1 @@
+Please consult the documentation in the doc directory, starting with index.html
diff --git a/third-party/s-base64/doc/API.html b/third-party/s-base64/doc/API.html
new file mode 100644
index 0000000..15076e2
--- /dev/null
+++ b/third-party/s-base64/doc/API.html
@@ -0,0 +1,11 @@
+<html><head><title>S-BASE64</title></head><body><h3>API for package S-BASE64</h3>
+<blockquote>An implementation of standard Base64 encoding and decoding</blockquote>
+<p>(<b>decode-base64</b> in out)&nbsp;&nbsp;&nbsp;<i>function</i></p>
+<blockquote>Decode a base64 encoded character input stream into a binary output stream</blockquote>
+<p>(<b>decode-base64-bytes</b> stream)&nbsp;&nbsp;&nbsp;<i>function</i></p>
+<blockquote>Decode a base64 encoded character stream, returns a byte array</blockquote>
+<p>(<b>encode-base64</b> in out &optional (break-lines t))&nbsp;&nbsp;&nbsp;<i>function</i></p>
+<blockquote>Encode a binary input stream into a base64 encoded character output stream</blockquote>
+<p>(<b>encode-base64-bytes</b> array stream &optional (break-lines t))&nbsp;&nbsp;&nbsp;<i>function</i></p>
+<blockquote>Encode a byte array into a base64b encoded character stream</blockquote>
+<font size=-1><p>Documentation generated by <a href="http://homepage.mac.com/svc/lispdoc/">lispdoc</a> running on LispWorks</p></font></body></html> \ No newline at end of file
diff --git a/third-party/s-base64/doc/index.html b/third-party/s-base64/doc/index.html
new file mode 100644
index 0000000..171ea6e
--- /dev/null
+++ b/third-party/s-base64/doc/index.html
@@ -0,0 +1,266 @@
+<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">
+<html xmlns="http://www.w3.org/1999/xhtml">
+<head>
+<title>S-BASE64</title>
+<meta http-equiv="Content-Type" content="text/html; charset=ISO-8859-1" />
+<meta name="description" content="S-BASE64 is Common Lisp implementation of Base64 Encoding/Decoding" />
+<meta name="keywords" content="base64, rfc1421, rfc2045, rfc3548, common lisp, lisp" />
+<meta name="author" content="Sven Van Caekenberghe" />
+<meta name="Copyright" content="Copyright (c) 2002-2006 Sven Van Caekenberghe, Beta Nine BVBA" />
+<style type="text/css">
+body {
+ background: white;
+ width: 900px;
+ font-family: Verdana, Arial, Helvetica, sans-serif;
+ font-size: 13px;
+}
+p {
+ width: 600px;
+ padding: 0 20px 10px 50px;
+}
+ul {
+ width: 600px;
+ padding: 0 5px 5px 70px;
+}
+.author {
+ padding: 0 20px 5px 50px;
+ font-style: italic;
+}
+.figure {
+ margin-top: 0;
+ margin-bottom: 0;
+ background: black;
+ color: white;
+ text-align: center;
+ padding: 20px 0 10px 0;
+}
+.listing {
+ background: #eee;
+ font-size: 12px;
+ padding-left: 10px;
+}
+.caption {
+ margin-top: 5px;
+ text-align: center;
+ font-size: 10px;
+ font-style: bold;
+}
+.footer {
+ font-size: 10px;
+ font-style: italic;
+}
+</style>
+</head>
+<body>
+<h3>Open Source Common Lisp Software</h3>
+<h1>S-BASE64</h1>
+<h2>A Common Lisp implementation of Base64 Encoding/Decoding</h2>
+<p>
+<a href="http://homepage.mac.com/svc/s-base64/index.html">S-BASE64</a>
+is an open source Common Lisp implementation of Base64 Encoding and Decoding.
+Base64 encoding is a technique to encode binary data in a portable, safe printable, 7-bit ASCII format.
+For a general introduction, please consult the <a href="http://en.wikipedia.org/wiki/Base64">Wikipedia article on Base64</a>.
+This simple package is used as a building block in a number of other open source projects,
+as can be seen from this description of some
+<a href="http://homepage.mac.com/svc/oscl.html">other Open Source Common Lisp packages</a>.
+</p>
+<h3>Contents</h3>
+<ul>
+<li><a href="#features">Features</a></li>
+<li><a href="#status">Status</a></li>
+<li><a href="#news">News</a></li>
+<li><a href="#platforms">Platforms</a></li>
+<li><a href="#downloading">Downloading</a></li>
+<li><a href="#installation">Installation</a></li>
+<li><a href="#usage">Usage</a></li>
+<li><a href="#api">API Reference</a></li>
+<li><a href="#mailinglist">Mailinglist</a></li>
+<li><a href="#changelog">Changelog</a></li>
+<li><a href="#tod">TODO</a></li>
+<li><a href="#faq">FAQ</a></li>
+<li><a href="#bugs">Bugs</a></li>
+<li><a href="#authors">Authors</a></li>
+<li><a href="#maintainers">Maintainers</a></li>
+<li><a href="#license">License</a></li>
+<li><a href="#history">History</a></li>
+<li><a href="#references">References</a></li>
+</ul>
+<h3 id="features">Features</h3>
+<p>
+S-BASE64 can:
+</p>
+<ul>
+<li>convert a Base64 encoded character input stream into a decoded binary output stream</li>
+<li>convert a binary output stream into a Base64 encoded character output stream</li>
+<li>convert a Base64 encoded character input stream into a byte array</li>
+<li>convert a byte array into a Base64 encoded character output stream</li>
+<li>optionally break lines at 76 characters</li>
+</ul>
+<h3 id="status">Status</h3>
+<p>
+S-BASE64 is considered stable code.
+</p>
+<h3 id="news">News</h3>
+<p>
+<em>October 2005</em> - Created as a seperate project.
+</p>
+<h3 id="platforms">Platforms</h3>
+<p>
+S-BASE64 is written in ANSI standard Common Lisp and should be portable across any CL implementation.
+</p>
+<h3 id="downloading">Downloading</h3>
+<p>
+You can download the latested released tarball of the S-BASE64 package from
+<a href="http://homepage.mac.com/svc/s-base64/s-base64.tar.gz">http://homepage.mac.com/svc/s-base64/s-base64.tar.gz</a>.
+This archive is signed on release by <a href="http://homepage.mac.com/svc">Sven Van Caekenberghe</a>,
+whose public key is published at
+<a href="http://homepage.mac.com/svc/sven-public-ascii.gpg">http://homepage.mac.com/svc/sven-public-ascii.gpg</a>,
+the signature is in
+<a href="http://homepage.mac.com/svc/s-base64/s-base64.tar.gz.asc">http://homepage.mac.com/svc/s-base64/s-base64.tar.gz.asc</a>.
+</p>
+<p>
+Alternatively you can access the <a href="http://abridgegame.org/darcs/">DARCS</a> repository at
+<a href="http://www.beta9.be/darcs/s-base64">http://www.beta9.be/darcs/s-base64</a>.
+For a good description on how to use DARCS see
+<a href="http://dirkgerrits.com/programming/erlisp/download/">http://dirkgerrits.com/programming/erlisp/download/</a>.
+</p>
+<div class="listing">
+<pre>$ darcs get http://www.beta9.be/darcs/s-base64
+Welcome to S-BASE64, a Common Lisp implementation of Base64 Encoding/Decoding
+**********************
+Copying patch 6 of 6... done!
+Applying patches to the "working" directory...
+............
+Finished getting.
+$ cd s-base64/
+$ darcs pull
+Pulling from "http://www.beta9.be/darcs/s-base64"...
+Welcome to S-BASE64, a Common Lisp implementation of Base64 Encoding/Decoding
+**********************
+No remote changes to pull in!</pre>
+</div>
+<div class="caption">Example of basic darcs usage, get everything once and keep up to date by pulling in changes</div>
+<h3 id="installation">Installation</h3>
+<p>
+The S-BASE64 package is loaded using <a href="http://www.cliki.net/asdf">ASDF</a>.
+There is an excellent <a href="http://constantly.at/lisp/asdf/">tutorial on ASDF</a> to get you started.
+Alternatively you can use <a href="http://www.cliki.net/asdf-install">ASDF-INSTALL</a>.
+There is an great <a href="http://weitz.de/asdf-install/">tutorial on ASDF-INSTALL</a> to get you on the way.
+</p>
+<div class="listing">
+<pre>$ cd apps/asdf/systems/
+$ ln -s ~/darcs/s-base64/s-base64.asd .
+$ cd ~
+$ /Applications/LispWorks/lispworks-tty
+LispWorks(R): The Common Lisp Programming Environment
+Copyright (C) 1987-2005 LispWorks Ltd. All rights reserved.
+Version 4.4.5
+Saved by sven as lispworks-tty, at 26 Oct 2005 11:53
+User sven on voyager.local
+; Loading text file /Applications/LispWorks/Library/lib/4-4-0-0/config/siteinit.lisp
+; Loading text file /Applications/LispWorks/Library/lib/4-4-0-0/private-patches/load.lisp
+; Loading text file /Users/sven/.lispworks
+; Loading text file /Users/sven/apps/asdf/init-asdf.lisp
+; Loading fasl file /Users/sven/apps/asdf/asdf.nfasl
+;Pushed #P"/Users/sven/apps/asdf/systems/" onto ASDF central registry
+
+CL-USER 1 > (asdf:oos 'asdf:load-op :s-base64)
+; Loading /Applications/LispWorks/Library/lib/4-4-0-0/load-on-demand/ccl/xp-fancyformat.nfasl on demand...
+; loading system definition from
+; /Users/sven/apps/asdf/systems/s-base64.asd into
+; #&lt;The ASDF787 package, 0/16 internal, 0/16 external&gt;
+; Loading text file /Users/sven/darcs/s-base64/s-base64.asd
+; registering #<SYSTEM :S-BASE64 100B004B> as S-BASE64
+;;; Compiling file /Users/sven/darcs/s-base64/src/package.lisp ...
+...
+; Loading fasl file /Users/sven/darcs/s-base64/src/package.nfasl
+;;; Compiling file /Users/sven/darcs/s-base64/src/base64.lisp ...
+...
+; Loading fasl file /Users/sven/darcs/s-base64/src/base64.nfasl</pre>
+</div>
+<div class="caption">Example of setting up and using ASDF to compile and load the package</div>
+<h3 id="usage">Usage</h3>
+<p>
+To encode you start with either a binary input stream or a byte array and write to a character output stream.
+To decode you start from a character input stream and write to a binary output stream or return a byte array.
+You can use the standard CL marcros WITH-OUTPUT-TO-STRING of WITH-INPUT-FROM-STRING to convert to and from a string.
+The following listener transcript show how to compute the second example from RFC 3548, section 7:
+</p>
+<div class="listing">
+<pre>CL-USER 1 > (in-package :s-base64)
+#&lt;The S-BASE64 package, 50/128 internal, 4/16 external&gt;
+
+S-BASE64 2 > (setf bytes #(#x14 #xfb #x9c #x03 #xd9))
+#(20 251 156 3 217)
+
+S-BASE64 3 > (with-output-to-string (out)
+ (encode-base64-bytes bytes out))
+"FPucA9k="
+
+S-BASE64 4 > (with-input-from-string (in *)
+ (decode-base64-bytes in))
+#(20 251 156 3 217)</pre>
+</div>
+<div class="caption">Example Base64 Encoding and Decoding</div>
+<h3 id="api">API Reference</h3>
+<p>
+There is automatically generated <a href="API.html">API Reference</a> documentation available for the S-BASE64 package.
+</p>
+<h3 id="mailinglist">Mailinglist</h3>
+<p>
+The <a href="http://common-lisp.net/cgi-bin/mailman/listinfo/kpax-devel">KPAX mailing list</a> is used for this project.
+</p>
+<h3 id="changelog">Changelog</h3>
+<p>
+Release Notes:
+</p>
+<ul>
+<li>release 1: moved S-BASE64 into a seperate project under a new structure</li>
+</ul>
+<h3 id="todo">TODO</h3>
+<p>
+There is a variant of Base64 encoding used for URL's and filenames that could be implemented.
+</p>
+<h3 id="faq">FAQ</h3>
+<p>
+Nothing appropriate.
+</p>
+<h3 id="bugs">Bugs</h3>
+<p>
+Illegal input results in generic low-level CL conditions rather than a more meaningful high-level application specific condition.
+</p>
+<h3 id="authors">Authors</h3>
+<p>
+S-BASE64 was written by <a href="http://homepage.mac.com/svc">Sven Van Caekenberghe</a>.
+</p>
+<h3 id="maintainers">Maintainers</h3>
+<p>
+S-BASE64 is being maintained by <a href="http://homepage.mac.com/svc">Sven Van Caekenberghe</a>.
+</p>
+<h3 id="license">License</h3>
+<p>
+You are granted the rights to distribute and use this software
+as governed by the terms of the Lisp Lesser General Public License
+(<a href="http://opensource.franz.com/preamble.html">http://opensource.franz.com/preamble.html</a>),
+also known as the LLGPL.
+</p>
+<h3 id="history">History</h3>
+<p>
+S-BASE64 was originally part of KPAX and became a seperate project in October 2005.
+</p>
+<h3 id="references">References</h3>
+<p>
+The following RFC's can be considered as definitions of Base64 Encoding:
+<ul>
+<li><a href="http://www.ietf.org/rfc/rfc1421.txt">RFC 1421</a></li>
+<li><a href="http://www.ietf.org/rfc/rfc2045.txt">RFC 2045</a></li>
+<li><a href="http://www.ietf.org/rfc/rfc3548.txt">RFC 3548</a></li>
+</ul>
+</p>
+<div class="footer">
+Copyright &copy; 2002-2006 Sven Van Caekenberghe, Beta Nine BVBA. All Right Reserved. -
+<a href="http://validator.w3.org/check/referer">This page is W3C Valid XHTML 1.0 Strict</a> -
+<a href="http://www.anybrowser.org/campaign/">Viewable With Any Browser</a>
+</div>
+</body>
+</html>
diff --git a/third-party/s-base64/s-base64.asd b/third-party/s-base64/s-base64.asd
new file mode 100644
index 0000000..1793973
--- /dev/null
+++ b/third-party/s-base64/s-base64.asd
@@ -0,0 +1,30 @@
+;;;; -*- Mode: LISP -*-
+;;;;
+;;;; $Id: s-xml-rpc.asd,v 1.2 2004/06/17 19:43:11 rschlatte Exp $
+;;;;
+;;;; The S-BASE64 ASDF system definition
+;;;;
+;;;; Copyright (C) 2002-2005 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-base64
+ :name "S-BASE64"
+ :author "Sven Van Caekenberghe <svc@mac.com>"
+ :version "2"
+ :maintainer "Sven Van Caekenberghe <svc@mac.com>"
+ :licence "Lesser Lisp General Public License (LLGPL)"
+ :description "Common Lisp Base64 Package"
+ :long-description "S-BASE64 is a Common Lisp implementation of Base64 Encoding/Decoding"
+
+ :components
+ ((:module
+ :src
+ :components ((:file "package")
+ (:file "base64" :depends-on ("package"))))))
+
+;;;; eof
diff --git a/third-party/s-base64/src/base64.lisp b/third-party/s-base64/src/base64.lisp
new file mode 100644
index 0000000..f6b799f
--- /dev/null
+++ b/third-party/s-base64/src/base64.lisp
@@ -0,0 +1,152 @@
+;;;; -*- mode: lisp -*-
+;;;;
+;;;; $Id: base64.lisp,v 1.3 2005/02/07 17:45:41 scaekenberghe Exp $
+;;;;
+;;;; This is a Common Lisp implementation of Base64 encoding and decoding.
+;;;;
+;;;; Copyright (C) 2002-2005 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-base64)
+
+(defparameter +base64-alphabet+
+ "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/")
+
+(defparameter +inverse-base64-alphabet+
+ (let ((inverse-base64-alphabet (make-array 127)))
+ (dotimes (i 127 inverse-base64-alphabet)
+ (setf (aref inverse-base64-alphabet i)
+ (position (code-char i) +base64-alphabet+)))))
+
+(defun core-encode-base64 (byte1 byte2 byte3)
+ (values (char +base64-alphabet+ (ash byte1 -2))
+ (char +base64-alphabet+ (logior (ash (logand byte1 #B11) 4)
+ (ash (logand byte2 #B11110000) -4)))
+ (char +base64-alphabet+ (logior (ash (logand byte2 #B00001111) 2)
+ (ash (logand byte3 #B11000000) -6)))
+ (char +base64-alphabet+ (logand byte3 #B111111))))
+
+(defun core-decode-base64 (char1 char2 char3 char4)
+ (let ((v1 (aref +inverse-base64-alphabet+ (char-code char1)))
+ (v2 (aref +inverse-base64-alphabet+ (char-code char2)))
+ (v3 (aref +inverse-base64-alphabet+ (char-code char3)))
+ (v4 (aref +inverse-base64-alphabet+ (char-code char4))))
+ (values (logior (ash v1 2)
+ (ash v2 -4))
+ (logior (ash (logand v2 #B1111) 4)
+ (ash v3 -2))
+ (logior (ash (logand v3 #B11) 6)
+ v4))))
+
+(defun skip-base64-whitespace (stream)
+ (loop
+ (let ((char (peek-char nil stream nil nil)))
+ (cond ((null char) (return nil))
+ ((null (aref +inverse-base64-alphabet+ (char-code char))) (read-char stream))
+ (t (return char))))))
+
+(defun decode-base64-bytes (stream)
+ "Decode a base64 encoded character stream, returns a byte array"
+ (let ((out (make-array 256
+ :element-type '(unsigned-byte 8)
+ :adjustable t
+ :fill-pointer 0)))
+ (loop
+ (skip-base64-whitespace stream)
+ (let ((in1 (read-char stream nil nil))
+ (in2 (read-char stream nil nil))
+ (in3 (read-char stream nil nil))
+ (in4 (read-char stream nil nil)))
+ (if (null in1) (return))
+ (if (or (null in2) (null in3) (null in4)) (error "input not aligned/padded for base64 encoding"))
+ (multiple-value-bind (out1 out2 out3)
+ (core-decode-base64 in1
+ in2
+ (if (char= in3 #\=) #\A in3)
+ (if (char= in4 #\=) #\A in4))
+ (vector-push-extend out1 out)
+ (when (char/= in3 #\=)
+ (vector-push-extend out2 out)
+ (when (char/= in4 #\=)
+ (vector-push-extend out3 out))))))
+ out))
+
+(defun encode-base64-bytes (array stream &optional (break-lines t))
+ "Encode a byte array into a base64 encoded character stream"
+ (let ((index 0)
+ (counter 0)
+ (len (length array)))
+ (loop
+ (when (>= index len) (return))
+ (let ((in1 (aref array index))
+ (in2 (if (< (+ index 1) len) (aref array (+ index 1)) nil))
+ (in3 (if (< (+ index 2) len) (aref array (+ index 2)) nil)))
+ (multiple-value-bind (out1 out2 out3 out4)
+ (core-encode-base64 in1
+ (if (null in2) 0 in2)
+ (if (null in3) 0 in3))
+ (write-char out1 stream)
+ (write-char out2 stream)
+ (if (null in2)
+ (progn
+ (write-char #\= stream)
+ (write-char #\= stream))
+ (progn
+ (write-char out3 stream)
+ (if (null in3)
+ (write-char #\= stream)
+ (write-char out4 stream))))
+ (incf index 3)
+ (incf counter 4)
+ (when (and break-lines (= counter 76))
+ (terpri stream)
+ (setf counter 0)))))))
+
+(defun decode-base64 (in out)
+ "Decode a base64 encoded character input stream into a binary output stream"
+ (loop
+ (skip-base64-whitespace in)
+ (let ((in1 (read-char in nil nil))
+ (in2 (read-char in nil nil))
+ (in3 (read-char in nil nil))
+ (in4 (read-char in nil nil)))
+ (if (null in1) (return))
+ (if (or (null in2) (null in3) (null in4)) (error "input not aligned/padded for base64 encoding"))
+ (multiple-value-bind (out1 out2 out3)
+ (core-decode-base64 in1 in2 (if (char= in3 #\=) #\A in3) (if (char= in4 #\=) #\A in4))
+ (write-byte out1 out)
+ (when (char/= in3 #\=)
+ (write-byte out2 out)
+ (when (char/= in4 #\=)
+ (write-byte out3 out)))))))
+
+(defun encode-base64 (in out &optional (break-lines t))
+ "Encode a binary input stream into a base64 encoded character output stream"
+ (let ((counter 0))
+ (loop
+ (let ((in1 (read-byte in nil nil))
+ (in2 (read-byte in nil nil))
+ (in3 (read-byte in nil nil)))
+ (if (null in1) (return))
+ (multiple-value-bind (out1 out2 out3 out4)
+ (core-encode-base64 in1 (if (null in2) 0 in2) (if (null in3) 0 in3))
+ (write-char out1 out)
+ (write-char out2 out)
+ (if (null in2)
+ (progn
+ (write-char #\= out)
+ (write-char #\= out))
+ (progn
+ (write-char out3 out)
+ (if (null in3)
+ (write-char #\= out)
+ (write-char out4 out))))
+ (incf counter 4)
+ (when (and break-lines (= counter 76))
+ (terpri out)
+ (setf counter 0)))))))
+
+;;;; eof
diff --git a/third-party/s-base64/src/package.lisp b/third-party/s-base64/src/package.lisp
new file mode 100644
index 0000000..fd457db
--- /dev/null
+++ b/third-party/s-base64/src/package.lisp
@@ -0,0 +1,22 @@
+;;;; -*- mode: lisp -*-
+;;;;
+;;;; $Id: base64.lisp,v 1.3 2005/02/07 17:45:41 scaekenberghe Exp $
+;;;;
+;;;; This is a Common Lisp implementation of Base64 encoding and decoding.
+;;;;
+;;;; Copyright (C) 2002-2005 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-base64
+ (:use common-lisp)
+ (:export
+ "DECODE-BASE64"
+ "ENCODE-BASE64"
+ "DECODE-BASE64-BYTES"
+ "ENCODE-BASE64-BYTES")
+ (:documentation "An implementation of standard Base64 encoding and decoding"))
+
+;;;; eof
diff --git a/third-party/s-base64/test/all-tests.lisp b/third-party/s-base64/test/all-tests.lisp
new file mode 100644
index 0000000..ad2fdec
--- /dev/null
+++ b/third-party/s-base64/test/all-tests.lisp
@@ -0,0 +1,15 @@
+;;;; -*- mode: lisp -*-
+;;;;
+;;;; $Id: all-tests.lisp,v 1.2 2004/06/17 19:43:11 rschlatte Exp $
+;;;;
+;;;; Load and execute all unit and functional tests
+;;;;
+;;;; Copyright (C) 2002-2005 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.
+
+(load (merge-pathnames "test-base64" *load-pathname*) :verbose t)
+
+;;;; eof
diff --git a/third-party/s-base64/test/test-base64.lisp b/third-party/s-base64/test/test-base64.lisp
new file mode 100644
index 0000000..ae5b50f
--- /dev/null
+++ b/third-party/s-base64/test/test-base64.lisp
@@ -0,0 +1,140 @@
+;;;; -*- mode: lisp -*-
+;;;;
+;;;; $Id: test-base64.lisp,v 1.1.1.1 2004/06/09 09:02:41 scaekenberghe Exp $
+;;;;
+;;;; Unit and functional tests for base64.lisp
+;;;;
+;;;; Copyright (C) 2002-2005 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-base64)
+
+(assert
+ (equal (multiple-value-list (core-encode-base64 0 0 0))
+ (list #\A #\A #\A #\A)))
+
+(assert
+ (equal (multiple-value-list (core-encode-base64 255 255 255))
+ (list #\/ #\/ #\/ #\/)))
+
+(assert
+ (equal (multiple-value-list (core-encode-base64 1 2 3))
+ (list #\A #\Q #\I #\D)))
+
+(assert
+ (equal (multiple-value-list (core-encode-base64 10 20 30))
+ (list #\C #\h #\Q #\e)))
+
+(assert
+ (equal (multiple-value-list (core-decode-base64 #\A #\A #\A #\A))
+ (list 0 0 0)))
+
+(assert
+ (equal (multiple-value-list (core-decode-base64 #\/ #\/ #\/ #\/))
+ (list 255 255 255)))
+
+(assert
+ (equal (multiple-value-list (core-decode-base64 #\A #\Q #\I #\D))
+ (list 1 2 3)))
+
+(assert
+ (equal (multiple-value-list (core-decode-base64 #\C #\h #\Q #\e))
+ (list 10 20 30)))
+
+(assert
+ (let* ((string "Hello World!")
+ (bytes (map 'vector #'char-code string))
+ encoded
+ decoded)
+ (setf encoded (with-output-to-string (out)
+ (encode-base64-bytes bytes out)))
+ (setf decoded (with-input-from-string (in encoded)
+ (decode-base64-bytes in)))
+ (equal string
+ (map 'string #'code-char decoded))))
+
+;;; test some known values (from RFC 3548, section 7)
+
+(assert
+ (string= (with-output-to-string (out)
+ (encode-base64-bytes #(#x14 #xfb #x9c #x03 #xd9 #x7e) out))
+ "FPucA9l+"))
+
+(assert
+ (string= (with-output-to-string (out)
+ (encode-base64-bytes #(#x14 #xfb #x9c #x03 #xd9) out))
+ "FPucA9k="))
+
+(assert
+ (string= (with-output-to-string (out)
+ (encode-base64-bytes #(#x14 #xfb #x9c #x03) out))
+ "FPucAw=="))
+
+;;; this is more of a functional test
+
+(defun same-character-file (file1 file2)
+ (with-open-file (a file1 :direction :input)
+ (with-open-file (b file2 :direction :input)
+ (loop
+ (let ((char-a (read-char a nil nil nil))
+ (char-b (read-char b nil nil nil)))
+ (cond ((not (or (and (null char-a) (null char-b))
+ (and char-a char-b)))
+ (return-from same-character-file nil))
+ ((null char-a)
+ (return-from same-character-file t))
+ ((char/= char-a char-b)
+ (return-from same-character-file nil))))))))
+
+(defun same-binary-file (file1 file2)
+ (with-open-file (a file1 :direction :input :element-type 'unsigned-byte)
+ (with-open-file (b file2 :direction :input :element-type 'unsigned-byte)
+ (loop
+ (let ((byte-a (read-byte a nil nil))
+ (byte-b (read-byte b nil nil)))
+ (cond ((not (or (and (null byte-a) (null byte-b))
+ (and byte-a byte-b)))
+ (return-from same-binary-file nil))
+ ((null byte-a)
+ (return-from same-binary-file t))
+ ((/= byte-a byte-b)
+ (return-from same-binary-file nil))))))))
+
+(let ((original (merge-pathnames "test.b64" *load-pathname*))
+ (first-gif (merge-pathnames "test.gif" *load-pathname*))
+ (b64 (merge-pathnames "test2.b64" *load-pathname*))
+ (second-gif (merge-pathnames "test2.gif" *load-pathname*)))
+ (with-open-file (in original
+ :direction :input)
+ (with-open-file (out first-gif
+ :direction :output
+ :element-type 'unsigned-byte
+ :if-does-not-exist :create
+ :if-exists :supersede)
+ (decode-base64 in out)))
+ (with-open-file (in first-gif
+ :direction :input
+ :element-type 'unsigned-byte)
+ (with-open-file (out b64
+ :direction :output
+ :if-does-not-exist :create
+ :if-exists :supersede)
+ (encode-base64 in out nil)))
+ (assert (same-character-file original b64))
+ (with-open-file (in b64
+ :direction :input)
+ (with-open-file (out second-gif
+ :direction :output
+ :element-type 'unsigned-byte
+ :if-does-not-exist :create
+ :if-exists :supersede)
+ (decode-base64 in out)))
+ (assert (same-binary-file first-gif second-gif))
+ (delete-file first-gif)
+ (delete-file b64)
+ (delete-file second-gif))
+
+;;;; eof \ No newline at end of file
diff --git a/third-party/s-base64/test/test.b64 b/third-party/s-base64/test/test.b64
new file mode 100644
index 0000000..55445dd
--- /dev/null
+++ b/third-party/s-base64/test/test.b64
@@ -0,0 +1 @@
+R0lGODlhNABYAMQAAP////vi5etreuM0SN8ZL+dOYPCIk+56hPi/xPGapPjP1N4EGvHr9PSstMzI6riw4IY+kHsie3lvyVtMu0Y4tN3b8Y+CzX1ast2ftskNNNBdfqGb2so0WeHL4E8spLA0aiH5BAAAAAAALAAAAAA0AFgAQAX/ICCOZGmeaKqeBUEc5WAATbECQnCfyiAWsFIBgfMJFoTOYcAQERYN0SK4KxEUp4FPC/ABXN/oKOCtmh0OxGPj+UAgHmKhIZiZHJLJhMKXNKsMFQAMFnp6EogWFxEWOAsCgw4VfyN5IhKNABMPZhAUe3yhoYiYFmsWiISYlCoMeaJ8ehR5hoektLCjEhCcJGgQqSkKC1BmxscBxEQkBAlOxSMDCzY/ZQAICyPEOwnbCgXgcyQCBeQFWCIHVDXhJN/hkMc0DR0iA80oPXbyI+Vd6CO+RdOxjAWVYz367bPXzciVHjKwGCAwg4AOfiUOEBgg4ICAe08WYCFgQ0aKBtaM/xWSEMuQKA+1WHrIhYpCJgB4KDzYA4BPFQejLAgdSvSB0QoOHgCT4GAEKqSfUuT8ZIHVCAYbWOaaQErSiqoYw4oVkWxBwRETt41RW2KBNWluq5QteCAbiQJxSRATQIDVRisLnJmQ5sLi2MNhP24cUIDxRcRjCAsG0HgHnbEaFRAwAURExxsJHh8jB2CJiQZBOALokHIEgXiqjQks3frcFyRdcKfzonGBaGMDxFzTIgDBMBd4GVN7sQSdAWpiuZQIsJHkCwNQqKOgCBmF2wZu5xj4XUL4MUJcMTlowmANhAgXhGoIIMA5NUKwQIWCcANNIkEMMPDBAWgUmAEGIgwDQ/97u2ByCQVNTdCIBRTssEEfVpUWjwgMpIHKTQCg0oQnguhhBgObPCBBLys4gIoEJVTA0gSCGIPUegBolV8tomwSVgUTiEBhehZsgMB6AZ4Q4JJLcjhIh1ntAeMITamw0ycSbDDJHx0aRdSLuPSIyQM1rnAEMcRc0R0/c7EADUppLgRAAoRtuE0ABvBF3lpmlTCMI9A5shkz1vB1G0AqtNkPEoWx9cwMGllRWEitmTCMSAlCw4ymAFxaz6KWOuqmnGuWaqqpHQTw6almbmSAAqoG8M0AB3XXA0mC/bWCbYjxNQ0JdHY6WQoJZDgaYymhJEICgaKQg1hXgDMYOuKooMD/hvJQx4BmlsYT7GyWGoZRcJRhm44z3HaaFzOD4mXeDglRVitlWMjgghYgJaCZuE8gWkW86ZJgxCOA0iBtp1royk8Zmi1UGAAT4WmSZwREYUClZhzQ7MX3MDqFri4kIK7BY12cxRW+4dNCuSaQNpYW74KHhALgbXawpQP4ixGzWoiD3UZ9HkAqCUKfysA9zx1AJznvrlkBmCuu10AGCFSgDg5Y0CFaIbLAAuIJF86CyAZGbWDKAxwcoEACFbzhgZEWwHEBV0H5oSNLX5eAipSkcDWBB3MjsocHeUhwwQdEoFgmABX4ZCJLrSylCwQfoFHB5RpwIAJ4BehIwQY49tTI/wMVArDTDu1JKRSL2GBBXdMkFNIE5JpMeQOKNYl9i+CFk9KLJIQ0gUpTURmTR+67J5/IA2iQQEhOthvjgH5crT7UUrZsMMIDNa04Vt9i75Ee+KNUiRF6sTDFIfU8toTIWUqm0PgmE5i/QpLyXGh/Ja/4AQHUsciFAGExEzGBhUOIMEF7JDfAUMykgFv5RB/CZ4sHGAsFeABFTJSXvCKFjlUgnA5cMBbCUPXpBBtCQB3yNCwa1OFqIkAADK5lgAOsygQdUMYJiPGWX5mgLo/BRmACooIcnpAZvjLPE2rVjVUxoGKiSoER4beysrQFU2TBohNgUBcSkmCK7piCAS62LlR12QUAC1hIC8aIHU6hAIzaGNYThtWNzbwGWGc04w0uVRAwhDGPufFhplqYnBUIMQB4WiKiREYMG2pjUJ0607A60MaJneBnJayCbjK5HR5y8pNiCQEAOw== \ No newline at end of file
diff --git a/third-party/s-sysdeps/.clbuild-skip-update b/third-party/s-sysdeps/.clbuild-skip-update
new file mode 100644
index 0000000..e69de29
--- /dev/null
+++ b/third-party/s-sysdeps/.clbuild-skip-update
diff --git a/third-party/s-sysdeps/Makefile b/third-party/s-sysdeps/Makefile
new file mode 100644
index 0000000..f0a663a
--- /dev/null
+++ b/third-party/s-sysdeps/Makefile
@@ -0,0 +1,82 @@
+#
+# This makefile contains command line tools to maintain this project
+# Please consult the documentation in doc/index.html for more user oriented information
+# Portability at this level is accidental, only LispWorks on Mac OS X is supported here
+# For some operations, edit the necessary variables to suit your environment
+# Some operations can obviously only be done by a specific person in a very specific context ;-)
+#
+
+default:
+ @echo Welcome to S-SYSDEPS, an abstraction over platform dependent functionality
+ @echo
+ @echo Possible makefile targets:
+ @echo
+ @echo clean-fasl --- remove all known lisp compiled fasl files recursively
+ @echo clean-emacs --- remove all '*~' recursively
+ @echo clean --- all of the above
+ @echo dist-clean --- remove all generated files and archives
+ @echo compile --- compile the project through ASDF
+ @echo check --- run all unit and functional tests for this project
+ @echo test --- run all unit and functional tests for this project
+ @echo dist --- create a source tarball for distribution
+ @echo release --- make a formal, public release
+ @echo sync-darcs --- synchronize local and remote darcs repositories
+ @echo metrics --- calculate some loc metrics
+ @echo
+ @echo Please consult the documentation in doc/index.html for more information
+
+clean-fasl:
+ find . -name "*.fas" | xargs rm
+ find . -name "*.lib" | xargs rm
+ find . -name "*.nfasl" | xargs rm
+ find . -name "*.dfsl" | xargs rm
+ find . -name "*.fasl" | xargs rm
+
+clean-emacs:
+ find . -name "*~" | xargs rm
+
+clean: clean-fasl clean-emacs
+
+dist-clean: clean
+ rm -rf *.tar.gz
+ rm -rf *.asc
+
+metrics:
+ find src -name "*.lisp" | xargs wc -l
+ find test -name "*.lisp" | xargs wc -l
+
+LISP=/Applications/LispWorks/lispworks-tty
+PRJ=s-sysdeps
+
+compile:
+ echo "(asdf:oos 'asdf:compile-op :$(PRJ)) :ok" | $(LISP)
+
+DIR=`pwd`/
+SRCDIR=$(DIR)src/
+TESTDIR=$(DIR)test/
+
+test: check
+
+check:
+ echo "(asdf:oos 'asdf:load-op :$(PRJ)) (load \"$(TESTDIR)all-tests.lisp\") :ok" | $(LISP)
+
+dist:
+ darcs dist
+
+IDISK=/Volumes/svc
+
+release: test dist clean
+ gpg -a -b $(PRJ).tar.gz
+ mkdir -p $(IDISK)/Sites/$(PRJ)/
+ cp $(PRJ).tar.gz $(IDISK)/Sites/$(PRJ)/
+ cp $(PRJ).tar.gz.asc $(IDISK)/Sites/$(PRJ)/
+ cp doc/* $(IDISK)/Sites/$(PRJ)/
+
+USER=
+HOST=
+RPATH=/var/www/html/beta9.be/darcs/
+
+sync-darcs: clean
+ cd ..; rsync -va -e /usr/bin/ssh $(PRJ) $(USER)@$(HOST):$(RPATH)
+
+# EOF
diff --git a/third-party/s-sysdeps/README.txt b/third-party/s-sysdeps/README.txt
new file mode 100644
index 0000000..c4fb71a
--- /dev/null
+++ b/third-party/s-sysdeps/README.txt
@@ -0,0 +1 @@
+Please consult the documentation in the doc directory, starting with index.html
diff --git a/third-party/s-sysdeps/doc/API.html b/third-party/s-sysdeps/doc/API.html
new file mode 100644
index 0000000..1e0581e
--- /dev/null
+++ b/third-party/s-sysdeps/doc/API.html
@@ -0,0 +1,19 @@
+<html><head><title>S-SYSDEPS</title></head><body><h3>API for package S-SYSDEPS</h3>
+<blockquote>S-SYSDEPS is an abstraction layer over platform dependent functionality</blockquote>
+<p>(<b>all-processes</b>)&nbsp;&nbsp;&nbsp;<i>function</i></p>
+<blockquote>Return a list of all processes currently running</blockquote>
+<p>(<b>current-process</b>)&nbsp;&nbsp;&nbsp;<i>function</i></p>
+<blockquote>Return the object representing the current process</blockquote>
+<p>(<b>kill-process</b> process)&nbsp;&nbsp;&nbsp;<i>function</i></p>
+<blockquote>Kill the process represented by the object process</blockquote>
+<p>(<b>make-process-lock</b> name)&nbsp;&nbsp;&nbsp;<i>function</i></p>
+<blockquote>Create a named process lock object</blockquote>
+<p>(<b>open-socket-stream</b> host port)&nbsp;&nbsp;&nbsp;<i>function</i></p>
+<blockquote>Create and open a bidirectional client TCP/IP socket stream to host:port</blockquote>
+<p>(<b>run-process</b> name function &rest arguments)&nbsp;&nbsp;&nbsp;<i>function</i></p>
+<blockquote>Create and run a new process with name, executing function on arguments</blockquote>
+<p>(<b>start-standard-server</b> &key port name connection-handler)&nbsp;&nbsp;&nbsp;<i>function</i></p>
+<blockquote>Start a server process with name, listening on port, delegating to connection-handler with stream as argument</blockquote>
+<p>(<b>with-process-lock</b> (lock) &body body)&nbsp;&nbsp;&nbsp;<i>function</i></p>
+<blockquote>Execute body wih the process lock grabbed, wait otherwise</blockquote>
+<font size=-1><p>Documentation generated by <a href="http://homepage.mac.com/svc/lispdoc/">lispdoc</a> running on LispWorks</p></font></body></html> \ No newline at end of file
diff --git a/third-party/s-sysdeps/doc/index.html b/third-party/s-sysdeps/doc/index.html
new file mode 100644
index 0000000..b7109b2
--- /dev/null
+++ b/third-party/s-sysdeps/doc/index.html
@@ -0,0 +1,203 @@
+<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">
+<html xmlns="http://www.w3.org/1999/xhtml">
+<head>
+<title>S-SYSDEPS</title>
+<meta http-equiv="Content-Type" content="text/html; charset=ISO-8859-1" />
+<meta name="description" content="S-SYSDEPS is an abstraction layer over implementation dependent functionality" />
+<meta name="keywords" content="sysdeps, common lisp, lisp, portability" />
+<meta name="author" content="Sven Van Caekenberghe" />
+<meta name="Copyright" content="Copyright (c) 2004-2005 Sven Van Caekenberghe, Beta Nine BVBA" />
+<style type="text/css">
+body {
+ background: white;
+ width: 900px;
+ font-family: Verdana, Arial, Helvetica, sans-serif;
+ font-size: 13px;
+}
+p {
+ width: 600px;
+ padding: 0 20px 10px 50px;
+}
+ul {
+ width: 600px;
+ padding: 0 5px 5px 70px;
+}
+.author {
+ padding: 0 20px 5px 50px;
+ font-style: italic;
+}
+.figure {
+ margin-top: 0;
+ margin-bottom: 0;
+ background: black;
+ color: white;
+ text-align: center;
+ padding: 20px 0 10px 0;
+}
+.listing {
+ background: #eee;
+ font-size: 12px;
+ padding-left: 10px;
+}
+.caption {
+ margin-top: 5px;
+ text-align: center;
+ font-size: 10px;
+ font-style: bold;
+}
+.footer {
+ font-size: 10px;
+ font-style: italic;
+}
+</style>
+</head>
+<body>
+<h3>Open Source Common Lisp Software</h3>
+<h1>S-SYSDEPS</h1>
+<h2>An Abstraction Layer Over Platform Dependent Functionality</h2>
+<p>
+<a href="http://homepage.mac.com/svc/temaplte/index.html">S-SYSDEPS</a>
+is an abstraction layer over platform dependent functionality.
+This simple package is used as a building block in a number of other open source projects,
+as can be seen from this description of some
+<a href="http://homepage.mac.com/svc/oscl.html">other Open Source Common Lisp packages</a>.
+</p>
+<h3>Contents</h3>
+<ul>
+<li><a href="#features">Features</a></li>
+<li><a href="#status">Status</a></li>
+<li><a href="#news">News</a></li>
+<li><a href="#platforms">Platforms</a></li>
+<li><a href="#downloading">Downloading</a></li>
+<li><a href="#installation">Installation</a></li>
+<li><a href="#usage">Usage</a></li>
+<li><a href="#api">API Reference</a></li>
+<li><a href="#mailinglist">Mailinglist</a></li>
+<li><a href="#changelog">Changelog</a></li>
+<li><a href="#tod">TODO</a></li>
+<li><a href="#faq">FAQ</a></li>
+<li><a href="#bugs">Bugs</a></li>
+<li><a href="#authors">Authors</a></li>
+<li><a href="#maintainers">Maintainers</a></li>
+<li><a href="#license">License</a></li>
+<li><a href="#history">History</a></li>
+<li><a href="#references">References</a></li>
+</ul>
+<h3 id="features">Features</h3>
+<p>
+S-SYSDEPS abstracts:
+</p>
+<ul>
+<li>managing processes</li>
+<li>implementing a standard TCP/IP server</li>
+<li>opening a client TCP/IP socket stream</li>
+<li>working with process locks</li>
+</ul>
+<h3 id="status">Status</h3>
+<p>
+S-SYSDEPS is considered stable code.
+</p>
+<h3 id="news">News</h3>
+<p>
+<em>November 2005</em> - Created as a seperate project.
+</p>
+<h3 id="platforms">Platforms</h3>
+<p>
+S-SYSDEPS is, by definition, written in ANSI standard Common Lisp
+but implemented using non-standard extensions.
+At the moment, ports for LispWorks (reference), OpenMCL, CMUCL and SBCL exist.
+Some other CL implementations are partially supported.
+</p>
+<h3 id="downloading">Downloading</h3>
+<p>
+You can download the latested released tarball of the S-SYSDEPS package from
+<a href="http://homepage.mac.com/svc/s-sysdeps/s-sysdeps.tar.gz">http://homepage.mac.com/svc/s-sysdeps/s-sysdeps.tar.gz</a>.
+This archive is signed on release by <a href="http://homepage.mac.com/svc">Sven Van Caekenberghe</a>,
+whose public key is published at
+<a href="http://homepage.mac.com/svc/sven-public-ascii.gpg">http://homepage.mac.com/svc/sven-public-ascii.gpg</a>,
+the signature is in
+<a href="http://homepage.mac.com/svc/s-sysdeps/s-sysdeps.tar.gz.asc">http://homepage.mac.com/svc/s-sysdeps/s-sysdeps.tar.gz.asc</a>.
+</p>
+<p>
+Alternatively you can access the <a href="http://abridgegame.org/darcs/">DARCS</a> repository at
+<a href="http://www.beta9.be/darcs/s-base64">http://www.beta9.be/darcs/s-base64</a>.
+For a good description on how to use DARCS see
+<a href="http://dirkgerrits.com/programming/erlisp/download/">http://dirkgerrits.com/programming/erlisp/download/</a>.
+</p>
+<div class="listing">
+<pre>$ darcs get http://www.beta9.be/darcs/s-sysdeps</pre>
+</div>
+<div class="caption">Example of basic darcs usage, get everything once and keep up to date by pulling in changes</div>
+<h3 id="installation">Installation</h3>
+<p>
+The S-SYSDEPS package is loaded using <a href="http://www.cliki.net/asdf">ASDF</a>.
+There is an excellent <a href="http://constantly.at/lisp/asdf/">tutorial on ASDF</a> to get you started.
+Alternatively you can use <a href="http://www.cliki.net/asdf-install">ASDF-INSTALL</a>.
+There is an great <a href="http://weitz.de/asdf-install/">tutorial on ASDF-INSTALL</a> to get you on the way.
+</p>
+<div class="listing">
+<pre>CL-USER 1 > (asdf:oos 'asdf:load-op :s-sysdeps)</pre>
+</div>
+<div class="caption">Example of setting up and using ASDF to compile and load the package</div>
+<h3 id="usage">Usage</h3>
+<p>
+For usage examples please have a look at the package using S-SYSDEPS.
+</p>
+<h3 id="api">API Reference</h3>
+<p>
+There is automatically generated <a href="API.html">API Reference</a> documentation available for the S-SYSDEPS package.
+</p>
+<h3 id="mailinglist">Mailinglist</h3>
+<p>
+There is no mailing list for this project.
+</p>
+<h3 id="changelog">Changelog</h3>
+<p>
+Release Notes:
+</p>
+<ul>
+<li>release 1: moved S-SYSDEPS into a seperate project under a new structure</li>
+</ul>
+<h3 id="todo">TODO</h3>
+<p>
+Port to even more platforms. Add some unit or functional tests, as well as some examples.
+</p>
+<h3 id="faq">FAQ</h3>
+<p>
+Nothing appropriate.
+</p>
+<h3 id="bugs">Bugs</h3>
+<p>
+There are no known bugs.
+</p>
+<h3 id="authors">Authors</h3>
+<p>
+S-SYSDEPS was written by <a href="http://homepage.mac.com/svc">Sven Van Caekenberghe</a>.
+Ports to CMUCL and SBCL were contributed.
+</p>
+<h3 id="maintainers">Maintainers</h3>
+<p>
+S-SYSDEPS is being maintained by <a href="http://homepage.mac.com/svc">Sven Van Caekenberghe</a>.
+</p>
+<h3 id="license">License</h3>
+<p>
+You are granted the rights to distribute and use this software
+as governed by the terms of the Lisp Lesser General Public License
+(<a href="http://opensource.franz.com/preamble.html">http://opensource.franz.com/preamble.html</a>),
+also known as the LLGPL.
+</p>
+<h3 id="history">History</h3>
+<p>
+This file was part of S-XML-RPC and (N)KPAX.
+</p>
+<h3 id="references">References</h3>
+<p>
+Thera are no references.
+</p>
+<div class="footer">
+Copyright &copy; 2004-2005 Sven Van Caekenberghe, Beta Nine BVBA. All Right Reserved. -
+<a href="http://validator.w3.org/check/referer">This page is W3C Valid XHTML 1.0 Strict</a> -
+<a href="http://www.anybrowser.org/campaign/">Viewable With Any Browser</a>
+</div>
+</body>
+</html>
diff --git a/third-party/s-sysdeps/s-sysdeps.asd b/third-party/s-sysdeps/s-sysdeps.asd
new file mode 100644
index 0000000..409a929
--- /dev/null
+++ b/third-party/s-sysdeps/s-sysdeps.asd
@@ -0,0 +1,31 @@
+;;;; -*- Mode: LISP -*-
+;;;;
+;;;; $Id: s-xml-rpc.asd,v 1.2 2004/06/17 19:43:11 rschlatte Exp $
+;;;;
+;;;; The S-SYSDEPS ASDF system definition
+;;;;
+;;;; Copyright (C) 2004-2005 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-sysdeps
+ :name "S-SYSDEPS"
+ :author "Sven Van Caekenberghe <svc@mac.com>"
+ :version "1"
+ :maintainer "Sven Van Caekenberghe <svc@mac.com>"
+ :licence "Lesser Lisp General Public License (LLGPL)"
+ :description "An abstraction layer over platform dependent functionality"
+ :long-description "An abstraction layer over platform dependent functionality"
+
+ :components
+ ((:module
+ :src
+ :components ((:file "package")
+ #+clisp (:file "bivalent-streams" :depends-on ("package"))
+ (:file "sysdeps" :depends-on ("package" #+clisp "bivalent-streams"))))))
+
+;;;; eof
diff --git a/third-party/s-sysdeps/src/bivalent-streams.lisp b/third-party/s-sysdeps/src/bivalent-streams.lisp
new file mode 100644
index 0000000..3261a50
--- /dev/null
+++ b/third-party/s-sysdeps/src/bivalent-streams.lisp
@@ -0,0 +1,107 @@
+;;;; -*- mode: lisp -*-
+;;;;
+;;;; $Id: base64.lisp,v 1.3 2005/02/07 17:45:41 scaekenberghe Exp $
+;;;;
+;;;; Bivalent streams for CLISP
+;;;;
+;;;; Copyright (C) 2007 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-sysdeps)
+
+;;; Rationale:
+
+;;; we want (socket) streams that support input and output (i.e. are bidirectional),
+;;; using bytes and characters (i.e. are bivalent) at the same time, with conversions
+;;; using a straight/native byte to character conversion
+
+;;; this is an (incomplete) implementation for CLISP based on Gray streams
+;;; in other words: this is a hack to fix a particular problem/situation
+
+(defclass bivalent-bidirectional-stream (gray:fundamental-character-input-stream
+ gray:fundamental-character-output-stream
+ gray:fundamental-binary-input-stream
+ gray:fundamental-binary-output-stream)
+ ((bidirectional-binary-stream :reader get-native-stream :initarg :bidirection-binary-stream)))
+
+(defun make-bivalent-stream (stream)
+ "Wrap a bidirectional binary stream so that it behaves as a bivalent bidirectional stream"
+ (make-instance 'bivalent-bidirectional-stream :bidirection-binary-stream stream))
+
+;;; minimal required methods
+
+(defmethod stream-element-type ((stream bivalent-bidirectional-stream))
+ '(or character (unsigned-byte 8)))
+
+(defmethod close ((stream bivalent-bidirectional-stream) &key abort)
+ (close (get-native-stream stream) :abort abort)
+ (call-next-method))
+
+(defmethod gray:stream-position ((stream bivalent-bidirectional-stream) position)
+ (gray:stream-position (get-native-stream stream) position))
+
+(defmethod gray:stream-read-char ((stream bivalent-bidirectional-stream))
+ (code-char (read-byte (get-native-stream stream))))
+
+#+nil
+(defmethod gray:stream-unread-char ((stream bivalent-bidirectional-stream)))
+
+(defmethod gray:stream-write-char ((stream bivalent-bidirectional-stream) char)
+ (write-byte (char-code char) (get-native-stream stream)))
+
+(defmethod gray:stream-line-column ((stream bivalent-bidirectional-stream))
+ nil)
+
+(defmethod gray:stream-finish-output ((stream bivalent-bidirectional-stream))
+ (finish-output (get-native-stream stream)))
+
+(defmethod gray:stream-force-output ((stream bivalent-bidirectional-stream))
+ (force-output (get-native-stream stream)))
+
+(defmethod gray:stream-read-byte ((stream bivalent-bidirectional-stream))
+ (read-byte (get-native-stream stream)))
+
+(defmethod gray:stream-read-byte-lookahead ((stream bivalent-bidirectional-stream))
+ (ext:read-byte-lookahead (get-native-stream stream)))
+
+(defmethod gray:stream-write-byte ((stream bivalent-bidirectional-stream) byte)
+ (write-byte byte (get-native-stream stream)))
+
+;;; 'optimized' sequence IO
+
+(defmethod gray:stream-read-char-sequence ((stream bivalent-bidirectional-stream) sequence
+ &optional start end)
+ (unless start (setf start 0))
+ (unless end (setf end (length sequence)))
+ (let* ((byte-buffer (make-array (- end start) :element-type '(unsigned-byte 8)))
+ (result (ext:read-byte-sequence byte-buffer (get-native-stream stream))))
+ (loop :for i :from start :below (min end result)
+ :do (setf (elt sequence (+ start i)) (code-char (elt byte-buffer i))))
+ (+ start result)))
+
+(defmethod gray:stream-write-char-sequence ((stream bivalent-bidirectional-stream) sequence
+ &optional start end)
+ (unless start (setf start 0))
+ (unless end (setf end (length sequence)))
+ (let ((byte-buffer (make-array (- end start) :element-type '(unsigned-byte 8))))
+ (loop :for i :from start :below (- end start)
+ :do (setf (elt byte-buffer i) (char-code (elt sequence (+ start i)))))
+ (multiple-value-bind (seq result)
+ (ext:write-byte-sequence byte-buffer (get-native-stream stream))
+ (declare (ignore seq))
+ (+ start result))))
+
+(defmethod gray:stream-read-byte-sequence ((stream bivalent-bidirectional-stream) sequence
+ &optional start end no-hang interactive)
+ (declare (ignore no-hang interactive))
+ (ext:read-byte-sequence sequence (get-native-stream stream) :start start :end end))
+
+(defmethod gray:stream-write-byte-sequence ((stream bivalent-bidirectional-stream) sequence
+ &optional start end no-hang interactive)
+ (declare (ignore no-hang interactive))
+ (ext:write-byte-sequence sequence (get-native-stream stream) :start start :end end))
+
+;;;; eof
diff --git a/third-party/s-sysdeps/src/package.lisp b/third-party/s-sysdeps/src/package.lisp
new file mode 100644
index 0000000..a273d74
--- /dev/null
+++ b/third-party/s-sysdeps/src/package.lisp
@@ -0,0 +1,28 @@
+;;;; -*- mode: lisp -*-
+;;;;
+;;;; $Id: base64.lisp,v 1.3 2005/02/07 17:45:41 scaekenberghe Exp $
+;;;;
+;;;; This is the S-SYSDEPS package definition
+;;;;
+;;;; Copyright (C) 2004-2007 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-sysdeps
+ (:use common-lisp)
+ (:export
+ #:multiprocessing-capable-p
+ #:current-process
+ #:kill-process
+ #:run-process
+ #:all-processes
+ #:start-standard-server
+ #:open-socket-stream
+ #:get-socket-stream-property
+ #:make-process-lock
+ #:with-process-lock)
+ (:documentation "S-SYSDEPS is an abstraction layer over platform dependent functionality"))
+
+;;;; eof
diff --git a/third-party/s-sysdeps/src/sysdeps.lisp b/third-party/s-sysdeps/src/sysdeps.lisp
new file mode 100644
index 0000000..1f9a638
--- /dev/null
+++ b/third-party/s-sysdeps/src/sysdeps.lisp
@@ -0,0 +1,281 @@
+;;;; -*- mode: lisp -*-
+;;;;
+;;;; $Id: base64.lisp,v 1.3 2005/02/07 17:45:41 scaekenberghe Exp $
+;;;;
+;;;; S-SYSDEPS is an abtraction layer over platform dependent functionality
+;;;;
+;;;; Copyright (C) 2004-2007 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-sysdeps)
+
+;; loading platform specific dependencies
+
+#+lispworks
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (require "comm"))
+
+#+sbcl
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (require :sb-bsd-sockets))
+
+;; managing processes
+
+(defun multiprocessing-capable-p ()
+ "Returns t when this implementation is multiprocessing capable"
+ #+(or lispworks abcl openmcl allegro sb-thread) t
+ #-(or lispworks abcl openmcl allegro sb-thread) nil)
+
+(defun current-process ()
+ "Return the object representing the current process"
+ #+lispworks mp:*current-process*
+ #+abcl (ext:current-thread)
+ #+openmcl ccl:*current-process*
+ #+sb-thread sb-thread:*current-thread*
+ #+allegro sys:*current-process*
+ #-(or lispworks abcl openmcl sb-thread allegro) nil)
+
+(defun kill-process (process)
+ "Kill the process represented by the object process"
+ #+lispworks (mp:process-kill process)
+ #+abcl (ext:destroy-thread process)
+ #+openmcl (ccl:process-kill process)
+ #+sb-thread (sb-thread:terminate-thread process)
+ #+allegro (mp:process-kill process)
+ #-(or lispworks abcl openmcl sb-thread allegro) process)
+
+(defun run-process (name function &rest arguments)
+ "Create and run a new process with name, executing function on arguments"
+ #+lispworks (apply #'mp:process-run-function name '(:priority 3) function arguments)
+ #+abcl (ext:make-thread #'(lambda () (apply function arguments)) :name name)
+ #+openmcl (apply #'ccl:process-run-function name function arguments)
+ #+allegro (apply #'mp:process-run-function name function arguments)
+ #+sb-thread (sb-thread:make-thread #'(lambda () (apply function arguments)) :name name)
+ #-(or lispworks abcl openmcl allegro sb-thread)
+ (declare (ignore name))
+ #-(or lispworks abcl openmcl allegro sb-thread)
+ (apply function arguments))
+
+(defun all-processes ()
+ "Return a list of all processes currently running"
+ #+lispworks (mp:list-all-processes)
+ #+abcl (ext:mapcar-threads #'identity)
+ #+openmcl (ccl:all-processes)
+ #+sb-thread (sb-thread:list-all-threads)
+ #+allegro sys:*all-processes*
+ #-(or lispworks abcl openmcl sb-thread allegro) nil)
+
+;; opening a client TCP/IP socket stream
+
+(defun open-socket-stream (host port &key connect-timeout read-timeout write-timeout)
+ "Create and open a bidirectional client TCP/IP socket stream to host:port"
+ #+(or abcl openmcl allegro clisp cmu sbcl) (declare (ignore connect-timeout read-timeout write-timeout))
+ #+lispworks (comm:open-tcp-stream host port
+ :timeout connect-timeout
+ :read-timeout read-timeout
+ :write-timeout write-timeout)
+ #+abcl (let ((socket (ext:make-socket host port)))
+ (ext:get-socket-stream socket))
+ #+openmcl (ccl:make-socket :remote-host host :remote-port port)
+ #+allegro (acl-socket:make-socket :remote-host host :remote-port port
+ :type :stream :address-family :internet)
+ #+clisp (make-bivalent-stream (socket:socket-connect port host :element-type '(unsigned-byte 8)))
+ #+cmu (sys:make-fd-stream (ext:connect-to-inet-socket host port)
+ :input t :output t :buffering :none)
+ #+sbcl (let ((socket (make-instance 'sb-bsd-sockets:inet-socket
+ :type :stream :protocol :tcp)))
+ (sb-bsd-sockets:socket-connect socket
+ (car
+ (sb-bsd-sockets:host-ent-addresses
+ (sb-bsd-sockets:get-host-by-name host)))
+ port)
+ (sb-bsd-sockets:socket-make-stream socket
+ :element-type :default
+ :input t :output t :buffering :none))
+ #-(or lispworks abcl openmcl allegro clisp cmu sbcl)
+ (error "Opening a socket stream to ~a:~d not yet ported this lisp system" host port))
+
+;; accessing socket stream properties
+
+(defun get-socket-stream-property (socket-stream property)
+ "Get the value of a socket stream property, one of :remote-host :remote-port :local-host :local-port"
+ #+lispworks (ecase property
+ ((:remote-host :remote-port) (multiple-value-bind (address port)
+ (comm:socket-stream-peer-address socket-stream)
+ (if (eql property :remote-host)
+ (when address (comm:ip-address-string address))
+ port)))
+ ((:local-host :local-port) (multiple-value-bind (address port)
+ (comm:socket-stream-address socket-stream)
+ (if (eql property :local-host)
+ (when address (comm:ip-address-string address))
+ port))))
+ #+clisp (ecase property
+ ((:remote-host :remote-port) (multiple-value-bind (host port)
+ (socket:socket-stream-peer (get-native-stream socket-stream))
+ (if (eql property :remote-host)
+ host
+ port)))
+ ((:local-host :local-port) (multiple-value-bind (host port)
+ (socket:socket-stream-local (get-native-stream socket-stream))
+ (if (eql property :local-host)
+ host
+ port))))
+ #-(or lispworks clisp)
+ (declare (ignore socket-stream property))
+ #-(or lispworks clisp)
+ nil)
+
+;; implementing a standard TCP/IP server
+
+#+(or sb-thread cmu)
+(defvar *server-processes* '()
+ "The list of processes created by S-SYSDEPS")
+
+(defun start-standard-server (&key port name connection-handler)
+ "Start a server process with name, listening on port, delegating to connection-handler with stream as argument"
+ #+lispworks (comm:start-up-server
+ :function #'(lambda (socket-handle)
+ (let ((client-stream (make-instance 'comm:socket-stream
+ ;; maybe specify a read timeout...
+ :socket socket-handle
+ :direction :io
+ :element-type 'base-char)))
+ (funcall connection-handler client-stream)))
+ :service port
+ :announce t
+ :wait t
+ :process-name name)
+ #+abcl (ext:make-thread
+ #'(lambda ()
+ (let ((server-socket (ext:make-server-socket port)))
+ (unwind-protect
+ (loop
+ (let* ((client-socket (ext:socket-accept server-socket))
+ (client-stream (ext:get-socket-stream client-socket)))
+ (funcall connection-handler client-stream)))
+ (ext:server-socket-close server-socket))))
+ :name name)
+ #+openmcl (ccl:process-run-function
+ name
+ #'(lambda ()
+ (let ((server-socket (ccl:make-socket :connect :passive
+ :local-port port
+ :reuse-address t)))
+ (unwind-protect
+ (loop
+ (let ((client-stream (ccl:accept-connection server-socket)))
+ (funcall connection-handler client-stream)))
+ (close server-socket)))))
+ #+allegro (mp:process-run-function
+ name
+ #'(lambda ()
+ (let ((server-socket (acl-socket:make-socket :connect :passive
+ :local-port port)))
+ (unwind-protect
+ (loop
+ (let ((client-stream (acl-socket:accept-connection server-socket)))
+ (funcall connection-handler client-stream)))
+ (close server-socket)))))
+ #+sb-thread (let* ((socket (make-instance 'sb-bsd-sockets:inet-socket
+ :type :stream :protocol :tcp))
+ (handler-fn (lambda (fd)
+ (declare (ignore fd))
+ (let ((stream
+ (sb-bsd-sockets:socket-make-stream
+ (sb-bsd-sockets:socket-accept socket)
+ :element-type 'character
+ :input t
+ :output t
+ :buffering :none)))
+ (funcall connection-handler stream)))))
+ (setf (sb-bsd-sockets:sockopt-reuse-address socket) t)
+ (sb-bsd-sockets:socket-bind socket #(0 0 0 0) port)
+ (sb-bsd-sockets:socket-listen socket 15)
+ (push (list name
+ socket
+ (sb-sys:add-fd-handler
+ (sb-bsd-sockets:socket-file-descriptor socket)
+ :input handler-fn))
+ *server-processes*))
+ #+cmu (let* ((socket (ext:create-inet-listener port :stream :reuse-address t
+ :backlog 15))
+ (handler-fn (lambda (fd)
+ (declare (ignore fd))
+ (let ((stream (sys:make-fd-stream
+ (ext:accept-tcp-connection socket)
+ :input t :output t
+ :element-type 'character
+ :buffering :none)))
+ (funcall connection-handler stream)))))
+ (push (list name
+ socket
+ (sys:add-fd-handler socket :input handler-fn))
+ *server-processes*))
+ #+clisp (declare (ignore name))
+ ;; Implementation Limitation: in CLISP this becomes a blocking single-threaded server
+ #+clisp (let ((server-socket (socket:socket-server port :backlog 15)))
+ (unwind-protect
+ (loop
+ (let ((client-socket (socket:socket-accept server-socket :element-type '(unsigned-byte 8))))
+ (funcall connection-handler (make-bivalent-stream client-socket))))
+ (socket:socket-server-close server-socket))
+ nil)
+ #-(or lispworks abcl openmcl allegro sb-thread cmu clisp)
+ (error "Starting a standard socket named ~s on port ~d using handler ~s not yet ported to this lisp system"
+ name port connection-handler))
+
+#+(or sb-thread cmu)
+(defun stop-server (name)
+ "Stop a named server"
+ #+sb-thread (progn
+ (destructuring-bind (name socket handler)
+ (assoc name *server-processes* :test #'string=)
+ (declare (ignore name))
+ (sb-sys:remove-fd-handler handler)
+ (sb-bsd-sockets:socket-close socket))
+ (setf *server-processes* (delete name *server-processes*
+ :key #'car :test #'string=)))
+ #+cmu (progn
+ (destructuring-bind (name socket handler)
+ (assoc name *server-processes* :test #'string=)
+ (declare (ignore name))
+ (sys:remove-fd-handler handler)
+ (unix:unix-close socket))
+ (setf *server-processes* (delete name *server-processes*
+ :key #'car :test #'string=)))
+ name)
+
+;; working with process locks
+
+(defun make-process-lock (name)
+ "Create a named process lock object"
+ #+lispworks (mp:make-lock :name name)
+ #+abcl (ext:make-thread-lock)
+ #+openmcl (ccl:make-lock name)
+ #+allegro (mp:make-process-lock :name name)
+ #+sb-thread (sb-thread:make-mutex :name name)
+ #-(or lispworks abcl openmcl allegro sb-thread)
+ (declare (ignore name))
+ #-(or lispworks abcl openmcl allegro sb-thread)
+ nil)
+
+(defmacro with-process-lock ((lock) &body body)
+ "Execute body wih the process lock grabbed, wait otherwise"
+ ;; maybe it is safer to always use a timeout:
+ ;; `(mp:with-lock (,lock (format nil "Waiting for ~s" (lock-name ,lock)) 5) ,@body)
+ ;; if the lock cannot be claimed in 5s, nil is returned: test it and throw a condition ?
+ #+lispworks `(mp:with-lock (,lock) ,@body)
+ #+abcl `(ext:with-thread-lock (,lock) ,@body)
+ #+openmcl `(ccl:with-lock-grabbed (,lock) ,@body)
+ #+allegro `(mp:with-process-lock (,lock) ,@body)
+ #+sb-thread `(sb-thread:with-recursive-lock (,lock) ,@body)
+ #-(or lispworks abcl openmcl allegro sb-thread)
+ (declare (ignore lock))
+ #-(or lispworks abcl openmcl allegro sb-thread)
+ `(progn ,@body))
+
+;;;; eof
diff --git a/third-party/s-sysdeps/test/all-tests.lisp b/third-party/s-sysdeps/test/all-tests.lisp
new file mode 100644
index 0000000..98aab53
--- /dev/null
+++ b/third-party/s-sysdeps/test/all-tests.lisp
@@ -0,0 +1,15 @@
+;;;; -*- mode: lisp -*-
+;;;;
+;;;; $Id: all-tests.lisp,v 1.2 2004/06/17 19:43:11 rschlatte Exp $
+;;;;
+;;;; Load and execute all unit and functional tests
+;;;;
+;;;; Copyright (C) 2002-2005 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.
+
+(load (merge-pathnames "test-sysdeps" *load-pathname*) :verbose t)
+
+;;;; eof
diff --git a/third-party/s-sysdeps/test/test-sysdeps.lisp b/third-party/s-sysdeps/test/test-sysdeps.lisp
new file mode 100644
index 0000000..82c07c4
--- /dev/null
+++ b/third-party/s-sysdeps/test/test-sysdeps.lisp
@@ -0,0 +1,19 @@
+;;;; -*- mode: lisp -*-
+;;;;
+;;;; $Id: test-base64.lisp,v 1.1.1.1 2004/06/09 09:02:41 scaekenberghe Exp $
+;;;;
+;;;; Unit and functional tests for S-SYSDEPS
+;;;;
+;;;; Copyright (C) 2002-2005 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-sysdeps)
+
+(print "to be completed later")
+
+(assert t)
+
+;;;; eof
diff --git a/third-party/s-xml-rpc/.clbuild-skip-update b/third-party/s-xml-rpc/.clbuild-skip-update
new file mode 100644
index 0000000..e69de29
--- /dev/null
+++ b/third-party/s-xml-rpc/.clbuild-skip-update
diff --git a/third-party/s-xml-rpc/ChangeLog b/third-party/s-xml-rpc/ChangeLog
new file mode 100644
index 0000000..d6b2ab1
--- /dev/null
+++ b/third-party/s-xml-rpc/ChangeLog
@@ -0,0 +1,63 @@
+2006-04-19 Sven Van Caekenberghe <svc@mac.com>
+
+ * changes due to reporting and initial fixes by Alain Picard
+ * added support for whitespace handling
+ * iso8601->universal-time now accepts leading & trailing whitespace
+ * encode-xml-rpc-value now encodes t and nil correctly as boolean 1 and 0
+ * parsing doubles (using read-from-string) with reader macros disabled for security
+ * decode-xml-rpc now handles whitespace more correctly in <data> and <value> tags
+ * added several test cases and fixed older stop-server problem
+
+2005-02-11
+
+ * ported to clisp 2.32 (sysdeps)
+ * changed end-of-header test to accept empty lines as well
+ * changed usage to princ to write-string where possible
+ * fixed a test (added import, unintern code to/from s-xml-rpc-exports)
+
+2005-01-22 Sven Van Caekenberghe <svc@mac.com>
+
+ * fixed a performance issue in base64 decoding
+
+2004-10-26 Rudi Schlatte <rudi@constantly.at>
+
+ * src/sysdeps.lisp (with-open-socket-stream, run-process)
+ (start-standard-server, stop-server): Port to cmucl.
+
+2004-06-17 Rudi Schlatte <rudi@constantly.at>
+
+ * src/package.lisp: Add system.getCapabilities.
+
+ * src/extensions.lisp: Create, move server extensions from
+ xml-rpc.lisp here.
+ (do-one-multicall): Raise standard fault codes.
+ (|system.getCapabilities|): Implement.
+
+ * src/xml-rpc.lisp: Remove server extensions.
+ (encode-xml-rpc-value): Encode symbols as strings
+ (execute-xml-rpc-call, handle-xml-rpc-call): Raise standard fault
+ codes.
+
+2004-06-13 Rudi Schlatte <rudi@constantly.at>
+
+ * src/xml-rpc.lisp (xml-literal): new datatype for unescaped
+ strings (used by system.multicall to pass back encoded fault structs)
+ (encode-xml-rpc-value): handle it.
+ (encode-xml-rpc-fault-value, encode-xml-rpc-fault): separate
+ encoding of fault and methodResponse for system.multicall
+ (do-one-multicall, |system.multicall|): Implement system.multicall.
+
+ * src/package.lisp (s-xml-rpc-exports): New package -- don't
+ export the whole common-lisp package by default ;)
+
+ * src/xml-rpc.lisp (*xml-rpc-package*): ... use it.
+
+ * src/xml-rpc.lisp (|system.listMethods|)
+ (|system.methodSignature|, |system.methodHelp|): Added
+ introspection methods, to be imported in *xml-rpc-package*.
+
+ * src/package.lisp (s-xml-rpc): ... export them, and also
+ |system.multicall|
+
+ * src/xml-rpc.lisp: Some indentation frobs.
+
diff --git a/third-party/s-xml-rpc/Makefile b/third-party/s-xml-rpc/Makefile
new file mode 100644
index 0000000..2c79e22
--- /dev/null
+++ b/third-party/s-xml-rpc/Makefile
@@ -0,0 +1,33 @@
+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-rpc
+ACCOUNT=scaekenberghe
+CVSRT=:ext:$(ACCOUNT)@common-lisp.net:/project/$(PRJ)/cvsroot
+
+release:
+ rm -rf /tmp/$(PRJ) /tmp/public_html /tmp/$(PRJ).tgz /tmp/$(PRJ).tgz.asc
+ cd /tmp; cvs -d$(CVSRT) export -r HEAD $(PRJ); cvs -d$(CVSRT) export -r HEAD public_html
+ mv /tmp/public_html /tmp/$(PRJ)/doc
+ cd /tmp; gnutar cvfz $(PRJ).tgz $(PRJ); gpg -a -b $(PRJ).tgz
+ scp /tmp/$(PRJ).tgz $(ACCOUNT)@common-lisp.net:/project/$(PRJ)/public_html
+ scp /tmp/$(PRJ).tgz.asc $(ACCOUNT)@common-lisp.net:/project/$(PRJ)/public_html
diff --git a/third-party/s-xml-rpc/s-xml-rpc.asd b/third-party/s-xml-rpc/s-xml-rpc.asd
new file mode 100644
index 0000000..8ff2538
--- /dev/null
+++ b/third-party/s-xml-rpc/s-xml-rpc.asd
@@ -0,0 +1,32 @@
+;;;; -*- Mode: LISP -*-
+;;;;
+;;;; $Id: s-xml-rpc.asd,v 1.3 2006-01-09 19:33:47 scaekenberghe Exp $
+;;;;
+;;;; The S-XML-RPC 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-rpc
+ :name "S-XML-RPC"
+ :author "Sven Van Caekenberghe <svc@mac.com>"
+ :version "7"
+ :maintainer "Sven Van Caekenberghe <svc@mac.com>, Brian Mastenbrook <>, Rudi Schlatte <>"
+ :licence "Lesser Lisp General Public License (LLGPL)"
+ :description "Common Lisp XML-RPC Package"
+ :long-description "s-xml-rpc is a Common Lisp implementation of the XML-RPC procotol for both client and server"
+
+ :components
+ ((:module
+ :src
+ :components ((:file "package")
+ (:file "xml-rpc" :depends-on ("package"))
+ (:file "extensions" :depends-on ("package" "xml-rpc")))))
+ :depends-on (:s-xml :s-sysdeps :s-base64))
+
+;;;; eof
diff --git a/third-party/s-xml-rpc/src/aserve.lisp b/third-party/s-xml-rpc/src/aserve.lisp
new file mode 100644
index 0000000..ecd9073
--- /dev/null
+++ b/third-party/s-xml-rpc/src/aserve.lisp
@@ -0,0 +1,79 @@
+;;;; -*- mode: lisp -*-
+;;;;
+;;;; $Id: aserve.lisp,v 1.1.1.1 2004-06-09 09:02:39 scaekenberghe Exp $
+;;;;
+;;;; This file implements XML-RPC client and server networking based
+;;;; on (Portable) AllegroServe (see http://opensource.franz.com/aserve/
+;;;; or http://sourceforge.net/projects/portableaserve/), which you have
+;;;; to install first.
+;;;;
+;;;; Copyright (C) 2002, 2004 Sven Van Caekenberghe.
+;;;;
+;;;; You are granted the rights to distribute and use this software
+;;;; as governed by the terms of the Lisp Lesser GNU Public License
+;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
+
+(defpackage xml-rpc-aserve
+ (:use common-lisp net.aserve.client net.aserve xml-rpc)
+ (:export
+ "XML-RPC-CALL"
+ "START-XML-RPC-ASERVE"
+ "PUBLISH-ASERVE-XML-RPC-HANDLER"))
+
+(in-package :xml-rpc-aserve)
+
+(defun xml-rpc-call-aserve (encoded &key
+ (url *xml-rpc-url*)
+ (agent *xml-rpc-agent*)
+ (host *xml-rpc-host*)
+ (port *xml-rpc-port*)
+ (basic-autorization *xml-rpc-authorization*)
+ (proxy))
+ (let ((xml (print-xml-string encoded)))
+ (multiple-value-bind (response response-code headers uri)
+ (do-http-request
+ (format nil "http://~a:~d~a" host port url)
+ :method :post
+ :protocol :http/1.0
+ :user-agent agent
+ :content-type "text/xml"
+ :basic-authorization basic-autorization
+ :content xml
+ :proxy proxy)
+ (declare (ignore headers uri))
+ (if (= response-code 200)
+ (let ((result (decode-xml-rpc (make-string-input-stream response))))
+ (if (typep result 'xml-rpc-fault)
+ (error result)
+ (car result)))
+ (error "http-error:~d" response-code)))))
+
+(defun start-xml-rpc-aserve (&key (port *xml-rpc-port*))
+ (process-run-function "aserve-xml-rpc"
+ #'(lambda ()
+ (start :port port
+ :listeners 4
+ :chunking nil
+ :keep-alive nil))))
+
+(defun publish-aserve-xml-rpc-handler (&key (url *xml-rpc-url*) (agent *xml-rpc-agent*))
+ (declare (ignore agent))
+ (publish :path url
+ :content-type "text/xml"
+ :function #'aserve-xml-rpc-handler))
+
+(defun aserve-xml-rpc-handler (request entity)
+ (with-http-response (request
+ entity
+ :response (if (eq :post (request-method request))
+ *response-ok*
+ *response-bad-request*))
+ (with-http-body (request entity)
+ (let ((body (get-request-body request))
+ (id (process-name *current-process*)))
+ (with-input-from-string (in body)
+ (let ((xml (handle-xml-rpc-call in id)))
+ (format-debug t "~d sending ~a~%" id xml)
+ (princ xml *html-stream*)))))))
+
+;;;; eof
diff --git a/third-party/s-xml-rpc/src/define-xmlrpc-method.lisp b/third-party/s-xml-rpc/src/define-xmlrpc-method.lisp
new file mode 100644
index 0000000..74a3bc3
--- /dev/null
+++ b/third-party/s-xml-rpc/src/define-xmlrpc-method.lisp
@@ -0,0 +1,30 @@
+;;;; -*- mode: lisp -*-
+;;;;
+;;;; $Id: define-xmlrpc-method.lisp,v 1.1 2004-07-08 19:45:25 scaekenberghe Exp $
+;;;;
+;;;; The code in this file adds a very handly define-xmlrpc-method macro.
+;;;;
+;;;; (define-xmlrpc-method get-state-name (state)
+;;;; :url #u"http://betty.userland.com/RPC2"
+;;;; :method "examples.getStateName")
+;;;;
+;;;; (define-xmlrpc-method get-time ()
+;;;; :url #u"http://time.xmlrpc.com/RPC2"
+;;;; :method "currentTime.getCurrentTime")
+;;;;
+;;;; It require the PURI package.
+;;;;
+;;;; Copyright (C) 2004 Frederic Brunel.
+;;;;
+;;;; You are granted the rights to distribute and use this software
+;;;; as governed by the terms of the Lisp Lesser GNU Public License
+;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
+
+(defmacro define-xmlrpc-method (name args &key url method)
+ `(defun ,name ,args
+ (xml-rpc-call (encode-xml-rpc-call ,method ,@args)
+ :url ,(puri:uri-path url)
+ :host ,(puri:uri-host url)
+ :port ,(cond ((puri:uri-port url)) (t 80)))))
+
+;;;; eof
diff --git a/third-party/s-xml-rpc/src/extensions.lisp b/third-party/s-xml-rpc/src/extensions.lisp
new file mode 100644
index 0000000..fa961e2
--- /dev/null
+++ b/third-party/s-xml-rpc/src/extensions.lisp
@@ -0,0 +1,107 @@
+;;;; -*- mode: lisp -*-
+;;;;
+;;;; $Id: extensions.lisp,v 1.1 2004-06-17 19:43:11 rschlatte Exp $
+;;;;
+;;;; Extensions for xml-rpc:
+;;;;
+;;;; Server introspection:
+;;;; http://xmlrpc.usefulinc.com/doc/reserved.html
+;;;;
+;;;; Multicall:
+;;;; http://www.xmlrpc.com/discuss/msgReader$1208
+;;;;
+;;;; Capabilities:
+;;;; http://groups.yahoo.com/group/xml-rpc/message/2897
+;;;;
+;;;;
+;;;; Copyright (C) 2004 Rudi Schlatte
+;;;;
+;;;; 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-rpc)
+
+;;; Introspection
+
+(defun |system.listMethods| ()
+ "List the methods that are available on this server."
+ (let ((result nil))
+ (do-symbols (sym *xml-rpc-package* (sort result #'string-lessp))
+ (when (and (fboundp sym) (valid-xml-rpc-method-name-p (symbol-name sym)))
+ (push (symbol-name sym) result)))))
+
+(defun |system.methodSignature| (method-name)
+ "Dummy system.methodSignature implementation. There's no way
+ to get (and no concept of) required argument types in Lisp, so
+ this function always returns nil or errors."
+ (let ((method (find-xml-rpc-method method-name)))
+ (if method
+ ;; http://xmlrpc.usefulinc.com/doc/sysmethodsig.html says to
+ ;; return a non-array if the signature is not available
+ "n/a"
+ (error "Method ~A not found." method-name))))
+
+(defun |system.methodHelp| (method-name)
+ "Returns the function documentation for the given method."
+ (let ((method (find-xml-rpc-method method-name)))
+ (if method
+ (or (documentation method 'function) "")
+ (error "Method ~A not found." method-name))))
+
+;;; system.multicall
+
+(defun do-one-multicall (call-struct)
+ (let ((name (get-xml-rpc-struct-member call-struct :|methodName|))
+ (params (get-xml-rpc-struct-member call-struct :|params|)))
+ (handler-bind
+ ((xml-rpc-fault
+ #'(lambda (c)
+ (format-debug (or *xml-rpc-debug-stream* t)
+ "Call to ~A in system.multicall failed with ~a~%"
+ name c)
+ (return-from do-one-multicall
+ (xml-literal
+ (encode-xml-rpc-fault-value (xml-rpc-fault-string c)
+ (xml-rpc-fault-code c))))))
+ (error
+ #'(lambda (c)
+ (format-debug
+ (or *xml-rpc-debug-stream* t)
+ "Call to ~A in system.multicall failed with ~a~%" name c)
+ (return-from do-one-multicall
+ (xml-literal
+ (encode-xml-rpc-fault-value
+ ;; -32603 ---> server error. internal xml-rpc error
+ (format nil "~a" c) -32603))))))
+ (format-debug (or *xml-rpc-debug-stream* t)
+ "system.multicall calling ~a with ~s~%" name params)
+ (let ((result (apply *xml-rpc-call-hook* name params)))
+ (list result)))))
+
+(defun |system.multicall| (calls)
+ "Implement system.multicall; see http://www.xmlrpc.com/discuss/msgReader$1208
+ for the specification."
+ (mapcar #'do-one-multicall calls))
+
+;;; system.getCapabilities
+
+(defun |system.getCapabilities| ()
+ "Get a list of supported capabilities; see
+ http://groups.yahoo.com/group/xml-rpc/message/2897 for the
+ specification."
+ (let ((capabilities
+ '("xmlrpc" ("specUrl" "http://www.xmlrpc.com/spec"
+ "specVersion" 1)
+ "introspect" ("specUrl" "http://xmlrpc.usefulinc.com/doc/reserved.html"
+ "specVersion" 1)
+ "multicall" ("specUrl" "http://www.xmlrpc.com/discuss/msgReader$1208"
+ "specVersion" 1)
+ "faults_interop" ("specUrl" "http://xmlrpc-epi.sourceforge.net/specs/rfc.fault_codes.php"
+ "specVersion" 20010516))))
+ (apply #'xml-rpc-struct
+ (loop for (name description) on capabilities by #'cddr
+ collecting name
+ collecting (apply #'xml-rpc-struct description)))))
+
+;;;; eof
diff --git a/third-party/s-xml-rpc/src/package.lisp b/third-party/s-xml-rpc/src/package.lisp
new file mode 100644
index 0000000..e3d2568
--- /dev/null
+++ b/third-party/s-xml-rpc/src/package.lisp
@@ -0,0 +1,49 @@
+;;;; -*- mode: lisp -*-
+;;;;
+;;;; $Id: package.lisp,v 1.4 2004-06-17 19:43:11 rschlatte Exp $
+;;;;
+;;;; S-XML-RPC package 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 GNU Public License
+;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
+
+(defpackage s-xml-rpc
+ (:use
+ common-lisp
+ #+ccl ccl
+ #+lispworks mp
+ #+lispworks comm
+ s-xml
+ s-base64)
+ (:export
+ #:xml-rpc-call
+ #:encode-xml-rpc-call
+ #:call-xml-rpc-server
+ #:xml-rpc-condition
+ #:xml-rpc-fault #:xml-rpc-fault-code #:xml-rpc-fault-string
+ #:xml-rpc-error #:xml-rpc-error-place #:xml-rpc-error-data
+ #:start-xml-rpc-server
+ #:xml-rpc-time #:xml-rpc-time-p
+ #:xml-rpc-time-universal-time
+ #:xml-rpc-struct #:xml-rpc-struct-p
+ #:xml-rpc-struct-alist #:get-xml-rpc-struct-member #:xml-rpc-struct-equal
+ #:*xml-rpc-host* #:*xml-rpc-port* #:*xml-rpc-url* #:*xml-rpc-agent*
+ #:*xml-rpc-proxy-host* #:*xml-rpc-proxy-port* #:*xml-rpc-authorization*
+ #:*xml-rpc-debug* #:*xml-rpc-debug-stream*
+ #:*xml-rpc-package* #:*xml-rpc-call-hook*
+ #:execute-xml-rpc-call #:stop-server
+ #:|system.listMethods| #:|system.methodSignature| #:|system.methodHelp|
+ #:|system.multicall| #:|system.getCapabilities|)
+ (:documentation "An implementation of the standard XML-RPC protocol for both client and server"))
+
+(defpackage s-xml-rpc-exports
+ (:use)
+ (:import-from :s-xml-rpc #:|system.listMethods| #:|system.methodSignature|
+ #:|system.methodHelp| #:|system.multicall|
+ #:|system.getCapabilities|)
+ (:documentation "This package contains the functions callable via xml-rpc."))
+
+;;;; eof
diff --git a/third-party/s-xml-rpc/src/validator1-client.lisp b/third-party/s-xml-rpc/src/validator1-client.lisp
new file mode 100644
index 0000000..8800671
--- /dev/null
+++ b/third-party/s-xml-rpc/src/validator1-client.lisp
@@ -0,0 +1,182 @@
+;;;; -*- mode: lisp -*-
+;;;;
+;;;; $Id: validator1-client.lisp,v 1.1 2004-06-14 20:11:55 scaekenberghe Exp $
+;;;;
+;;;; This is a Common Lisp implementation of the XML-RPC 'validator1'
+;;;; server test suite, as live testable from the website
+;;;; http://validator.xmlrpc.com and documented on the web page
+;;;; http://www.xmlrpc.com/validator1Docs
+;;;;
+;;;; 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-rpc)
+
+(defun random-string (&optional (length 8))
+ (with-output-to-string (stream)
+ (dotimes (i (random length))
+ (write-char (code-char (+ 32 (random 95)))
+ stream))))
+
+(defun echo-struct-test ()
+ (let* ((struct (xml-rpc-struct :|foo| (random 1000000)
+ :|bar| (random-string)
+ :|fooBar| (list (random 100) (random 100))))
+ (result (xml-rpc-call (encode-xml-rpc-call :|validator1.echoStructTest|
+ struct))))
+ (format t "validator1.echoStructTest(~s)=~s~%" struct result)
+ (assert (xml-rpc-struct-equal struct result))))
+
+(defun easy-struct-test ()
+ (let* ((moe (random 1000))
+ (larry (random 1000))
+ (curry (random 1000))
+ (struct (xml-rpc-struct :|moe| moe
+ :|larry| larry
+ :|curly| curry))
+ (result (xml-rpc-call (encode-xml-rpc-call :|validator1.easyStructTest|
+ struct))))
+ (format t "validator1.easyStructTest(~s)=~s~%" struct result)
+ (assert (= (+ moe larry curry) result))))
+
+(defun count-the-entities ()
+ (let* ((string (random-string 512))
+ (left-angle-brackets (count #\< string))
+ (right-angle-brackets (count #\> string))
+ (apostrophes (count #\' string))
+ (quotes (count #\" string))
+ (ampersands (count #\& string))
+ (result (xml-rpc-call (encode-xml-rpc-call :|validator1.countTheEntities|
+ string))))
+ (format t "validator1.countTheEntitities(~s)=~s~%" string result)
+ (assert
+ (and (xml-rpc-struct-p result)
+ (= left-angle-brackets
+ (get-xml-rpc-struct-member result :|ctLeftAngleBrackets|))
+ (= right-angle-brackets
+ (get-xml-rpc-struct-member result :|ctRightAngleBrackets|))
+ (= apostrophes
+ (get-xml-rpc-struct-member result :|ctApostrophes|))
+ (= quotes
+ (get-xml-rpc-struct-member result :|ctQuotes|))
+ (= ampersands
+ (get-xml-rpc-struct-member result :|ctAmpersands|))))))
+
+(defun array-of-structs-test ()
+ (let ((array (make-array (random 32)))
+ (sum 0))
+ (dotimes (i (length array))
+ (setf (aref array i)
+ (xml-rpc-struct :|moe| (random 1000)
+ :|larry| (random 1000)
+ :|curly| (random 1000)))
+ (incf sum (get-xml-rpc-struct-member (aref array i)
+ :|curly|)))
+ (let ((result (xml-rpc-call (encode-xml-rpc-call :|validator1.arrayOfStructsTest|
+ array))))
+ (format t "validator1.arrayOfStructsTest(~s)=~s~%" array result)
+ (assert (= result sum)))))
+
+(defun random-bytes (&optional (length 16))
+ (let ((bytes (make-array (random length) :element-type '(unsigned-byte 8))))
+ (dotimes (i (length bytes) bytes)
+ (setf (aref bytes i) (random 256)))))
+
+(defun many-types-test ()
+ (let* ((integer (random 10000))
+ (boolean (if (zerop (random 2)) t nil))
+ (string (random-string))
+ (double (random 10000.0))
+ (dateTime (xml-rpc-time))
+ (base64 (random-bytes))
+ (result (xml-rpc-call (encode-xml-rpc-call :|validator1.manyTypesTest|
+ integer
+ boolean
+ string
+ double
+ dateTime
+ base64))))
+ (format t
+ "validator1.manyTypesTest(~s,~s,~s,~s,~s,~s)=~s~%"
+ integer
+ boolean
+ string
+ double
+ dateTime
+ base64
+ result)
+ (assert (equal integer (elt result 0)))
+ (assert (equal boolean (elt result 1)))
+ (assert (equal string (elt result 2)))
+ (assert (equal double (elt result 3)))
+ (assert (equal (xml-rpc-time-universal-time dateTime)
+ (xml-rpc-time-universal-time (elt result 4))))
+ (assert (reduce #'(lambda (x y) (and x y))
+ (map 'list #'= base64 (elt result 5))
+ :initial-value t))))
+
+(defun simple-struct-return-test ()
+ (let* ((number (random 1000))
+ (result (xml-rpc-call (encode-xml-rpc-call :|validator1.simpleStructReturnTest| number))))
+ (format t "validator1.simpleStructReturnTest(~s)=~s~%" number result)
+ (assert
+ (and (= (* number 10)
+ (get-xml-rpc-struct-member result :|times10|))
+ (= (* number 100)
+ (get-xml-rpc-struct-member result :|times100|))
+ (= (* number 1000)
+ (get-xml-rpc-struct-member result :|times1000|))))))
+
+(defun moderate-size-array-check ()
+ (let ((array (make-array (+ 100 (random 100))
+ :element-type 'string)))
+ (dotimes (i (length array))
+ (setf (aref array i) (random-string)))
+ (let ((result (xml-rpc-call (encode-xml-rpc-call :|validator1.moderateSizeArrayCheck|
+ array))))
+ (format t "validator1.moderateSizeArrayCheck(~s)=~s~%" array result)
+ (assert
+ (equal (concatenate 'string (elt array 0) (elt array (1- (length array))))
+ result)))))
+
+(defun nested-struct-test ()
+ (let* ((moe (random 1000))
+ (larry (random 1000))
+ (curry (random 1000))
+ (struct (xml-rpc-struct :|moe| moe
+ :|larry| larry
+ :|curly| curry))
+ (first (xml-rpc-struct :\01 struct))
+ (april (xml-rpc-struct :\04 first))
+ (year (xml-rpc-struct :\2000 april))
+ (result (xml-rpc-call (encode-xml-rpc-call :|validator1.nestedStructTest|
+ year))))
+ (format t "validator1.nestedStructTest(~s)=~s~%" year result)
+ (assert (= (+ moe larry curry) result))))
+
+(defun test-run (&optional (runs 1))
+ (dotimes (i runs t)
+ (echo-struct-test)
+ (easy-struct-test)
+ (count-the-entities)
+ (array-of-structs-test)
+ (many-types-test)
+ (simple-struct-return-test)
+ (moderate-size-array-check)
+ (nested-struct-test)))
+
+(defun timed-test-run (&optional (runs 1))
+ (dotimes (i runs t)
+ (time (echo-struct-test))
+ (time (easy-struct-test))
+ (time (count-the-entities))
+ (time (array-of-structs-test))
+ (time (many-types-test))
+ (time (simple-struct-return-test))
+ (time (moderate-size-array-check))
+ (time (nested-struct-test))))
+
+;;;; eof
diff --git a/third-party/s-xml-rpc/src/validator1-server.lisp b/third-party/s-xml-rpc/src/validator1-server.lisp
new file mode 100644
index 0000000..2833b8d
--- /dev/null
+++ b/third-party/s-xml-rpc/src/validator1-server.lisp
@@ -0,0 +1,90 @@
+;;;; -*- mode: lisp -*-
+;;;;
+;;;; $Id: validator1-server.lisp,v 1.1 2004-06-14 20:11:55 scaekenberghe Exp $
+;;;;
+;;;; This is a Common Lisp implementation of the XML-RPC 'validator1'
+;;;; server test suite, as live testable from the website
+;;;; http://validator.xmlrpc.com and documented on the web page
+;;;; http://www.xmlrpc.com/validator1Docs
+;;;;
+;;;; 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-rpc)
+
+(defun |validator1.echoStructTest| (struct)
+ (assert (xml-rpc-struct-p struct))
+ struct)
+
+(defun |validator1.easyStructTest| (struct)
+ (assert (xml-rpc-struct-p struct))
+ (+ (get-xml-rpc-struct-member struct :|moe|)
+ (get-xml-rpc-struct-member struct :|larry|)
+ (get-xml-rpc-struct-member struct :|curly|)))
+
+(defun |validator1.countTheEntities| (string)
+ (assert (stringp string))
+ (let ((left-angle-brackets (count #\< string))
+ (right-angle-brackets (count #\> string))
+ (apostrophes (count #\' string))
+ (quotes (count #\" string))
+ (ampersands (count #\& string)))
+ (xml-rpc-struct :|ctLeftAngleBrackets| left-angle-brackets
+ :|ctRightAngleBrackets| right-angle-brackets
+ :|ctApostrophes| apostrophes
+ :|ctQuotes| quotes
+ :|ctAmpersands| ampersands)))
+
+(defun |validator1.manyTypesTest| (number boolean string double dateTime base64)
+ (assert
+ (and (integerp number)
+ (or (null boolean) (eq boolean t))
+ (stringp string)
+ (floatp double)
+ (xml-rpc-time-p dateTime)
+ (and (arrayp base64)
+ (= (array-rank base64) 1)
+ (subtypep (array-element-type base64)
+ '(unsigned-byte 8)))))
+ (list number boolean string double dateTime base64))
+
+(defun |validator1.arrayOfStructsTest| (array)
+ (assert (listp array))
+ (reduce #'+
+ (mapcar #'(lambda (struct)
+ (assert (xml-rpc-struct-p struct))
+ (get-xml-rpc-struct-member struct :|curly|))
+ array)
+ :initial-value 0))
+
+(defun |validator1.simpleStructReturnTest| (number)
+ (assert (integerp number))
+ (xml-rpc-struct :|times10| (* number 10)
+ :|times100| (* number 100)
+ :|times1000| (* number 1000)))
+
+(defun |validator1.moderateSizeArrayCheck| (array)
+ (assert (listp array))
+ (concatenate 'string (first array) (first (last array))))
+
+(defun |validator1.nestedStructTest| (struct)
+ (assert (xml-rpc-struct-p struct))
+ (let* ((year (get-xml-rpc-struct-member struct :\2000))
+ (april (get-xml-rpc-struct-member year :\04))
+ (first (get-xml-rpc-struct-member april :\01)))
+ (|validator1.easyStructTest| first)))
+
+(import '(|validator1.echoStructTest|
+ |validator1.easyStructTest|
+ |validator1.countTheEntities|
+ |validator1.manyTypesTest|
+ |validator1.arrayOfStructsTest|
+ |validator1.simpleStructReturnTest|
+ |validator1.moderateSizeArrayCheck|
+ |validator1.nestedStructTest|)
+ :s-xml-rpc-exports)
+
+;;;; eof
diff --git a/third-party/s-xml-rpc/src/xml-rpc.lisp b/third-party/s-xml-rpc/src/xml-rpc.lisp
new file mode 100644
index 0000000..b65d2c0
--- /dev/null
+++ b/third-party/s-xml-rpc/src/xml-rpc.lisp
@@ -0,0 +1,586 @@
+;;;; -*- mode: lisp -*-
+;;;;
+;;;; $Id: xml-rpc.lisp,v 1.11 2008-02-15 15:42:40 scaekenberghe Exp $
+;;;;
+;;;; This is a Common Lisp implementation of the XML-RPC protocol,
+;;;; as documented on the website http://www.xmlrpc.com
+;;;; This implementation includes both a client and server part.
+;;;; A Base64 encoder/decoder and a minimal XML parser are required.
+;;;;
+;;;; 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-rpc)
+
+;;; conditions
+
+(define-condition xml-rpc-condition (error)
+ ()
+ (:documentation "Parent condition for all conditions thrown by the XML-RPC package"))
+
+(define-condition xml-rpc-fault (xml-rpc-condition)
+ ((code :initarg :code :reader xml-rpc-fault-code)
+ (string :initarg :string :reader xml-rpc-fault-string))
+ (:report (lambda (condition stream)
+ (format stream
+ "XML-RPC fault with message '~a' and code ~d."
+ (xml-rpc-fault-string condition)
+ (xml-rpc-fault-code condition))))
+ (:documentation "This condition is thrown when the XML-RPC server returns a fault"))
+
+(setf (documentation 'xml-rpc-fault-code 'function) "Get the code from an XML-RPC fault")
+(setf (documentation 'xml-rpc-fault-string 'function) "Get the string from an XML-RPC fault")
+
+(define-condition xml-rpc-error (xml-rpc-condition)
+ ((place :initarg :code :reader xml-rpc-error-place)
+ (data :initarg :data :reader xml-rpc-error-data))
+ (:report (lambda (condition stream)
+ (format stream
+ "XML-RPC error ~a at ~a."
+ (xml-rpc-error-data condition)
+ (xml-rpc-error-place condition))))
+ (:documentation "This condition is thrown when an XML-RPC protocol error occurs"))
+
+(setf (documentation 'xml-rpc-error-place 'function)
+ "Get the place from an XML-RPC error"
+ (documentation 'xml-rpc-error-data 'function)
+ "Get the data from an XML-RPC error")
+
+;;; whitespace handling support
+
+(defparameter +whitespace-characters+
+ '(#\Tab #\Space #\Page #\Return #\Newline #\Linefeed)
+ "The list of characters that we consider as whitespace")
+
+(defun whitespace-char? (char)
+ "Return t when char is considered whitespace"
+ (member char +whitespace-characters+ :test #'char=))
+
+(defun whitespace-string? (str)
+ "Return t when str consists of nothing but whitespace characters"
+ (every #'whitespace-char? str))
+
+;;; iso8601 support (the xml-rpc variant)
+
+(defun universal-time->iso8601 (time &optional (stream nil))
+ "Convert a Common Lisp universal time to a string in the XML-RPC variant of ISO8601"
+ (multiple-value-bind (second minute hour date month year)
+ (decode-universal-time time)
+ (format stream
+ "~d~2,'0d~2,'0dT~2,'0d:~2,'0d:~2,'0d"
+ year
+ month
+ date
+ hour
+ minute
+ second)))
+
+(defun iso8601->universal-time (string)
+ "Convert string in the XML-RPC variant of ISO8601 to a Common Lisp universal time"
+ (let (year month date (hour 0) (minute 0) (second 0))
+ (setf string (string-trim +whitespace-characters+ string))
+ (when (< (length string) 9)
+ (error "~s is to short to represent an iso8601" string))
+ (setf year (parse-integer string :start 0 :end 4)
+ month (parse-integer string :start 4 :end 6)
+ date (parse-integer string :start 6 :end 8))
+ (when (and (>= (length string) 17) (char= #\T (char string 8)))
+ (setf hour (parse-integer string :start 9 :end 11)
+ minute (parse-integer string :start 12 :end 14)
+ second (parse-integer string :start 15 :end 17)))
+ (encode-universal-time second minute hour date month year)))
+
+(defstruct (xml-rpc-time (:print-function print-xml-rpc-time))
+ "A wrapper around a Common Lisp universal time to be interpreted as an XML-RPC-TIME"
+ universal-time)
+
+(setf (documentation 'xml-rpc-time-p 'function)
+ "Return T when the argument is an XML-RPC time"
+ (documentation 'xml-rpc-time-universal-time 'function)
+ "Return the universal time from an XML-RPC time")
+
+(defun print-xml-rpc-time (xml-rpc-time stream depth)
+ (declare (ignore depth))
+ (format stream
+ "#<XML-RPC-TIME ~a>"
+ (universal-time->iso8601 (xml-rpc-time-universal-time xml-rpc-time))))
+
+(defun xml-rpc-time (&optional (universal-time (get-universal-time)))
+ "Create a new XML-RPC-TIME struct with the universal time specified, defaulting to now"
+ (make-xml-rpc-time :universal-time universal-time))
+
+;;; a wrapper for literal strings, where escaping #\< and #\& is not
+;;; desired
+
+(defstruct (xml-literal (:print-function print-xml-literal))
+ "A wrapper around a Common Lisp string that will be sent over
+ the wire unescaped"
+ content)
+
+(setf (documentation 'xml-literal-p 'function)
+ "Return T when the argument is an unescaped xml string"
+ (documentation 'xml-literal-content 'function)
+ "Return the content of a literal xml string")
+
+(defun print-xml-literal (xml-literal stream depth)
+ (declare (ignore depth))
+ (format stream
+ "#<XML-LITERAL \"~a\" >"
+ (xml-literal-content xml-literal)))
+
+(defun xml-literal (content)
+ "Create a new XML-LITERAL struct with the specified content."
+ (make-xml-literal :content content))
+
+;;; an extra datatype for xml-rpc structures (associative maps)
+
+(defstruct (xml-rpc-struct (:print-function print-xml-rpc-struct))
+ "An XML-RPC-STRUCT is an associative map of member names and values"
+ alist)
+
+(setf (documentation 'xml-rpc-struct-p 'function)
+ "Return T when the argument is an XML-RPC struct"
+ (documentation 'xml-rpc-struct-alist 'function)
+ "Return the alist of member names and values from an XML-RPC struct")
+
+(defun print-xml-rpc-struct (xml-element stream depth)
+ (declare (ignore depth))
+ (format stream "#<XML-RPC-STRUCT~{ ~S~}>" (xml-rpc-struct-alist xml-element)))
+
+(defun get-xml-rpc-struct-member (struct member)
+ "Get the value of a specific member of an XML-RPC-STRUCT"
+ (cdr (assoc member (xml-rpc-struct-alist struct))))
+
+(defun (setf get-xml-rpc-struct-member) (value struct member)
+ "Set the value of a specific member of an XML-RPC-STRUCT"
+ (let ((pair (assoc member (xml-rpc-struct-alist struct))))
+ (if pair
+ (rplacd pair value)
+ (push (cons member value) (xml-rpc-struct-alist struct)))
+ value))
+
+(defun xml-rpc-struct (&rest args)
+ "Create a new XML-RPC-STRUCT from the arguments: alternating member names and values"
+ (unless (evenp (length args))
+ (error "~s must contain an even number of elements" args))
+ (let (alist)
+ (loop
+ (if (null args)
+ (return)
+ (push (cons (pop args) (pop args)) alist)))
+ (make-xml-rpc-struct :alist alist)))
+
+(defun xml-rpc-struct-equal (struct1 struct2)
+ "Compare two XML-RPC-STRUCTs for equality"
+ (if (and (xml-rpc-struct-p struct1)
+ (xml-rpc-struct-p struct2)
+ (= (length (xml-rpc-struct-alist struct1))
+ (length (xml-rpc-struct-alist struct2))))
+ (dolist (assoc (xml-rpc-struct-alist struct1) t)
+ (unless (equal (get-xml-rpc-struct-member struct2 (car assoc))
+ (cdr assoc))
+ (return-from xml-rpc-struct-equal nil)))
+ nil))
+
+;;; encoding support
+
+(defun encode-xml-rpc-struct (struct stream)
+ (write-string "<struct>" stream)
+ (dolist (member (xml-rpc-struct-alist struct))
+ (write-string "<member>" stream)
+ (format stream "<name>~a</name>" (car member)) ; assuming name contains no special characters
+ (encode-xml-rpc-value (cdr member) stream)
+ (write-string "</member>" stream))
+ (write-string "</struct>" stream))
+
+(defun encode-xml-rpc-array (sequence stream)
+ (write-string "<array><data>" stream)
+ (map 'nil #'(lambda (element) (encode-xml-rpc-value element stream)) sequence)
+ (write-string "</data></array>" stream))
+
+(defun encode-xml-rpc-value (arg stream)
+ (write-string "<value>" stream)
+ (cond ((or (null arg) (eql arg t))
+ (write-string "<boolean>" stream)
+ (write-string (if arg "1" "0") stream)
+ (write-string "</boolean>" stream))
+ ((or (stringp arg) (symbolp arg))
+ (write-string "<string>" stream)
+ (print-string-xml (string arg) stream)
+ (write-string "</string>" stream))
+ ((integerp arg) (format stream "<int>~d</int>" arg))
+ ((floatp arg) (format stream "<double>~f</double>" arg))
+ ((and (arrayp arg)
+ (= (array-rank arg) 1)
+ (subtypep (array-element-type arg)
+ '(unsigned-byte 8)))
+ (write-string "<base64>" stream)
+ (encode-base64-bytes arg stream)
+ (write-string "</base64>" stream))
+ ((xml-rpc-time-p arg)
+ (write-string "<dateTime.iso8601>" stream)
+ (universal-time->iso8601 (xml-rpc-time-universal-time arg) stream)
+ (write-string "</dateTime.iso8601>" stream))
+ ((xml-literal-p arg)
+ (write-string (xml-literal-content arg) stream))
+ ((or (listp arg) (vectorp arg)) (encode-xml-rpc-array arg stream))
+ ((xml-rpc-struct-p arg) (encode-xml-rpc-struct arg stream))
+ ;; add generic method call
+ (t (error "cannot encode ~s" arg)))
+ (write-string "</value>" stream))
+
+(defun encode-xml-rpc-args (args stream)
+ (write-string "<params>" stream)
+ (dolist (arg args)
+ (write-string "<param>" stream)
+ (encode-xml-rpc-value arg stream)
+ (write-string "</param>" stream))
+ (write-string "</params>" stream))
+
+(defun encode-xml-rpc-call (name &rest args)
+ "Encode an XML-RPC call with name and args as an XML string"
+ (with-output-to-string (stream)
+ (write-string "<methodCall>" stream)
+ ;; Spec says: The string may only contain identifier characters,
+ ;; upper and lower-case A-Z, the numeric characters, 0-9,
+ ;; underscore, dot, colon and slash.
+ (format stream "<methodName>~a</methodName>" (string name)) ; assuming name contains no special characters
+ (when args
+ (encode-xml-rpc-args args stream))
+ (write-string "</methodCall>" stream)))
+
+(defun encode-xml-rpc-result (value)
+ (with-output-to-string (stream)
+ (write-string "<methodResponse>" stream)
+ (encode-xml-rpc-args (list value) stream)
+ (write-string "</methodResponse>" stream)))
+
+(defun encode-xml-rpc-fault-value (fault-string &optional (fault-code 0))
+ ;; for system.multicall
+ (with-output-to-string (stream)
+ (write-string "<struct>" stream)
+ (format stream "<member><name>faultCode</name><value><int>~d</int></value></member>" fault-code)
+ (write-string "<member><name>faultString</name><value><string>" stream)
+ (print-string-xml fault-string stream)
+ (write-string "</string></value></member>" stream)
+ (write-string "</struct>" stream)))
+
+(defun encode-xml-rpc-fault (fault-string &optional (fault-code 0))
+ (with-output-to-string (stream)
+ (write-string "<methodResponse><fault><value>" stream)
+ (write-string (encode-xml-rpc-fault-value fault-string fault-code) stream)
+ (write-string "</value></fault></methodResponse>" stream)))
+
+;;; decoding support
+
+(defun decode-xml-rpc-new-element (name attributes seed)
+ (declare (ignore seed name attributes))
+ '())
+
+(defun decode-xml-rpc-finish-element (name attributes parent-seed seed)
+ (declare (ignore attributes))
+ (cons (case name
+ ((:|int| :|i4|) (parse-integer seed))
+ (:|double| (let ((*read-eval* nil)
+ (*read-default-float-format* 'double-float))
+ (read-from-string seed)))
+ (:|boolean| (= 1 (parse-integer seed)))
+ (:|string| (if (null seed) "" seed))
+ (:|dateTime.iso8601| (xml-rpc-time (iso8601->universal-time seed)))
+ (:|base64| (if (null seed)
+ (make-array 0 :element-type '(unsigned-byte 8))
+ (with-input-from-string (in seed)
+ (decode-base64-bytes in))))
+ (:|array| (car seed))
+ (:|data| (unless (stringp seed) (nreverse seed)))
+ (:|value| (cond ((stringp seed) seed)
+ ((null seed) "")
+ (t (car seed))))
+ (:|struct| (make-xml-rpc-struct :alist seed))
+ (:|member| (cons (cadr seed) (car seed)))
+ (:|name| (intern seed :keyword))
+ (:|params| (nreverse seed))
+ (:|param| (car seed))
+ (:|fault| (make-condition 'xml-rpc-fault
+ :string (get-xml-rpc-struct-member (car seed) :|faultString|)
+ :code (get-xml-rpc-struct-member (car seed) :|faultCode|)))
+ (:|methodName| seed)
+ (:|methodCall| (let ((pair (nreverse seed)))
+ (cons (car pair) (cadr pair))))
+ (:|methodResponse| (car seed)))
+ parent-seed))
+
+(defun decode-xml-rpc-text (string seed)
+ (declare (ignore seed))
+ string)
+
+(defun decode-xml-rpc (stream)
+ (car (start-parse-xml stream
+ (make-instance 'xml-parser-state
+ :new-element-hook #'decode-xml-rpc-new-element
+ :finish-element-hook #'decode-xml-rpc-finish-element
+ :text-hook #'decode-xml-rpc-text))))
+
+;;; networking basics
+
+(defparameter *xml-rpc-host* "localhost"
+ "String naming the default XML-RPC host to use")
+
+(defparameter *xml-rpc-port* 80
+ "Integer specifying the default XML-RPC port to use")
+
+(defparameter *xml-rpc-url* "/RPC2"
+ "String specifying the default XML-RPC URL to use")
+
+(defparameter *xml-rpc-agent* (concatenate 'string
+ (lisp-implementation-type)
+ " "
+ (lisp-implementation-version))
+ "String specifying the default XML-RPC agent to include in server responses")
+
+(defvar *xml-rpc-debug* nil
+ "When T the XML-RPC client and server part will be more verbose about their protocol")
+
+(defvar *xml-rpc-debug-stream* nil
+ "When not nil it specifies where debugging output should be written to")
+
+(defparameter *xml-rpc-proxy-host* nil
+ "When not null, a string naming the XML-RPC proxy host to use")
+
+(defparameter *xml-rpc-proxy-port* nil
+ "When not null, an integer specifying the XML-RPC proxy port to use")
+
+(defparameter *xml-rpc-package* (find-package :s-xml-rpc-exports)
+ "Package for XML-RPC callable functions")
+
+(defparameter *xml-rpc-authorization* nil
+ "When not null, a string to be used as Authorization header")
+
+(defun format-debug (&rest args)
+ (when *xml-rpc-debug*
+ (apply #'format args)))
+
+(defparameter +crlf+ (make-array 2
+ :element-type 'character
+ :initial-contents '(#\return #\linefeed)))
+
+(defun tokens (string &key (start 0) (separators (list #\space #\return #\linefeed #\tab)))
+ (if (= start (length string))
+ '()
+ (let ((p (position-if #'(lambda (char) (find char separators)) string :start start)))
+ (if p
+ (if (= p start)
+ (tokens string :start (1+ start) :separators separators)
+ (cons (subseq string start p)
+ (tokens string :start (1+ p) :separators separators)))
+ (list (subseq string start))))))
+
+(defun format-header (stream headers)
+ (mapc #'(lambda (header)
+ (cond ((null (rest header)) (write-string (first header) stream) (write-string +crlf+ stream))
+ ((second header) (apply #'format stream header) (write-string +crlf+ stream))))
+ headers)
+ (write-string +crlf+ stream))
+
+(defun debug-stream (in)
+ (if *xml-rpc-debug*
+ (make-echo-stream in *standard-output*)
+ in))
+
+;;; client API
+
+(defun xml-rpc-call (encoded &key
+ (url *xml-rpc-url*)
+ (agent *xml-rpc-agent*)
+ (host *xml-rpc-host*)
+ (port *xml-rpc-port*)
+ (authorization *xml-rpc-authorization*)
+ (proxy-host *xml-rpc-proxy-host*)
+ (proxy-port *xml-rpc-proxy-port*))
+ "Execute an already encoded XML-RPC call and return the decoded result"
+ (let ((uri (if proxy-host (format nil "http://~a:~d~a" host port url) url)))
+ (with-open-stream (connection (s-sysdeps:open-socket-stream (if proxy-host proxy-host host)
+ (if proxy-port proxy-port port)))
+ (format-debug (or *xml-rpc-debug-stream* t) "POST ~a HTTP/1.0~%Host: ~a:~d~%" uri host port)
+ (format-header connection `(("POST ~a HTTP/1.0" ,uri)
+ ("User-Agent: ~a" ,agent)
+ ("Host: ~a:~d" ,host ,port)
+ ("Authorization: ~a" ,authorization)
+ ("Content-Type: text/xml")
+ ("Content-Length: ~d" ,(length encoded))))
+ (write-string encoded connection)
+ (finish-output connection)
+ (format-debug (or *xml-rpc-debug-stream* t) "Sending ~a~%~%" encoded)
+ (let ((header (read-line connection nil nil)))
+ (when (null header) (error "no response from server"))
+ (format-debug (or *xml-rpc-debug-stream* t) "~a~%" header)
+ (setf header (tokens header))
+ (unless (and (>= (length header) 3)
+ (string-equal (second header) "200")
+ (string-equal (third header) "OK"))
+ (error "http-error:~{ ~a~}" header)))
+ (do ((line (read-line connection nil nil)
+ (read-line connection nil nil)))
+ ((or (null line) (<= (length line) 1)))
+ (format-debug (or *xml-rpc-debug-stream* t) "~a~%" line))
+ (let ((result (decode-xml-rpc (debug-stream connection))))
+ (if (typep result 'xml-rpc-fault)
+ (error result)
+ (car result))))))
+
+(defun call-xml-rpc-server (server-keywords name &rest args)
+ "Encode and execute an XML-RPC call with name and args, using the list of server-keywords"
+ (apply #'xml-rpc-call
+ (cons (apply #'encode-xml-rpc-call (cons name args))
+ server-keywords)))
+
+(defun describe-server (&key (host *xml-rpc-host*) (port *xml-rpc-port*) (url *xml-rpc-url*))
+ "Tries to describe a remote server using system.* methods"
+ (dolist (method (xml-rpc-call (encode-xml-rpc-call "system.listMethods")
+ :host host
+ :port port
+ :url url))
+ (format t
+ "Method ~a ~a~%~a~%~%"
+ method
+ (xml-rpc-call (encode-xml-rpc-call "system.methodSignature" method)
+ :host host
+ :port port
+ :url url)
+ (xml-rpc-call (encode-xml-rpc-call "system.methodHelp" method)
+ :host host
+ :port port
+ :url url))))
+
+
+;;; server API
+
+(defvar *xml-rpc-call-hook* 'execute-xml-rpc-call
+ "A function to execute the xml-rpc call and return the result, accepting a method-name string and a optional argument list")
+
+(defparameter +xml-rpc-method-characters+
+ "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789_.:/")
+
+(defun valid-xml-rpc-method-name-p (method-name)
+ (not (find-if-not (lambda (c) (find c +xml-rpc-method-characters+))
+ method-name)))
+
+(defun find-xml-rpc-method (method-name)
+ "Looks for a method with the given name in *xml-rpc-package*.
+ Returns the symbol named METHOD-NAME if it exists and is
+ fbound, or NIL if not."
+ (let ((sym (find-symbol method-name *xml-rpc-package*)))
+ (if (fboundp sym) sym nil)))
+
+(defun execute-xml-rpc-call (method-name &rest arguments)
+ "Execute method METHOD-NAME on ARGUMENTS, or raise an error if
+ no such method exists in *XML-RPC-PACKAGE*"
+ (let ((method (find-xml-rpc-method method-name)))
+ (if method
+ (apply method arguments)
+ ;; http://xmlrpc-epi.sourceforge.net/specs/rfc.fault_codes.php
+ ;; -32601 ---> server error. requested method not found
+ (error 'xml-rpc-fault :code -32601
+ :string (format nil "Method ~A not found." method-name)))))
+
+(defun handle-xml-rpc-call (in id)
+ "Handle an actual call, reading XML from in and returning the
+ XML-encoded result."
+ ;; Try to conform to
+ ;; http://xmlrpc-epi.sourceforge.net/specs/rfc.fault_codes.php
+ (handler-bind ((s-xml:xml-parser-error
+ #'(lambda (c)
+ (format-debug (or *xml-rpc-debug-stream* t)
+ "~a request parsing failed with ~a~%"
+ id c)
+ (return-from handle-xml-rpc-call
+ ;; -32700 ---> parse error. not well formed
+ (encode-xml-rpc-fault (format nil "~a" c) -32700))))
+ (xml-rpc-fault
+ #'(lambda (c)
+ (format-debug (or *xml-rpc-debug-stream* t)
+ "~a call failed with ~a~%" id c)
+ (return-from handle-xml-rpc-call
+ (encode-xml-rpc-fault (xml-rpc-fault-string c)
+ (xml-rpc-fault-code c)))))
+ (error
+ #'(lambda (c)
+ (format-debug (or *xml-rpc-debug-stream* t)
+ "~a call failed with ~a~%" id c)
+ (return-from handle-xml-rpc-call
+ ;; -32603 ---> server error. internal xml-rpc error
+ (encode-xml-rpc-fault (format nil "~a" c) -32603)))))
+ (let ((call (decode-xml-rpc (debug-stream in))))
+ (format-debug (or *xml-rpc-debug-stream* t) "~a received call ~s~%" id call)
+ (let ((result (apply *xml-rpc-call-hook*
+ (first call)
+ (rest call))))
+ (format-debug (or *xml-rpc-debug-stream* t) "~a call result is ~s~%" id result)
+ (encode-xml-rpc-result result)))))
+
+(defun xml-rpc-implementation-version ()
+ "Identify ourselves"
+ (concatenate 'string
+ "$Id: xml-rpc.lisp,v 1.11 2008-02-15 15:42:40 scaekenberghe Exp $"
+ " "
+ (lisp-implementation-type)
+ " "
+ (lisp-implementation-version)))
+
+(defun xml-rpc-server-connection-handler (connection id agent url)
+ "Handle an incoming connection, doing both all HTTP and XML-RPC stuff"
+ (handler-bind ((error #'(lambda (c)
+ (format-debug (or *xml-rpc-debug-stream* t)
+ "xml-rpc server connection handler failed with ~a~%" c)
+ (error c)
+ (return-from xml-rpc-server-connection-handler nil))))
+ (let ((header (read-line connection nil nil)))
+ (when (null header) (error "no request from client"))
+ (setf header (tokens header))
+ (if (and (>= (length header) 3)
+ (string-equal (first header) "POST")
+ (string-equal (second header) url))
+ (progn
+ (do ((line (read-line connection nil nil)
+ (read-line connection nil nil)))
+ ((or (null line) (<= (length line) 1)))
+ (format-debug (or *xml-rpc-debug-stream* t) "~d ~a~%" id line))
+ (let ((xml (handle-xml-rpc-call connection id)))
+ (format-header connection
+ `(("HTTP/1.0 200 OK")
+ ("Server: ~a" ,agent)
+ ("Connection: close")
+ ("Content-Type: text/xml")
+ ("Content-Length: ~d" ,(length xml))))
+ (write-string xml connection)
+ (format-debug (or *xml-rpc-debug-stream* t) "~d sending ~a~%" id xml)))
+ (progn
+ (format-header connection
+ `(("HTTP/1.0 400 Bad Request")
+ ("Server: ~a" ,agent)
+ ("Connection: close")))
+ (format-debug (or *xml-rpc-debug-stream* t) "~d got a bad request~%" id)))
+ (force-output connection)
+ (close connection))))
+
+(defparameter *counter* 0 "Unique ID for incoming connections")
+
+(defun start-xml-rpc-server (&key (port *xml-rpc-port*) (url *xml-rpc-url*) (agent *xml-rpc-agent*))
+ "Start an XML-RPC server in a separate process"
+ (s-sysdeps:start-standard-server
+ :name (format nil "xml-rpc server ~a:~d" url port)
+ :port port
+ :connection-handler #'(lambda (client-stream)
+ (let ((id (incf *counter*)))
+ (format-debug (or *xml-rpc-debug-stream* t) "spawned connection handler ~d~%" id)
+ (s-sysdeps:run-process (format nil "xml-rpc-server-connection-handler-~d" id)
+ #'xml-rpc-server-connection-handler
+ client-stream
+ id
+ agent
+ url)))))
+
+;;;; eof
diff --git a/third-party/s-xml-rpc/test/all-tests.lisp b/third-party/s-xml-rpc/test/all-tests.lisp
new file mode 100644
index 0000000..3b24e2a
--- /dev/null
+++ b/third-party/s-xml-rpc/test/all-tests.lisp
@@ -0,0 +1,17 @@
+;;;; -*- mode: lisp -*-
+;;;;
+;;;; $Id: all-tests.lisp,v 1.2 2004-06-17 19:43:11 rschlatte Exp $
+;;;;
+;;;; Load and execute all unit and functional tests
+;;;;
+;;;; 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.
+
+(load (merge-pathnames "test-base64" *load-pathname*) :verbose t)
+(load (merge-pathnames "test-xml-rpc" *load-pathname*) :verbose t)
+(load (merge-pathnames "test-extensions" *load-pathname*) :verbose t)
+
+;;;; eof
diff --git a/third-party/s-xml-rpc/test/test-base64.lisp b/third-party/s-xml-rpc/test/test-base64.lisp
new file mode 100644
index 0000000..c263788
--- /dev/null
+++ b/third-party/s-xml-rpc/test/test-base64.lisp
@@ -0,0 +1,123 @@
+;;;; -*- mode: lisp -*-
+;;;;
+;;;; $Id: test-base64.lisp,v 1.1.1.1 2004-06-09 09:02:41 scaekenberghe Exp $
+;;;;
+;;;; Unit and functional tests for base64.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-base64)
+
+(assert
+ (equal (multiple-value-list (core-encode-base64 0 0 0))
+ (list #\A #\A #\A #\A)))
+
+(assert
+ (equal (multiple-value-list (core-encode-base64 255 255 255))
+ (list #\/ #\/ #\/ #\/)))
+
+(assert
+ (equal (multiple-value-list (core-encode-base64 1 2 3))
+ (list #\A #\Q #\I #\D)))
+
+(assert
+ (equal (multiple-value-list (core-encode-base64 10 20 30))
+ (list #\C #\h #\Q #\e)))
+
+(assert
+ (equal (multiple-value-list (core-decode-base64 #\A #\A #\A #\A))
+ (list 0 0 0)))
+
+(assert
+ (equal (multiple-value-list (core-decode-base64 #\/ #\/ #\/ #\/))
+ (list 255 255 255)))
+
+(assert
+ (equal (multiple-value-list (core-decode-base64 #\A #\Q #\I #\D))
+ (list 1 2 3)))
+
+(assert
+ (equal (multiple-value-list (core-decode-base64 #\C #\h #\Q #\e))
+ (list 10 20 30)))
+
+(assert
+ (let* ((string "Hello World!")
+ (bytes (map 'vector #'char-code string))
+ encoded
+ decoded)
+ (setf encoded (with-output-to-string (out)
+ (encode-base64-bytes bytes out)))
+ (setf decoded (with-input-from-string (in encoded)
+ (decode-base64-bytes in)))
+ (equal string
+ (map 'string #'code-char decoded))))
+
+;;; this is more of a functional test
+
+(defun same-character-file (file1 file2)
+ (with-open-file (a file1 :direction :input)
+ (with-open-file (b file2 :direction :input)
+ (loop
+ (let ((char-a (read-char a nil nil nil))
+ (char-b (read-char b nil nil nil)))
+ (cond ((not (or (and (null char-a) (null char-b))
+ (and char-a char-b)))
+ (return-from same-character-file nil))
+ ((null char-a)
+ (return-from same-character-file t))
+ ((char/= char-a char-b)
+ (return-from same-character-file nil))))))))
+
+(defun same-binary-file (file1 file2)
+ (with-open-file (a file1 :direction :input :element-type 'unsigned-byte)
+ (with-open-file (b file2 :direction :input :element-type 'unsigned-byte)
+ (loop
+ (let ((byte-a (read-byte a nil nil))
+ (byte-b (read-byte b nil nil)))
+ (cond ((not (or (and (null byte-a) (null byte-b))
+ (and byte-a byte-b)))
+ (return-from same-binary-file nil))
+ ((null byte-a)
+ (return-from same-binary-file t))
+ ((/= byte-a byte-b)
+ (return-from same-binary-file nil))))))))
+
+(let ((original (merge-pathnames "test.b64" *load-pathname*))
+ (first-gif (merge-pathnames "test.gif" *load-pathname*))
+ (b64 (merge-pathnames "test2.b64" *load-pathname*))
+ (second-gif (merge-pathnames "test2.gif" *load-pathname*)))
+ (with-open-file (in original
+ :direction :input)
+ (with-open-file (out first-gif
+ :direction :output
+ :element-type 'unsigned-byte
+ :if-does-not-exist :create
+ :if-exists :supersede)
+ (decode-base64 in out)))
+ (with-open-file (in first-gif
+ :direction :input
+ :element-type 'unsigned-byte)
+ (with-open-file (out b64
+ :direction :output
+ :if-does-not-exist :create
+ :if-exists :supersede)
+ (encode-base64 in out nil)))
+ (assert (same-character-file original b64))
+ (with-open-file (in b64
+ :direction :input)
+ (with-open-file (out second-gif
+ :direction :output
+ :element-type 'unsigned-byte
+ :if-does-not-exist :create
+ :if-exists :supersede)
+ (decode-base64 in out)))
+ (assert (same-binary-file first-gif second-gif))
+ (delete-file first-gif)
+ (delete-file b64)
+ (delete-file second-gif))
+
+;;;; eof \ No newline at end of file
diff --git a/third-party/s-xml-rpc/test/test-extensions.lisp b/third-party/s-xml-rpc/test/test-extensions.lisp
new file mode 100644
index 0000000..a3e3eb0
--- /dev/null
+++ b/third-party/s-xml-rpc/test/test-extensions.lisp
@@ -0,0 +1,53 @@
+;;;; -*- mode: lisp -*-
+;;;;
+;;;; $Id: test-extensions.lisp,v 1.2 2006-04-19 10:22:31 scaekenberghe Exp $
+;;;;
+;;;; Unit and functional tests for xml-rpc.lisp
+;;;;
+;;;; Copyright (C) 2004 Rudi Schlatte
+;;;;
+;;;; 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-rpc)
+
+(let* ((server-port 8080)
+ (server-process (start-xml-rpc-server :port server-port))
+ (server-args `(:port ,server-port))
+ (*xml-rpc-package* (make-package (gensym)))
+ (symbols '(|system.listMethods| |system.methodSignature|
+ |system.methodHelp| |system.multicall|
+ |system.getCapabilities|)))
+ (import symbols *xml-rpc-package*)
+ (sleep 1) ; give the server some time to come up ;-)
+ (unwind-protect
+ (progn
+ (assert
+ (equal (sort (call-xml-rpc-server server-args "system.listMethods")
+ #'string<)
+ (sort (mapcar #'string symbols) #'string<)))
+ (assert
+ (every #'string=
+ (mapcar (lambda (name)
+ (call-xml-rpc-server server-args "system.methodHelp"
+ name))
+ symbols)
+ (mapcar (lambda (name)
+ (or (documentation name 'function) ""))
+ symbols)))
+ (assert
+ (= 2
+ (length (call-xml-rpc-server
+ server-args "system.multicall"
+ (list
+ (xml-rpc-struct "methodName"
+ "system.listMethods")
+ (xml-rpc-struct "methodName"
+ "system.methodHelp"
+ "params"
+ (list "system.multicall"))))))))
+ (s-sysdeps:kill-process server-process)
+ (delete-package *xml-rpc-package*)))
+
+;;;; eof \ No newline at end of file
diff --git a/third-party/s-xml-rpc/test/test-xml-rpc.lisp b/third-party/s-xml-rpc/test/test-xml-rpc.lisp
new file mode 100644
index 0000000..3933a88
--- /dev/null
+++ b/third-party/s-xml-rpc/test/test-xml-rpc.lisp
@@ -0,0 +1,176 @@
+;;;; -*- mode: lisp -*-
+;;;;
+;;;; $Id: test-xml-rpc.lisp,v 1.4 2008-02-15 15:42:40 scaekenberghe Exp $
+;;;;
+;;;; Unit and functional tests for xml-rpc.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-rpc)
+
+(assert
+ (let ((now (get-universal-time)))
+ (equal (iso8601->universal-time (universal-time->iso8601 now))
+ now)))
+
+(assert
+ (equal (with-input-from-string (in (encode-xml-rpc-call "add" 1 2))
+ (decode-xml-rpc in))
+ '("add" 1 2)))
+
+(assert
+ (equal (with-input-from-string (in (encode-xml-rpc-result '(1 2)))
+ (car (decode-xml-rpc in)))
+ '(1 2)))
+
+(let ((condition (with-input-from-string (in (encode-xml-rpc-fault "Fatal Error" 100))
+ (decode-xml-rpc in))))
+ (assert (typep condition 'xml-rpc-fault))
+ (assert (equal (xml-rpc-fault-string condition) "Fatal Error"))
+ (assert (equal (xml-rpc-fault-code condition) 100)))
+
+(assert
+ (xml-rpc-time-p (xml-rpc-call (encode-xml-rpc-call "currentTime.getCurrentTime")
+ :host "time.xmlrpc.com")))
+
+(assert
+ (equal (xml-rpc-call (encode-xml-rpc-call "examples.getStateName" 41)
+ :host "betty.userland.com")
+ "South Dakota"))
+
+(assert
+ (equal (call-xml-rpc-server '(:host "betty.userland.com") "examples.getStateName" 41)
+ "South Dakota"))
+
+#-clisp
+(assert
+ (let ((server-process (start-xml-rpc-server :port 8080)))
+ (import 's-xml-rpc::xml-rpc-implementation-version :s-xml-rpc-exports)
+ (sleep 1) ; give the server some time to come up ;-)
+ (unwind-protect
+ (equal (xml-rpc-call (encode-xml-rpc-call "XML-RPC-IMPLEMENTATION-VERSION") :port 8080)
+ (xml-rpc-implementation-version))
+ (s-sysdeps:kill-process server-process)
+ (unintern 's-xml-rpc::xml-rpc-implementation-version :s-xml-rpc-exports))))
+
+(assert
+ (let* ((struct-in (xml-rpc-struct :foo 100 :bar ""))
+ (xml (with-output-to-string (out)
+ (encode-xml-rpc-value struct-in out)))
+ (struct-out (with-input-from-string (in xml)
+ (decode-xml-rpc in))))
+ (xml-rpc-struct-equal struct-in struct-out)))
+
+;; testing whitespace handling
+
+(assert (null (decode-xml-rpc (make-string-input-stream
+"<array>
+ <data>
+ </data>
+</array>"))))
+
+(assert (equalp (decode-xml-rpc (make-string-input-stream
+"<params>
+ <param>
+ <value>
+ foo
+ </value>
+ </param>
+ <param>
+ <value>
+ <array>
+ <data>
+ <value><i4>12</i4></value>
+ <value><string>Egypt</string></value>
+ <value><boolean>1</boolean></value>
+ <value> <string> </string> </value>
+ <value> </value>
+ <value> fgo </value>
+ <value><i4>-31</i4></value>
+ <value></value>
+ <double> -12.214 </double>
+ <dateTime.iso8601>
+ 19980717T14:08:55 </dateTime.iso8601>
+ <base64>eW91IGNhbid0IHJlYWQgdGhpcyE=</base64>
+ </data>
+ </array>
+ </value>
+ </param>
+</params>"))
+`("
+ foo
+ "
+ (12
+ "Egypt"
+ T
+ " "
+ " "
+ " fgo "
+ -31
+ ""
+ -12.214D0
+ ,(xml-rpc-time (iso8601->universal-time "19980717T14:08:55"))
+ #(121 111 117 32 99 97 110 39 116 32 114 101 97 100 32 116 104 105 115 33)))))
+
+(assert (equalp (decode-xml-rpc (make-string-input-stream
+"<array>
+ <data>
+ <value></value>
+ </data>
+</array>"))
+'("")))
+
+(assert (equalp (decode-xml-rpc (make-string-input-stream
+"<array>
+ <data>
+ <value>
+ <string>XYZ</string>
+ </value>
+ </data>
+</array>"))
+'("XYZ")))
+
+;; double decoding
+
+(assert (< (abs (- (decode-xml-rpc (make-string-input-stream "<value><double>3.141592653589793</double></value>"))
+ pi))
+ 0.000000000001D0))
+
+;; string decoding
+
+(assert (equal (decode-xml-rpc (make-string-input-stream "<value><string>foo</string></value>"))
+ "foo"))
+
+(assert (equal (decode-xml-rpc (make-string-input-stream "<value>foo</value>"))
+ "foo"))
+
+(assert (equal (decode-xml-rpc (make-string-input-stream "<value><string></string></value>"))
+ ""))
+
+(assert (equal (decode-xml-rpc (make-string-input-stream "<value></value>"))
+ ""))
+
+;; boolean encoding
+
+(assert (equal (with-output-to-string (out)
+ (encode-xml-rpc-value t out))
+ "<value><boolean>1</boolean></value>"))
+
+(assert (equal (with-output-to-string (out)
+ (encode-xml-rpc-value nil out))
+ "<value><boolean>0</boolean></value>"))
+
+
+;; boolean decoding
+
+(assert (equal (decode-xml-rpc (make-string-input-stream "<value><boolean>1</boolean></value>"))
+ t))
+
+(assert (equal (decode-xml-rpc (make-string-input-stream "<value><boolean>0</boolean></value>"))
+ nil))
+
+;;;; eof
diff --git a/third-party/s-xml-rpc/test/test.b64 b/third-party/s-xml-rpc/test/test.b64
new file mode 100644
index 0000000..55445dd
--- /dev/null
+++ b/third-party/s-xml-rpc/test/test.b64
@@ -0,0 +1 @@
+R0lGODlhNABYAMQAAP////vi5etreuM0SN8ZL+dOYPCIk+56hPi/xPGapPjP1N4EGvHr9PSstMzI6riw4IY+kHsie3lvyVtMu0Y4tN3b8Y+CzX1ast2ftskNNNBdfqGb2so0WeHL4E8spLA0aiH5BAAAAAAALAAAAAA0AFgAQAX/ICCOZGmeaKqeBUEc5WAATbECQnCfyiAWsFIBgfMJFoTOYcAQERYN0SK4KxEUp4FPC/ABXN/oKOCtmh0OxGPj+UAgHmKhIZiZHJLJhMKXNKsMFQAMFnp6EogWFxEWOAsCgw4VfyN5IhKNABMPZhAUe3yhoYiYFmsWiISYlCoMeaJ8ehR5hoektLCjEhCcJGgQqSkKC1BmxscBxEQkBAlOxSMDCzY/ZQAICyPEOwnbCgXgcyQCBeQFWCIHVDXhJN/hkMc0DR0iA80oPXbyI+Vd6CO+RdOxjAWVYz367bPXzciVHjKwGCAwg4AOfiUOEBgg4ICAe08WYCFgQ0aKBtaM/xWSEMuQKA+1WHrIhYpCJgB4KDzYA4BPFQejLAgdSvSB0QoOHgCT4GAEKqSfUuT8ZIHVCAYbWOaaQErSiqoYw4oVkWxBwRETt41RW2KBNWluq5QteCAbiQJxSRATQIDVRisLnJmQ5sLi2MNhP24cUIDxRcRjCAsG0HgHnbEaFRAwAURExxsJHh8jB2CJiQZBOALokHIEgXiqjQks3frcFyRdcKfzonGBaGMDxFzTIgDBMBd4GVN7sQSdAWpiuZQIsJHkCwNQqKOgCBmF2wZu5xj4XUL4MUJcMTlowmANhAgXhGoIIMA5NUKwQIWCcANNIkEMMPDBAWgUmAEGIgwDQ/97u2ByCQVNTdCIBRTssEEfVpUWjwgMpIHKTQCg0oQnguhhBgObPCBBLys4gIoEJVTA0gSCGIPUegBolV8tomwSVgUTiEBhehZsgMB6AZ4Q4JJLcjhIh1ntAeMITamw0ycSbDDJHx0aRdSLuPSIyQM1rnAEMcRc0R0/c7EADUppLgRAAoRtuE0ABvBF3lpmlTCMI9A5shkz1vB1G0AqtNkPEoWx9cwMGllRWEitmTCMSAlCw4ymAFxaz6KWOuqmnGuWaqqpHQTw6almbmSAAqoG8M0AB3XXA0mC/bWCbYjxNQ0JdHY6WQoJZDgaYymhJEICgaKQg1hXgDMYOuKooMD/hvJQx4BmlsYT7GyWGoZRcJRhm44z3HaaFzOD4mXeDglRVitlWMjgghYgJaCZuE8gWkW86ZJgxCOA0iBtp1royk8Zmi1UGAAT4WmSZwREYUClZhzQ7MX3MDqFri4kIK7BY12cxRW+4dNCuSaQNpYW74KHhALgbXawpQP4ixGzWoiD3UZ9HkAqCUKfysA9zx1AJznvrlkBmCuu10AGCFSgDg5Y0CFaIbLAAuIJF86CyAZGbWDKAxwcoEACFbzhgZEWwHEBV0H5oSNLX5eAipSkcDWBB3MjsocHeUhwwQdEoFgmABX4ZCJLrSylCwQfoFHB5RpwIAJ4BehIwQY49tTI/wMVArDTDu1JKRSL2GBBXdMkFNIE5JpMeQOKNYl9i+CFk9KLJIQ0gUpTURmTR+67J5/IA2iQQEhOthvjgH5crT7UUrZsMMIDNa04Vt9i75Ee+KNUiRF6sTDFIfU8toTIWUqm0PgmE5i/QpLyXGh/Ja/4AQHUsciFAGExEzGBhUOIMEF7JDfAUMykgFv5RB/CZ4sHGAsFeABFTJSXvCKFjlUgnA5cMBbCUPXpBBtCQB3yNCwa1OFqIkAADK5lgAOsygQdUMYJiPGWX5mgLo/BRmACooIcnpAZvjLPE2rVjVUxoGKiSoER4beysrQFU2TBohNgUBcSkmCK7piCAS62LlR12QUAC1hIC8aIHU6hAIzaGNYThtWNzbwGWGc04w0uVRAwhDGPufFhplqYnBUIMQB4WiKiREYMG2pjUJ0607A60MaJneBnJayCbjK5HR5y8pNiCQEAOw== \ No newline at end of file
diff --git a/third-party/s-xml/.clbuild-skip-update b/third-party/s-xml/.clbuild-skip-update
new file mode 100644
index 0000000..e69de29
--- /dev/null
+++ b/third-party/s-xml/.clbuild-skip-update
diff --git a/third-party/s-xml/ChangeLog b/third-party/s-xml/ChangeLog
new file mode 100644
index 0000000..7c9ab49
--- /dev/null
+++ b/third-party/s-xml/ChangeLog
@@ -0,0 +1,66 @@
+2006-01-19 Sven Van Caekenberghe <svc@mac.com>
+
+ * added a set of patches contributed by David Tolpin dvd@davidashen.net : we're now using char of type
+ Character and #\Null instead of null, read/unread instead of peek/read and some more declarations for
+ more efficiency - added hooks for customizing parsing attribute names and values
+
+2005-11-20 Sven Van Caekenberghe <svc@mac.com>
+
+ * added xml prefix namespace as per REC-xml-names-19990114 (by Rudi Schlatte)
+
+2005-11-06 Sven Van Caekenberghe <svc@mac.com>
+
+ * removed Debian packaging directory (on Luca's request)
+ * added CDATA support (patch contributed by Peter Van Eynde pvaneynd@mailworks.org)
+
+2005-08-30 Sven Van Caekenberghe <svc@mac.com>
+
+ * added Debian packaging directory (contributed by Luca Capello luca@pca.it)
+ * added experimental XML namespace support
+
+2005-02-03 Sven Van Caekenberghe <svc@mac.com>
+
+ * release 5 (cvs tag RELEASE_5)
+ * added :start and :end keywords to print-string-xml
+ * fixed a bug: in a tag containing whitespace, like <foo> </foo> the parser collapsed
+ and ingnored all whitespace and considered the tag to be empty!
+ this is now fixed and a unit test has been added
+ * cleaned up xml character escaping a bit: single quotes and all normal whitespace
+ (newline, return and tab) is preserved a unit test for this has been added
+ * IE doesn't understand the &apos; XML entity, so I've commented that out for now.
+ Also, using actual newlines for newlines is probably better than using #xA,
+ which won't get any end of line conversion by the server or user agent.
+
+June 2004 Sven Van Caekenberghe <svc@mac.com>
+
+ * release 4
+ * project moved to common-lisp.net, renamed to s-xml,
+ * added examples counter, tracer and remove-markup, improved documentation
+
+13 Jan 2004 Sven Van Caekenberghe <svc@mac.com>
+
+ * release 3
+ * added ASDF systems
+ * optimized print-string-xml
+
+10 Jun 2003 Sven Van Caekenberghe <svc@mac.com>
+
+ * release 2
+ * added echo-xml function: we are no longer taking the car when
+ the last seed is returned from start-parse-xml
+
+25 May 2003 Sven Van Caekenberghe <svc@mac.com>
+
+ * release 1
+ * first public release of working code
+ * tested on OpenMCL
+ * rewritten to be event-based, to improve efficiency and
+ to optionally use different DOM representations
+ * more documentation
+
+end of 2002 Sven Van Caekenberghe <svc@mac.com>
+
+ * release 0
+ * as part of an XML-RPC implementation
+
+$Id: ChangeLog,v 1.6 2006-01-19 20:00:05 scaekenberghe Exp $
diff --git a/third-party/s-xml/Makefile b/third-party/s-xml/Makefile
new file mode 100644
index 0000000..bd17b3c
--- /dev/null
+++ b/third-party/s-xml/Makefile
@@ -0,0 +1,35 @@
+# $Id: Makefile,v 1.3 2004-07-08 19:31:22 scaekenberghe Exp $
+
+default:
+ @echo Possible targets:
+ @echo clean-openmcl --- remove all '*.dfsl' recursively
+ @echo clean-lw --- remove all '*.nfasl' recursively
+ @echo clean-emacs --- remove all '*~' recursively
+ @echo clean --- all of the above
+
+clean-openmcl:
+ find . -name "*.dfsl" | xargs rm
+
+clean-lw:
+ find . -name "*.nfasl" | xargs rm
+
+clean-emacs:
+ find . -name "*~" | xargs rm
+
+clean: clean-openmcl clean-lw clean-emacs
+
+#
+# This can obviously only be done by a specific person in a very specific context ;-)
+#
+
+PRJ=s-xml
+ACCOUNT=scaekenberghe
+CVSRT=:ext:$(ACCOUNT)@common-lisp.net:/project/$(PRJ)/cvsroot
+
+release:
+ rm -rf /tmp/$(PRJ) /tmp/public_html /tmp/$(PRJ).tgz /tmp/$(PRJ).tgz.asc
+ cd /tmp; cvs -d$(CVSRT) export -r HEAD $(PRJ); cvs -d$(CVSRT) export -r HEAD public_html
+ mv /tmp/public_html /tmp/$(PRJ)/doc
+ cd /tmp; gnutar cvfz $(PRJ).tgz $(PRJ); gpg -a -b $(PRJ).tgz
+ scp /tmp/$(PRJ).tgz $(ACCOUNT)@common-lisp.net:/project/$(PRJ)/public_html
+ scp /tmp/$(PRJ).tgz.asc $(ACCOUNT)@common-lisp.net:/project/$(PRJ)/public_html
diff --git a/third-party/s-xml/examples/counter.lisp b/third-party/s-xml/examples/counter.lisp
new file mode 100644
index 0000000..0154166
--- /dev/null
+++ b/third-party/s-xml/examples/counter.lisp
@@ -0,0 +1,47 @@
+;;;; -*- mode: lisp -*-
+;;;;
+;;;; $Id: counter.lisp,v 1.1 2008-02-15 13:54:57 scaekenberghe Exp $
+;;;;
+;;;; A simple SSAX counter example that can be used as a performance test
+;;;;
+;;;; Copyright (C) 2004 Sven Van Caekenberghe, Beta Nine BVBA.
+;;;;
+;;;; You are granted the rights to distribute and use this software
+;;;; as governed by the terms of the Lisp Lesser General Public License
+;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
+
+(in-package :s-xml)
+
+(defclass count-xml-seed ()
+ ((elements :initform 0)
+ (attributes :initform 0)
+ (characters :initform 0)))
+
+(defun count-xml-new-element-hook (name attributes seed)
+ (declare (ignore name))
+ (incf (slot-value seed 'elements))
+ (incf (slot-value seed 'attributes) (length attributes))
+ seed)
+
+(defun count-xml-text-hook (string seed)
+ (incf (slot-value seed 'characters) (length string))
+ seed)
+
+(defun count-xml (in)
+ "Parse a toplevel XML element from stream in, counting elements, attributes and characters"
+ (start-parse-xml in
+ (make-instance 'xml-parser-state
+ :seed (make-instance 'count-xml-seed)
+ :new-element-hook #'count-xml-new-element-hook
+ :text-hook #'count-xml-text-hook)))
+
+(defun count-xml-file (pathname)
+ "Parse XMl from the file at pathname, counting elements, attributes and characters"
+ (with-open-file (in pathname)
+ (let ((result (count-xml in)))
+ (with-slots (elements attributes characters) result
+ (format t
+ "~a contains ~d XML elements, ~d attributes and ~d characters.~%"
+ pathname elements attributes characters)))))
+
+;;;; eof
diff --git a/third-party/s-xml/examples/echo.lisp b/third-party/s-xml/examples/echo.lisp
new file mode 100644
index 0000000..84e7ea1
--- /dev/null
+++ b/third-party/s-xml/examples/echo.lisp
@@ -0,0 +1,64 @@
+;;;; -*- mode: lisp -*-
+;;;;
+;;;; $Id: echo.lisp,v 1.1 2008-02-15 13:54:57 scaekenberghe Exp $
+;;;;
+;;;; A simple example as well as a useful tool: parse, echo and pretty print XML
+;;;;
+;;;; Copyright (C) 2002, 2004 Sven Van Caekenberghe, Beta Nine BVBA.
+;;;;
+;;;; You are granted the rights to distribute and use this software
+;;;; as governed by the terms of the Lisp Lesser General Public License
+;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
+
+(in-package :s-xml)
+
+(defun indent (stream count)
+ (loop :repeat (* count 2) :do (write-char #\space stream)))
+
+(defclass echo-xml-seed ()
+ ((stream :initarg :stream)
+ (level :initarg :level :initform 0)))
+
+#+NIL
+(defmethod print-object ((seed echo-xml-seed) stream)
+ (with-slots (stream level) seed
+ (print-unreadable-object (seed stream :type t)
+ (format stream "level=~d" level))))
+
+(defun echo-xml-new-element-hook (name attributes seed)
+ (with-slots (stream level) seed
+ (indent stream level)
+ (format stream "<~a" name)
+ (dolist (attribute (reverse attributes))
+ (format stream " ~a=\'" (car attribute))
+ (print-string-xml (cdr attribute) stream)
+ (write-char #\' stream))
+ (format stream ">~%")
+ (incf level)
+ seed))
+
+(defun echo-xml-finish-element-hook (name attributes parent-seed seed)
+ (declare (ignore attributes parent-seed))
+ (with-slots (stream level) seed
+ (decf level)
+ (indent stream level)
+ (format stream "</~a>~%" name)
+ seed))
+
+(defun echo-xml-text-hook (string seed)
+ (with-slots (stream level) seed
+ (indent stream level)
+ (print-string-xml string stream)
+ (terpri stream)
+ seed))
+
+(defun echo-xml (in out)
+ "Parse a toplevel XML element from stream in, echoing and pretty printing the result to stream out"
+ (start-parse-xml in
+ (make-instance 'xml-parser-state
+ :seed (make-instance 'echo-xml-seed :stream out)
+ :new-element-hook #'echo-xml-new-element-hook
+ :finish-element-hook #'echo-xml-finish-element-hook
+ :text-hook #'echo-xml-text-hook)))
+
+;;;; eof
diff --git a/third-party/s-xml/examples/remove-markup.lisp b/third-party/s-xml/examples/remove-markup.lisp
new file mode 100644
index 0000000..95c13b1
--- /dev/null
+++ b/third-party/s-xml/examples/remove-markup.lisp
@@ -0,0 +1,21 @@
+;;;; -*- mode: lisp -*-
+;;;;
+;;;; $Id: remove-markup.lisp,v 1.1 2008-02-15 13:54:57 scaekenberghe Exp $
+;;;;
+;;;; Remove markup from an XML document using the SSAX interface
+;;;;
+;;;; Copyright (C) 2004 Sven Van Caekenberghe, Beta Nine BVBA.
+;;;;
+;;;; You are granted the rights to distribute and use this software
+;;;; as governed by the terms of the Lisp Lesser General Public License
+;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
+
+(in-package :s-xml)
+
+(defun remove-xml-markup (in)
+ (let* ((state (make-instance 'xml-parser-state
+ :text-hook #'(lambda (string seed) (cons string seed))))
+ (result (start-parse-xml in state)))
+ (apply #'concatenate 'string (nreverse result))))
+
+;;;; eof \ No newline at end of file
diff --git a/third-party/s-xml/examples/tracer.lisp b/third-party/s-xml/examples/tracer.lisp
new file mode 100644
index 0000000..44782f5
--- /dev/null
+++ b/third-party/s-xml/examples/tracer.lisp
@@ -0,0 +1,57 @@
+;;;; -*- mode: lisp -*-
+;;;;
+;;;; $Id: tracer.lisp,v 1.1 2008-02-15 13:54:57 scaekenberghe Exp $
+;;;;
+;;;; A simple SSAX tracer example that can be used to understand how the hooks are called
+;;;;
+;;;; Copyright (C) 2004 Sven Van Caekenberghe, Beta Nine BVBA.
+;;;;
+;;;; You are granted the rights to distribute and use this software
+;;;; as governed by the terms of the Lisp Lesser General Public License
+;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
+
+(in-package :s-xml)
+
+(defun trace-xml-log (level msg &rest args)
+ (indent *standard-output* level)
+ (apply #'format *standard-output* msg args)
+ (terpri *standard-output*))
+
+(defun trace-xml-new-element-hook (name attributes seed)
+ (let ((new-seed (cons (1+ (car seed)) (1+ (cdr seed)))))
+ (trace-xml-log (car seed)
+ "(new-element :name ~s :attributes ~:[()~;~:*~s~] :seed ~s) => ~s"
+ name attributes seed new-seed)
+ new-seed))
+
+(defun trace-xml-finish-element-hook (name attributes parent-seed seed)
+ (let ((new-seed (cons (1- (car seed)) (1+ (cdr seed)))))
+ (trace-xml-log (car parent-seed)
+ "(finish-element :name ~s :attributes ~:[()~;~:*~s~] :parent-seed ~s :seed ~s) => ~s"
+ name attributes parent-seed seed new-seed)
+ new-seed))
+
+(defun trace-xml-text-hook (string seed)
+ (let ((new-seed (cons (car seed) (1+ (cdr seed)))))
+ (trace-xml-log (car seed)
+ "(text :string ~s :seed ~s) => ~s"
+ string seed new-seed)
+ new-seed))
+
+(defun trace-xml (in)
+ "Parse and trace a toplevel XML element from stream in"
+ (start-parse-xml in
+ (make-instance 'xml-parser-state
+ :seed (cons 0 0)
+ ;; seed car is xml element nesting level
+ ;; seed cdr is ever increasing from element to element
+ :new-element-hook #'trace-xml-new-element-hook
+ :finish-element-hook #'trace-xml-finish-element-hook
+ :text-hook #'trace-xml-text-hook)))
+
+(defun trace-xml-file (pathname)
+ "Parse and trace XMl from the file at pathname"
+ (with-open-file (in pathname)
+ (trace-xml in)))
+
+;;;; eof
diff --git a/third-party/s-xml/s-xml.asd b/third-party/s-xml/s-xml.asd
new file mode 100644
index 0000000..d7ceb86
--- /dev/null
+++ b/third-party/s-xml/s-xml.asd
@@ -0,0 +1,49 @@
+;;;; -*- Mode: LISP -*-
+;;;;
+;;;; $Id: s-xml.asd,v 1.3 2008-02-15 13:54:57 scaekenberghe Exp $
+;;;;
+;;;; The S-XML ASDF system definition
+;;;;
+;;;; Copyright (C) 2002, 2004 Sven Van Caekenberghe, Beta Nine BVBA.
+;;;;
+;;;; You are granted the rights to distribute and use this software
+;;;; as governed by the terms of the Lisp Lesser General Public License
+;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
+
+(in-package :asdf)
+
+(defsystem :s-xml
+ :name "S-XML"
+ :author "Sven Van Caekenberghe <svc@mac.com>"
+ :version "3"
+ :maintainer "Sven Van Caekenberghe <svc@mac.com>, Brian Mastenbrook <>, Rudi Schlatte <>"
+ :licence "Lisp Lesser General Public License (LLGPL)"
+ :description "Simple Common Lisp XML Parser"
+ :long-description "S-XML is a Common Lisp implementation of a simple XML parser, with a SAX-like and DOM interface"
+
+ :components
+ ((:module
+ :src
+ :components ((:file "package")
+ (:file "xml" :depends-on ("package"))
+ (:file "dom" :depends-on ("package" "xml"))
+ (:file "lxml-dom" :depends-on ("dom"))
+ (:file "sxml-dom" :depends-on ("dom"))
+ (:file "xml-struct-dom" :depends-on ("dom"))))))
+
+(defsystem :s-xml.test
+ :depends-on (:s-xml)
+ :components ((:module :test
+ :components ((:file "test-xml")
+ (:file "test-xml-struct-dom")
+ (:file "test-lxml-dom")
+ (:file "test-sxml-dom")))))
+
+(defsystem :s-xml.examples
+ :depends-on (:s-xml)
+ :components ((:module :examples
+ :components ((:file "counter")
+ (:file "echo")
+ (:file "remove-markup")
+ (:file "tracer")))))
+;;;; eof
diff --git a/third-party/s-xml/src/dom.lisp b/third-party/s-xml/src/dom.lisp
new file mode 100644
index 0000000..dcf6e82
--- /dev/null
+++ b/third-party/s-xml/src/dom.lisp
@@ -0,0 +1,75 @@
+;;;; -*- mode: lisp -*-
+;;;;
+;;;; $Id: dom.lisp,v 1.2 2005-08-29 15:01:47 scaekenberghe Exp $
+;;;;
+;;;; This is the generic simple DOM parser and printer interface.
+;;;;
+;;;; Copyright (C) 2002, 2004 Sven Van Caekenberghe, Beta Nine BVBA.
+;;;;
+;;;; You are granted the rights to distribute and use this software
+;;;; as governed by the terms of the Lisp Lesser General Public License
+;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
+
+(in-package :s-xml)
+
+;;; top level DOM parser interface
+
+(defgeneric parse-xml-dom (stream output-type)
+ (:documentation "Parse a character stream as XML and generate a DOM of output-type"))
+
+(defun parse-xml (stream &key (output-type :lxml))
+ "Parse a character stream as XML and generate a DOM of output-type, defaulting to :lxml"
+ (parse-xml-dom stream output-type))
+
+(defun parse-xml-string (string &key (output-type :lxml))
+ "Parse a string as XML and generate a DOM of output-type, defaulting to :lxml"
+ (with-input-from-string (stream string)
+ (parse-xml-dom stream output-type)))
+
+(defun parse-xml-file (filename &key (output-type :lxml))
+ "Parse a character file as XML and generate a DOM of output-type, defaulting to :lxml"
+ (with-open-file (in filename :direction :input)
+ (parse-xml-dom in output-type)))
+
+;;; top level DOM printer interface
+
+(defgeneric print-xml-dom (dom input-type stream pretty level)
+ (:documentation "Generate XML output on a character stream from a DOM of input-type, optionally pretty printing using level"))
+
+(defun print-xml (dom &key (stream t) (pretty nil) (input-type :lxml) (header))
+ "Generate XML output on a character stream (t by default) from a DOM of input-type (:lxml by default), optionally pretty printing (off by default), or adding a header (none by default)"
+ (when header (format stream header))
+ (when pretty (terpri stream))
+ (print-xml-dom dom input-type stream pretty 1))
+
+(defun print-xml-string (dom &key (pretty nil) (input-type :lxml))
+ "Generate XML output to a string from a DOM of input-type (:lxml by default), optionally pretty printing (off by default)"
+ (with-output-to-string (stream)
+ (print-xml dom :stream stream :pretty pretty :input-type input-type)))
+
+;;; shared/common support functions
+
+(defun print-spaces (n stream &optional (preceding-newline t))
+ (when preceding-newline
+ (terpri stream))
+ (loop :repeat n
+ :do (write-char #\Space stream)))
+
+(defun print-solitary-tag (tag stream)
+ (write-char #\< stream)
+ (print-identifier tag stream)
+ (write-string "/>" stream))
+
+(defun print-closing-tag (tag stream)
+ (write-string "</" stream)
+ (print-identifier tag stream)
+ (write-char #\> stream))
+
+(defun print-attribute (name value stream)
+ (write-char #\space stream)
+ (print-identifier name stream t)
+ (write-string "=\"" stream)
+ (print-string-xml value stream)
+ (write-char #\" stream))
+
+;;;; eof
diff --git a/third-party/s-xml/src/lxml-dom.lisp b/third-party/s-xml/src/lxml-dom.lisp
new file mode 100644
index 0000000..449fea3
--- /dev/null
+++ b/third-party/s-xml/src/lxml-dom.lisp
@@ -0,0 +1,83 @@
+;;;; -*- mode: lisp -*-
+;;;;
+;;;; $Id: lxml-dom.lisp,v 1.6 2005-11-20 14:34:15 scaekenberghe Exp $
+;;;;
+;;;; LXML implementation of the generic DOM parser and printer.
+;;;;
+;;;; Copyright (C) 2002, 2004 Sven Van Caekenberghe, Beta Nine BVBA.
+;;;;
+;;;; You are granted the rights to distribute and use this software
+;;;; as governed by the terms of the Lisp Lesser General Public License
+;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
+
+(in-package :s-xml)
+
+;;; the lxml hooks to generate lxml
+
+(defun lxml-new-element-hook (name attributes seed)
+ (declare (ignore name attributes seed))
+ '())
+
+(defun lxml-finish-element-hook (name attributes parent-seed seed)
+ (let ((xml-element
+ (cond ((and (null seed) (null attributes))
+ name)
+ (attributes
+ `((,name ,@(let (list)
+ (dolist (attribute attributes list)
+ (push (cdr attribute) list)
+ (push (car attribute) list))))
+ ,@(nreverse seed)))
+ (t
+ `(,name ,@(nreverse seed))))))
+ (cons xml-element parent-seed)))
+
+(defun lxml-text-hook (string seed)
+ (cons string seed))
+
+;;; standard DOM interfaces
+
+(defmethod parse-xml-dom (stream (output-type (eql :lxml)))
+ (car (start-parse-xml stream
+ (make-instance 'xml-parser-state
+ :new-element-hook #'lxml-new-element-hook
+ :finish-element-hook #'lxml-finish-element-hook
+ :text-hook #'lxml-text-hook))))
+
+(defun plist->alist (plist)
+ (when plist
+ (cons (cons (first plist) (second plist))
+ (plist->alist (rest (rest plist))))))
+
+(defmethod print-xml-dom (dom (input-type (eql :lxml)) stream pretty level)
+ (declare (special *namespaces*))
+ (cond ((symbolp dom) (print-solitary-tag dom stream))
+ ((stringp dom) (print-string-xml dom stream))
+ ((consp dom)
+ (let (tag attributes)
+ (cond ((symbolp (first dom)) (setf tag (first dom)))
+ ((consp (first dom)) (setf tag (first (first dom))
+ attributes (plist->alist (rest (first dom)))))
+ (t (error "Input not recognized as LXML ~s" dom)))
+ (let ((*namespaces* (extend-namespaces attributes *namespaces*)))
+ (write-char #\< stream)
+ (print-identifier tag stream)
+ (loop :for (name . value) :in attributes
+ :do (print-attribute name value stream))
+ (if (rest dom)
+ (let ((children (rest dom)))
+ (write-char #\> stream)
+ (if (and (= (length children) 1) (stringp (first children)))
+ (print-string-xml (first children) stream)
+ (progn
+ (dolist (child children)
+ (when pretty (print-spaces (* 2 level) stream))
+ (if (stringp child)
+ (print-string-xml child stream)
+ (print-xml-dom child input-type stream pretty (1+ level))))
+ (when pretty (print-spaces (* 2 (1- level)) stream))))
+ (print-closing-tag tag stream))
+ (write-string "/>" stream)))))
+ (t (error "Input not recognized as LXML ~s" dom))))
+
+;;;; eof \ No newline at end of file
diff --git a/third-party/s-xml/src/package.lisp b/third-party/s-xml/src/package.lisp
new file mode 100644
index 0000000..1fc0cca
--- /dev/null
+++ b/third-party/s-xml/src/package.lisp
@@ -0,0 +1,46 @@
+;;;; -*- mode: lisp -*-
+;;;;
+;;;; $Id: package.lisp,v 1.8 2006-01-31 11:44:15 scaekenberghe Exp $
+;;;;
+;;;; This is a Common Lisp implementation of a very basic XML parser.
+;;;; The parser is non-validating.
+;;;; The API into the parser is pure functional parser hook model that comes from SSAX,
+;;;; see also http://pobox.com/~oleg/ftp/Scheme/xml.html or http://ssax.sourceforge.net
+;;;; Different DOM models are provided, an XSML, an LXML and a xml-element struct based one.
+;;;;
+;;;; Copyright (C) 2002, 2003, 2004, 2005, 2006 Sven Van Caekenberghe, Beta Nine BVBA.
+;;;;
+;;;; You are granted the rights to distribute and use this software
+;;;; as governed by the terms of the Lisp Lesser General Public License
+;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
+
+(defpackage s-xml
+ (:use common-lisp)
+ (:export
+ ;; main parser interface
+ #:start-parse-xml
+ #:print-string-xml
+ #:xml-parser-error #:xml-parser-error-message #:xml-parser-error-args #:xml-parser-error-stream
+ #:xml-parser-state #:get-entities #:get-seed
+ #:get-new-element-hook #:get-finish-element-hook #:get-text-hook
+ ;; callbacks
+ #:*attribute-name-parser*
+ #:*attribute-value-parser*
+ #:parse-attribute-name
+ #:parse-attribute-value
+ ;; dom parser and printer
+ #:parse-xml-dom #:parse-xml #:parse-xml-string #:parse-xml-file
+ #:print-xml-dom #:print-xml #:print-xml-string
+ ;; xml-element structure
+ #:make-xml-element #:xml-element-children #:xml-element-name
+ #:xml-element-attribute #:xml-element-attributes
+ #:xml-element-p #:new-xml-element #:first-xml-element-child
+ ;; namespaces
+ #:*ignore-namespaces* #:*local-namespace* #:*namespaces*
+ #:*require-existing-symbols* #:*auto-export-symbols* #:*auto-create-namespace-packages*
+ #:find-namespace #:register-namespace #:get-prefix #:get-uri #:get-package
+ #:resolve-identifier #:extend-namespaces #:print-identifier #:split-identifier)
+ (:documentation
+ "A simple XML parser with an efficient, purely functional, event-based interface as well as a DOM interface"))
+
+;;;; eof
diff --git a/third-party/s-xml/src/sxml-dom.lisp b/third-party/s-xml/src/sxml-dom.lisp
new file mode 100644
index 0000000..dee3de8
--- /dev/null
+++ b/third-party/s-xml/src/sxml-dom.lisp
@@ -0,0 +1,76 @@
+;;;; -*- mode: lisp -*-
+;;;;
+;;;; $Id: sxml-dom.lisp,v 1.5 2005-11-20 14:34:15 scaekenberghe Exp $
+;;;;
+;;;; LXML implementation of the generic DOM parser and printer.
+;;;;
+;;;; Copyright (C) 2003, 2004 Sven Van Caekenberghe, Beta Nine BVBA.
+;;;;
+;;;; You are granted the rights to distribute and use this software
+;;;; as governed by the terms of the Lisp Lesser General Public License
+;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
+
+(in-package :s-xml)
+
+;;; the sxml hooks to generate sxml
+
+(defun sxml-new-element-hook (name attributes seed)
+ (declare (ignore name attributes seed))
+ '())
+
+(defun sxml-finish-element-hook (name attributes parent-seed seed)
+ (let ((xml-element (append (list name)
+ (when attributes
+ (list (let (list)
+ (dolist (attribute attributes (cons :@ list))
+ (push (list (car attribute) (cdr attribute)) list)))))
+ (nreverse seed))))
+ (cons xml-element parent-seed)))
+
+(defun sxml-text-hook (string seed)
+ (cons string seed))
+
+;;; the standard DOM interfaces
+
+(defmethod parse-xml-dom (stream (output-type (eql :sxml)))
+ (car (start-parse-xml stream
+ (make-instance 'xml-parser-state
+ :new-element-hook #'sxml-new-element-hook
+ :finish-element-hook #'sxml-finish-element-hook
+ :text-hook #'sxml-text-hook))))
+
+(defmethod print-xml-dom (dom (input-type (eql :sxml)) stream pretty level)
+ (declare (special *namespaces*))
+ (cond ((stringp dom) (print-string-xml dom stream))
+ ((consp dom)
+ (let ((tag (first dom))
+ attributes
+ children)
+ (if (and (consp (second dom)) (eq (first (second dom)) :@))
+ (setf attributes (rest (second dom))
+ children (rest (rest dom)))
+ (setf children (rest dom)))
+ (let ((*namespaces* (extend-namespaces (loop :for (name value) :in attributes
+ :collect (cons name value))
+ *namespaces*)))
+ (write-char #\< stream)
+ (print-identifier tag stream)
+ (loop :for (name value) :in attributes
+ :do (print-attribute name value stream))
+ (if children
+ (progn
+ (write-char #\> stream)
+ (if (and (= (length children) 1) (stringp (first children)))
+ (print-string-xml (first children) stream)
+ (progn
+ (dolist (child children)
+ (when pretty (print-spaces (* 2 level) stream))
+ (if (stringp child)
+ (print-string-xml child stream)
+ (print-xml-dom child input-type stream pretty (1+ level))))
+ (when pretty (print-spaces (* 2 (1- level)) stream))))
+ (print-closing-tag tag stream))
+ (write-string "/>" stream)))))
+ (t (error "Input not recognized as SXML ~s" dom))))
+
+;;;; eof
diff --git a/third-party/s-xml/src/xml-struct-dom.lisp b/third-party/s-xml/src/xml-struct-dom.lisp
new file mode 100644
index 0000000..916f747
--- /dev/null
+++ b/third-party/s-xml/src/xml-struct-dom.lisp
@@ -0,0 +1,125 @@
+;;;; -*- mode: lisp -*-
+;;;;
+;;;; $Id: xml-struct-dom.lisp,v 1.3 2005-09-20 09:57:48 scaekenberghe Exp $
+;;;;
+;;;; XML-STRUCT implementation of the generic DOM parser and printer.
+;;;;
+;;;; Copyright (C) 2002, 2004 Sven Van Caekenberghe, Beta Nine BVBA.
+;;;;
+;;;; You are granted the rights to distribute and use this software
+;;;; as governed by the terms of the Lisp Lesser General Public License
+;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
+
+(in-package :s-xml)
+
+;;; xml-element struct datastructure and API
+
+(defstruct xml-element
+ name ; :tag-name
+ attributes ; a assoc list of (:attribute-name . "attribute-value")
+ children ; a list of children/content either text strings or xml-elements
+ )
+
+(setf (documentation 'xml-element-p 'function)
+ "Return T when the argument is an xml-element struct"
+ (documentation 'xml-element-attributes 'function)
+ "Return the alist of attribute names and values dotted pairs from an xml-element struct"
+ (documentation 'xml-element-children 'function)
+ "Return the list of children from an xml-element struct"
+ (documentation 'xml-element-name 'function)
+ "Return the name from an xml-element struct"
+ (documentation 'make-xml-element 'function)
+ "Make and return a new xml-element struct")
+
+(defun xml-element-attribute (xml-element key)
+ "Return the string value of the attribute with name the keyword :key
+ of xml-element if any, return null if not found"
+ (let ((pair (assoc key (xml-element-attributes xml-element) :test #'eq)))
+ (when pair (cdr pair))))
+
+(defun (setf xml-element-attribute) (value xml-element key)
+ "Set the string value of the attribute with name the keyword :key of
+ xml-element, creating a new attribute if necessary or overwriting an
+ existing one, returning the value"
+ (let ((attributes (xml-element-attributes xml-element)))
+ (if (null attributes)
+ (push (cons key value) (xml-element-attributes xml-element))
+ (let ((pair (assoc key attributes :test #'eq)))
+ (if pair
+ (setf (cdr pair) value)
+ (push (cons key value) (xml-element-attributes xml-element)))))
+ value))
+
+(defun new-xml-element (name &rest children)
+ "Make a new xml-element with name and children"
+ (make-xml-element :name name :children children))
+
+(defun first-xml-element-child (xml-element)
+ "Get the first child of an xml-element"
+ (first (xml-element-children xml-element)))
+
+(defun xml-equal (xml-1 xml-2)
+ (and (xml-element-p xml-1)
+ (xml-element-p xml-2)
+ (eq (xml-element-name xml-1)
+ (xml-element-name xml-2))
+ (equal (xml-element-attributes xml-1)
+ (xml-element-attributes xml-2))
+ (reduce #'(lambda (&optional (x t) (y t)) (and x y))
+ (mapcar #'(lambda (x y)
+ (or (and (stringp x) (stringp y) (string= x y))
+ (xml-equal x y)))
+ (xml-element-children xml-1)
+ (xml-element-children xml-2)))))
+
+;;; printing xml structures
+
+(defmethod print-xml-dom (xml-element (input-type (eql :xml-struct)) stream pretty level)
+ (declare (special *namespaces*))
+ (let ((*namespaces* (extend-namespaces (xml-element-attributes xml-element)
+ *namespaces*)))
+ (write-char #\< stream)
+ (print-identifier (xml-element-name xml-element) stream)
+ (loop :for (name . value) :in (xml-element-attributes xml-element)
+ :do (print-attribute name value stream))
+ (let ((children (xml-element-children xml-element)))
+ (if children
+ (progn
+ (write-char #\> stream)
+ (if (and (= (length children) 1) (stringp (first children)))
+ (print-string-xml (first children) stream)
+ (progn
+ (dolist (child children)
+ (when pretty (print-spaces (* 2 level) stream))
+ (if (stringp child)
+ (print-string-xml child stream)
+ (print-xml-dom child input-type stream pretty (1+ level))))
+ (when pretty (print-spaces (* 2 (1- level)) stream))))
+ (print-closing-tag (xml-element-name xml-element) stream))
+ (write-string "/>" stream)))))
+
+;;; the standard hooks to generate xml-element structs
+
+(defun standard-new-element-hook (name attributes seed)
+ (declare (ignore name attributes seed))
+ '())
+
+(defun standard-finish-element-hook (name attributes parent-seed seed)
+ (let ((xml-element (make-xml-element :name name
+ :attributes attributes
+ :children (nreverse seed))))
+ (cons xml-element parent-seed)))
+
+(defun standard-text-hook (string seed)
+ (cons string seed))
+
+;;; top level standard parser interfaces
+
+(defmethod parse-xml-dom (stream (output-type (eql :xml-struct)))
+ (car (start-parse-xml stream
+ (make-instance 'xml-parser-state
+ :new-element-hook #'standard-new-element-hook
+ :finish-element-hook #'standard-finish-element-hook
+ :text-hook #'standard-text-hook))))
+
+;;;; eof
diff --git a/third-party/s-xml/src/xml.lisp b/third-party/s-xml/src/xml.lisp
new file mode 100644
index 0000000..8df61c6
--- /dev/null
+++ b/third-party/s-xml/src/xml.lisp
@@ -0,0 +1,700 @@
+;;;; -*- mode: lisp -*-
+;;;;
+;;;; $Id: xml.lisp,v 1.16 2006-01-31 11:44:15 scaekenberghe Exp $
+;;;;
+;;;; This is a Common Lisp implementation of a basic but usable XML parser.
+;;;; The parser is non-validating and not complete (no PI).
+;;;; Namespace and entities are handled.
+;;;; The API into the parser is a pure functional parser hook model that comes from SSAX,
+;;;; see also http://pobox.com/~oleg/ftp/Scheme/xml.html or http://ssax.sourceforge.net
+;;;; Different DOM models are provided, an XSML, an LXML and a xml-element struct based one.
+;;;;
+;;;; Copyright (C) 2002, 2003, 2004, 2005, 2006 Sven Van Caekenberghe, Beta Nine BVBA.
+;;;;
+;;;; You are granted the rights to distribute and use this software
+;;;; as governed by the terms of the Lisp Lesser General Public License
+;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
+
+(in-package :s-xml)
+
+;;; error reporting
+
+(define-condition xml-parser-error (error)
+ ((message :initarg :message :reader xml-parser-error-message)
+ (args :initarg :args :reader xml-parser-error-args)
+ (stream :initarg :stream :reader xml-parser-error-stream :initform nil))
+ (:report (lambda (condition stream)
+ (format stream
+ "XML parser ~?~@[ near stream position ~d~]."
+ (xml-parser-error-message condition)
+ (xml-parser-error-args condition)
+ (and (xml-parser-error-stream condition)
+ (file-position (xml-parser-error-stream condition))))))
+ (:documentation "Thrown by the XML parser to indicate errorneous input"))
+
+(setf (documentation 'xml-parser-error-message 'function)
+ "Get the message from an XML parser error"
+ (documentation 'xml-parser-error-args 'function)
+ "Get the error arguments from an XML parser error"
+ (documentation 'xml-parser-error-stream 'function)
+ "Get the stream from an XML parser error")
+
+(defun parser-error (message &optional args stream)
+ (make-condition 'xml-parser-error
+ :message message
+ :args args
+ :stream stream))
+
+;; attribute parsing hooks
+;; this is a bit complicated, refer to the mailing lists for a more detailed explanation
+
+(defun parse-attribute-name (string)
+ "Default parser for the attribute name"
+ (declare (special *namespaces*))
+ (resolve-identifier string *namespaces* t))
+
+(defun parse-attribute-value (name string)
+ "Default parser for the attribute value"
+ (declare (ignore name)
+ (special *ignore-namespace*))
+ (if *ignore-namespaces*
+ (copy-seq string)
+ string))
+
+(defparameter *attribute-name-parser* #'parse-attribute-name
+ "Called to compute interned attribute name from a buffer that will be reused")
+
+(defparameter *attribute-value-parser* #'parse-attribute-value
+ "Called to compute an element of an attribute list from a buffer that will be reused")
+
+;;; utilities
+
+(defun whitespace-char-p (char)
+ "Is char an XML whitespace character ?"
+ (declare (type character char))
+ (or (char= char #\space)
+ (char= char #\tab)
+ (char= char #\return)
+ (char= char #\linefeed)))
+
+(defun identifier-char-p (char)
+ "Is char an XML identifier character ?"
+ (declare (type character char))
+ (or (and (char<= #\A char) (char<= char #\Z))
+ (and (char<= #\a char) (char<= char #\z))
+ (and (char<= #\0 char) (char<= char #\9))
+ (char= char #\-)
+ (char= char #\_)
+ (char= char #\.)
+ (char= char #\:)))
+
+(defun skip-whitespace (stream)
+ "Skip over XML whitespace in stream, return first non-whitespace
+ character which was peeked but not read, return nil on eof"
+ (loop
+ (let ((char (peek-char nil stream nil #\Null)))
+ (declare (type character char))
+ (if (whitespace-char-p char)
+ (read-char stream)
+ (return char)))))
+
+(defun make-extendable-string (&optional (size 10))
+ "Make an extendable string which is a one-dimensional character
+ array which is adjustable and has a fill pointer"
+ (make-array size
+ :element-type 'character
+ :adjustable t
+ :fill-pointer 0))
+
+(defun print-string-xml (string stream &key (start 0) end)
+ "Write the characters of string to stream using basic XML conventions"
+ (loop for offset upfrom start below (or end (length string))
+ for char = (char string offset)
+ do (case char
+ (#\& (write-string "&amp;" stream))
+ (#\< (write-string "&lt;" stream))
+ (#\> (write-string "&gt;" stream))
+ (#\" (write-string "&quot;" stream))
+ ((#\newline #\return #\tab) (write-char char stream))
+ (t (if (and (<= 32 (char-code char))
+ (<= (char-code char) 126))
+ (write-char char stream)
+ (progn
+ (write-string "&#x" stream)
+ (write (char-code char) :stream stream :base 16)
+ (write-char #\; stream)))))))
+
+(defun make-standard-entities ()
+ "A hashtable mapping XML entity names to their replacement strings,
+ filled with the standard set"
+ (let ((entities (make-hash-table :test #'equal)))
+ (setf (gethash "amp" entities) (string #\&)
+ (gethash "quot" entities) (string #\")
+ (gethash "apos" entities) (string #\')
+ (gethash "lt" entities) (string #\<)
+ (gethash "gt" entities) (string #\>)
+ (gethash "nbsp" entities) (string #\space))
+ entities))
+
+(defun resolve-entity (stream extendable-string entities entity)
+ "Read and resolve an XML entity from stream, positioned after the '&' entity marker,
+ accepting &name; &#DEC; and &#xHEX; formats,
+ destructively modifying string, which is also returned,
+ destructively modifying entity, incorrect entity formats result in errors"
+ (declare (type (vector character) entity))
+ (loop
+ (let ((char (read-char stream nil #\Null)))
+ (declare (type character char))
+ (cond ((char= char #\Null) (error (parser-error "encountered eof before end of entity")))
+ ((char= #\; char) (return))
+ (t (vector-push-extend char entity)))))
+ (if (char= (char entity 0) #\#)
+ (let ((code (if (char= (char entity 1) #\x)
+ (parse-integer entity :start 2 :radix 16 :junk-allowed t)
+ (parse-integer entity :start 1 :radix 10 :junk-allowed t))))
+ (when (null code)
+ (error (parser-error "encountered incorrect entity &~s;" (list entity) stream)))
+ (vector-push-extend (code-char code) extendable-string))
+ (let ((value (gethash entity entities)))
+ (if value
+ (loop :for char :across value
+ :do (vector-push-extend char extendable-string))
+ (error (parser-error "encountered unknown entity &~s;" (list entity) stream)))))
+ extendable-string)
+
+;;; namespace support
+
+(defvar *ignore-namespaces* nil
+ "When t, namespaces are ignored like in the old version of S-XML")
+
+(defclass xml-namespace ()
+ ((uri :documentation "The URI used to identify this namespace"
+ :accessor get-uri
+ :initarg :uri)
+ (prefix :documentation "The preferred prefix assigned to this namespace"
+ :accessor get-prefix
+ :initarg :prefix
+ :initform nil)
+ (package :documentation "The Common Lisp package where this namespace's symbols are interned"
+ :accessor get-package
+ :initarg :package
+ :initform nil))
+ (:documentation "Describes an XML namespace and how it is handled"))
+
+(setf (documentation 'get-uri 'function)
+ "The URI used to identify this namespace"
+ (documentation 'get-prefix 'function)
+ "The preferred prefix assigned to this namespace"
+ (documentation 'get-package 'function)
+ "The Common Lisp package where this namespace's symbols are interned")
+
+(defmethod print-object ((object xml-namespace) stream)
+ (print-unreadable-object (object stream :type t :identity t)
+ (format stream "~A - ~A" (get-prefix object) (get-uri object))))
+
+(defvar *local-namespace* (make-instance 'xml-namespace
+ :uri "local"
+ :prefix ""
+ :package (find-package :keyword))
+ "The local (global default) XML namespace")
+
+(defvar *xml-namespace* (make-instance 'xml-namespace
+ :uri "http://www.w3.org/XML/1998/namespace"
+ :prefix "xml"
+ :package (or (find-package :xml)
+ (make-package :xml :nicknames '("XML"))))
+ "REC-xml-names-19990114 says the prefix xml is bound to the namespace http://www.w3.org/XML/1998/namespace.")
+
+(defvar *known-namespaces* (list *local-namespace* *xml-namespace*)
+ "The list of known/defined namespaces")
+
+(defvar *namespaces* `(("xml" . ,*xml-namespace*) ("" . ,*local-namespace*))
+ "Ordered list of (prefix . XML-namespace) bindings currently in effect - special variable")
+
+(defun find-namespace (uri)
+ "Find a registered XML namespace identified by uri"
+ (find uri *known-namespaces* :key #'get-uri :test #'string-equal))
+
+(defun register-namespace (uri prefix package)
+ "Register a new or redefine an existing XML namespace defined by uri with prefix and package"
+ (let ((namespace (find-namespace uri)))
+ (if namespace
+ (setf (get-prefix namespace) prefix
+ (get-package namespace) (find-package package))
+ (push (setf namespace (make-instance 'xml-namespace
+ :uri uri
+ :prefix prefix
+ :package (find-package package)))
+ *known-namespaces*))
+ namespace))
+
+(defun find-namespace-binding (prefix namespaces)
+ "Find the XML namespace currently bound to prefix in the namespaces bindings"
+ (cdr (assoc prefix namespaces :test #'string-equal)))
+
+(defun split-identifier (identifier)
+ "Split an identifier 'prefix:name' and return (values prefix name)"
+ (when (symbolp identifier)
+ (setf identifier (symbol-name identifier)))
+ (let ((colon-position (position #\: identifier :test #'char=)))
+ (if colon-position
+ (values (subseq identifier 0 colon-position)
+ (subseq identifier (1+ colon-position)))
+ (values nil identifier))))
+
+(defvar *require-existing-symbols* nil
+ "If t, each XML identifier must exist as symbol already")
+
+(defvar *auto-export-symbols* t
+ "If t, export newly interned symbols form their packages")
+
+(defun resolve-identifier (identifier namespaces &optional as-attribute)
+ "Resolve the string identifier in the list of namespace bindings"
+ (if *ignore-namespaces*
+ (intern identifier :keyword)
+ (flet ((intern-symbol (string package) ; intern string as a symbol in package
+ (if *require-existing-symbols*
+ (let ((symbol (find-symbol string package)))
+ (or symbol
+ (error "Symbol ~s does not exist in ~s" string package)))
+ (let ((symbol (intern string package)))
+ (when (and *auto-export-symbols*
+ (not (eql package (find-package :keyword))))
+ (export symbol package))
+ symbol))))
+ (multiple-value-bind (prefix name)
+ (split-identifier identifier)
+ (if (or (null prefix) (string= prefix "xmlns"))
+ (if as-attribute
+ (intern (if (string= prefix "xmlns") identifier name) (get-package *local-namespace*))
+ (let ((default-namespace (find-namespace-binding "" namespaces)))
+ (intern-symbol name (get-package default-namespace))))
+ (let ((namespace (find-namespace-binding prefix namespaces)))
+ (if namespace
+ (intern-symbol name (get-package namespace))
+ (error "namespace not found for prefix ~s" prefix))))))))
+
+(defvar *auto-create-namespace-packages* t
+ "If t, new packages will be created for namespaces, if needed, named by the prefix")
+
+(defun new-namespace (uri &optional prefix)
+ "Register a new namespace for uri and prefix, creating a package if necessary"
+ (if prefix
+ (register-namespace uri
+ prefix
+ (or (find-package prefix)
+ (if *auto-create-namespace-packages*
+ (make-package prefix :nicknames `(,(string-upcase prefix)))
+ (error "Cannot find or create package ~s" prefix))))
+ (let ((unique-name (loop :for i :upfrom 0
+ :do (let ((name (format nil "ns-~d" i)))
+ (when (not (find-package name))
+ (return name))))))
+ (register-namespace uri
+ unique-name
+ (if *auto-create-namespace-packages*
+ (make-package (string-upcase unique-name) :nicknames `(,unique-name))
+ (error "Cannot create package ~s" unique-name))))))
+
+(defun extend-namespaces (attributes namespaces)
+ "Given possible 'xmlns[:prefix]' attributes, extend the namespaces bindings"
+ (unless *ignore-namespaces*
+ (let (default-namespace-uri)
+ (loop :for (key . value) :in attributes
+ :do (if (string= key "xmlns")
+ (setf default-namespace-uri value)
+ (multiple-value-bind (prefix name)
+ (split-identifier key)
+ (when (string= prefix "xmlns")
+ (let* ((uri value)
+ (prefix name)
+ (namespace (find-namespace uri)))
+ (unless namespace
+ (setf namespace (new-namespace uri prefix)))
+ (push `(,prefix . ,namespace) namespaces))))))
+ (when default-namespace-uri
+ (let ((namespace (find-namespace default-namespace-uri)))
+ (unless namespace
+ (setf namespace (new-namespace default-namespace-uri)))
+ (push `("" . ,namespace) namespaces)))))
+ namespaces)
+
+(defun print-identifier (identifier stream &optional as-attribute)
+ "Print identifier on stream using namespace conventions"
+ (declare (ignore as-attribute) (special *namespaces*))
+ (if *ignore-namespaces*
+ (princ identifier stream)
+ (if (symbolp identifier)
+ (let ((package (symbol-package identifier))
+ (name (symbol-name identifier)))
+ (let* ((namespace (find package *known-namespaces* :key #'get-package))
+ (prefix (or (car (find namespace *namespaces* :key #'cdr))
+ (get-prefix namespace))))
+ (if (string= prefix "")
+ (princ name stream)
+ (format stream "~a:~a" prefix name))))
+ (princ identifier stream))))
+
+;;; the parser state
+
+(defclass xml-parser-state ()
+ ((entities :documentation "A hashtable mapping XML entity names to their replacement stings"
+ :accessor get-entities
+ :initarg :entities
+ :initform (make-standard-entities))
+ (seed :documentation "The user seed object"
+ :accessor get-seed
+ :initarg :seed
+ :initform nil)
+ (buffer :documentation "The main reusable character buffer"
+ :accessor get-buffer
+ :initform (make-extendable-string))
+ (mini-buffer :documentation "The secondary, smaller reusable character buffer"
+ :accessor get-mini-buffer
+ :initform (make-extendable-string))
+ (new-element-hook :documentation "Called when new element starts"
+ ;; Handle the start of a new xml element with name and attributes,
+ ;; receiving seed from previous element (sibling or parent)
+ ;; return seed to be used for first child (content)
+ ;; or directly to finish-element-hook
+ :accessor get-new-element-hook
+ :initarg :new-element-hook
+ :initform #'(lambda (name attributes seed)
+ (declare (ignore name attributes))
+ seed))
+ (finish-element-hook :documentation "Called when element ends"
+ ;; Handle the end of an xml element with name and attributes,
+ ;; receiving parent-seed, the seed passed to us when this element started,
+ ;; i.e. passed to our corresponding new-element-hook
+ ;; and receiving seed from last child (content)
+ ;; or directly from new-element-hook
+ ;; return final seed for this element to next element (sibling or parent)
+ :accessor get-finish-element-hook
+ :initarg :finish-element-hook
+ :initform #'(lambda (name attributes parent-seed seed)
+ (declare (ignore name attributes parent-seed))
+ seed))
+ (text-hook :documentation "Called when text is found"
+ ;; Handle text in string, found as contents,
+ ;; receiving seed from previous element (sibling or parent),
+ ;; return final seed for this element to next element (sibling or parent)
+ :accessor get-text-hook
+ :initarg :text-hook
+ :initform #'(lambda (string seed)
+ (declare (ignore string))
+ seed)))
+ (:documentation "The XML parser state passed along all code making up the parser"))
+
+(setf (documentation 'get-seed 'function)
+ "Get the initial user seed of an XML parser state"
+ (documentation 'get-entities 'function)
+ "Get the entities hashtable of an XML parser state"
+ (documentation 'get-new-element-hook 'function)
+ "Get the new element hook of an XML parser state"
+ (documentation 'get-finish-element-hook 'function)
+ "Get the finish element hook of an XML parser state"
+ (documentation 'get-text-hook 'function)
+ "Get the text hook of an XML parser state")
+
+#-allegro
+(setf (documentation '(setf get-seed) 'function)
+ "Set the initial user seed of an XML parser state"
+ (documentation '(setf get-entities) 'function)
+ "Set the entities hashtable of an XML parser state"
+ (documentation '(setf get-new-element-hook) 'function)
+ "Set the new element hook of an XML parser state"
+ (documentation '(setf get-finish-element-hook) 'function)
+ "Set the finish element hook of an XML parser state"
+ (documentation '(setf get-text-hook) 'function)
+ "Set the text hook of an XML parser state")
+
+(defmethod get-mini-buffer :after ((state xml-parser-state))
+ "Reset and return the reusable mini buffer"
+ (with-slots (mini-buffer) state
+ (setf (fill-pointer mini-buffer) 0)))
+
+(defmethod get-buffer :after ((state xml-parser-state))
+ "Reset and return the main reusable buffer"
+ (with-slots (buffer) state
+ (setf (fill-pointer buffer) 0)))
+
+;;; parser support
+
+(defun parse-whitespace (stream extendable-string)
+ "Read and collect XML whitespace from stream in string which is
+ destructively modified, return first non-whitespace character which
+ was peeked but not read, return #\Null on eof"
+ (declare (type (vector character) extendable-string))
+ (loop
+ (let ((char (peek-char nil stream nil #\Null)))
+ (declare (type character char))
+ (if (whitespace-char-p char)
+ (vector-push-extend (read-char stream) extendable-string)
+ (return char)))))
+
+(defun parse-string (stream state string)
+ "Read and return an XML string from stream, delimited by either
+ single or double quotes, the stream is expected to be on the opening
+ delimiter, at the end the closing delimiter is also read, entities
+ are resolved, eof before end of string is an error"
+ (declare (type (vector character) string))
+ (let ((delimiter (read-char stream nil #\Null))
+ (char #\Null))
+ (declare (type character delimiter char))
+ (unless (or (char= delimiter #\') (char= delimiter #\"))
+ (error (parser-error "expected string delimiter" nil stream)))
+ (loop
+ (setf char (read-char stream nil #\Null))
+ (cond ((char= char #\Null) (error (parser-error "encountered eof before end of string")))
+ ((char= char delimiter) (return))
+ ((char= char #\&) (resolve-entity stream string (get-entities state) (get-mini-buffer state)))
+ (t (vector-push-extend char string))))
+ string))
+
+(defun parse-text (stream state extendable-string)
+ "Read and collect XML text from stream in string which is
+ destructively modified, the text ends with a '<', which is peeked and
+ returned, entities are resolved, eof is considered an error"
+ (declare (type (vector character) extendable-string))
+ (let ((char #\Null))
+ (declare (type character char))
+ (loop
+ (setf char (peek-char nil stream nil #\Null))
+ (when (char= char #\Null) (error (parser-error "encountered unexpected eof in text")))
+ (when (char= char #\<) (return))
+ (read-char stream)
+ (if (char= char #\&)
+ (resolve-entity stream extendable-string (get-entities state) (get-mini-buffer state))
+ (vector-push-extend char extendable-string)))
+ char))
+
+(defun parse-identifier (stream identifier)
+ "Read and returns an XML identifier from stream, positioned at the
+ start of the identifier, ending with the first non-identifier
+ character, which is peeked, the identifier is written destructively
+ into identifier which is also returned"
+ (declare (type (vector character) identifier))
+ (loop
+ (let ((char (read-char stream nil #\Null)))
+ (declare (type character char))
+ (cond ((identifier-char-p char)
+ (vector-push-extend char identifier))
+ (t
+ (when (char/= char #\Null) (unread-char char stream))
+ (return identifier))))))
+
+(defun skip-comment (stream)
+ "Skip an XML comment in stream, positioned after the opening '<!--',
+ consumes the closing '-->' sequence, unexpected eof or a malformed
+ closing sequence result in a error"
+ (let ((dashes-to-read 2))
+ (loop
+ (if (zerop dashes-to-read) (return))
+ (let ((char (read-char stream nil #\Null)))
+ (declare (type character char))
+ (if (char= char #\Null)
+ (error (parser-error "encountered unexpected eof for comment")))
+ (if (char= char #\-)
+ (decf dashes-to-read)
+ (setf dashes-to-read 2)))))
+ (if (char/= (read-char stream nil #\Null) #\>)
+ (error (parser-error "expected > ending comment" nil stream))))
+
+(defun read-cdata (stream state string)
+ "Reads in the CDATA and calls the callback for CDATA if it exists"
+ ;; we already read the <![CDATA[ stuff
+ ;; continue to read until we hit ]]>
+ (let ((char #\space)
+ (last-3-characters (list #\[ #\A #\T))
+ (pattern (list #\> #\] #\])))
+ (declare (type character char))
+ (loop
+ (setf char (read-char stream nil #\Null))
+ (when (char= char #\Null) (error (parser-error "encountered unexpected eof in text")))
+ (push char last-3-characters)
+ (setf (cdddr last-3-characters) nil)
+ (cond
+ ((equal last-3-characters
+ pattern)
+ (setf (fill-pointer string)
+ (- (fill-pointer string) 2))
+ (setf (get-seed state)
+ (funcall (get-text-hook state)
+ (copy-seq string)
+ (get-seed state)))
+ (return-from read-cdata))
+ (t
+ (vector-push-extend char string))))))
+
+(defun skip-special-tag (stream state)
+ "Skip an XML special tag (comments and processing instructions) in
+ stream, positioned after the opening '<', unexpected eof is an error"
+ ;; opening < has been read, consume ? or !
+ (read-char stream)
+ (let ((char (read-char stream nil #\Null)))
+ (declare (type character char))
+ ;; see if we are dealing with a comment
+ (when (char= char #\-)
+ (setf char (read-char stream nil #\Null))
+ (when (char= char #\-)
+ (skip-comment stream)
+ (return-from skip-special-tag)))
+ ;; maybe we are dealing with CDATA?
+ (when (and (char= char #\[)
+ (loop :for pattern :across "CDATA["
+ :for char = (read-char stream nil #\Null)
+ :when (char= char #\Null) :do
+ (error (parser-error "encountered unexpected eof in cdata"))
+ :always (char= char pattern)))
+ (read-cdata stream state (get-buffer state))
+ (return-from skip-special-tag))
+ ;; loop over chars, dealing with strings (skipping their content)
+ ;; and counting opening and closing < and > chars
+ (let ((taglevel 1)
+ (string-delimiter #\Null))
+ (declare (type character string-delimiter))
+ (loop
+ (when (zerop taglevel) (return))
+ (setf char (read-char stream nil #\Null))
+ (when (char= char #\Null)
+ (error (parser-error "encountered unexpected eof for special (! or ?) tag" nil stream)))
+ (if (char/= string-delimiter #\Null)
+ ;; inside a string we only look for a closing string delimiter
+ (when (char= char string-delimiter)
+ (setf string-delimiter #\Null))
+ ;; outside a string we count < and > and watch out for strings
+ (cond ((or (char= char #\') (char= char #\")) (setf string-delimiter char))
+ ((char= char #\<) (incf taglevel))
+ ((char= char #\>) (decf taglevel))))))))
+
+;;; the XML parser proper
+
+(defun parse-xml-element-attributes (stream state)
+ "Parse XML element attributes from stream positioned after the tag
+ identifier, returning the attributes as an assoc list, ending at
+ either a '>' or a '/' which is peeked and also returned"
+ (declare (special *namespaces*))
+ (let ((char #\Null) attributes)
+ (declare (type character char))
+ (loop
+ ;; skip whitespace separating items
+ (setf char (skip-whitespace stream))
+ ;; start tag attributes ends with > or />
+ (when (or (char= char #\>) (char= char #\/)) (return))
+ ;; read the attribute key
+ (let ((key (let ((string (parse-identifier stream (get-mini-buffer state))))
+ (if *ignore-namespaces*
+ (funcall *attribute-name-parser* string)
+ (copy-seq string)))))
+ ;; skip separating whitespace
+ (setf char (skip-whitespace stream))
+ ;; require = sign (and consume it if present)
+ (if (char= char #\=)
+ (read-char stream)
+ (error (parser-error "expected =" nil stream)))
+ ;; skip separating whitespace
+ (skip-whitespace stream)
+ ;; read the attribute value as a string
+ (push (cons key (let ((string (parse-string stream state (get-buffer state))))
+ (if *ignore-namespaces*
+ (funcall *attribute-value-parser* key string)
+ (copy-seq string))))
+ attributes)))
+ ;; return attributes peek char ending loop
+ (values attributes char)))
+
+(defun parse-xml-element (stream state)
+ "Parse and return an XML element from stream, positioned after the opening '<'"
+ (declare (special *namespaces*))
+ ;; opening < has been read
+ (when (char= (peek-char nil stream nil #\Null) #\!)
+ (skip-special-tag stream state)
+ (return-from parse-xml-element))
+ (let ((char #\Null) buffer open-tag parent-seed has-children)
+ (declare (type character char))
+ (setf parent-seed (get-seed state))
+ ;; read tag name (no whitespace between < and name ?)
+ (setf open-tag (copy-seq (parse-identifier stream (get-mini-buffer state))))
+ ;; tag has been read, read attributes if any
+ (multiple-value-bind (attributes peeked-char)
+ (parse-xml-element-attributes stream state)
+ (let ((*namespaces* (extend-namespaces attributes *namespaces*)))
+ (setf open-tag (resolve-identifier open-tag *namespaces*))
+ (unless *ignore-namespaces*
+ (dolist (attribute attributes)
+ (setf (car attribute) (funcall *attribute-name-parser* (car attribute))
+ (cdr attribute) (funcall *attribute-value-parser* (car attribute) (cdr attribute)))))
+ (setf (get-seed state) (funcall (get-new-element-hook state)
+ open-tag attributes (get-seed state)))
+ (setf char peeked-char)
+ (when (char= char #\/)
+ ;; handle solitary tag of the form <tag .. />
+ (read-char stream)
+ (setf char (read-char stream nil #\Null))
+ (if (char= #\> char)
+ (progn
+ (setf (get-seed state) (funcall (get-finish-element-hook state)
+ open-tag attributes parent-seed (get-seed state)))
+ (return-from parse-xml-element))
+ (error (parser-error "expected >" nil stream))))
+ ;; consume >
+ (read-char stream)
+ (loop
+ (setf buffer (get-buffer state))
+ ;; read whitespace into buffer
+ (setf char (parse-whitespace stream buffer))
+ ;; see what ended the whitespace scan
+ (cond ((char= char #\Null) (error (parser-error "encountered unexpected eof handling ~a"
+ (list open-tag))))
+ ((char= char #\<)
+ ;; consume the <
+ (read-char stream)
+ (if (char= (peek-char nil stream nil #\Null) #\/)
+ (progn
+ ;; handle the matching closing tag </tag> and done
+ ;; if we read whitespace as this (leaf) element's contents, it is significant
+ (when (and (not has-children) (plusp (length buffer)))
+ (setf (get-seed state) (funcall (get-text-hook state)
+ (copy-seq buffer) (get-seed state))))
+ (read-char stream)
+ (let ((close-tag (resolve-identifier (parse-identifier stream (get-mini-buffer state))
+ *namespaces*)))
+ (unless (eq open-tag close-tag)
+ (error (parser-error "found <~a> not matched by </~a> but by <~a>"
+ (list open-tag open-tag close-tag) stream)))
+ (unless (char= (read-char stream nil #\Null) #\>)
+ (error (parser-error "expected >" nil stream)))
+ (setf (get-seed state) (funcall (get-finish-element-hook state)
+ open-tag attributes parent-seed (get-seed state))))
+ (return))
+ ;; handle child tag and loop, no hooks to call here
+ ;; whitespace between child elements is skipped
+ (progn
+ (setf has-children t)
+ (parse-xml-element stream state))))
+ (t
+ ;; no child tag, concatenate text to whitespace in buffer
+ ;; handle text content and loop
+ (setf char (parse-text stream state buffer))
+ (setf (get-seed state) (funcall (get-text-hook state)
+ (copy-seq buffer) (get-seed state))))))))))
+
+(defun start-parse-xml (stream &optional (state (make-instance 'xml-parser-state)))
+ "Parse and return a toplevel XML element from stream, using parser state"
+ (loop
+ (let ((char (skip-whitespace stream)))
+ (when (char= char #\Null) (return-from start-parse-xml))
+ ;; skip whitespace until start tag
+ (unless (char= char #\<)
+ (error (parser-error "expected <" nil stream)))
+ (read-char stream) ; consume peeked char
+ (setf char (peek-char nil stream nil #\Null))
+ (if (or (char= char #\!) (char= char #\?))
+ ;; deal with special tags
+ (skip-special-tag stream state)
+ (progn
+ ;; read the main element
+ (parse-xml-element stream state)
+ (return-from start-parse-xml (get-seed state)))))))
+
+;;;; eof
diff --git a/third-party/s-xml/test/ant-build-file.xml b/third-party/s-xml/test/ant-build-file.xml
new file mode 100644
index 0000000..8aef4cc
--- /dev/null
+++ b/third-party/s-xml/test/ant-build-file.xml
@@ -0,0 +1,252 @@
+<!-- $Id: ant-build-file.xml,v 1.1.1.1 2004-06-07 18:49:59 scaekenberghe Exp $ -->
+<!-- Ant 1.2 build file -->
+
+<project name="Libretto" default="compile" basedir=".">
+
+ <!-- set global properties for this build -->
+ <property name="src" value="${basedir}/src" />
+ <property name="rsrc" value="${basedir}/rsrc" />
+ <property name="build" value="${basedir}/bin" />
+ <property name="api" value="${basedir}/api" />
+ <property name="lib" value="${basedir}/lib" />
+ <property name="junit" value="${basedir}/junit" />
+ <property name="rsrc" value="${basedir}/rsrc" />
+
+ <target name="prepare">
+ <!-- Create the time stamp -->
+ <tstamp/>
+ <!-- Create the build directory structure used by compile -->
+ <mkdir dir="${build}" />
+ <mkdir dir="${api}" />
+ <mkdir dir="${junit}" />
+ <copy file="${rsrc}/build/build.version" tofile="${build}/build.properties"/>
+ <replace file="${build}/build.properties" token="@@@BUILD_ID@@@" value="${DSTAMP}-${TSTAMP}"/>
+ </target>
+
+ <target name="compile" depends="copy-rsrc">
+ <!-- Compile the java code from ${src} into ${build} -->
+ <javac srcdir="${src}" destdir="${build}" debug="on">
+ <classpath>
+ <fileset dir="${lib}">
+ <include name="log4j-core.jar" />
+ <include name="jaxp.jar" />
+ <include name="crimson.jar" />
+ <include name="jdom.jar" />
+ <include name="beanshell.jar" />
+ </fileset>
+ </classpath>
+ </javac>
+ </target>
+
+ <target name="compile-junit" depends="copy-rsrc">
+ <!-- Compile the java code from ${src} into ${build} -->
+ <javac srcdir="${junit}" destdir="${build}" debug="on">
+ <classpath>
+ <fileset dir="${lib}">
+ <include name="*.jar" />
+ </fileset>
+ </classpath>
+ </javac>
+ </target>
+
+ <target name="copy-rsrc" depends="prepare">
+ <!-- Copy various resource files into ${build} -->
+ <copy todir="${build}">
+ <fileset
+ dir="${basedir}"
+ includes="images/*.gif, images/*.jpg" />
+ </copy>
+ <copy todir="${build}">
+ <fileset
+ dir="${src}"
+ includes="be/beta9/libretto/data/*.txt" />
+ </copy>
+ <copy todir="${build}">
+ <fileset
+ dir="${rsrc}/log4j"
+ includes="log4j.properties" />
+ </copy>
+ </target>
+
+ <target name="c-header" depends="compile">
+ <javah destdir="${rsrc}/VC_source" class="be.beta9.libretto.io.ParallelPort">
+ <classpath>
+ <pathelement location="${build}" />
+ </classpath>
+ </javah>
+ </target>
+
+ <target name="test-parport" depends="compile">
+ <java
+ classname="be.beta9.libretto.io.ParallelPortWriter"
+ fork="yes">
+ <classpath>
+ <pathelement location="${build}" />
+ <fileset dir="${lib}">
+ <include name="*.jar" />
+ </fileset>
+ </classpath>
+ </java>
+ </target>
+
+ <target name="jar-simple" depends="compile">
+ <!-- Put everything in ${build} into the a jar file -->
+ <jar
+ jarfile="${basedir}/libretto.jar"
+ basedir="${build}"
+ manifest="${rsrc}/manifest/libretto.mf"/>
+ </target>
+
+ <target name="jar" depends="compile">
+ <!-- Put everything in ${build} into the a jar file including all dependecies -->
+ <unjar src="${lib}/jaxp.jar" dest="${build}" />
+ <unjar src="${lib}/crimson.jar" dest="${build}" />
+ <unjar src="${lib}/jdom.jar" dest="${build}" />
+ <unjar src="${lib}/log4j-core.jar" dest="${build}" />
+ <jar
+ jarfile="${basedir}/libretto.jar"
+ basedir="${build}"
+ manifest="${rsrc}/manifest/libretto.mf"/>
+ </target>
+
+ <target name="client-jar" depends="background-jar">
+ <!-- Put everything in ${build} into the a jar file including all dependecies -->
+ <unjar src="${lib}/log4j-core.jar" dest="${build}" />
+ <jar jarfile="${basedir}/libretto-client.jar" manifest="${rsrc}/manifest/libretto-client.mf">
+ <fileset dir="${build}">
+ <include name="build.properties"/>
+ <include name="log4j.properties"/>
+ <include name="be/beta9/libretto/io/*.class"/>
+ <include name="be/beta9/libretto/application/Build.class"/>
+ <include name="be/beta9/libretto/net/LibrettoTextClient*.class"/>
+ <include name="be/beta9/libretto/net/TestClientMessage.class"/>
+ <include name="be/beta9/libretto/net/ClientStatusMessageResult.class"/>
+ <include name="be/beta9/libretto/net/Client*.class"/>
+ <include name="be/beta9/libretto/net/Constants.class"/>
+ <include name="be/beta9/libretto/net/TextMessage.class"/>
+ <include name="be/beta9/libretto/net/MessageResult.class"/>
+ <include name="be/beta9/libretto/net/MessageException.class"/>
+ <include name="be/beta9/libretto/net/SingleTextMessage.class"/>
+ <include name="be/beta9/libretto/net/Message.class"/>
+ <include name="be/beta9/libretto/net/Util.class"/>
+ <include name="be/beta9/libretto/gui/ShowSingleTextFrame*.class"/>
+ <include name="be/beta9/libretto/gui/AWTTextView*.class"/>
+ <include name="be/beta9/libretto/model/AttributedString*.class"/>
+ <include name="be/beta9/libretto/model/AWTTextStyle.class"/>
+ <include name="be/beta9/libretto/model/LTextStyle.class"/>
+ <include name="be/beta9/libretto/model/AWTCharacterAttributes.class"/>
+ <include name="be/beta9/libretto/model/Java2DTextStyle.class"/>
+ <include name="be/beta9/libretto/model/LCharacterAttributes.class"/>
+ <include name="be/beta9/libretto/model/Java2DCharacterAttributes.class"/>
+ <include name="be/beta9/libretto/util/TextStyleManager.class"/>
+ <include name="be/beta9/libretto/util/Bean.class"/>
+ <include name="be/beta9/libretto/util/LibrettoSaxReader.class"/>
+ <include name="be/beta9/libretto/util/Preferences.class"/>
+ <include name="be/beta9/libretto/util/Utilities.class"/>
+ <include name="org/apache/log4j/**"/>
+ </fileset>
+ </jar>
+ </target>
+
+ <target name="background-jar" depends="compile">
+ <!-- Put everything in ${build} into the a jar file including all dependecies -->
+ <jar jarfile="${basedir}/background.jar" manifest="${rsrc}/manifest/background-black-window.mf">
+ <fileset dir="${build}">
+ <include name="be/beta9/libretto/gui/BackgroundBlackWindow.class"/>
+ </fileset>
+ </jar>
+ </target>
+
+ <target name="run" depends="compile">
+ <!-- Execute the main application -->
+ <java
+ classname="be.beta9.libretto.application.Libretto"
+ fork="yes">
+ <classpath>
+ <pathelement location="${build}" />
+ <fileset dir="${lib}">
+ <include name="log4j-core.jar" />
+ <include name="jaxp.jar" />
+ <include name="crimson.jar" />
+ <include name="jdom.jar" />
+ </fileset>
+ </classpath>
+ </java>
+ </target>
+
+ <target name="debug" depends="compile">
+ <!-- Execute the main application in debug mode -->
+ <java
+ classname="be.beta9.libretto.application.LibrettoDebug"
+ fork="yes">
+ <classpath>
+ <pathelement location="${build}" />
+ <fileset dir="${lib}">
+ <include name="*.jar" />
+ </fileset>
+ </classpath>
+ </java>
+ </target>
+
+ <target name="junit" depends="compile-junit">
+ <!-- Execute all junit tests -->
+ <java
+ classname="be.beta9.libretto.AllTests"
+ fork="yes">
+ <classpath>
+ <pathelement location="${build}" />
+ <fileset dir="${lib}">
+ <include name="*.jar" />
+ </fileset>
+ </classpath>
+ </java>
+ </target>
+
+ <target name="clean">
+ <!-- Delete the ${build} directory trees -->
+ <delete dir="${build}" />
+ <delete dir="${api}" />
+ </target>
+
+ <target name="api" depends="prepare">
+ <!-- Generate javadoc -->
+ <javadoc
+ packagenames="be.beta9.libretto.*"
+ sourcepath="${src}"
+ destdir="${api}"
+ windowtitle="Libretto"
+ author="true"
+ version="true"
+ use="true"/>
+ </target>
+
+ <target name="zip-all" depends="jar, client-jar">
+ <zip zipfile="libretto.zip">
+ <fileset dir="${basedir}">
+ <include name="libretto.jar"/>
+ <include name="libretto-client.jar"/>
+ </fileset>
+ </zip>
+ </target>
+
+ <target name="upload" depends="clean, zip-all">
+ <ftp
+ server="users.pandora.be"
+ userid="a002458"
+ password="bast0s"
+ remotedir="libretto"
+ verbose="true"
+ passive="true">
+ <fileset dir="${basedir}">
+ <include name="libretto.jar" />
+ <include name="libretto-client.jar" />
+ <include name="libretto.zip" />
+ </fileset>
+ </ftp>
+ </target>
+
+</project>
+
+
+
+
diff --git a/third-party/s-xml/test/plist.xml b/third-party/s-xml/test/plist.xml
new file mode 100644
index 0000000..910e632
--- /dev/null
+++ b/third-party/s-xml/test/plist.xml
@@ -0,0 +1,38 @@
+<?xml version="1.0" encoding="UTF-8"?>
+<!DOCTYPE plist PUBLIC "-//Apple Computer//DTD PLIST 1.0//EN" "http://www.apple.com/DTDs/PropertyList-1.0.dtd">
+<plist version="1.0">
+<dict>
+ <key>AppleDockIconEnabled</key>
+ <true/>
+ <key>AppleNavServices:GetFile:0:Path</key>
+ <string>file://localhost/Users/sven/Pictures/</string>
+ <key>AppleNavServices:GetFile:0:Position</key>
+ <data>
+ AOUBXw==
+ </data>
+ <key>AppleNavServices:GetFile:0:Size</key>
+ <data>
+ AAAAAAFeAcI=
+ </data>
+ <key>AppleNavServices:PutFile:0:Disclosure</key>
+ <data>
+ AQ==
+ </data>
+ <key>AppleNavServices:PutFile:0:Path</key>
+ <string>file://localhost/Users/sven/Desktop/</string>
+ <key>AppleNavServices:PutFile:0:Position</key>
+ <data>
+ AUIBVQ==
+ </data>
+ <key>AppleNavServices:PutFile:0:Size</key>
+ <data>
+ AAAAAACkAdY=
+ </data>
+ <key>AppleSavePanelExpanded</key>
+ <string>YES</string>
+ <key>NSDefaultOpenDirectory</key>
+ <string>~/Desktop</string>
+ <key>NSNoBigString</key>
+ <true/>
+</dict>
+</plist>
diff --git a/third-party/s-xml/test/simple.xml b/third-party/s-xml/test/simple.xml
new file mode 100644
index 0000000..08ad942
--- /dev/null
+++ b/third-party/s-xml/test/simple.xml
@@ -0,0 +1,5 @@
+<?xml version="1.0"?>
+<!-- This is a very simple XML document -->
+<root id="123">
+ <text>Hello World!</text>
+</root>
diff --git a/third-party/s-xml/test/test-lxml-dom.lisp b/third-party/s-xml/test/test-lxml-dom.lisp
new file mode 100644
index 0000000..f7aadbe
--- /dev/null
+++ b/third-party/s-xml/test/test-lxml-dom.lisp
@@ -0,0 +1,86 @@
+;;;; -*- mode: lisp -*-
+;;;;
+;;;; $Id: test-lxml-dom.lisp,v 1.3 2008-02-15 13:54:57 scaekenberghe Exp $
+;;;;
+;;;; Unit and functional tests for lxml-dom.lisp
+;;;;
+;;;; Copyright (C) 2002, 2004 Sven Van Caekenberghe, Beta Nine BVBA.
+;;;;
+;;;; You are granted the rights to distribute and use this software
+;;;; as governed by the terms of the Lisp Lesser General Public License
+;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
+
+(in-package :s-xml)
+
+(assert
+ (equal (with-input-from-string (stream " <foo/>")
+ (parse-xml stream :output-type :lxml))
+ :|foo|))
+
+(assert
+ (equal (parse-xml-string "<tag1><tag2 att1='one'/>this is some text</tag1>"
+ :output-type :lxml)
+ '(:|tag1|
+ ((:|tag2| :|att1| "one"))
+ "this is some text")))
+
+(assert
+ (equal (parse-xml-string "<TAG>&lt;foo&gt;</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 &amp; trailing space </P>"
+ :output-type :lxml)
+ '(:p
+ ((:index :item "one"))
+ " This is some "
+ (:b "bold")
+ " text, with a leading & trailing space ")))
+
+(assert
+ (consp (parse-xml-file (merge-pathnames "test/xhtml-page.xml"
+ (asdf:component-pathname
+ (asdf:find-system :s-xml.test)))
+ :output-type :lxml)))
+
+(assert
+ (consp (parse-xml-file (merge-pathnames "test/ant-build-file.xml"
+ (asdf:component-pathname
+ (asdf:find-system :s-xml.test)))
+ :output-type :lxml)))
+
+(assert
+ (consp (parse-xml-file (merge-pathnames "test/plist.xml"
+ (asdf:component-pathname
+ (asdf:find-system :s-xml.test)))
+ :output-type :lxml)))
+
+(assert
+ (string-equal (print-xml-string :|foo| :input-type :lxml)
+ "<foo/>"))
+
+(assert
+ (string-equal (print-xml-string '((:|foo| :|bar| "1")) :input-type :lxml)
+ "<foo bar=\"1\"/>"))
+
+(assert
+ (string-equal (print-xml-string '(:foo "some text") :input-type :lxml)
+ "<FOO>some text</FOO>"))
+
+(assert
+ (string-equal (print-xml-string '(:|foo| :|bar|) :input-type :lxml)
+ "<foo><bar/></foo>"))
+
+(assert (string-equal (second
+ (with-input-from-string (stream "<foo><![CDATA[<greeting>Hello, world!</greeting>]]></foo>")
+ (parse-xml stream :output-type :lxml)))
+ "<greeting>Hello, world!</greeting>"))
+
+(assert (string-equal (second
+ (with-input-from-string (stream "<foo><![CDATA[<greeting>Hello, < world!</greeting>]]></foo>")
+ (parse-xml stream :output-type :lxml)))
+ "<greeting>Hello, < world!</greeting>"))
+
+;;;; eof
diff --git a/third-party/s-xml/test/test-sxml-dom.lisp b/third-party/s-xml/test/test-sxml-dom.lisp
new file mode 100644
index 0000000..41cf72f
--- /dev/null
+++ b/third-party/s-xml/test/test-sxml-dom.lisp
@@ -0,0 +1,76 @@
+;;;; -*- mode: lisp -*-
+;;;;
+;;;; $Id: test-sxml-dom.lisp,v 1.2 2008-02-15 13:54:57 scaekenberghe Exp $
+;;;;
+;;;; Unit and functional tests for sxml-dom.lisp
+;;;;
+;;;; Copyright (C) 2002, 2004 Sven Van Caekenberghe, Beta Nine BVBA.
+;;;;
+;;;; You are granted the rights to distribute and use this software
+;;;; as governed by the terms of the Lisp Lesser General Public License
+;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
+
+(in-package :s-xml)
+
+(assert
+ (equal (with-input-from-string (stream " <foo/>")
+ (parse-xml stream :output-type :sxml))
+ '(:|foo|)))
+
+(assert
+ (equal (parse-xml-string "<tag1><tag2 att1='one'/>this is some text</tag1>"
+ :output-type :sxml)
+ '(:|tag1|
+ (:|tag2| (:@ (:|att1| "one")))
+ "this is some text")))
+
+(assert
+ (equal (parse-xml-string "<TAG>&lt;foo&gt;</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 &amp; trailing space </P>"
+ :output-type :sxml)
+ '(:p
+ (:index (:@ (:item "one")))
+ " This is some "
+ (:b "bold")
+ " text, with a leading & trailing space ")))
+
+(assert
+ (consp (parse-xml-file (merge-pathnames "test/xhtml-page.xml"
+ (asdf:component-pathname
+ (asdf:find-system :s-xml.test)))
+ :output-type :sxml)))
+
+(assert
+ (consp (parse-xml-file (merge-pathnames "test/ant-build-file.xml"
+ (asdf:component-pathname
+ (asdf:find-system :s-xml.test)))
+ :output-type :sxml)))
+
+(assert
+ (consp (parse-xml-file (merge-pathnames "test/plist.xml"
+ (asdf:component-pathname
+ (asdf:find-system :s-xml.test)))
+ :output-type :sxml)))
+
+(assert
+ (string-equal (print-xml-string '(:|foo|) :input-type :sxml)
+ "<foo/>"))
+
+(assert
+ (string-equal (print-xml-string '(:|foo| (:@ (:|bar| "1"))) :input-type :sxml)
+ "<foo bar=\"1\"/>"))
+
+(assert
+ (string-equal (print-xml-string '(:foo "some text") :input-type :sxml)
+ "<FOO>some text</FOO>"))
+
+(assert
+ (string-equal (print-xml-string '(:|foo| (:|bar|)) :input-type :sxml)
+ "<foo><bar/></foo>"))
+
+;;;; eof \ No newline at end of file
diff --git a/third-party/s-xml/test/test-xml-struct-dom.lisp b/third-party/s-xml/test/test-xml-struct-dom.lisp
new file mode 100644
index 0000000..607402b
--- /dev/null
+++ b/third-party/s-xml/test/test-xml-struct-dom.lisp
@@ -0,0 +1,84 @@
+;;;; -*- mode: lisp -*-
+;;;;
+;;;; $Id: test-xml-struct-dom.lisp,v 1.3 2008-02-15 13:54:57 scaekenberghe Exp $
+;;;;
+;;;; Unit and functional tests for xml-struct-dom.lisp
+;;;;
+;;;; Copyright (C) 2002, 2004 Sven Van Caekenberghe, Beta Nine BVBA.
+;;;;
+;;;; You are granted the rights to distribute and use this software
+;;;; as governed by the terms of the Lisp Lesser General Public License
+;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
+
+(in-package :s-xml)
+
+(assert
+ (xml-equal (with-input-from-string (stream " <foo/>")
+ (parse-xml stream :output-type :xml-struct))
+ (make-xml-element :name :|foo|)))
+
+(assert
+ (xml-equal (parse-xml-string "<tag1><tag2 att1='one'/>this is some text</tag1>"
+ :output-type :xml-struct)
+ (make-xml-element :name :|tag1|
+ :children (list (make-xml-element :name :|tag2|
+ :attributes '((:|att1| . "one")))
+ "this is some text"))))
+
+(assert
+ (xml-equal (parse-xml-string "<tag>&lt;foo&gt;</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 &amp; trailing space </P>"
+ :output-type :xml-struct)
+ (make-xml-element :name :p
+ :children (list (make-xml-element :name :index
+ :attributes '((:item . "one")))
+ " This is some "
+ (make-xml-element :name :b
+ :children (list "bold"))
+ " text, with a leading & trailing space "))))
+
+(assert
+ (xml-element-p (parse-xml-file (merge-pathnames "test/xhtml-page.xml"
+ (asdf:component-pathname
+ (asdf:find-system :s-xml.test)))
+ :output-type :xml-struct)))
+
+(assert
+ (xml-element-p (parse-xml-file (merge-pathnames "test/ant-build-file.xml"
+ (asdf:component-pathname
+ (asdf:find-system :s-xml.test)))
+ :output-type :xml-struct)))
+
+(assert
+ (xml-element-p (parse-xml-file (merge-pathnames "test/plist.xml"
+ (asdf:component-pathname
+ (asdf:find-system :s-xml.test)))
+ :output-type :xml-struct)))
+
+(assert
+ (string-equal (print-xml-string (make-xml-element :name "foo")
+ :input-type :xml-struct)
+ "<foo/>"))
+
+(assert
+ (string-equal (print-xml-string (make-xml-element :name "foo" :attributes '((:|bar| . "1")))
+ :input-type :xml-struct)
+ "<foo bar=\"1\"/>"))
+
+(assert
+ (string-equal (print-xml-string (make-xml-element :name "foo" :children (list "some text"))
+ :input-type :xml-struct)
+ "<foo>some text</foo>"))
+
+(assert
+ (string-equal (print-xml-string (make-xml-element :name "foo" :children (list (make-xml-element :name "bar")))
+ :input-type :xml-struct)
+ "<foo><bar/></foo>"))
+
+;;;; eof \ No newline at end of file
diff --git a/third-party/s-xml/test/test-xml.lisp b/third-party/s-xml/test/test-xml.lisp
new file mode 100644
index 0000000..6d636a8
--- /dev/null
+++ b/third-party/s-xml/test/test-xml.lisp
@@ -0,0 +1,86 @@
+;;;; -*- mode: lisp -*-
+;;;;
+;;;; $Id: test-xml.lisp,v 1.4 2006-01-19 20:00:06 scaekenberghe Exp $
+;;;;
+;;;; Unit and functional tests for xml.lisp
+;;;;
+;;;; Copyright (C) 2002, 2004 Sven Van Caekenberghe, Beta Nine BVBA.
+;;;;
+;;;; You are granted the rights to distribute and use this software
+;;;; as governed by the terms of the Lisp Lesser General Public License
+;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
+
+(in-package :s-xml)
+
+(assert
+ (whitespace-char-p (character " ")))
+
+(assert
+ (whitespace-char-p (character " ")))
+
+(assert
+ (whitespace-char-p (code-char 10)))
+
+(assert
+ (whitespace-char-p (code-char 13)))
+
+(assert
+ (not (whitespace-char-p #\A)))
+
+(assert
+ (char= (with-input-from-string (stream " ABC")
+ (skip-whitespace stream))
+ #\A))
+
+(assert
+ (char= (with-input-from-string (stream "ABC")
+ (skip-whitespace stream))
+ #\A))
+
+(assert
+ (string-equal (with-output-to-string (stream) (print-string-xml "<foo>" stream))
+ "&lt;foo&gt;"))
+
+(assert
+ (string-equal (with-output-to-string (stream) (print-string-xml "' '" stream))
+ "' '"))
+
+(assert
+ (let ((string (map 'string #'identity '(#\return #\tab #\newline))))
+ (string-equal (with-output-to-string (stream) (print-string-xml string stream))
+ string)))
+
+(defun simple-echo-xml (in out)
+ (start-parse-xml
+ in
+ (make-instance 'xml-parser-state
+ :new-element-hook #'(lambda (name attributes seed)
+ (declare (ignore seed))
+ (format out "<~a~:{ ~a='~a'~}>"
+ name
+ (mapcar #'(lambda (p) (list (car p) (cdr p)))
+ (reverse attributes))))
+ :finish-element-hook #'(lambda (name attributes parent-seed seed)
+ (declare (ignore attributes parent-seed seed))
+ (format out "</~a>" name))
+ :text-hook #'(lambda (string seed)
+ (declare (ignore seed))
+ (princ string out)))))
+
+(defun simple-echo-xml-string (string)
+ (with-input-from-string (in string)
+ (with-output-to-string (out)
+ (simple-echo-xml in out))))
+
+(dolist (*ignore-namespaces* '(nil t))
+ (assert
+ (let ((xml "<FOO ATT1='1' ATT2='2'><B>Text</B><EMPTY></EMPTY>More text!<SUB><SUB></SUB></SUB></FOO>"))
+ (equal (simple-echo-xml-string xml)
+ xml))))
+
+(assert
+ (let ((xml "<p> </p>"))
+ (equal (simple-echo-xml-string xml)
+ xml)))
+
+;;;; eof \ No newline at end of file
diff --git a/third-party/s-xml/test/xhtml-page.xml b/third-party/s-xml/test/xhtml-page.xml
new file mode 100644
index 0000000..79f3ae3
--- /dev/null
+++ b/third-party/s-xml/test/xhtml-page.xml
@@ -0,0 +1,271 @@
+<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
+
+<html>
+<head>
+
+<title>XHTML Tutorial</title>
+<meta http-equiv="Content-Type" content="text/html; charset=windows-1252" />
+<meta name="Keywords" content="XML,tutorial,HTML,DHTML,CSS,XSL,XHTML,JavaScript,ASP,ADO,VBScript,DOM,authoring,programming,learning,beginner's guide,primer,lessons,school,howto,reference,examples,samples,source code,demos,tips,links,FAQ,tag list,forms,frames,color table,W3C,Cascading Style Sheets,Active Server Pages,Dynamic HTML,Internet database development,Webbuilder,Sitebuilder,Webmaster,HTMLGuide,SiteExpert" />
+<meta name="Description" content="HTML,CSS,JavaScript,DHTML,XML,XHTML,ASP,ADO and VBScript tutorial from W3Schools." />
+<meta http-equiv="pragma" content="no-cache" />
+<meta http-equiv="cache-control" content="no-cache" />
+
+<link rel="stylesheet" type="text/css" href="../stdtheme.css" />
+
+</head>
+<body>
+
+<table border="0" cellpadding="0" cellspacing="0" width="775">
+<tr>
+<td width="140" class="content" valign="top">
+<br />
+<a class="left" href="../default.asp" target="_top"><b>HOME</b></a><br />
+<br />
+<b>XHTML Tutorial</b><br />
+<a class="left" target="_top" href="default.asp" style='font-weight:bold;color:#000000;background-color:transparent;'>XHTML HOME</a><br />
+<a class="left" target="_top" href="xhtml_intro.asp" >XHTML Introduction</a><br />
+<a class="left" target="_top" href="xhtml_why.asp" >XHTML Why</a><br />
+<a class="left" target="_top" href="xhtml_html.asp" >XHTML v HTML</a><br />
+<a class="left" target="_top" href="xhtml_syntax.asp" >XHTML Syntax</a><br />
+<a class="left" target="_top" href="xhtml_dtd.asp" >XHTML DTD</a><br />
+<a class="left" target="_top" href="xhtml_howto.asp" >XHTML HowTo</a><br />
+<a class="left" target="_top" href="xhtml_validate.asp" >XHTML Validation</a><br />
+<br />
+<b>Quiz</b>
+<br />
+<a class="left" target="_top" href="xhtml_quiz.asp" >XHTML Quiz</a><br />
+<br />
+<b>References</b>
+<br />
+<a class="left" target="_top" href="xhtml_reference.asp" >XHTML Tag List</a><br />
+<a class="left" target="_top" href="xhtml_standardattributes.asp" >XHTML Attributes</a><br />
+<a class="left" target="_top" href="xhtml_eventattributes.asp" >XHTML Events</a><br />
+</td>
+<td width="490" valign="top">
+<table width="100%" bgcolor="#FFFFFF" border="1" cellpadding="7" cellspacing="0">
+<tr>
+<td>
+<center>
+<a href="http://ad.doubleclick.net/jump/N1951.w3schools/B1097963;sz=468x60;ord=[timestamp]?" target="_new">
+<img src="http://ad.doubleclick.net/ad/N1951.w3schools/B1097963;sz=468x60;ord=[timestamp]?"
+border="0" width="468" height="60" alt="Corel XMetal 3" /></a>
+
+
+<br />Please Visit Our Sponsors !
+</center>
+<h1>XHTML Tutorial</h1>
+<a href="../default.asp"><img border="0" src="../images/btn_previous.gif" alt="Previous" /></a>
+<a href="xhtml_intro.asp"><img border="0" src="../images/btn_next.gif" width="100" height="20" alt="Next" /></a>
+
+<hr />
+
+<h2>XHTML Tutorial</h2>
+<p>XHTML is the next generation of HTML! In our XHTML tutorial you will learn the difference between HTML and XHTML, and how to use XHTML in your future
+applications. You will also see how we converted this Web site into XHTML. <a href="xhtml_intro.asp">Start&nbsp;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>&nbsp;</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>&nbsp;<br />
+This chapter explains the basic syntax of XHTML.</p>
+<p><a href="xhtml_dtd.asp">XHTML DTD</a>&nbsp;<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&nbsp; 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 &quot;XHTML 1.0 Reference&quot; 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>