From ddb83b1fb2d305e0c06fc067d82d6bab5458b0fd Mon Sep 17 00:00:00 2001 From: Matthias Benkard Date: Fri, 30 Oct 2009 20:52:07 +0100 Subject: Add third-party XML processing libraries. Ignore-this: 5ca28497555bf944858ca2f58bc8a62b darcs-hash:a0b0f9baa7c9b1259e755435db1fb17123630a6c --- third-party/s-base64/.clbuild-skip-update | 0 third-party/s-base64/Makefile | 82 +++ third-party/s-base64/README.txt | 1 + third-party/s-base64/doc/API.html | 11 + third-party/s-base64/doc/index.html | 266 ++++++++ third-party/s-base64/s-base64.asd | 30 + third-party/s-base64/src/base64.lisp | 152 +++++ third-party/s-base64/src/package.lisp | 22 + third-party/s-base64/test/all-tests.lisp | 15 + third-party/s-base64/test/test-base64.lisp | 140 +++++ third-party/s-base64/test/test.b64 | 1 + third-party/s-sysdeps/.clbuild-skip-update | 0 third-party/s-sysdeps/Makefile | 82 +++ third-party/s-sysdeps/README.txt | 1 + third-party/s-sysdeps/doc/API.html | 19 + third-party/s-sysdeps/doc/index.html | 203 ++++++ third-party/s-sysdeps/s-sysdeps.asd | 31 + third-party/s-sysdeps/src/bivalent-streams.lisp | 107 ++++ third-party/s-sysdeps/src/package.lisp | 28 + third-party/s-sysdeps/src/sysdeps.lisp | 281 +++++++++ third-party/s-sysdeps/test/all-tests.lisp | 15 + third-party/s-sysdeps/test/test-sysdeps.lisp | 19 + third-party/s-xml-rpc/.clbuild-skip-update | 0 third-party/s-xml-rpc/ChangeLog | 63 ++ third-party/s-xml-rpc/Makefile | 33 + third-party/s-xml-rpc/s-xml-rpc.asd | 32 + third-party/s-xml-rpc/src/aserve.lisp | 79 +++ .../s-xml-rpc/src/define-xmlrpc-method.lisp | 30 + third-party/s-xml-rpc/src/extensions.lisp | 107 ++++ third-party/s-xml-rpc/src/package.lisp | 49 ++ third-party/s-xml-rpc/src/validator1-client.lisp | 182 ++++++ third-party/s-xml-rpc/src/validator1-server.lisp | 90 +++ third-party/s-xml-rpc/src/xml-rpc.lisp | 586 +++++++++++++++++ third-party/s-xml-rpc/test/all-tests.lisp | 17 + third-party/s-xml-rpc/test/test-base64.lisp | 123 ++++ third-party/s-xml-rpc/test/test-extensions.lisp | 53 ++ third-party/s-xml-rpc/test/test-xml-rpc.lisp | 176 ++++++ third-party/s-xml-rpc/test/test.b64 | 1 + third-party/s-xml/.clbuild-skip-update | 0 third-party/s-xml/ChangeLog | 66 ++ third-party/s-xml/Makefile | 35 ++ third-party/s-xml/examples/counter.lisp | 47 ++ third-party/s-xml/examples/echo.lisp | 64 ++ third-party/s-xml/examples/remove-markup.lisp | 21 + third-party/s-xml/examples/tracer.lisp | 57 ++ third-party/s-xml/s-xml.asd | 49 ++ third-party/s-xml/src/dom.lisp | 75 +++ third-party/s-xml/src/lxml-dom.lisp | 83 +++ third-party/s-xml/src/package.lisp | 46 ++ third-party/s-xml/src/sxml-dom.lisp | 76 +++ third-party/s-xml/src/xml-struct-dom.lisp | 125 ++++ third-party/s-xml/src/xml.lisp | 700 +++++++++++++++++++++ third-party/s-xml/test/ant-build-file.xml | 252 ++++++++ third-party/s-xml/test/plist.xml | 38 ++ third-party/s-xml/test/simple.xml | 5 + third-party/s-xml/test/test-lxml-dom.lisp | 86 +++ third-party/s-xml/test/test-sxml-dom.lisp | 76 +++ third-party/s-xml/test/test-xml-struct-dom.lisp | 84 +++ third-party/s-xml/test/test-xml.lisp | 86 +++ third-party/s-xml/test/xhtml-page.xml | 271 ++++++++ 60 files changed, 5469 insertions(+) create mode 100644 third-party/s-base64/.clbuild-skip-update create mode 100644 third-party/s-base64/Makefile create mode 100644 third-party/s-base64/README.txt create mode 100644 third-party/s-base64/doc/API.html create mode 100644 third-party/s-base64/doc/index.html create mode 100644 third-party/s-base64/s-base64.asd create mode 100644 third-party/s-base64/src/base64.lisp create mode 100644 third-party/s-base64/src/package.lisp create mode 100644 third-party/s-base64/test/all-tests.lisp create mode 100644 third-party/s-base64/test/test-base64.lisp create mode 100644 third-party/s-base64/test/test.b64 create mode 100644 third-party/s-sysdeps/.clbuild-skip-update create mode 100644 third-party/s-sysdeps/Makefile create mode 100644 third-party/s-sysdeps/README.txt create mode 100644 third-party/s-sysdeps/doc/API.html create mode 100644 third-party/s-sysdeps/doc/index.html create mode 100644 third-party/s-sysdeps/s-sysdeps.asd create mode 100644 third-party/s-sysdeps/src/bivalent-streams.lisp create mode 100644 third-party/s-sysdeps/src/package.lisp create mode 100644 third-party/s-sysdeps/src/sysdeps.lisp create mode 100644 third-party/s-sysdeps/test/all-tests.lisp create mode 100644 third-party/s-sysdeps/test/test-sysdeps.lisp create mode 100644 third-party/s-xml-rpc/.clbuild-skip-update create mode 100644 third-party/s-xml-rpc/ChangeLog create mode 100644 third-party/s-xml-rpc/Makefile create mode 100644 third-party/s-xml-rpc/s-xml-rpc.asd create mode 100644 third-party/s-xml-rpc/src/aserve.lisp create mode 100644 third-party/s-xml-rpc/src/define-xmlrpc-method.lisp create mode 100644 third-party/s-xml-rpc/src/extensions.lisp create mode 100644 third-party/s-xml-rpc/src/package.lisp create mode 100644 third-party/s-xml-rpc/src/validator1-client.lisp create mode 100644 third-party/s-xml-rpc/src/validator1-server.lisp create mode 100644 third-party/s-xml-rpc/src/xml-rpc.lisp create mode 100644 third-party/s-xml-rpc/test/all-tests.lisp create mode 100644 third-party/s-xml-rpc/test/test-base64.lisp create mode 100644 third-party/s-xml-rpc/test/test-extensions.lisp create mode 100644 third-party/s-xml-rpc/test/test-xml-rpc.lisp create mode 100644 third-party/s-xml-rpc/test/test.b64 create mode 100644 third-party/s-xml/.clbuild-skip-update create mode 100644 third-party/s-xml/ChangeLog create mode 100644 third-party/s-xml/Makefile create mode 100644 third-party/s-xml/examples/counter.lisp create mode 100644 third-party/s-xml/examples/echo.lisp create mode 100644 third-party/s-xml/examples/remove-markup.lisp create mode 100644 third-party/s-xml/examples/tracer.lisp create mode 100644 third-party/s-xml/s-xml.asd create mode 100644 third-party/s-xml/src/dom.lisp create mode 100644 third-party/s-xml/src/lxml-dom.lisp create mode 100644 third-party/s-xml/src/package.lisp create mode 100644 third-party/s-xml/src/sxml-dom.lisp create mode 100644 third-party/s-xml/src/xml-struct-dom.lisp create mode 100644 third-party/s-xml/src/xml.lisp create mode 100644 third-party/s-xml/test/ant-build-file.xml create mode 100644 third-party/s-xml/test/plist.xml create mode 100644 third-party/s-xml/test/simple.xml create mode 100644 third-party/s-xml/test/test-lxml-dom.lisp create mode 100644 third-party/s-xml/test/test-sxml-dom.lisp create mode 100644 third-party/s-xml/test/test-xml-struct-dom.lisp create mode 100644 third-party/s-xml/test/test-xml.lisp create mode 100644 third-party/s-xml/test/xhtml-page.xml 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 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 @@ +S-BASE64

