Add third-party XML processing libraries.

Ignore-this: 5ca28497555bf944858ca2f58bc8a62b

darcs-hash:a0b0f9baa7c9b1259e755435db1fb17123630a6c

3 files changed, 416 insertions, 0 deletions

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