summaryrefslogtreecommitdiff
path: root/third-party/s-sysdeps
diff options
context:
space:
mode:
Diffstat (limited to 'third-party/s-sysdeps')
-rw-r--r--third-party/s-sysdeps/.clbuild-skip-update0
-rw-r--r--third-party/s-sysdeps/Makefile82
-rw-r--r--third-party/s-sysdeps/README.txt1
-rw-r--r--third-party/s-sysdeps/doc/API.html19
-rw-r--r--third-party/s-sysdeps/doc/index.html203
-rw-r--r--third-party/s-sysdeps/s-sysdeps.asd31
-rw-r--r--third-party/s-sysdeps/src/bivalent-streams.lisp107
-rw-r--r--third-party/s-sysdeps/src/package.lisp28
-rw-r--r--third-party/s-sysdeps/src/sysdeps.lisp281
-rw-r--r--third-party/s-sysdeps/test/all-tests.lisp15
-rw-r--r--third-party/s-sysdeps/test/test-sysdeps.lisp19
11 files changed, 786 insertions, 0 deletions
diff --git a/third-party/s-sysdeps/.clbuild-skip-update b/third-party/s-sysdeps/.clbuild-skip-update
new file mode 100644
index 0000000..e69de29
--- /dev/null
+++ b/third-party/s-sysdeps/.clbuild-skip-update
diff --git a/third-party/s-sysdeps/Makefile b/third-party/s-sysdeps/Makefile
new file mode 100644
index 0000000..f0a663a
--- /dev/null
+++ b/third-party/s-sysdeps/Makefile
@@ -0,0 +1,82 @@
+#
+# This makefile contains command line tools to maintain this project
+# Please consult the documentation in doc/index.html for more user oriented information
+# Portability at this level is accidental, only LispWorks on Mac OS X is supported here
+# For some operations, edit the necessary variables to suit your environment
+# Some operations can obviously only be done by a specific person in a very specific context ;-)
+#
+
+default:
+ @echo Welcome to S-SYSDEPS, an abstraction over platform dependent functionality
+ @echo
+ @echo Possible makefile targets:
+ @echo
+ @echo clean-fasl --- remove all known lisp compiled fasl files recursively
+ @echo clean-emacs --- remove all '*~' recursively
+ @echo clean --- all of the above
+ @echo dist-clean --- remove all generated files and archives
+ @echo compile --- compile the project through ASDF
+ @echo check --- run all unit and functional tests for this project
+ @echo test --- run all unit and functional tests for this project
+ @echo dist --- create a source tarball for distribution
+ @echo release --- make a formal, public release
+ @echo sync-darcs --- synchronize local and remote darcs repositories
+ @echo metrics --- calculate some loc metrics
+ @echo
+ @echo Please consult the documentation in doc/index.html for more information
+
+clean-fasl:
+ find . -name "*.fas" | xargs rm
+ find . -name "*.lib" | xargs rm
+ find . -name "*.nfasl" | xargs rm
+ find . -name "*.dfsl" | xargs rm
+ find . -name "*.fasl" | xargs rm
+
+clean-emacs:
+ find . -name "*~" | xargs rm
+
+clean: clean-fasl clean-emacs
+
+dist-clean: clean
+ rm -rf *.tar.gz
+ rm -rf *.asc
+
+metrics:
+ find src -name "*.lisp" | xargs wc -l
+ find test -name "*.lisp" | xargs wc -l
+
+LISP=/Applications/LispWorks/lispworks-tty
+PRJ=s-sysdeps
+
+compile:
+ echo "(asdf:oos 'asdf:compile-op :$(PRJ)) :ok" | $(LISP)
+
+DIR=`pwd`/
+SRCDIR=$(DIR)src/
+TESTDIR=$(DIR)test/
+
+test: check
+
+check:
+ echo "(asdf:oos 'asdf:load-op :$(PRJ)) (load \"$(TESTDIR)all-tests.lisp\") :ok" | $(LISP)
+
+dist:
+ darcs dist
+
+IDISK=/Volumes/svc
+
+release: test dist clean
+ gpg -a -b $(PRJ).tar.gz
+ mkdir -p $(IDISK)/Sites/$(PRJ)/
+ cp $(PRJ).tar.gz $(IDISK)/Sites/$(PRJ)/
+ cp $(PRJ).tar.gz.asc $(IDISK)/Sites/$(PRJ)/
+ cp doc/* $(IDISK)/Sites/$(PRJ)/
+
+USER=
+HOST=
+RPATH=/var/www/html/beta9.be/darcs/
+
+sync-darcs: clean
+ cd ..; rsync -va -e /usr/bin/ssh $(PRJ) $(USER)@$(HOST):$(RPATH)
+
+# EOF
diff --git a/third-party/s-sysdeps/README.txt b/third-party/s-sysdeps/README.txt
new file mode 100644
index 0000000..c4fb71a
--- /dev/null
+++ b/third-party/s-sysdeps/README.txt
@@ -0,0 +1 @@
+Please consult the documentation in the doc directory, starting with index.html
diff --git a/third-party/s-sysdeps/doc/API.html b/third-party/s-sysdeps/doc/API.html
new file mode 100644
index 0000000..1e0581e
--- /dev/null
+++ b/third-party/s-sysdeps/doc/API.html
@@ -0,0 +1,19 @@
+<html><head><title>S-SYSDEPS</title></head><body><h3>API for package S-SYSDEPS</h3>
+<blockquote>S-SYSDEPS is an abstraction layer over platform dependent functionality</blockquote>
+<p>(<b>all-processes</b>)&nbsp;&nbsp;&nbsp;<i>function</i></p>
+<blockquote>Return a list of all processes currently running</blockquote>
+<p>(<b>current-process</b>)&nbsp;&nbsp;&nbsp;<i>function</i></p>
+<blockquote>Return the object representing the current process</blockquote>
+<p>(<b>kill-process</b> process)&nbsp;&nbsp;&nbsp;<i>function</i></p>
+<blockquote>Kill the process represented by the object process</blockquote>
+<p>(<b>make-process-lock</b> name)&nbsp;&nbsp;&nbsp;<i>function</i></p>
+<blockquote>Create a named process lock object</blockquote>
+<p>(<b>open-socket-stream</b> host port)&nbsp;&nbsp;&nbsp;<i>function</i></p>
+<blockquote>Create and open a bidirectional client TCP/IP socket stream to host:port</blockquote>
+<p>(<b>run-process</b> name function &rest arguments)&nbsp;&nbsp;&nbsp;<i>function</i></p>
+<blockquote>Create and run a new process with name, executing function on arguments</blockquote>
+<p>(<b>start-standard-server</b> &key port name connection-handler)&nbsp;&nbsp;&nbsp;<i>function</i></p>
+<blockquote>Start a server process with name, listening on port, delegating to connection-handler with stream as argument</blockquote>
+<p>(<b>with-process-lock</b> (lock) &body body)&nbsp;&nbsp;&nbsp;<i>function</i></p>
+<blockquote>Execute body wih the process lock grabbed, wait otherwise</blockquote>
+<font size=-1><p>Documentation generated by <a href="http://homepage.mac.com/svc/lispdoc/">lispdoc</a> running on LispWorks</p></font></body></html> \ No newline at end of file
diff --git a/third-party/s-sysdeps/doc/index.html b/third-party/s-sysdeps/doc/index.html
new file mode 100644
index 0000000..b7109b2
--- /dev/null
+++ b/third-party/s-sysdeps/doc/index.html
@@ -0,0 +1,203 @@
+<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">
+<html xmlns="http://www.w3.org/1999/xhtml">
+<head>
+<title>S-SYSDEPS</title>
+<meta http-equiv="Content-Type" content="text/html; charset=ISO-8859-1" />
+<meta name="description" content="S-SYSDEPS is an abstraction layer over implementation dependent functionality" />
+<meta name="keywords" content="sysdeps, common lisp, lisp, portability" />
+<meta name="author" content="Sven Van Caekenberghe" />
+<meta name="Copyright" content="Copyright (c) 2004-2005 Sven Van Caekenberghe, Beta Nine BVBA" />
+<style type="text/css">
+body {
+ background: white;
+ width: 900px;
+ font-family: Verdana, Arial, Helvetica, sans-serif;
+ font-size: 13px;
+}
+p {
+ width: 600px;
+ padding: 0 20px 10px 50px;
+}
+ul {
+ width: 600px;
+ padding: 0 5px 5px 70px;
+}
+.author {
+ padding: 0 20px 5px 50px;
+ font-style: italic;
+}
+.figure {
+ margin-top: 0;
+ margin-bottom: 0;
+ background: black;
+ color: white;
+ text-align: center;
+ padding: 20px 0 10px 0;
+}
+.listing {
+ background: #eee;
+ font-size: 12px;
+ padding-left: 10px;
+}
+.caption {
+ margin-top: 5px;
+ text-align: center;
+ font-size: 10px;
+ font-style: bold;
+}
+.footer {
+ font-size: 10px;
+ font-style: italic;
+}
+</style>
+</head>
+<body>
+<h3>Open Source Common Lisp Software</h3>
+<h1>S-SYSDEPS</h1>
+<h2>An Abstraction Layer Over Platform Dependent Functionality</h2>
+<p>
+<a href="http://homepage.mac.com/svc/temaplte/index.html">S-SYSDEPS</a>
+is an abstraction layer over platform dependent functionality.
+This simple package is used as a building block in a number of other open source projects,
+as can be seen from this description of some
+<a href="http://homepage.mac.com/svc/oscl.html">other Open Source Common Lisp packages</a>.
+</p>
+<h3>Contents</h3>
+<ul>
+<li><a href="#features">Features</a></li>
+<li><a href="#status">Status</a></li>
+<li><a href="#news">News</a></li>
+<li><a href="#platforms">Platforms</a></li>
+<li><a href="#downloading">Downloading</a></li>
+<li><a href="#installation">Installation</a></li>
+<li><a href="#usage">Usage</a></li>
+<li><a href="#api">API Reference</a></li>
+<li><a href="#mailinglist">Mailinglist</a></li>
+<li><a href="#changelog">Changelog</a></li>
+<li><a href="#tod">TODO</a></li>
+<li><a href="#faq">FAQ</a></li>
+<li><a href="#bugs">Bugs</a></li>
+<li><a href="#authors">Authors</a></li>
+<li><a href="#maintainers">Maintainers</a></li>
+<li><a href="#license">License</a></li>
+<li><a href="#history">History</a></li>
+<li><a href="#references">References</a></li>
+</ul>
+<h3 id="features">Features</h3>
+<p>
+S-SYSDEPS abstracts:
+</p>
+<ul>
+<li>managing processes</li>
+<li>implementing a standard TCP/IP server</li>
+<li>opening a client TCP/IP socket stream</li>
+<li>working with process locks</li>
+</ul>
+<h3 id="status">Status</h3>
+<p>
+S-SYSDEPS is considered stable code.
+</p>
+<h3 id="news">News</h3>
+<p>
+<em>November 2005</em> - Created as a seperate project.
+</p>
+<h3 id="platforms">Platforms</h3>
+<p>
+S-SYSDEPS is, by definition, written in ANSI standard Common Lisp
+but implemented using non-standard extensions.
+At the moment, ports for LispWorks (reference), OpenMCL, CMUCL and SBCL exist.
+Some other CL implementations are partially supported.
+</p>
+<h3 id="downloading">Downloading</h3>
+<p>
+You can download the latested released tarball of the S-SYSDEPS package from
+<a href="http://homepage.mac.com/svc/s-sysdeps/s-sysdeps.tar.gz">http://homepage.mac.com/svc/s-sysdeps/s-sysdeps.tar.gz</a>.
+This archive is signed on release by <a href="http://homepage.mac.com/svc">Sven Van Caekenberghe</a>,
+whose public key is published at
+<a href="http://homepage.mac.com/svc/sven-public-ascii.gpg">http://homepage.mac.com/svc/sven-public-ascii.gpg</a>,
+the signature is in
+<a href="http://homepage.mac.com/svc/s-sysdeps/s-sysdeps.tar.gz.asc">http://homepage.mac.com/svc/s-sysdeps/s-sysdeps.tar.gz.asc</a>.
+</p>
+<p>
+Alternatively you can access the <a href="http://abridgegame.org/darcs/">DARCS</a> repository at
+<a href="http://www.beta9.be/darcs/s-base64">http://www.beta9.be/darcs/s-base64</a>.
+For a good description on how to use DARCS see
+<a href="http://dirkgerrits.com/programming/erlisp/download/">http://dirkgerrits.com/programming/erlisp/download/</a>.
+</p>
+<div class="listing">
+<pre>$ darcs get http://www.beta9.be/darcs/s-sysdeps</pre>
+</div>
+<div class="caption">Example of basic darcs usage, get everything once and keep up to date by pulling in changes</div>
+<h3 id="installation">Installation</h3>
+<p>
+The S-SYSDEPS package is loaded using <a href="http://www.cliki.net/asdf">ASDF</a>.
+There is an excellent <a href="http://constantly.at/lisp/asdf/">tutorial on ASDF</a> to get you started.
+Alternatively you can use <a href="http://www.cliki.net/asdf-install">ASDF-INSTALL</a>.
+There is an great <a href="http://weitz.de/asdf-install/">tutorial on ASDF-INSTALL</a> to get you on the way.
+</p>
+<div class="listing">
+<pre>CL-USER 1 > (asdf:oos 'asdf:load-op :s-sysdeps)</pre>
+</div>
+<div class="caption">Example of setting up and using ASDF to compile and load the package</div>
+<h3 id="usage">Usage</h3>
+<p>
+For usage examples please have a look at the package using S-SYSDEPS.
+</p>
+<h3 id="api">API Reference</h3>
+<p>
+There is automatically generated <a href="API.html">API Reference</a> documentation available for the S-SYSDEPS package.
+</p>
+<h3 id="mailinglist">Mailinglist</h3>
+<p>
+There is no mailing list for this project.
+</p>
+<h3 id="changelog">Changelog</h3>
+<p>
+Release Notes:
+</p>
+<ul>
+<li>release 1: moved S-SYSDEPS into a seperate project under a new structure</li>
+</ul>
+<h3 id="todo">TODO</h3>
+<p>
+Port to even more platforms. Add some unit or functional tests, as well as some examples.
+</p>
+<h3 id="faq">FAQ</h3>
+<p>
+Nothing appropriate.
+</p>
+<h3 id="bugs">Bugs</h3>
+<p>
+There are no known bugs.
+</p>
+<h3 id="authors">Authors</h3>
+<p>
+S-SYSDEPS was written by <a href="http://homepage.mac.com/svc">Sven Van Caekenberghe</a>.
+Ports to CMUCL and SBCL were contributed.
+</p>
+<h3 id="maintainers">Maintainers</h3>
+<p>
+S-SYSDEPS is being maintained by <a href="http://homepage.mac.com/svc">Sven Van Caekenberghe</a>.
+</p>
+<h3 id="license">License</h3>
+<p>
+You are granted the rights to distribute and use this software
+as governed by the terms of the Lisp Lesser General Public License
+(<a href="http://opensource.franz.com/preamble.html">http://opensource.franz.com/preamble.html</a>),
+also known as the LLGPL.
+</p>
+<h3 id="history">History</h3>
+<p>
+This file was part of S-XML-RPC and (N)KPAX.
+</p>
+<h3 id="references">References</h3>
+<p>
+Thera are no references.
+</p>
+<div class="footer">
+Copyright &copy; 2004-2005 Sven Van Caekenberghe, Beta Nine BVBA. All Right Reserved. -
+<a href="http://validator.w3.org/check/referer">This page is W3C Valid XHTML 1.0 Strict</a> -
+<a href="http://www.anybrowser.org/campaign/">Viewable With Any Browser</a>
+</div>
+</body>
+</html>
diff --git a/third-party/s-sysdeps/s-sysdeps.asd b/third-party/s-sysdeps/s-sysdeps.asd
new file mode 100644
index 0000000..409a929
--- /dev/null
+++ b/third-party/s-sysdeps/s-sysdeps.asd
@@ -0,0 +1,31 @@
+;;;; -*- Mode: LISP -*-
+;;;;
+;;;; $Id: s-xml-rpc.asd,v 1.2 2004/06/17 19:43:11 rschlatte Exp $
+;;;;
+;;;; The S-SYSDEPS ASDF system definition
+;;;;
+;;;; Copyright (C) 2004-2005 Sven Van Caekenberghe, Beta Nine BVBA.
+;;;;
+;;;; You are granted the rights to distribute and use this software
+;;;; as governed by the terms of the Lisp Lesser General Public License
+;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
+
+(in-package :asdf)
+
+(defsystem :s-sysdeps
+ :name "S-SYSDEPS"
+ :author "Sven Van Caekenberghe <svc@mac.com>"
+ :version "1"
+ :maintainer "Sven Van Caekenberghe <svc@mac.com>"
+ :licence "Lesser Lisp General Public License (LLGPL)"
+ :description "An abstraction layer over platform dependent functionality"
+ :long-description "An abstraction layer over platform dependent functionality"
+
+ :components
+ ((:module
+ :src
+ :components ((:file "package")
+ #+clisp (:file "bivalent-streams" :depends-on ("package"))
+ (:file "sysdeps" :depends-on ("package" #+clisp "bivalent-streams"))))))
+
+;;;; eof
diff --git a/third-party/s-sysdeps/src/bivalent-streams.lisp b/third-party/s-sysdeps/src/bivalent-streams.lisp
new file mode 100644
index 0000000..3261a50
--- /dev/null
+++ b/third-party/s-sysdeps/src/bivalent-streams.lisp
@@ -0,0 +1,107 @@
+;;;; -*- mode: lisp -*-
+;;;;
+;;;; $Id: base64.lisp,v 1.3 2005/02/07 17:45:41 scaekenberghe Exp $
+;;;;
+;;;; Bivalent streams for CLISP
+;;;;
+;;;; Copyright (C) 2007 Sven Van Caekenberghe, Beta Nine BVBA.
+;;;;
+;;;; You are granted the rights to distribute and use this software
+;;;; as governed by the terms of the Lisp Lesser General Public License
+;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
+
+(in-package :s-sysdeps)
+
+;;; Rationale:
+
+;;; we want (socket) streams that support input and output (i.e. are bidirectional),
+;;; using bytes and characters (i.e. are bivalent) at the same time, with conversions
+;;; using a straight/native byte to character conversion
+
+;;; this is an (incomplete) implementation for CLISP based on Gray streams
+;;; in other words: this is a hack to fix a particular problem/situation
+
+(defclass bivalent-bidirectional-stream (gray:fundamental-character-input-stream
+ gray:fundamental-character-output-stream
+ gray:fundamental-binary-input-stream
+ gray:fundamental-binary-output-stream)
+ ((bidirectional-binary-stream :reader get-native-stream :initarg :bidirection-binary-stream)))
+
+(defun make-bivalent-stream (stream)
+ "Wrap a bidirectional binary stream so that it behaves as a bivalent bidirectional stream"
+ (make-instance 'bivalent-bidirectional-stream :bidirection-binary-stream stream))
+
+;;; minimal required methods
+
+(defmethod stream-element-type ((stream bivalent-bidirectional-stream))
+ '(or character (unsigned-byte 8)))
+
+(defmethod close ((stream bivalent-bidirectional-stream) &key abort)
+ (close (get-native-stream stream) :abort abort)
+ (call-next-method))
+
+(defmethod gray:stream-position ((stream bivalent-bidirectional-stream) position)
+ (gray:stream-position (get-native-stream stream) position))
+
+(defmethod gray:stream-read-char ((stream bivalent-bidirectional-stream))
+ (code-char (read-byte (get-native-stream stream))))
+
+#+nil
+(defmethod gray:stream-unread-char ((stream bivalent-bidirectional-stream)))
+
+(defmethod gray:stream-write-char ((stream bivalent-bidirectional-stream) char)
+ (write-byte (char-code char) (get-native-stream stream)))
+
+(defmethod gray:stream-line-column ((stream bivalent-bidirectional-stream))
+ nil)
+
+(defmethod gray:stream-finish-output ((stream bivalent-bidirectional-stream))
+ (finish-output (get-native-stream stream)))
+
+(defmethod gray:stream-force-output ((stream bivalent-bidirectional-stream))
+ (force-output (get-native-stream stream)))
+
+(defmethod gray:stream-read-byte ((stream bivalent-bidirectional-stream))
+ (read-byte (get-native-stream stream)))
+
+(defmethod gray:stream-read-byte-lookahead ((stream bivalent-bidirectional-stream))
+ (ext:read-byte-lookahead (get-native-stream stream)))
+
+(defmethod gray:stream-write-byte ((stream bivalent-bidirectional-stream) byte)
+ (write-byte byte (get-native-stream stream)))
+
+;;; 'optimized' sequence IO
+
+(defmethod gray:stream-read-char-sequence ((stream bivalent-bidirectional-stream) sequence
+ &optional start end)
+ (unless start (setf start 0))
+ (unless end (setf end (length sequence)))
+ (let* ((byte-buffer (make-array (- end start) :element-type '(unsigned-byte 8)))
+ (result (ext:read-byte-sequence byte-buffer (get-native-stream stream))))
+ (loop :for i :from start :below (min end result)
+ :do (setf (elt sequence (+ start i)) (code-char (elt byte-buffer i))))
+ (+ start result)))
+
+(defmethod gray:stream-write-char-sequence ((stream bivalent-bidirectional-stream) sequence
+ &optional start end)
+ (unless start (setf start 0))
+ (unless end (setf end (length sequence)))
+ (let ((byte-buffer (make-array (- end start) :element-type '(unsigned-byte 8))))
+ (loop :for i :from start :below (- end start)
+ :do (setf (elt byte-buffer i) (char-code (elt sequence (+ start i)))))
+ (multiple-value-bind (seq result)
+ (ext:write-byte-sequence byte-buffer (get-native-stream stream))
+ (declare (ignore seq))
+ (+ start result))))
+
+(defmethod gray:stream-read-byte-sequence ((stream bivalent-bidirectional-stream) sequence
+ &optional start end no-hang interactive)
+ (declare (ignore no-hang interactive))
+ (ext:read-byte-sequence sequence (get-native-stream stream) :start start :end end))
+
+(defmethod gray:stream-write-byte-sequence ((stream bivalent-bidirectional-stream) sequence
+ &optional start end no-hang interactive)
+ (declare (ignore no-hang interactive))
+ (ext:write-byte-sequence sequence (get-native-stream stream) :start start :end end))
+
+;;;; eof
diff --git a/third-party/s-sysdeps/src/package.lisp b/third-party/s-sysdeps/src/package.lisp
new file mode 100644
index 0000000..a273d74
--- /dev/null
+++ b/third-party/s-sysdeps/src/package.lisp
@@ -0,0 +1,28 @@
+;;;; -*- mode: lisp -*-
+;;;;
+;;;; $Id: base64.lisp,v 1.3 2005/02/07 17:45:41 scaekenberghe Exp $
+;;;;
+;;;; This is the S-SYSDEPS package definition
+;;;;
+;;;; Copyright (C) 2004-2007 Sven Van Caekenberghe, Beta Nine BVBA.
+;;;;
+;;;; You are granted the rights to distribute and use this software
+;;;; as governed by the terms of the Lisp Lesser General Public License
+;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
+
+(defpackage :s-sysdeps
+ (:use common-lisp)
+ (:export
+ #:multiprocessing-capable-p
+ #:current-process
+ #:kill-process
+ #:run-process
+ #:all-processes
+ #:start-standard-server
+ #:open-socket-stream
+ #:get-socket-stream-property
+ #:make-process-lock
+ #:with-process-lock)
+ (:documentation "S-SYSDEPS is an abstraction layer over platform dependent functionality"))
+
+;;;; eof
diff --git a/third-party/s-sysdeps/src/sysdeps.lisp b/third-party/s-sysdeps/src/sysdeps.lisp
new file mode 100644
index 0000000..1f9a638
--- /dev/null
+++ b/third-party/s-sysdeps/src/sysdeps.lisp
@@ -0,0 +1,281 @@
+;;;; -*- mode: lisp -*-
+;;;;
+;;;; $Id: base64.lisp,v 1.3 2005/02/07 17:45:41 scaekenberghe Exp $
+;;;;
+;;;; S-SYSDEPS is an abtraction layer over platform dependent functionality
+;;;;
+;;;; Copyright (C) 2004-2007 Sven Van Caekenberghe, Beta Nine BVBA.
+;;;;
+;;;; You are granted the rights to distribute and use this software
+;;;; as governed by the terms of the Lisp Lesser General Public License
+;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
+
+(in-package :s-sysdeps)
+
+;; loading platform specific dependencies
+
+#+lispworks
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (require "comm"))
+
+#+sbcl
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (require :sb-bsd-sockets))
+
+;; managing processes
+
+(defun multiprocessing-capable-p ()
+ "Returns t when this implementation is multiprocessing capable"
+ #+(or lispworks abcl openmcl allegro sb-thread) t
+ #-(or lispworks abcl openmcl allegro sb-thread) nil)
+
+(defun current-process ()
+ "Return the object representing the current process"
+ #+lispworks mp:*current-process*
+ #+abcl (ext:current-thread)
+ #+openmcl ccl:*current-process*
+ #+sb-thread sb-thread:*current-thread*
+ #+allegro sys:*current-process*
+ #-(or lispworks abcl openmcl sb-thread allegro) nil)
+
+(defun kill-process (process)
+ "Kill the process represented by the object process"
+ #+lispworks (mp:process-kill process)
+ #+abcl (ext:destroy-thread process)
+ #+openmcl (ccl:process-kill process)
+ #+sb-thread (sb-thread:terminate-thread process)
+ #+allegro (mp:process-kill process)
+ #-(or lispworks abcl openmcl sb-thread allegro) process)
+
+(defun run-process (name function &rest arguments)
+ "Create and run a new process with name, executing function on arguments"
+ #+lispworks (apply #'mp:process-run-function name '(:priority 3) function arguments)
+ #+abcl (ext:make-thread #'(lambda () (apply function arguments)) :name name)
+ #+openmcl (apply #'ccl:process-run-function name function arguments)
+ #+allegro (apply #'mp:process-run-function name function arguments)
+ #+sb-thread (sb-thread:make-thread #'(lambda () (apply function arguments)) :name name)
+ #-(or lispworks abcl openmcl allegro sb-thread)
+ (declare (ignore name))
+ #-(or lispworks abcl openmcl allegro sb-thread)
+ (apply function arguments))
+
+(defun all-processes ()
+ "Return a list of all processes currently running"
+ #+lispworks (mp:list-all-processes)
+ #+abcl (ext:mapcar-threads #'identity)
+ #+openmcl (ccl:all-processes)
+ #+sb-thread (sb-thread:list-all-threads)
+ #+allegro sys:*all-processes*
+ #-(or lispworks abcl openmcl sb-thread allegro) nil)
+
+;; opening a client TCP/IP socket stream
+
+(defun open-socket-stream (host port &key connect-timeout read-timeout write-timeout)
+ "Create and open a bidirectional client TCP/IP socket stream to host:port"
+ #+(or abcl openmcl allegro clisp cmu sbcl) (declare (ignore connect-timeout read-timeout write-timeout))
+ #+lispworks (comm:open-tcp-stream host port
+ :timeout connect-timeout
+ :read-timeout read-timeout
+ :write-timeout write-timeout)
+ #+abcl (let ((socket (ext:make-socket host port)))
+ (ext:get-socket-stream socket))
+ #+openmcl (ccl:make-socket :remote-host host :remote-port port)
+ #+allegro (acl-socket:make-socket :remote-host host :remote-port port
+ :type :stream :address-family :internet)
+ #+clisp (make-bivalent-stream (socket:socket-connect port host :element-type '(unsigned-byte 8)))
+ #+cmu (sys:make-fd-stream (ext:connect-to-inet-socket host port)
+ :input t :output t :buffering :none)
+ #+sbcl (let ((socket (make-instance 'sb-bsd-sockets:inet-socket
+ :type :stream :protocol :tcp)))
+ (sb-bsd-sockets:socket-connect socket
+ (car
+ (sb-bsd-sockets:host-ent-addresses
+ (sb-bsd-sockets:get-host-by-name host)))
+ port)
+ (sb-bsd-sockets:socket-make-stream socket
+ :element-type :default
+ :input t :output t :buffering :none))
+ #-(or lispworks abcl openmcl allegro clisp cmu sbcl)
+ (error "Opening a socket stream to ~a:~d not yet ported this lisp system" host port))
+
+;; accessing socket stream properties
+
+(defun get-socket-stream-property (socket-stream property)
+ "Get the value of a socket stream property, one of :remote-host :remote-port :local-host :local-port"
+ #+lispworks (ecase property
+ ((:remote-host :remote-port) (multiple-value-bind (address port)
+ (comm:socket-stream-peer-address socket-stream)
+ (if (eql property :remote-host)
+ (when address (comm:ip-address-string address))
+ port)))
+ ((:local-host :local-port) (multiple-value-bind (address port)
+ (comm:socket-stream-address socket-stream)
+ (if (eql property :local-host)
+ (when address (comm:ip-address-string address))
+ port))))
+ #+clisp (ecase property
+ ((:remote-host :remote-port) (multiple-value-bind (host port)
+ (socket:socket-stream-peer (get-native-stream socket-stream))
+ (if (eql property :remote-host)
+ host
+ port)))
+ ((:local-host :local-port) (multiple-value-bind (host port)
+ (socket:socket-stream-local (get-native-stream socket-stream))
+ (if (eql property :local-host)
+ host
+ port))))
+ #-(or lispworks clisp)
+ (declare (ignore socket-stream property))
+ #-(or lispworks clisp)
+ nil)
+
+;; implementing a standard TCP/IP server
+
+#+(or sb-thread cmu)
+(defvar *server-processes* '()
+ "The list of processes created by S-SYSDEPS")
+
+(defun start-standard-server (&key port name connection-handler)
+ "Start a server process with name, listening on port, delegating to connection-handler with stream as argument"
+ #+lispworks (comm:start-up-server
+ :function #'(lambda (socket-handle)
+ (let ((client-stream (make-instance 'comm:socket-stream
+ ;; maybe specify a read timeout...
+ :socket socket-handle
+ :direction :io
+ :element-type 'base-char)))
+ (funcall connection-handler client-stream)))
+ :service port
+ :announce t
+ :wait t
+ :process-name name)
+ #+abcl (ext:make-thread
+ #'(lambda ()
+ (let ((server-socket (ext:make-server-socket port)))
+ (unwind-protect
+ (loop
+ (let* ((client-socket (ext:socket-accept server-socket))
+ (client-stream (ext:get-socket-stream client-socket)))
+ (funcall connection-handler client-stream)))
+ (ext:server-socket-close server-socket))))
+ :name name)
+ #+openmcl (ccl:process-run-function
+ name
+ #'(lambda ()
+ (let ((server-socket (ccl:make-socket :connect :passive
+ :local-port port
+ :reuse-address t)))
+ (unwind-protect
+ (loop
+ (let ((client-stream (ccl:accept-connection server-socket)))
+ (funcall connection-handler client-stream)))
+ (close server-socket)))))
+ #+allegro (mp:process-run-function
+ name
+ #'(lambda ()
+ (let ((server-socket (acl-socket:make-socket :connect :passive
+ :local-port port)))
+ (unwind-protect
+ (loop
+ (let ((client-stream (acl-socket:accept-connection server-socket)))
+ (funcall connection-handler client-stream)))
+ (close server-socket)))))
+ #+sb-thread (let* ((socket (make-instance 'sb-bsd-sockets:inet-socket
+ :type :stream :protocol :tcp))
+ (handler-fn (lambda (fd)
+ (declare (ignore fd))
+ (let ((stream
+ (sb-bsd-sockets:socket-make-stream
+ (sb-bsd-sockets:socket-accept socket)
+ :element-type 'character
+ :input t
+ :output t
+ :buffering :none)))
+ (funcall connection-handler stream)))))
+ (setf (sb-bsd-sockets:sockopt-reuse-address socket) t)
+ (sb-bsd-sockets:socket-bind socket #(0 0 0 0) port)
+ (sb-bsd-sockets:socket-listen socket 15)
+ (push (list name
+ socket
+ (sb-sys:add-fd-handler
+ (sb-bsd-sockets:socket-file-descriptor socket)
+ :input handler-fn))
+ *server-processes*))
+ #+cmu (let* ((socket (ext:create-inet-listener port :stream :reuse-address t
+ :backlog 15))
+ (handler-fn (lambda (fd)
+ (declare (ignore fd))
+ (let ((stream (sys:make-fd-stream
+ (ext:accept-tcp-connection socket)
+ :input t :output t
+ :element-type 'character
+ :buffering :none)))
+ (funcall connection-handler stream)))))
+ (push (list name
+ socket
+ (sys:add-fd-handler socket :input handler-fn))
+ *server-processes*))
+ #+clisp (declare (ignore name))
+ ;; Implementation Limitation: in CLISP this becomes a blocking single-threaded server
+ #+clisp (let ((server-socket (socket:socket-server port :backlog 15)))
+ (unwind-protect
+ (loop
+ (let ((client-socket (socket:socket-accept server-socket :element-type '(unsigned-byte 8))))
+ (funcall connection-handler (make-bivalent-stream client-socket))))
+ (socket:socket-server-close server-socket))
+ nil)
+ #-(or lispworks abcl openmcl allegro sb-thread cmu clisp)
+ (error "Starting a standard socket named ~s on port ~d using handler ~s not yet ported to this lisp system"
+ name port connection-handler))
+
+#+(or sb-thread cmu)
+(defun stop-server (name)
+ "Stop a named server"
+ #+sb-thread (progn
+ (destructuring-bind (name socket handler)
+ (assoc name *server-processes* :test #'string=)
+ (declare (ignore name))
+ (sb-sys:remove-fd-handler handler)
+ (sb-bsd-sockets:socket-close socket))
+ (setf *server-processes* (delete name *server-processes*
+ :key #'car :test #'string=)))
+ #+cmu (progn
+ (destructuring-bind (name socket handler)
+ (assoc name *server-processes* :test #'string=)
+ (declare (ignore name))
+ (sys:remove-fd-handler handler)
+ (unix:unix-close socket))
+ (setf *server-processes* (delete name *server-processes*
+ :key #'car :test #'string=)))
+ name)
+
+;; working with process locks
+
+(defun make-process-lock (name)
+ "Create a named process lock object"
+ #+lispworks (mp:make-lock :name name)
+ #+abcl (ext:make-thread-lock)
+ #+openmcl (ccl:make-lock name)
+ #+allegro (mp:make-process-lock :name name)
+ #+sb-thread (sb-thread:make-mutex :name name)
+ #-(or lispworks abcl openmcl allegro sb-thread)
+ (declare (ignore name))
+ #-(or lispworks abcl openmcl allegro sb-thread)
+ nil)
+
+(defmacro with-process-lock ((lock) &body body)
+ "Execute body wih the process lock grabbed, wait otherwise"
+ ;; maybe it is safer to always use a timeout:
+ ;; `(mp:with-lock (,lock (format nil "Waiting for ~s" (lock-name ,lock)) 5) ,@body)
+ ;; if the lock cannot be claimed in 5s, nil is returned: test it and throw a condition ?
+ #+lispworks `(mp:with-lock (,lock) ,@body)
+ #+abcl `(ext:with-thread-lock (,lock) ,@body)
+ #+openmcl `(ccl:with-lock-grabbed (,lock) ,@body)
+ #+allegro `(mp:with-process-lock (,lock) ,@body)
+ #+sb-thread `(sb-thread:with-recursive-lock (,lock) ,@body)
+ #-(or lispworks abcl openmcl allegro sb-thread)
+ (declare (ignore lock))
+ #-(or lispworks abcl openmcl allegro sb-thread)
+ `(progn ,@body))
+
+;;;; eof
diff --git a/third-party/s-sysdeps/test/all-tests.lisp b/third-party/s-sysdeps/test/all-tests.lisp
new file mode 100644
index 0000000..98aab53
--- /dev/null
+++ b/third-party/s-sysdeps/test/all-tests.lisp
@@ -0,0 +1,15 @@
+;;;; -*- mode: lisp -*-
+;;;;
+;;;; $Id: all-tests.lisp,v 1.2 2004/06/17 19:43:11 rschlatte Exp $
+;;;;
+;;;; Load and execute all unit and functional tests
+;;;;
+;;;; Copyright (C) 2002-2005 Sven Van Caekenberghe, Beta Nine BVBA.
+;;;;
+;;;; You are granted the rights to distribute and use this software
+;;;; as governed by the terms of the Lisp Lesser General Public License
+;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
+
+(load (merge-pathnames "test-sysdeps" *load-pathname*) :verbose t)
+
+;;;; eof
diff --git a/third-party/s-sysdeps/test/test-sysdeps.lisp b/third-party/s-sysdeps/test/test-sysdeps.lisp
new file mode 100644
index 0000000..82c07c4
--- /dev/null
+++ b/third-party/s-sysdeps/test/test-sysdeps.lisp
@@ -0,0 +1,19 @@
+;;;; -*- mode: lisp -*-
+;;;;
+;;;; $Id: test-base64.lisp,v 1.1.1.1 2004/06/09 09:02:41 scaekenberghe Exp $
+;;;;
+;;;; Unit and functional tests for S-SYSDEPS
+;;;;
+;;;; Copyright (C) 2002-2005 Sven Van Caekenberghe, Beta Nine BVBA.
+;;;;
+;;;; You are granted the rights to distribute and use this software
+;;;; as governed by the terms of the Lisp Lesser General Public License
+;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
+
+(in-package :s-sysdeps)
+
+(print "to be completed later")
+
+(assert t)
+
+;;;; eof