API for package S-BASE64

+
An implementation of standard Base64 encoding and decoding
+

(decode-base64 in out)   function

+
Decode a base64 encoded character input stream into a binary output stream
+

(decode-base64-bytes stream)   function

+
Decode a base64 encoded character stream, returns a byte array
+

(encode-base64 in out &optional (break-lines t))   function

+
Encode a binary input stream into a base64 encoded character output stream
+

(encode-base64-bytes array stream &optional (break-lines t))   function

+
Encode a byte array into a base64b encoded character stream
+

Documentation generated by lispdoc running on LispWorks

 \ 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 @@ + + + +S-BASE64 + + + + + + + + +

Open Source Common Lisp Software

+

S-BASE64

+

A Common Lisp implementation of Base64 Encoding/Decoding

+

+S-BASE64 +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 Wikipedia article on Base64. +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 +other Open Source Common Lisp packages. +

+

Contents

+ +

Features

+

+S-BASE64 can: +

+ +

Status

+

+S-BASE64 is considered stable code. +

+

News

+

+October 2005 - Created as a seperate project. +

+

Platforms

+

+S-BASE64 is written in ANSI standard Common Lisp and should be portable across any CL implementation. +

+

Downloading

+

+You can download the latested released tarball of the S-BASE64 package from +http://homepage.mac.com/svc/s-base64/s-base64.tar.gz. +This archive is signed on release by Sven Van Caekenberghe, +whose public key is published at +http://homepage.mac.com/svc/sven-public-ascii.gpg, +the signature is in +http://homepage.mac.com/svc/s-base64/s-base64.tar.gz.asc. +

+

+Alternatively you can access the DARCS repository at +http://www.beta9.be/darcs/s-base64. +For a good description on how to use DARCS see +http://dirkgerrits.com/programming/erlisp/download/. +

+
+
$ 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!
+
+
Example of basic darcs usage, get everything once and keep up to date by pulling in changes
+

Installation

+

+The S-BASE64 package is loaded using ASDF. +There is an excellent tutorial on ASDF to get you started. +Alternatively you can use ASDF-INSTALL. +There is an great tutorial on ASDF-INSTALL to get you on the way. +

+
+
$ 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
+; #<The ASDF787 package, 0/16 internal, 0/16 external>
+; Loading text file /Users/sven/darcs/s-base64/s-base64.asd
+; registering # 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
+
+
Example of setting up and using ASDF to compile and load the package
+

Usage

+

+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: +

+
+
CL-USER 1 > (in-package :s-base64)
+#<The S-BASE64 package, 50/128 internal, 4/16 external>
+
+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)
+
+
Example Base64 Encoding and Decoding
+

API Reference

+

+There is automatically generated API Reference documentation available for the S-BASE64 package. +

+

Mailinglist

+

+The KPAX mailing list is used for this project. +

+

Changelog

+

+Release Notes: +

+ +

TODO

+

+There is a variant of Base64 encoding used for URL's and filenames that could be implemented. +

+

FAQ

+

+Nothing appropriate. +

+

Bugs

+

+Illegal input results in generic low-level CL conditions rather than a more meaningful high-level application specific condition. +

+

Authors

+

+S-BASE64 was written by Sven Van Caekenberghe. +

+

Maintainers

+

+S-BASE64 is being maintained by Sven Van Caekenberghe. +

+

License

+

+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. +

+

History

+

+S-BASE64 was originally part of KPAX and became a seperate project in October 2005. +

+

References

+

+The following RFC's can be considered as definitions of Base64 Encoding: +

+

+
+Copyright © 2002-2006 Sven Van Caekenberghe, Beta Nine BVBA. All Right Reserved. - +This page is W3C Valid XHTML 1.0 Strict - +Viewable With Any Browser +
+ + 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 " + :version "2" + :maintainer "Sven Van Caekenberghe " + :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 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 @@ +S-SYSDEPS

API for package S-SYSDEPS

+
S-SYSDEPS is an abstraction layer over platform dependent functionality
+

(all-processes)   function

+
Return a list of all processes currently running
+

(current-process)   function

+
Return the object representing the current process
+

(kill-process process)   function

+
Kill the process represented by the object process
+

(make-process-lock name)   function

+
Create a named process lock object
+

(open-socket-stream host port)   function

+
Create and open a bidirectional client TCP/IP socket stream to host:port
+

(run-process name function &rest arguments)   function

+
Create and run a new process with name, executing function on arguments
+

(start-standard-server &key port name connection-handler)   function

+
Start a server process with name, listening on port, delegating to connection-handler with stream as argument
+

(with-process-lock (lock) &body body)   function

+
Execute body wih the process lock grabbed, wait otherwise
+

Documentation generated by lispdoc running on LispWorks

 \ 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 @@ + + + +S-SYSDEPS + + + + + + + + +

Open Source Common Lisp Software

+

S-SYSDEPS

+

An Abstraction Layer Over Platform Dependent Functionality

+

+S-SYSDEPS +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 +other Open Source Common Lisp packages. +

+

Contents

+ +

Features

+

+S-SYSDEPS abstracts: +

+
    +
  • managing processes
    • +
  • implementing a standard TCP/IP server
    • +
  • opening a client TCP/IP socket stream
    • +
  • working with process locks
    • +
+

Status

+

+S-SYSDEPS is considered stable code. +

+

News

+

+November 2005 - Created as a seperate project. +

+

Platforms

+

+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. +

+

Downloading

+

+You can download the latested released tarball of the S-SYSDEPS package from +http://homepage.mac.com/svc/s-sysdeps/s-sysdeps.tar.gz. +This archive is signed on release by Sven Van Caekenberghe, +whose public key is published at +http://homepage.mac.com/svc/sven-public-ascii.gpg, +the signature is in +http://homepage.mac.com/svc/s-sysdeps/s-sysdeps.tar.gz.asc. +

+

+Alternatively you can access the DARCS repository at +http://www.beta9.be/darcs/s-base64. +For a good description on how to use DARCS see +http://dirkgerrits.com/programming/erlisp/download/. +

+
+
$ darcs get http://www.beta9.be/darcs/s-sysdeps
+
+
Example of basic darcs usage, get everything once and keep up to date by pulling in changes
+

Installation

+

+The S-SYSDEPS package is loaded using ASDF. +There is an excellent tutorial on ASDF to get you started. +Alternatively you can use ASDF-INSTALL. +There is an great tutorial on ASDF-INSTALL to get you on the way. +

