diff options
Diffstat (limited to 'third-party/s-sysdeps')
| -rw-r--r-- | third-party/s-sysdeps/.clbuild-skip-update | 0 | ||||
| -rw-r--r-- | third-party/s-sysdeps/Makefile | 82 | ||||
| -rw-r--r-- | third-party/s-sysdeps/README.txt | 1 | ||||
| -rw-r--r-- | third-party/s-sysdeps/doc/API.html | 19 | ||||
| -rw-r--r-- | third-party/s-sysdeps/doc/index.html | 203 | ||||
| -rw-r--r-- | third-party/s-sysdeps/s-sysdeps.asd | 31 | ||||
| -rw-r--r-- | third-party/s-sysdeps/src/bivalent-streams.lisp | 107 | ||||
| -rw-r--r-- | third-party/s-sysdeps/src/package.lisp | 28 | ||||
| -rw-r--r-- | third-party/s-sysdeps/src/sysdeps.lisp | 281 | ||||
| -rw-r--r-- | third-party/s-sysdeps/test/all-tests.lisp | 15 | ||||
| -rw-r--r-- | third-party/s-sysdeps/test/test-sysdeps.lisp | 19 |
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>) <i>function</i></p> +<blockquote>Return a list of all processes currently running</blockquote> +<p>(<b>current-process</b>) <i>function</i></p> +<blockquote>Return the object representing the current process</blockquote> +<p>(<b>kill-process</b> process) <i>function</i></p> +<blockquote>Kill the process represented by the object process</blockquote> +<p>(<b>make-process-lock</b> name) <i>function</i></p> +<blockquote>Create a named process lock object</blockquote> +<p>(<b>open-socket-stream</b> host port) <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) <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) <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) <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 © 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 |