+
+
CL-USER 1 > (asdf:oos 'asdf:load-op :s-sysdeps)
+
+
Example of setting up and using ASDF to compile and load the package
+

Usage

+

+For usage examples please have a look at the package using S-SYSDEPS. +

+

API Reference

+

+There is automatically generated API Reference documentation available for the S-SYSDEPS package. +

+

Mailinglist

+

+There is no mailing list for this project. +

+

Changelog

+

+Release Notes: +

+
    +
  • release 1: moved S-SYSDEPS into a seperate project under a new structure
    • +
+

TODO

+

+Port to even more platforms. Add some unit or functional tests, as well as some examples. +

+

FAQ

+

+Nothing appropriate. +

+

Bugs

+

+There are no known bugs. +

+

Authors

+

+S-SYSDEPS was written by Sven Van Caekenberghe. +Ports to CMUCL and SBCL were contributed. +

+

Maintainers

+

+S-SYSDEPS is being maintained by Sven Van Caekenberghe. +

+

License

+

+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. +

+

History

+

+This file was part of S-XML-RPC and (N)KPAX. +

+

References

+

+Thera are no references. +

+
+Copyright © 2004-2005 Sven Van Caekenberghe, Beta Nine BVBA. All Right Reserved. - +This page is W3C Valid XHTML 1.0 Strict - +Viewable With Any Browser +
+ + 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 " + :version "1" + :maintainer "Sven Van Caekenberghe " + :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 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 + + * 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 and 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 + + * fixed a performance issue in base64 decoding + +2004-10-26 Rudi Schlatte + + * src/sysdeps.lisp (with-open-socket-stream, run-process) + (start-standard-server, stop-server): Port to cmucl. + +2004-06-17 Rudi Schlatte + + * 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 + + * 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 " + :version "7" + :maintainer "Sven Van Caekenberghe , 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 + "#" + (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-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-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 "" stream) + (dolist (member (xml-rpc-struct-alist struct)) + (write-string "" stream) + (format stream "~a" (car member)) ; assuming name contains no special characters + (encode-xml-rpc-value (cdr member) stream) + (write-string "" stream)) + (write-string "" stream)) + +(defun encode-xml-rpc-array (sequence stream) + (write-string "" stream) + (map 'nil #'(lambda (element) (encode-xml-rpc-value element stream)) sequence) + (write-string "" stream)) + +(defun encode-xml-rpc-value (arg stream) + (write-string "" stream) + (cond ((or (null arg) (eql arg t)) + (write-string "" stream) + (write-string (if arg "1" "0") stream) + (write-string "" stream)) + ((or (stringp arg) (symbolp arg)) + (write-string "" stream) + (print-string-xml (string arg) stream) + (write-string "" stream)) + ((integerp arg) (format stream "~d" arg)) + ((floatp arg) (format stream "~f" arg)) + ((and (arrayp arg) + (= (array-rank arg) 1) + (subtypep (array-element-type arg) + '(unsigned-byte 8))) + (write-string "" stream) + (encode-base64-bytes arg stream) + (write-string "" stream)) + ((xml-rpc-time-p arg) + (write-string "" stream) + (universal-time->iso8601 (xml-rpc-time-universal-time arg) stream) + (write-string "" 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 "" stream)) + +(defun encode-xml-rpc-args (args stream) + (write-string "" stream) + (dolist (arg args) + (write-string "" stream) + (encode-xml-rpc-value arg stream) + (write-string "" stream)) + (write-string "" 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 "" 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 "~a" (string name)) ; assuming name contains no special characters + (when args + (encode-xml-rpc-args args stream)) + (write-string "" stream))) + +(defun encode-xml-rpc-result (value) + (with-output-to-string (stream) + (write-string "" stream) + (encode-xml-rpc-args (list value) stream) + (write-string "" stream))) + +(defun encode-xml-rpc-fault-value (fault-string &optional (fault-code 0)) + ;; for system.multicall + (with-output-to-string (stream) + (write-string "" stream) + (format stream "faultCode~d" fault-code) + (write-string "faultString" stream) + (print-string-xml fault-string stream) + (write-string "" stream) + (write-string "" stream))) + +(defun encode-xml-rpc-fault (fault-string &optional (fault-code 0)) + (with-output-to-string (stream) + (write-string "" stream) + (write-string (encode-xml-rpc-fault-value fault-string fault-code) stream) + (write-string "" 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 +" + + +")))) + +(assert (equalp (decode-xml-rpc (make-string-input-stream +" + + + foo + + + + + + + 12 + Egypt + 1 + + + fgo + -31 + + -12.214 + + 19980717T14:08:55 + eW91IGNhbid0IHJlYWQgdGhpcyE= + + + + +")) +`(" + 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 +" + + + +")) +'(""))) + +(assert (equalp (decode-xml-rpc (make-string-input-stream +" + + + XYZ + + +")) +'("XYZ"))) + +;; double decoding + +(assert (< (abs (- (decode-xml-rpc (make-string-input-stream "3.141592653589793")) + pi)) + 0.000000000001D0)) + +;; string decoding + +(assert (equal (decode-xml-rpc (make-string-input-stream "foo")) + "foo")) + +(assert (equal (decode-xml-rpc (make-string-input-stream "foo")) + "foo")) + +(assert (equal (decode-xml-rpc (make-string-input-stream "")) + "")) + +(assert (equal (decode-xml-rpc (make-string-input-stream "")) + "")) + +;; boolean encoding + +(assert (equal (with-output-to-string (out) + (encode-xml-rpc-value t out)) + "1")) + +(assert (equal (with-output-to-string (out) + (encode-xml-rpc-value nil out)) + "0")) + + +;; boolean decoding + +(assert (equal (decode-xml-rpc (make-string-input-stream "1")) + t)) + +(assert (equal (decode-xml-rpc (make-string-input-stream "0")) + 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 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 + + * 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 + + * added xml prefix namespace as per REC-xml-names-19990114 (by Rudi Schlatte) + +2005-11-06 Sven Van Caekenberghe + + * 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 + + * added Debian packaging directory (contributed by Luca Capello luca@pca.it) + * added experimental XML namespace support + +2005-02-03 Sven Van Caekenberghe + + * release 5 (cvs tag RELEASE_5) + * added :start and :end keywords to print-string-xml + * fixed a bug: in a tag containing whitespace, like the parser collapsed + and ingnored all whitespace and considered the tag to be empty! + this is now fixed and a unit test has been added + * cleaned up xml character escaping a bit: single quotes and all normal whitespace + (newline, return and tab) is preserved a unit test for this has been added + * IE doesn't understand the ' XML entity, so I've commented that out for now. + Also, using actual newlines for newlines is probably better than using #xA, + which won't get any end of line conversion by the server or user agent. + +June 2004 Sven Van Caekenberghe + + * 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 + + * release 3 + * added ASDF systems + * optimized print-string-xml + +10 Jun 2003 Sven Van Caekenberghe + + * 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 + + * 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 + + * 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 "~%" 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 " + :version "3" + :maintainer "Sven Van Caekenberghe , 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)) + +(defun print-attribute (name value stream) + (write-char #\space stream) + (print-identifier name stream t) + (write-string "=\"" stream) + (print-string-xml value stream) + (write-char #\" stream)) + +;;;; eof diff --git a/third-party/s-xml/src/lxml-dom.lisp b/third-party/s-xml/src/lxml-dom.lisp new file mode 100644 index 0000000..449fea3 --- /dev/null +++ b/third-party/s-xml/src/lxml-dom.lisp @@ -0,0 +1,83 @@ +;;;; -*- mode: lisp -*- +;;;; +;;;; $Id: lxml-dom.lisp,v 1.6 2005-11-20 14:34:15 scaekenberghe Exp $ +;;;; +;;;; LXML implementation of the generic DOM parser and printer. +;;;; +;;;; Copyright (C) 2002, 2004 Sven Van Caekenberghe, Beta Nine BVBA. +;;;; +;;;; You are granted the rights to distribute and use this software +;;;; as governed by the terms of the Lisp Lesser General Public License +;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. + +(in-package :s-xml) + +;;; the lxml hooks to generate lxml + +(defun lxml-new-element-hook (name attributes seed) + (declare (ignore name attributes seed)) + '()) + +(defun lxml-finish-element-hook (name attributes parent-seed seed) + (let ((xml-element + (cond ((and (null seed) (null attributes)) + name) + (attributes + `((,name ,@(let (list) + (dolist (attribute attributes list) + (push (cdr attribute) list) + (push (car attribute) list)))) + ,@(nreverse seed))) + (t + `(,name ,@(nreverse seed)))))) + (cons xml-element parent-seed))) + +(defun lxml-text-hook (string seed) + (cons string seed)) + +;;; standard DOM interfaces + +(defmethod parse-xml-dom (stream (output-type (eql :lxml))) + (car (start-parse-xml stream + (make-instance 'xml-parser-state + :new-element-hook #'lxml-new-element-hook + :finish-element-hook #'lxml-finish-element-hook + :text-hook #'lxml-text-hook)))) + +(defun plist->alist (plist) + (when plist + (cons (cons (first plist) (second plist)) + (plist->alist (rest (rest plist)))))) + +(defmethod print-xml-dom (dom (input-type (eql :lxml)) stream pretty level) + (declare (special *namespaces*)) + (cond ((symbolp dom) (print-solitary-tag dom stream)) + ((stringp dom) (print-string-xml dom stream)) + ((consp dom) + (let (tag attributes) + (cond ((symbolp (first dom)) (setf tag (first dom))) + ((consp (first dom)) (setf tag (first (first dom)) + attributes (plist->alist (rest (first dom))))) + (t (error "Input not recognized as LXML ~s" dom))) + (let ((*namespaces* (extend-namespaces attributes *namespaces*))) + (write-char #\< stream) + (print-identifier tag stream) + (loop :for (name . value) :in attributes + :do (print-attribute name value stream)) + (if (rest dom) + (let ((children (rest dom))) + (write-char #\> stream) + (if (and (= (length children) 1) (stringp (first children))) + (print-string-xml (first children) stream) + (progn + (dolist (child children) + (when pretty (print-spaces (* 2 level) stream)) + (if (stringp child) + (print-string-xml child stream) + (print-xml-dom child input-type stream pretty (1+ level)))) + (when pretty (print-spaces (* 2 (1- level)) stream)))) + (print-closing-tag tag stream)) + (write-string "/>" stream))))) + (t (error "Input not recognized as LXML ~s" dom)))) + +;;;; eof \ No newline at end of file diff --git a/third-party/s-xml/src/package.lisp b/third-party/s-xml/src/package.lisp new file mode 100644 index 0000000..1fc0cca --- /dev/null +++ b/third-party/s-xml/src/package.lisp @@ -0,0 +1,46 @@ +;;;; -*- mode: lisp -*- +;;;; +;;;; $Id: package.lisp,v 1.8 2006-01-31 11:44:15 scaekenberghe Exp $ +;;;; +;;;; This is a Common Lisp implementation of a very basic XML parser. +;;;; The parser is non-validating. +;;;; The API into the parser is pure functional parser hook model that comes from SSAX, +;;;; see also http://pobox.com/~oleg/ftp/Scheme/xml.html or http://ssax.sourceforge.net +;;;; Different DOM models are provided, an XSML, an LXML and a xml-element struct based one. +;;;; +;;;; Copyright (C) 2002, 2003, 2004, 2005, 2006 Sven Van Caekenberghe, Beta Nine BVBA. +;;;; +;;;; You are granted the rights to distribute and use this software +;;;; as governed by the terms of the Lisp Lesser General Public License +;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. + +(defpackage s-xml + (:use common-lisp) + (:export + ;; main parser interface + #:start-parse-xml + #:print-string-xml + #:xml-parser-error #:xml-parser-error-message #:xml-parser-error-args #:xml-parser-error-stream + #:xml-parser-state #:get-entities #:get-seed + #:get-new-element-hook #:get-finish-element-hook #:get-text-hook + ;; callbacks + #:*attribute-name-parser* + #:*attribute-value-parser* + #:parse-attribute-name + #:parse-attribute-value + ;; dom parser and printer + #:parse-xml-dom #:parse-xml #:parse-xml-string #:parse-xml-file + #:print-xml-dom #:print-xml #:print-xml-string + ;; xml-element structure + #:make-xml-element #:xml-element-children #:xml-element-name + #:xml-element-attribute #:xml-element-attributes + #:xml-element-p #:new-xml-element #:first-xml-element-child + ;; namespaces + #:*ignore-namespaces* #:*local-namespace* #:*namespaces* + #:*require-existing-symbols* #:*auto-export-symbols* #:*auto-create-namespace-packages* + #:find-namespace #:register-namespace #:get-prefix #:get-uri #:get-package + #:resolve-identifier #:extend-namespaces #:print-identifier #:split-identifier) + (:documentation + "A simple XML parser with an efficient, purely functional, event-based interface as well as a DOM interface")) + +;;;; eof diff --git a/third-party/s-xml/src/sxml-dom.lisp b/third-party/s-xml/src/sxml-dom.lisp new file mode 100644 index 0000000..dee3de8 --- /dev/null +++ b/third-party/s-xml/src/sxml-dom.lisp @@ -0,0 +1,76 @@ +;;;; -*- mode: lisp -*- +;;;; +;;;; $Id: sxml-dom.lisp,v 1.5 2005-11-20 14:34:15 scaekenberghe Exp $ +;;;; +;;;; LXML implementation of the generic DOM parser and printer. +;;;; +;;;; Copyright (C) 2003, 2004 Sven Van Caekenberghe, Beta Nine BVBA. +;;;; +;;;; You are granted the rights to distribute and use this software +;;;; as governed by the terms of the Lisp Lesser General Public License +;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. + +(in-package :s-xml) + +;;; the sxml hooks to generate sxml + +(defun sxml-new-element-hook (name attributes seed) + (declare (ignore name attributes seed)) + '()) + +(defun sxml-finish-element-hook (name attributes parent-seed seed) + (let ((xml-element (append (list name) + (when attributes + (list (let (list) + (dolist (attribute attributes (cons :@ list)) + (push (list (car attribute) (cdr attribute)) list))))) + (nreverse seed)))) + (cons xml-element parent-seed))) + +(defun sxml-text-hook (string seed) + (cons string seed)) + +;;; the standard DOM interfaces + +(defmethod parse-xml-dom (stream (output-type (eql :sxml))) + (car (start-parse-xml stream + (make-instance 'xml-parser-state + :new-element-hook #'sxml-new-element-hook + :finish-element-hook #'sxml-finish-element-hook + :text-hook #'sxml-text-hook)))) + +(defmethod print-xml-dom (dom (input-type (eql :sxml)) stream pretty level) + (declare (special *namespaces*)) + (cond ((stringp dom) (print-string-xml dom stream)) + ((consp dom) + (let ((tag (first dom)) + attributes + children) + (if (and (consp (second dom)) (eq (first (second dom)) :@)) + (setf attributes (rest (second dom)) + children (rest (rest dom))) + (setf children (rest dom))) + (let ((*namespaces* (extend-namespaces (loop :for (name value) :in attributes + :collect (cons name value)) + *namespaces*))) + (write-char #\< stream) + (print-identifier tag stream) + (loop :for (name value) :in attributes + :do (print-attribute name value stream)) + (if children + (progn + (write-char #\> stream) + (if (and (= (length children) 1) (stringp (first children))) + (print-string-xml (first children) stream) + (progn + (dolist (child children) + (when pretty (print-spaces (* 2 level) stream)) + (if (stringp child) + (print-string-xml child stream) + (print-xml-dom child input-type stream pretty (1+ level)))) + (when pretty (print-spaces (* 2 (1- level)) stream)))) + (print-closing-tag tag stream)) + (write-string "/>" stream))))) + (t (error "Input not recognized as SXML ~s" dom)))) + +;;;; eof diff --git a/third-party/s-xml/src/xml-struct-dom.lisp b/third-party/s-xml/src/xml-struct-dom.lisp new file mode 100644 index 0000000..916f747 --- /dev/null +++ b/third-party/s-xml/src/xml-struct-dom.lisp @@ -0,0 +1,125 @@ +;;;; -*- mode: lisp -*- +;;;; +;;;; $Id: xml-struct-dom.lisp,v 1.3 2005-09-20 09:57:48 scaekenberghe Exp $ +;;;; +;;;; XML-STRUCT implementation of the generic DOM parser and printer. +;;;; +;;;; Copyright (C) 2002, 2004 Sven Van Caekenberghe, Beta Nine BVBA. +;;;; +;;;; You are granted the rights to distribute and use this software +;;;; as governed by the terms of the Lisp Lesser General Public License +;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. + +(in-package :s-xml) + +;;; xml-element struct datastructure and API + +(defstruct xml-element + name ; :tag-name + attributes ; a assoc list of (:attribute-name . "attribute-value") + children ; a list of children/content either text strings or xml-elements + ) + +(setf (documentation 'xml-element-p 'function) + "Return T when the argument is an xml-element struct" + (documentation 'xml-element-attributes 'function) + "Return the alist of attribute names and values dotted pairs from an xml-element struct" + (documentation 'xml-element-children 'function) + "Return the list of children from an xml-element struct" + (documentation 'xml-element-name 'function) + "Return the name from an xml-element struct" + (documentation 'make-xml-element 'function) + "Make and return a new xml-element struct") + +(defun xml-element-attribute (xml-element key) + "Return the string value of the attribute with name the keyword :key + of xml-element if any, return null if not found" + (let ((pair (assoc key (xml-element-attributes xml-element) :test #'eq))) + (when pair (cdr pair)))) + +(defun (setf xml-element-attribute) (value xml-element key) + "Set the string value of the attribute with name the keyword :key of + xml-element, creating a new attribute if necessary or overwriting an + existing one, returning the value" + (let ((attributes (xml-element-attributes xml-element))) + (if (null attributes) + (push (cons key value) (xml-element-attributes xml-element)) + (let ((pair (assoc key attributes :test #'eq))) + (if pair + (setf (cdr pair) value) + (push (cons key value) (xml-element-attributes xml-element))))) + value)) + +(defun new-xml-element (name &rest children) + "Make a new xml-element with name and children" + (make-xml-element :name name :children children)) + +(defun first-xml-element-child (xml-element) + "Get the first child of an xml-element" + (first (xml-element-children xml-element))) + +(defun xml-equal (xml-1 xml-2) + (and (xml-element-p xml-1) + (xml-element-p xml-2) + (eq (xml-element-name xml-1) + (xml-element-name xml-2)) + (equal (xml-element-attributes xml-1) + (xml-element-attributes xml-2)) + (reduce #'(lambda (&optional (x t) (y t)) (and x y)) + (mapcar #'(lambda (x y) + (or (and (stringp x) (stringp y) (string= x y)) + (xml-equal x y))) + (xml-element-children xml-1) + (xml-element-children xml-2))))) + +;;; printing xml structures + +(defmethod print-xml-dom (xml-element (input-type (eql :xml-struct)) stream pretty level) + (declare (special *namespaces*)) + (let ((*namespaces* (extend-namespaces (xml-element-attributes xml-element) + *namespaces*))) + (write-char #\< stream) + (print-identifier (xml-element-name xml-element) stream) + (loop :for (name . value) :in (xml-element-attributes xml-element) + :do (print-attribute name value stream)) + (let ((children (xml-element-children xml-element))) + (if children + (progn + (write-char #\> stream) + (if (and (= (length children) 1) (stringp (first children))) + (print-string-xml (first children) stream) + (progn + (dolist (child children) + (when pretty (print-spaces (* 2 level) stream)) + (if (stringp child) + (print-string-xml child stream) + (print-xml-dom child input-type stream pretty (1+ level)))) + (when pretty (print-spaces (* 2 (1- level)) stream)))) + (print-closing-tag (xml-element-name xml-element) stream)) + (write-string "/>" stream))))) + +;;; the standard hooks to generate xml-element structs + +(defun standard-new-element-hook (name attributes seed) + (declare (ignore name attributes seed)) + '()) + +(defun standard-finish-element-hook (name attributes parent-seed seed) + (let ((xml-element (make-xml-element :name name + :attributes attributes + :children (nreverse seed)))) + (cons xml-element parent-seed))) + +(defun standard-text-hook (string seed) + (cons string seed)) + +;;; top level standard parser interfaces + +(defmethod parse-xml-dom (stream (output-type (eql :xml-struct))) + (car (start-parse-xml stream + (make-instance 'xml-parser-state + :new-element-hook #'standard-new-element-hook + :finish-element-hook #'standard-finish-element-hook + :text-hook #'standard-text-hook)))) + +;;;; eof diff --git a/third-party/s-xml/src/xml.lisp b/third-party/s-xml/src/xml.lisp new file mode 100644 index 0000000..8df61c6 --- /dev/null +++ b/third-party/s-xml/src/xml.lisp @@ -0,0 +1,700 @@ +;;;; -*- mode: lisp -*- +;;;; +;;;; $Id: xml.lisp,v 1.16 2006-01-31 11:44:15 scaekenberghe Exp $ +;;;; +;;;; This is a Common Lisp implementation of a basic but usable XML parser. +;;;; The parser is non-validating and not complete (no PI). +;;;; Namespace and entities are handled. +;;;; The API into the parser is a pure functional parser hook model that comes from SSAX, +;;;; see also http://pobox.com/~oleg/ftp/Scheme/xml.html or http://ssax.sourceforge.net +;;;; Different DOM models are provided, an XSML, an LXML and a xml-element struct based one. +;;;; +;;;; Copyright (C) 2002, 2003, 2004, 2005, 2006 Sven Van Caekenberghe, Beta Nine BVBA. +;;;; +;;;; You are granted the rights to distribute and use this software +;;;; as governed by the terms of the Lisp Lesser General Public License +;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. + +(in-package :s-xml) + +;;; error reporting + +(define-condition xml-parser-error (error) + ((message :initarg :message :reader xml-parser-error-message) + (args :initarg :args :reader xml-parser-error-args) + (stream :initarg :stream :reader xml-parser-error-stream :initform nil)) + (:report (lambda (condition stream) + (format stream + "XML parser ~?~@[ near stream position ~d~]." + (xml-parser-error-message condition) + (xml-parser-error-args condition) + (and (xml-parser-error-stream condition) + (file-position (xml-parser-error-stream condition)))))) + (:documentation "Thrown by the XML parser to indicate errorneous input")) + +(setf (documentation 'xml-parser-error-message 'function) + "Get the message from an XML parser error" + (documentation 'xml-parser-error-args 'function) + "Get the error arguments from an XML parser error" + (documentation 'xml-parser-error-stream 'function) + "Get the stream from an XML parser error") + +(defun parser-error (message &optional args stream) + (make-condition 'xml-parser-error + :message message + :args args + :stream stream)) + +;; attribute parsing hooks +;; this is a bit complicated, refer to the mailing lists for a more detailed explanation + +(defun parse-attribute-name (string) + "Default parser for the attribute name" + (declare (special *namespaces*)) + (resolve-identifier string *namespaces* t)) + +(defun parse-attribute-value (name string) + "Default parser for the attribute value" + (declare (ignore name) + (special *ignore-namespace*)) + (if *ignore-namespaces* + (copy-seq string) + string)) + +(defparameter *attribute-name-parser* #'parse-attribute-name + "Called to compute interned attribute name from a buffer that will be reused") + +(defparameter *attribute-value-parser* #'parse-attribute-value + "Called to compute an element of an attribute list from a buffer that will be reused") + +;;; utilities + +(defun whitespace-char-p (char) + "Is char an XML whitespace character ?" + (declare (type character char)) + (or (char= char #\space) + (char= char #\tab) + (char= char #\return) + (char= char #\linefeed))) + +(defun identifier-char-p (char) + "Is char an XML identifier character ?" + (declare (type character char)) + (or (and (char<= #\A char) (char<= char #\Z)) + (and (char<= #\a char) (char<= char #\z)) + (and (char<= #\0 char) (char<= char #\9)) + (char= char #\-) + (char= char #\_) + (char= char #\.) + (char= char #\:))) + +(defun skip-whitespace (stream) + "Skip over XML whitespace in stream, return first non-whitespace + character which was peeked but not read, return nil on eof" + (loop + (let ((char (peek-char nil stream nil #\Null))) + (declare (type character char)) + (if (whitespace-char-p char) + (read-char stream) + (return char))))) + +(defun make-extendable-string (&optional (size 10)) + "Make an extendable string which is a one-dimensional character + array which is adjustable and has a fill pointer" + (make-array size + :element-type 'character + :adjustable t + :fill-pointer 0)) + +(defun print-string-xml (string stream &key (start 0) end) + "Write the characters of string to stream using basic XML conventions" + (loop for offset upfrom start below (or end (length string)) + for char = (char string offset) + do (case char + (#\& (write-string "&" stream)) + (#\< (write-string "<" stream)) + (#\> (write-string ">" stream)) + (#\" (write-string """ stream)) + ((#\newline #\return #\tab) (write-char char stream)) + (t (if (and (<= 32 (char-code char)) + (<= (char-code char) 126)) + (write-char char stream) + (progn + (write-string "&#x" stream) + (write (char-code char) :stream stream :base 16) + (write-char #\; stream))))))) + +(defun make-standard-entities () + "A hashtable mapping XML entity names to their replacement strings, + filled with the standard set" + (let ((entities (make-hash-table :test #'equal))) + (setf (gethash "amp" entities) (string #\&) + (gethash "quot" entities) (string #\") + (gethash "apos" entities) (string #\') + (gethash "lt" entities) (string #\<) + (gethash "gt" entities) (string #\>) + (gethash "nbsp" entities) (string #\space)) + entities)) + +(defun resolve-entity (stream extendable-string entities entity) + "Read and resolve an XML entity from stream, positioned after the '&' entity marker, + accepting &name; &#DEC; and &#xHEX; formats, + destructively modifying string, which is also returned, + destructively modifying entity, incorrect entity formats result in errors" + (declare (type (vector character) entity)) + (loop + (let ((char (read-char stream nil #\Null))) + (declare (type character char)) + (cond ((char= char #\Null) (error (parser-error "encountered eof before end of entity"))) + ((char= #\; char) (return)) + (t (vector-push-extend char entity))))) + (if (char= (char entity 0) #\#) + (let ((code (if (char= (char entity 1) #\x) + (parse-integer entity :start 2 :radix 16 :junk-allowed t) + (parse-integer entity :start 1 :radix 10 :junk-allowed t)))) + (when (null code) + (error (parser-error "encountered incorrect entity &~s;" (list entity) stream))) + (vector-push-extend (code-char code) extendable-string)) + (let ((value (gethash entity entities))) + (if value + (loop :for char :across value + :do (vector-push-extend char extendable-string)) + (error (parser-error "encountered unknown entity &~s;" (list entity) stream))))) + extendable-string) + +;;; namespace support + +(defvar *ignore-namespaces* nil + "When t, namespaces are ignored like in the old version of S-XML") + +(defclass xml-namespace () + ((uri :documentation "The URI used to identify this namespace" + :accessor get-uri + :initarg :uri) + (prefix :documentation "The preferred prefix assigned to this namespace" + :accessor get-prefix + :initarg :prefix + :initform nil) + (package :documentation "The Common Lisp package where this namespace's symbols are interned" + :accessor get-package + :initarg :package + :initform nil)) + (:documentation "Describes an XML namespace and how it is handled")) + +(setf (documentation 'get-uri 'function) + "The URI used to identify this namespace" + (documentation 'get-prefix 'function) + "The preferred prefix assigned to this namespace" + (documentation 'get-package 'function) + "The Common Lisp package where this namespace's symbols are interned") + +(defmethod print-object ((object xml-namespace) stream) + (print-unreadable-object (object stream :type t :identity t) + (format stream "~A - ~A" (get-prefix object) (get-uri object)))) + +(defvar *local-namespace* (make-instance 'xml-namespace + :uri "local" + :prefix "" + :package (find-package :keyword)) + "The local (global default) XML namespace") + +(defvar *xml-namespace* (make-instance 'xml-namespace + :uri "http://www.w3.org/XML/1998/namespace" + :prefix "xml" + :package (or (find-package :xml) + (make-package :xml :nicknames '("XML")))) + "REC-xml-names-19990114 says the prefix xml is bound to the namespace http://www.w3.org/XML/1998/namespace.") + +(defvar *known-namespaces* (list *local-namespace* *xml-namespace*) + "The list of known/defined namespaces") + +(defvar *namespaces* `(("xml" . ,*xml-namespace*) ("" . ,*local-namespace*)) + "Ordered list of (prefix . XML-namespace) bindings currently in effect - special variable") + +(defun find-namespace (uri) + "Find a registered XML namespace identified by uri" + (find uri *known-namespaces* :key #'get-uri :test #'string-equal)) + +(defun register-namespace (uri prefix package) + "Register a new or redefine an existing XML namespace defined by uri with prefix and package" + (let ((namespace (find-namespace uri))) + (if namespace + (setf (get-prefix namespace) prefix + (get-package namespace) (find-package package)) + (push (setf namespace (make-instance 'xml-namespace + :uri uri + :prefix prefix + :package (find-package package))) + *known-namespaces*)) + namespace)) + +(defun find-namespace-binding (prefix namespaces) + "Find the XML namespace currently bound to prefix in the namespaces bindings" + (cdr (assoc prefix namespaces :test #'string-equal))) + +(defun split-identifier (identifier) + "Split an identifier 'prefix:name' and return (values prefix name)" + (when (symbolp identifier) + (setf identifier (symbol-name identifier))) + (let ((colon-position (position #\: identifier :test #'char=))) + (if colon-position + (values (subseq identifier 0 colon-position) + (subseq identifier (1+ colon-position))) + (values nil identifier)))) + +(defvar *require-existing-symbols* nil + "If t, each XML identifier must exist as symbol already") + +(defvar *auto-export-symbols* t + "If t, export newly interned symbols form their packages") + +(defun resolve-identifier (identifier namespaces &optional as-attribute) + "Resolve the string identifier in the list of namespace bindings" + (if *ignore-namespaces* + (intern identifier :keyword) + (flet ((intern-symbol (string package) ; intern string as a symbol in package + (if *require-existing-symbols* + (let ((symbol (find-symbol string package))) + (or symbol + (error "Symbol ~s does not exist in ~s" string package))) + (let ((symbol (intern string package))) + (when (and *auto-export-symbols* + (not (eql package (find-package :keyword)))) + (export symbol package)) + symbol)))) + (multiple-value-bind (prefix name) + (split-identifier identifier) + (if (or (null prefix) (string= prefix "xmlns")) + (if as-attribute + (intern (if (string= prefix "xmlns") identifier name) (get-package *local-namespace*)) + (let ((default-namespace (find-namespace-binding "" namespaces))) + (intern-symbol name (get-package default-namespace)))) + (let ((namespace (find-namespace-binding prefix namespaces))) + (if namespace + (intern-symbol name (get-package namespace)) + (error "namespace not found for prefix ~s" prefix)))))))) + +(defvar *auto-create-namespace-packages* t + "If t, new packages will be created for namespaces, if needed, named by the prefix") + +(defun new-namespace (uri &optional prefix) + "Register a new namespace for uri and prefix, creating a package if necessary" + (if prefix + (register-namespace uri + prefix + (or (find-package prefix) + (if *auto-create-namespace-packages* + (make-package prefix :nicknames `(,(string-upcase prefix))) + (error "Cannot find or create package ~s" prefix)))) + (let ((unique-name (loop :for i :upfrom 0 + :do (let ((name (format nil "ns-~d" i))) + (when (not (find-package name)) + (return name)))))) + (register-namespace uri + unique-name + (if *auto-create-namespace-packages* + (make-package (string-upcase unique-name) :nicknames `(,unique-name)) + (error "Cannot create package ~s" unique-name)))))) + +(defun extend-namespaces (attributes namespaces) + "Given possible 'xmlns[:prefix]' attributes, extend the namespaces bindings" + (unless *ignore-namespaces* + (let (default-namespace-uri) + (loop :for (key . value) :in attributes + :do (if (string= key "xmlns") + (setf default-namespace-uri value) + (multiple-value-bind (prefix name) + (split-identifier key) + (when (string= prefix "xmlns") + (let* ((uri value) + (prefix name) + (namespace (find-namespace uri))) + (unless namespace + (setf namespace (new-namespace uri prefix))) + (push `(,prefix . ,namespace) namespaces)))))) + (when default-namespace-uri + (let ((namespace (find-namespace default-namespace-uri))) + (unless namespace + (setf namespace (new-namespace default-namespace-uri))) + (push `("" . ,namespace) namespaces))))) + namespaces) + +(defun print-identifier (identifier stream &optional as-attribute) + "Print identifier on stream using namespace conventions" + (declare (ignore as-attribute) (special *namespaces*)) + (if *ignore-namespaces* + (princ identifier stream) + (if (symbolp identifier) + (let ((package (symbol-package identifier)) + (name (symbol-name identifier))) + (let* ((namespace (find package *known-namespaces* :key #'get-package)) + (prefix (or (car (find namespace *namespaces* :key #'cdr)) + (get-prefix namespace)))) + (if (string= prefix "") + (princ name stream) + (format stream "~a:~a" prefix name)))) + (princ identifier stream)))) + +;;; the parser state + +(defclass xml-parser-state () + ((entities :documentation "A hashtable mapping XML entity names to their replacement stings" + :accessor get-entities + :initarg :entities + :initform (make-standard-entities)) + (seed :documentation "The user seed object" + :accessor get-seed + :initarg :seed + :initform nil) + (buffer :documentation "The main reusable character buffer" + :accessor get-buffer + :initform (make-extendable-string)) + (mini-buffer :documentation "The secondary, smaller reusable character buffer" + :accessor get-mini-buffer + :initform (make-extendable-string)) + (new-element-hook :documentation "Called when new element starts" + ;; Handle the start of a new xml element with name and attributes, + ;; receiving seed from previous element (sibling or parent) + ;; return seed to be used for first child (content) + ;; or directly to finish-element-hook + :accessor get-new-element-hook + :initarg :new-element-hook + :initform #'(lambda (name attributes seed) + (declare (ignore name attributes)) + seed)) + (finish-element-hook :documentation "Called when element ends" + ;; Handle the end of an xml element with name and attributes, + ;; receiving parent-seed, the seed passed to us when this element started, + ;; i.e. passed to our corresponding new-element-hook + ;; and receiving seed from last child (content) + ;; or directly from new-element-hook + ;; return final seed for this element to next element (sibling or parent) + :accessor get-finish-element-hook + :initarg :finish-element-hook + :initform #'(lambda (name attributes parent-seed seed) + (declare (ignore name attributes parent-seed)) + seed)) + (text-hook :documentation "Called when text is found" + ;; Handle text in string, found as contents, + ;; receiving seed from previous element (sibling or parent), + ;; return final seed for this element to next element (sibling or parent) + :accessor get-text-hook + :initarg :text-hook + :initform #'(lambda (string seed) + (declare (ignore string)) + seed))) + (:documentation "The XML parser state passed along all code making up the parser")) + +(setf (documentation 'get-seed 'function) + "Get the initial user seed of an XML parser state" + (documentation 'get-entities 'function) + "Get the entities hashtable of an XML parser state" + (documentation 'get-new-element-hook 'function) + "Get the new element hook of an XML parser state" + (documentation 'get-finish-element-hook 'function) + "Get the finish element hook of an XML parser state" + (documentation 'get-text-hook 'function) + "Get the text hook of an XML parser state") + +#-allegro +(setf (documentation '(setf get-seed) 'function) + "Set the initial user seed of an XML parser state" + (documentation '(setf get-entities) 'function) + "Set the entities hashtable of an XML parser state" + (documentation '(setf get-new-element-hook) 'function) + "Set the new element hook of an XML parser state" + (documentation '(setf get-finish-element-hook) 'function) + "Set the finish element hook of an XML parser state" + (documentation '(setf get-text-hook) 'function) + "Set the text hook of an XML parser state") + +(defmethod get-mini-buffer :after ((state xml-parser-state)) + "Reset and return the reusable mini buffer" + (with-slots (mini-buffer) state + (setf (fill-pointer mini-buffer) 0))) + +(defmethod get-buffer :after ((state xml-parser-state)) + "Reset and return the main reusable buffer" + (with-slots (buffer) state + (setf (fill-pointer buffer) 0))) + +;;; parser support + +(defun parse-whitespace (stream extendable-string) + "Read and collect XML whitespace from stream in string which is + destructively modified, return first non-whitespace character which + was peeked but not read, return #\Null on eof" + (declare (type (vector character) extendable-string)) + (loop + (let ((char (peek-char nil stream nil #\Null))) + (declare (type character char)) + (if (whitespace-char-p char) + (vector-push-extend (read-char stream) extendable-string) + (return char))))) + +(defun parse-string (stream state string) + "Read and return an XML string from stream, delimited by either + single or double quotes, the stream is expected to be on the opening + delimiter, at the end the closing delimiter is also read, entities + are resolved, eof before end of string is an error" + (declare (type (vector character) string)) + (let ((delimiter (read-char stream nil #\Null)) + (char #\Null)) + (declare (type character delimiter char)) + (unless (or (char= delimiter #\') (char= delimiter #\")) + (error (parser-error "expected string delimiter" nil stream))) + (loop + (setf char (read-char stream nil #\Null)) + (cond ((char= char #\Null) (error (parser-error "encountered eof before end of string"))) + ((char= char delimiter) (return)) + ((char= char #\&) (resolve-entity stream string (get-entities state) (get-mini-buffer state))) + (t (vector-push-extend char string)))) + string)) + +(defun parse-text (stream state extendable-string) + "Read and collect XML text from stream in string which is + destructively modified, the text ends with a '<', which is peeked and + returned, entities are resolved, eof is considered an error" + (declare (type (vector character) extendable-string)) + (let ((char #\Null)) + (declare (type character char)) + (loop + (setf char (peek-char nil stream nil #\Null)) + (when (char= char #\Null) (error (parser-error "encountered unexpected eof in text"))) + (when (char= char #\<) (return)) + (read-char stream) + (if (char= char #\&) + (resolve-entity stream extendable-string (get-entities state) (get-mini-buffer state)) + (vector-push-extend char extendable-string))) + char)) + +(defun parse-identifier (stream identifier) + "Read and returns an XML identifier from stream, positioned at the + start of the identifier, ending with the first non-identifier + character, which is peeked, the identifier is written destructively + into identifier which is also returned" + (declare (type (vector character) identifier)) + (loop + (let ((char (read-char stream nil #\Null))) + (declare (type character char)) + (cond ((identifier-char-p char) + (vector-push-extend char identifier)) + (t + (when (char/= char #\Null) (unread-char char stream)) + (return identifier)))))) + +(defun skip-comment (stream) + "Skip an XML comment in stream, positioned after the opening '' 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 + (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 + (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 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 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 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + 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 @@ + + + + + AppleDockIconEnabled + + AppleNavServices:GetFile:0:Path + file://localhost/Users/sven/Pictures/ + AppleNavServices:GetFile:0:Position + + AOUBXw== + + AppleNavServices:GetFile:0:Size + + AAAAAAFeAcI= + + AppleNavServices:PutFile:0:Disclosure + + AQ== + + AppleNavServices:PutFile:0:Path + file://localhost/Users/sven/Desktop/ + AppleNavServices:PutFile:0:Position + + AUIBVQ== + + AppleNavServices:PutFile:0:Size + + AAAAAACkAdY= + + AppleSavePanelExpanded + YES + NSDefaultOpenDirectory + ~/Desktop + NSNoBigString + + + 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 @@ + + + + Hello World! + 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 " ") + (parse-xml stream :output-type :lxml)) + :|foo|)) + +(assert + (equal (parse-xml-string "this is some text" + :output-type :lxml) + '(:|tag1| + ((:|tag2| :|att1| "one")) + "this is some text"))) + +(assert + (equal (parse-xml-string "<foo>" + :output-type :lxml) + '(:TAG ""))) + +(assert + (equal (parse-xml-string + "

This is some bold text, with a leading & trailing space

" + :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) + "")) + +(assert + (string-equal (print-xml-string '((:|foo| :|bar| "1")) :input-type :lxml) + "")) + +(assert + (string-equal (print-xml-string '(:foo "some text") :input-type :lxml) + "some text")) + +(assert + (string-equal (print-xml-string '(:|foo| :|bar|) :input-type :lxml) + "")) + +(assert (string-equal (second + (with-input-from-string (stream "Hello, world!]]>") + (parse-xml stream :output-type :lxml))) + "Hello, world!")) + +(assert (string-equal (second + (with-input-from-string (stream "Hello, < world!]]>") + (parse-xml stream :output-type :lxml))) + "Hello, < world!")) + +;;;; 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 " ") + (parse-xml stream :output-type :sxml)) + '(:|foo|))) + +(assert + (equal (parse-xml-string "this is some text" + :output-type :sxml) + '(:|tag1| + (:|tag2| (:@ (:|att1| "one"))) + "this is some text"))) + +(assert + (equal (parse-xml-string "<foo>" + :output-type :sxml) + '(:TAG ""))) + +(assert + (equal (parse-xml-string + "

This is some bold text, with a leading & trailing space

" + :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) + "")) + +(assert + (string-equal (print-xml-string '(:|foo| (:@ (:|bar| "1"))) :input-type :sxml) + "")) + +(assert + (string-equal (print-xml-string '(:foo "some text") :input-type :sxml) + "some text")) + +(assert + (string-equal (print-xml-string '(:|foo| (:|bar|)) :input-type :sxml) + "")) + +;;;; 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 " ") + (parse-xml stream :output-type :xml-struct)) + (make-xml-element :name :|foo|))) + +(assert + (xml-equal (parse-xml-string "this is some text" + :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 "<foo>" + :output-type :xml-struct) + (make-xml-element :name :|tag| + :children (list "")))) + +(assert + (xml-equal (parse-xml-string + "

This is some bold text, with a leading & trailing space

" + :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) + "")) + +(assert + (string-equal (print-xml-string (make-xml-element :name "foo" :attributes '((:|bar| . "1"))) + :input-type :xml-struct) + "")) + +(assert + (string-equal (print-xml-string (make-xml-element :name "foo" :children (list "some text")) + :input-type :xml-struct) + "some text")) + +(assert + (string-equal (print-xml-string (make-xml-element :name "foo" :children (list (make-xml-element :name "bar"))) + :input-type :xml-struct) + "")) + +;;;; 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 "" stream)) + "<foo>")) + +(assert + (string-equal (with-output-to-string (stream) (print-string-xml "' '" stream)) + "' '")) + +(assert + (let ((string (map 'string #'identity '(#\return #\tab #\newline)))) + (string-equal (with-output-to-string (stream) (print-string-xml string stream)) + string))) + +(defun simple-echo-xml (in out) + (start-parse-xml + in + (make-instance 'xml-parser-state + :new-element-hook #'(lambda (name attributes seed) + (declare (ignore seed)) + (format out "<~a~:{ ~a='~a'~}>" + name + (mapcar #'(lambda (p) (list (car p) (cdr p))) + (reverse attributes)))) + :finish-element-hook #'(lambda (name attributes parent-seed seed) + (declare (ignore attributes parent-seed seed)) + (format out "" 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 "TextMore text!")) + (equal (simple-echo-xml-string xml) + xml)))) + +(assert + (let ((xml "

")) + (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 @@ + + + + + +XHTML Tutorial + + + + + + + + + + + + + + + + + + +
+
+HOME
+
+XHTML Tutorial
+XHTML HOME
+XHTML Introduction
+XHTML Why
+XHTML v HTML
+XHTML Syntax
+XHTML DTD
+XHTML HowTo
+XHTML Validation
+
+Quiz +
+XHTML Quiz
+
+References +
+XHTML Tag List
+XHTML Attributes
+XHTML Events
+		 + + + + +
+
+ +Corel XMetal 3 + + +
Please Visit Our Sponsors ! +
+

XHTML Tutorial

+Previous +Next + +
+ +

XHTML Tutorial

+

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. Start Learning +XHTML!

+ +

XHTML Quiz Test

+

Test your XHTML skills at W3Schools! Start XHTML +Quiz! 

+ +

XHTML References

+

At W3Schools you will find complete XHTML references about tags, attributes +and events. XHTML 1.0 References.

+
+

Table of Contents

+

Introduction to XHTML
+This chapter gives a brief introduction to XHTML and explains what XHTML is.

+

XHTML - Why?
+This chapter explains why we needed a new language like XHTML.

+

Differences between XHTML and HTML
+This chapter explains the main differences in syntax between XHTML and HTML.

+

XHTML Syntax 
+This chapter explains the basic syntax of XHTML.

+

XHTML DTD 
+This chapter explains the three different XHTML Document Type Definitions.

+

XHTML HowTo
+This chapter explains how this web site was converted from HTML to XHTML.

+

XHTML Validation
+This chapter explains how to validate XHTML documents.

+
+

XHTML References

+

XHTML 1.0 Reference
+Our complete XHTML 1.0 reference is an alphabetical list of all XHTML tags +with lots of  examples and tips.

+

XHTML 1.0 Standard Attributes
+All the tags have attributes. The attributes for each tag are listed in the +examples in the "XHTML 1.0 Reference" page. The attributes listed here +are the core and language attributes all the tags has as standard (with +few exceptions). This reference describes the attributes, and shows possible +values for each.

+

XHTML 1.0 Event Attributes
+All the standard event attributes of the tags. This reference describes the attributes, and shows possible +values for each.

+
+Previous +Next + + +
+

+Jump to: Top of Page +or HOME or + +Printer Friendly +Printer friendly page +

+
+ +

Search W3Schools:

+
+ + + +
+ +
+

What Others Say About Us

+

Does the world know about us? Check out these places:

+

+Dogpile +Alta Vista +MSN +Google +Excite +Lycos +Yahoo +Ask Jeeves +

+
+

We Help You For Free. You Can Help Us!

+ + +
+

+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 +terms of use and +privacy policy.

+

+Copyright 1999-2002 by Refsnes Data. All Rights Reserved

+
+ + + + +
+ +Validate + +How we converted to XHTML + + +Validate +
+
+		 + + +

+ +Web charting +
+Web based charting
for ASP.NET + +

+
+ + +
+
+ +Your own Web Site?
+
Read W3Schools +
Hosting Tutorial +
+
+
+ + +
+
+$15 Domain Name
Registration
Save $20 / year! +
+
+
+ + + + +
+
+SELECTED LINKS +

+University Online
+Master Degree
Bachelor Degree +

+Web Software +

+The Future of
Web Development +

+Jobs and Careers +

+Web Security +
+Web Statistics +
+Web Standards +

+
+ + + + +
+
+ +Recommended
+Reading:

+ + +HTML XHTML + + +

+ + + +
+
+PARTNERS
+
+W3Schools
+TopXML
+VisualBuilder
+XMLPitstop
+DevelopersDex
+DevGuru
+Programmers Heaven
+The Code Project
+Tek Tips Forum
+ZVON.ORG
+TopXML Search
+
+
+
+ + + -- cgit v1.2.3