Author: hhubner Date: Thu Feb 7 03:21:48 2008 New Revision: 2450 Added: branches/trunk-reorg/thirdparty/acl-compat/ branches/trunk-reorg/thirdparty/acl-compat/CREDITS branches/trunk-reorg/thirdparty/acl-compat/ChangeLog branches/trunk-reorg/thirdparty/acl-compat/README branches/trunk-reorg/thirdparty/acl-compat/acl-compat-cmu.system branches/trunk-reorg/thirdparty/acl-compat/acl-compat-common-lisp-lw.lisp branches/trunk-reorg/thirdparty/acl-compat/acl-compat-corman.lisp branches/trunk-reorg/thirdparty/acl-compat/acl-compat.asd branches/trunk-reorg/thirdparty/acl-compat/acl-excl-common.lisp branches/trunk-reorg/thirdparty/acl-compat/acl-excl-corman.lisp branches/trunk-reorg/thirdparty/acl-compat/acl-mp-corman.lisp branches/trunk-reorg/thirdparty/acl-compat/acl-mp-package.lisp branches/trunk-reorg/thirdparty/acl-compat/acl-socket-corman.lisp branches/trunk-reorg/thirdparty/acl-compat/acl-ssl-streams.lisp branches/trunk-reorg/thirdparty/acl-compat/acl-ssl.lisp branches/trunk-reorg/thirdparty/acl-compat/allegro/ branches/trunk-reorg/thirdparty/acl-compat/allegro/acl-excl.lisp branches/trunk-reorg/thirdparty/acl-compat/allegro/acl-mp.lisp branches/trunk-reorg/thirdparty/acl-compat/allegro/acl-socket.lisp branches/trunk-reorg/thirdparty/acl-compat/allegro/acl-sys.lisp branches/trunk-reorg/thirdparty/acl-compat/chunked-stream-mixin.lisp branches/trunk-reorg/thirdparty/acl-compat/chunked.lisp (contents, props changed) branches/trunk-reorg/thirdparty/acl-compat/clisp/ branches/trunk-reorg/thirdparty/acl-compat/clisp/acl-excl.lisp branches/trunk-reorg/thirdparty/acl-compat/clisp/acl-mp.lisp branches/trunk-reorg/thirdparty/acl-compat/clisp/acl-socket.lisp branches/trunk-reorg/thirdparty/acl-compat/clisp/acl-sys.lisp branches/trunk-reorg/thirdparty/acl-compat/cmucl/ branches/trunk-reorg/thirdparty/acl-compat/cmucl/acl-excl.lisp branches/trunk-reorg/thirdparty/acl-compat/cmucl/acl-mp.lisp branches/trunk-reorg/thirdparty/acl-compat/cmucl/acl-socket.lisp branches/trunk-reorg/thirdparty/acl-compat/cmucl/acl-sys.lisp branches/trunk-reorg/thirdparty/acl-compat/defsys.lisp branches/trunk-reorg/thirdparty/acl-compat/lispworks/ branches/trunk-reorg/thirdparty/acl-compat/lispworks/acl-excl.lisp branches/trunk-reorg/thirdparty/acl-compat/lispworks/acl-mp.lisp branches/trunk-reorg/thirdparty/acl-compat/lispworks/acl-socket.lisp branches/trunk-reorg/thirdparty/acl-compat/lispworks/acl-sys.lisp branches/trunk-reorg/thirdparty/acl-compat/lw-buffering.lisp branches/trunk-reorg/thirdparty/acl-compat/mcl/ branches/trunk-reorg/thirdparty/acl-compat/mcl/acl-excl.lisp branches/trunk-reorg/thirdparty/acl-compat/mcl/acl-mp.lisp branches/trunk-reorg/thirdparty/acl-compat/mcl/acl-socket-mcl.lisp branches/trunk-reorg/thirdparty/acl-compat/mcl/acl-socket-openmcl.lisp branches/trunk-reorg/thirdparty/acl-compat/mcl/acl-sys.lisp branches/trunk-reorg/thirdparty/acl-compat/mcl/mcl-stream-fix.lisp branches/trunk-reorg/thirdparty/acl-compat/mcl/mcl-timers.lisp branches/trunk-reorg/thirdparty/acl-compat/packages.lisp branches/trunk-reorg/thirdparty/acl-compat/sbcl/ branches/trunk-reorg/thirdparty/acl-compat/sbcl/acl-excl.lisp branches/trunk-reorg/thirdparty/acl-compat/sbcl/acl-mp.lisp branches/trunk-reorg/thirdparty/acl-compat/sbcl/acl-socket.lisp branches/trunk-reorg/thirdparty/acl-compat/sbcl/acl-sys.lisp branches/trunk-reorg/thirdparty/acl-compat/scl/ branches/trunk-reorg/thirdparty/acl-compat/scl/acl-excl.lisp branches/trunk-reorg/thirdparty/acl-compat/scl/acl-mp.lisp branches/trunk-reorg/thirdparty/acl-compat/scl/acl-socket.lisp branches/trunk-reorg/thirdparty/acl-compat/scl/acl-sys.lisp branches/trunk-reorg/thirdparty/acl-compat/test-acl-socket.lisp (contents, props changed) Log: add acl-compat Added: branches/trunk-reorg/thirdparty/acl-compat/CREDITS ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/acl-compat/CREDITS Thu Feb 7 03:21:48 2008 @@ -0,0 +1,59 @@ +-*- text -*- + +CREDITS; a.k.a. the history of Portable AllegroServe + +This was written by Rudi Schlatte, who (knowing himself) is sure he +forgot some important contributors. Please mail me (rudi at +constantly.at) to point out any inconsistencies, don't be shy! + +* Corman Lisp + +The code that started it all. Chris Double took Allegro's +open-sourced code, got it to run on Corman Lisp and released the +code.. After Portable AllegroServe got off the ground, he re-arranged +his port so that it fit in the structure of acl-compat. + +* Xanalys LispWorks + +Jochen Schmidt ported Chris Double's AllegroServe port to LispWorks, +laid the groundwork for the "Portable" part of paserve and started +the SourceForge project. + +* cmucl + +cmucl was the third Lisp implementation to run Portable +AllegroServe. The port was done by Rudi Schlatte during his military +service out of sheer boredom. + +* Digitool MCL + +John DeSoi contributed this port and kept it working when the antics +of other developers broke his code once again. + +* OpenMCL + +Also done by John DeSoi. Gary Byers himself later contributed code to +support OpenMCL's OS-level threads (OpenMCL version 14 and up) in an +efficient way. + +* sbcl + +This port was done by Rudi Schlatte, using Daniel Barlow's sbcl +multiprocessing code in the McCLIM GUI project as inspiration. + +* clisp + +Also by Rudi Schlatte. Since clisp has no support for threads, +neither does acl-compat on this platform. Code can still be +compiled, however. + +* Scieneer Common Lisp + +This port was contributed by Douglas Crosher. + +* Allegro Common Lisp + +It may seem strange to implement an API on top of itself, but Kevin +Rosenberg's implementation makes it possible to run systems that use +acl-compat on ACL itself without source changes. + Added: branches/trunk-reorg/thirdparty/acl-compat/ChangeLog ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/acl-compat/ChangeLog Thu Feb 7 03:21:48 2008 @@ -0,0 +1,354 @@ +2006-01-22 Rudi Schlatte <rudi@constantly.at> + + * sbcl/acl-mp.lisp (defun/sb-thread): silence compilation style + warning on single-threaded sbcl + + * sbcl/acl-excl.lisp (filesys-type): Fix bogus variable name :( + +2006-01-21 Rudi Schlatte <rudi@constantly.at> + + * sbcl/acl-excl.lisp (filesys-type, filesys-inode): use sb-posix + instead of sbcl internals + +2005-08-05 Gabor Melis <mega@hotpop.com> + + * sbcl/acl-mp.lisp: updated to use the thread object api + available since sbcl 0.9.2 + +2004-02-17 Rudi Schlatte <rudi@SLAW40.kfunigraz.ac.at> + + * acl-excl-common.lisp (match-regexp): Make :return :index return + values same as ACL + +2004-02-16 Rudi Schlatte <rudi@62-99-252-74.C-GMITTE.Xdsl-line.inode.at> + + * acl-compat.asd: + - Add some meta-information to system definition + - Fix bug: all but the first :depends-on arguments are silently + ignored. :/ + +2004-02-16 Rudi Schlatte <rudi@constantly.at> + + * packages.lisp: Remove references to nregex package. + + * acl-excl-common.lisp (match-regexp, compile-regexp): Implement + using cl-ppcre. + + * acl-compat.asd: Eliminate meta and nregex, use cl-ppcre instead. + +2004-02-14 Rudi Schlatte <rudi@constantly.at> + + * acl-compat.asd: Make Gray streams loading on cmucl a little bit + saner (but only a little bit) + + * chunked-stream-mixin.lisp: Don't add to *features*, remove + provide form. + +2004-02-08 Rudi Schlatte <rudi@constantly.at> + + * acl-compat.asd: Introduce dependency on puri, remove meta and + uri.lisp + +2004-02-02 Rudi Schlatte <rudi@constantly.at> + + * cmucl/acl-mp.lisp (process-run-function): Give the new process + a run reason, so that it doesn't hang from the start. + + * cmucl/acl-socket.lisp (get-fd): Added method for server-socket. + +2004-01-28 Rudi Schlatte <rudi@constantly.at> + + * packages.lisp: excl -> acl-compat.excl + + * lispworks/acl-socket.lisp: ditto. + +2004-01-27 Rudi Schlatte <rudi@constantly.at> + + * chunked-stream-mixin.lisp: replace excl: package prefix with + acl-compat.excl: + +2004-01-26 Rudi Schlatte <rudi@constantly.at> + + * mcl/acl-excl.lisp (fixnump): new function. + + * packages.lisp (:acl-compat.excl): Remove "excl" nickname. + + * clisp/acl-excl.lisp (fixnump): new function. + +2004-01-24 Rudi Schlatte <rudi@constantly.at> + + * acl-excl-common.lisp (string-to-octets): null-terminate vector + when asked to. + + * cmucl/acl-excl.lisp, lispworks/acl-excl.lisp, mcl/acl-excl.lisp, + sbcl/acl-excl.lisp, scl/acl-excl.lisp: Move write-vector, + string-to-octets to commmon file. + + * acl-excl-common.lisp: Moved write-vector, string-to-octets from + implementation-specific files. + +2004-01-19 Rudi Schlatte <rudi@constantly.at> + + * scl/acl-excl.lisp, sbcl/acl-excl.lisp, mcl/acl-excl.lisp, + lispworks/acl-excl.lisp, cmucl/acl-excl.lisp, + clisp/acl-excl.lisp: Remove common functionality from + implementation-specific files, dammit! + + * acl-compat.asd: Added acl-excl-common. + + * acl-excl-common.lisp: New file. + +2004-01-18 Rudi Schlatte <rudi@62-99-252-74.C-GMITTE.Xdsl-line.inode.at> + + * acl-excl-corman.lisp (intern*), sbcl/acl-excl.lisp (intern*), + mcl/acl-excl.lisp (intern*), lispworks/acl-excl.lisp (intern*), + cmucl/acl-excl.lisp (intern*), clisp/acl-excl.lisp (intern*), + scl/acl-excl.lisp (intern*): Don't upcase symbol before interning + (thanks to Marco Baringer, whose code was broken by this). Now + I'm motivated to factor out common code from all the backends ... + + * cmucl/acl-mp.lisp (apply-with-bindings): Fix "How did this ever + work" typo; thanks to Marco Baringer. + +2004-01-11 Rudi Schlatte <rudi@constantly.at> + + * sbcl/acl-socket.lisp (make-socket): Handle :local-port nil, + don't bind socket in that case (let os choose a port) + +2004-01-11 Rudi Schlatte <rudi@constantly.at> + + * packages.lisp (defpackage acl-compat.excl): Export some symbols + for mcl, too + + * mcl/acl-excl.lisp (run-shell-command): Implement (largely + untested for now, needed for cgi support) + + * mcl/acl-sys.lisp (command-line-argument, + command-line-arguments): Implement for OpenMCL + + * mcl/acl-mp.lisp (wait-for-input-available): Implement. Needed + for cgi support. + + * mcl/acl-socket-openmcl.lisp (server-socket): Remove :type slot + argument. + + * sbcl/acl-socket.lisp (make-socket): Add reuse-address argument. + + * cmucl/acl-socket.lisp (make-socket): Add reuse-address argument. + + * acl-compat.asd: Load sb-posix for sbcl. + +2003-12-15 Rudi Schlatte <rudi@constantly.at> + + NOTE: this checkin has a reasonable chance of breaking (and mcl + (not openmcl)) + + * mcl/acl-socket-openmcl.lisp: Remove package definition, + implement chunked transfer encoding (accepting a speed loss in the + process) + + * mcl/acl-excl.lisp, mcl/acl-mp.lisp, mcl/acl-sys.lisp: remove + package definitions + + * uri.lisp: deftype also at load time; openmcl breaks otherwise + + * packages.lisp: mcl doesn't have stream-(read,write)-sequence + + * lw-buffering.lisp: formatting frobs. + + * acl-compat.asd: Merge mcl defsystem with the others. + + * sbcl/acl-socket.lisp: Use acl-compat.socket package name. + +2003-12-02 Rudi Schlatte <rudi@SLAW40.kfunigraz.ac.at> + + * meta.lisp (enable-meta-syntax): Save current readtable before + installing *meta-readtable*. + +2003-12-01 Rudi Schlatte <rudi@constantly.at> + + * chunked-stream-mixin.lisp: Merge Lispworks patch from Edi Weitz + (paserve-help 2003-11-28) + +2003-11-27 Rudi Schlatte <rudi@constantly.at> + + * chunked-stream-mixin.lisp (gray-stream:stream-fill-buffer): + LispWorks refill-buffer does not always return the amount of + bytes read (reported by Edi Weitz to paserve-discuss + 2003-11-26). Treat its return value as a boolean. + + * lw-buffering.lisp (stream-fill-buffer): Remove cmucl-specific + read-n-bytes call because it does block after all :( + + * chunked-stream-mixin.lisp (gray-stream:stream-fill-buffer): Fix + for Lispworks client mode contributed by Edi Weitz to + paserve-discuss list on 2003-11-25 + + * sbcl/acl-mp.lisp: Single-threaded "implementation" of process-name + +2003-09-19 Rudi Schlatte <rudi@constantly.at> + + * sbcl/acl-mp.lisp: Merged threading patch from Brian Downing + (posted to portableaserve-discuss 2003-09-12) + + * clisp/acl-excl.lisp, clisp/acl-socket.lisp: Eliminate compile + failures, activate chunked support for clisp (forwarded by Kevin + M. Rosenberg from Debian) + +2003-08-31 Rudi Schlatte <rudi@constantly.at> + + * acl-compat.asd: Remove old cmu-read-sequence cruft, bug is fixed + in reasonably recent cmucl + + * lw-buffering.lisp (stream-fill-buffer): Use package-external + symbol that doesn't break on CVS cmucl + +2003-08-30 Rudi Schlatte <rudi@62-99-252-74.C-GMITTE.Xdsl-line.inode.at> + + * cmucl/acl-socket.lisp (make-socket): set reuse-address option. + + * lw-buffering.lisp (stream-fill-buffer): Implement b/nb semantics + for cmucl as well. client mode should now neither hang trying to + read closed streams nor give spurious errors for slow servers. + +2003-08-17 Rudi Schlatte <rudi@constantly.at> + + * sbcl/acl-mp.lisp (with-timeout): Eliminate unused-variable + warning. + +2003-05-13 Rudi Schlatte <rudi@constantly.at> + + * cmucl/acl-sys.lisp, cmucl/acl-socket.lisp, cmucl/acl-excl.lisp: + Use correct package names in in-package forms (Reported by Johan + Parin) + + * packages.lisp (acl-compat.system): Add nickname acl-compat.sys, + remove commented-out nicknames. + + * lispworks/acl-sys.lisp: push MSWINDOWS onto *features* if + appropriate (Thanks to Alain Picard for the report). + +2003-05-11 Rudi Schlatte <rudi@constantly.at> + + * acl-compat.asd: Don't load read-/write-sequence patches on cmucl + 18e. + +2003-05-06 Rudi Schlatte <rudi@constantly.at> + + * lw-buffering.lisp (stream-fill-buffer): Implement + blocking/non-blocking semantics (read at least one byte per + fill-buffer call). Otherwise we'd get spurious EOFs with slow + servers. + + * chunked-stream-mixin.lisp (gray-stream:stream-fill-buffer): + Return a sensible value (amount of bytes that can be read before + next call to fill-buffer). + +2003-05-03 Rudi Schlatte <rudi@constantly.at> + + * chunked-stream-mixin.lisp (gray-stream:stream-fill-buffer): Make + input-chunking work, refactor somewhat to make all slot changes in + one place. + +2003-05-02 Rudi Schlatte <rudi@constantly.at> + + * acl-compat.asd (acl-compat): Current cmucl versions handle Gray + streams in (read,write)-sequence -- remove hack + +2003-04-30 Rudi Schlatte <rudi@constantly.at> + + * sbcl/acl-mp.lisp (with-timeout): Use timeout symbols from the + ext package; latest cvs exports them + + * cmucl/acl-mp.lisp: Use acl-compat.mp package name. + + * acl-compat.asd et al: The Great Renaming: begin move of + implementation-dependent files into subdirectories + +2003-04-27 Rudi Schlatte <rudi@constantly.at> + + * acl-socket-sbcl.lisp: Implemented peername lookup (by storing + the socket in the plist of the bivalent stream object for now) + +2003-04-26 Rudi Schlatte <rudi@constantly.at> + + * acl-mp-sbcl.lisp: Add initial support for multi-threaded sbcl + +2003-04-08 Rudi Schlatte <rudi@constantly.at> + + * uri.lisp (render-uri): Reinstate with-output-to-string logic; + render-uri has to handle nil as a stream value. + +2003-04-03 Rudi Schlatte <rudi@constantly.at> + + * uri.lisp (render-uri, print-object): Further frob printing of + URIs, inspired by patch of Harley Gorrell + +2003-04-02 Rudi Schlatte <rudi@constantly.at> + + * uri.lisp (render-uri): Fix printing URIs in the presence of #\~ + (Thanks to Harley Gorrell) + +2003-03-24 Rudi Schlatte <rudi@constantly.at> + + * lw-buffering.lisp (stream-write-buffer, stream-flush-buffer): + Eliminate "wait" parameter to regain api-compatibility with lispworks + (stream-finish-output, stream-force-output): Call (finish|force)-output + here instead of using "wait" parameter of stream-flush-buffer + + * chunked-stream-mixin.lisp: some documentation added, formatting, + eliminate use of "wait" parameter on stream-write-buffer etc. + +2003-02-28 Rudi Schlatte <rudi@constantly.at> + + * acl-socket-sbcl.lisp: + (remote-host, remote-port, local-host, local-port): Change return + value to something convertible to an (invalid) inet address + + * acl-compat.asd, packages.lisp: Support sbcl 0.7.13 single-threaded + +2002-12-26 Rudi Schlatte <rudi@constantly.at> + + * lw-buffering.lisp (write-elements): end argument value can be + nil (fix contributed by Simon Andras 2002-12-24) + + * meta.lisp: Switch to new-style eval-when times + + * lw-buffering.lisp: Switch to new-style eval-when times + (defstruct buffer-state): Add type declarations + (stream-fill-buffer): Remove bug for non-cmucl case (need + unblocking read-sequence) + + * chunked-stream-mixin.lisp: Add defgeneric forms + + * acl-socket-sbcl.lisp: Enable chunked transfer encoding support + +2002-12-23 Rudi Schlatte <rudi@constantly.at> + + * packages.lisp, acl-sys-sbcl.lisp: Various sbcl fixes + +2002-12-18 Rudi Schlatte <rudi@constantly.at> + + * packages.lisp: Add package definition of + de.dataheaven.chunked-stream-mixin, remove nicknames for + acl-compat.system + +2002-12-17 Rudi Schlatte <rudi@constantly.at> + + * (Module): Added first stab at sbcl support (some stub + functions, basic page serving works) + +2002-12-13 Rudi Schlatte <rudi@constantly.at> + + * lw-buffering.lisp (stream-write-sequence): Make publish-multi + work (provide default value for start arg). + + * acl-excl-cmu.lisp (write-vector): ditto. + +2002-12-03 Rudi Schlatte <rudi@constantly.at> + + * acl-compat.asd: load lw-buffering in every implementation except + lispworks + + * packages.lisp: define gray-stream package for every + implementation Added: branches/trunk-reorg/thirdparty/acl-compat/README ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/acl-compat/README Thu Feb 7 03:21:48 2008 @@ -0,0 +1,33 @@ +-*- text -*- + +acl-compat is a library that implements parts of the Allegro Common +Lisp (ACL) API for areas that are not covered by the ANSI Common Lisp +standard itself (e.g. sockets, threading). The motivation for +creating and maintaining acl-compat is to get the web server +AllegroServe (that was released by Franz Inc under the LLGPL) running +on a wide range of Lisp implementations, with as few source changes to +its core code as possible. + +acl-compat names its packages by prepending the corresponding ACL +package name with the string "ACL-COMPAT.". For example, the ACL +threading API symbols are exported from the package ACL-COMPAT.MP. +Ideally, ACL-specific code could run on any supported Lisp +implementation only by changing package references. + +Of course, the present situation is not ideal. :( Functionality is +only implemented on an as-needed basis, implemented functions don't +handle all argument combinations properly, etc. On the other hand, +enough is implemented to support a web and application server that +exercises a wide range of functionality (client and server sockets, +threading, etc.). + + +To load acl-compat: + +- install asdf (see < http://www.cliki.net/asdf >) and make sure it's + loaded. + +- load acl-compat.asd + +- evaluate (asdf:operate 'asdf:load-op :acl-compat) + Added: branches/trunk-reorg/thirdparty/acl-compat/acl-compat-cmu.system ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/acl-compat/acl-compat-cmu.system Thu Feb 7 03:21:48 2008 @@ -0,0 +1,36 @@ +;;; -*- mode: lisp -*- + +(in-package :CL-USER) + +;; Stig: we're a debian-package if clc is present +;; Rudi: Not if kludge-no-cclan is also present +#+(and common-lisp-controller (not kludge-no-cclan)) +(setf (logical-pathname-translations "acl-compat") + '(("**;*.*.*" "cl-library:;acl-compat;**;*.*.*"))) + +(mk:defsystem "ACL-COMPAT" + :source-pathname (make-pathname :directory + (pathname-directory *load-truename*)) ;"acl-compat:" +; :source-extension "lisp" +; :binary-pathname nil +; :binary-extension nil + :components ((:file "nregex") + (:file "packages" :depends-on ("nregex")) + (:file "lw-buffering" :depends-on ("packages")) + (:file "acl-mp-cmu" :depends-on ("packages")) + (:file "acl-excl-cmu" :depends-on ("packages" "nregex")) + (:file "cmu-read-sequence") + (:file "acl-socket-cmu" + :depends-on ("packages" "acl-excl-cmu" + "chunked-stream-mixin" + "cmu-read-sequence")) + (:file "acl-sys-cmu" :depends-on ("packages")) + (:file "meta") + (:file "uri" :depends-on ("meta")) + (:file "chunked-stream-mixin" + :depends-on ("packages" "acl-excl-cmu" + "lw-buffering"))) + ;; Stig: if we're CMU and a debian-package, we need graystreams + #+(and cmu common-lisp-controller) + :depends-on + #+(and cmu common-lisp-controller) (cmucl-graystream)) Added: branches/trunk-reorg/thirdparty/acl-compat/acl-compat-common-lisp-lw.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/acl-compat/acl-compat-common-lisp-lw.lisp Thu Feb 7 03:21:48 2008 @@ -0,0 +1,21 @@ +(defpackage acl-compat-common-lisp + (:use common-lisp) + (:shadow make-hash-table) + (:export make-hash-table)) + +(in-package :acl-compat-common-lisp) + +(defun make-hash-table (&rest args &key test size rehash-size rehash-threshold (hash-function nil h-f-p) + (values t) weak-keys) + (declare (ignore hash-function)) + (when h-f-p (error "User defined hash-functions are not supported.")) + (let ((table (apply #'cl:make-hash-table :allow-other-keys t args))) + (hcl:set-hash-table-weak table + (if weak-keys + (if (eq values :weak) + :both + :key) + (if (eq values :weak) + :value + nil))) + table)) \ No newline at end of file Added: branches/trunk-reorg/thirdparty/acl-compat/acl-compat-corman.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/acl-compat/acl-compat-corman.lisp Thu Feb 7 03:21:48 2008 @@ -0,0 +1,13 @@ +(require 'gray-streams) +(in-package :cl-user) + +(defvar *acl-compat-directory* "d:/projects/lisp/portableaserve/acl-compat/") +(load (concatenate 'string *acl-compat-directory* "nregex.lisp")) +(load (concatenate 'string *acl-compat-directory* "meta.lisp")) +(load (concatenate 'string *acl-compat-directory* "acl-excl-corman.lisp")) +(load (concatenate 'string *acl-compat-directory* "acl-mp-corman.lisp")) +(load (concatenate 'string *acl-compat-directory* "acl-socket-corman.lisp")) +(load (concatenate 'string *acl-compat-directory* "uri.lisp")) +(load (concatenate 'string *acl-compat-directory* "packages.lisp")) + +(pushnew :acl-compat *features*) \ No newline at end of file Added: branches/trunk-reorg/thirdparty/acl-compat/acl-compat.asd ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/acl-compat/acl-compat.asd Thu Feb 7 03:21:48 2008 @@ -0,0 +1,182 @@ +;;;; -*- mode: lisp -*- +;;;; +;;;; This as an ASDF system for ACL-COMPAT, meant to replace +;;;; acl-compat-cmu.system, but could replace all other systems, too. +;;;; (hint, hint) + +(defpackage #:acl-compat-system + (:use #:cl #:asdf)) +(in-package #:acl-compat-system) + +;;;; gray stream support for cmucl: Debian/common-lisp-controller has +;;;; a `cmucl-graystream' system; if this is not found, we assume a +;;;; cmucl downloaded from cons.org, where Gray stream support resides +;;;; in the subsystems/ directory. + + +#+cmu +(progn + +(defclass precompiled-file (static-file) + ()) + +(defmethod perform ((operation load-op) (c precompiled-file)) + (load (component-pathname c))) + +(defmethod operation-done-p ((operation load-op) (c precompiled-file)) + nil) + +#-gray-streams +(eval-when (:compile-toplevel :load-toplevel :execute) + (unless (asdf:find-system :cmucl-graystream nil) + (asdf:defsystem cmucl-graystream + :pathname (make-pathname + :name nil :type nil :version nil + :defaults (truename "library:subsystems/gray-streams-library.x86f")) + :components ((:precompiled-file "gray-streams-library.x86f"))))) +) + +;;;; ignore warnings +;;;; +;;;; FIXME: should better fix warnings instead of ignoring them +;;;; FIXME: (perform legacy-cl-sourcefile) duplicates ASDF code + +(defclass legacy-cl-source-file (cl-source-file) + () + (:documentation + "Common Lisp source code module with (non-style) warnings. +In contrast to CL-SOURCE-FILE, this class does not think that such warnings +indicate failure.")) + +(defmethod perform ((operation compile-op) (c legacy-cl-source-file)) + (let ((source-file (component-pathname c)) + (output-file (car (output-files operation c))) + (warnings-p nil) + (failure-p nil)) + (setf (asdf::component-property c 'last-compiled) nil) + (handler-bind ((warning (lambda (c) + (declare (ignore c)) + (setq warnings-p t))) + ;; _not_ (or error (and warning (not style-warning))) + (error (lambda (c) + (declare (ignore c)) + (setq failure-p t)))) + (compile-file source-file + :output-file output-file)) + ;; rest of this method is as for CL-SOURCE-FILE + (setf (asdf::component-property c 'last-compiled) (file-write-date output-file)) + (when warnings-p + (case (asdf::operation-on-warnings operation) + (:warn (warn "COMPILE-FILE warned while performing ~A on ~A" + c operation)) + (:error (error 'compile-warned :component c :operation operation)) + (:ignore nil))) + (when failure-p + (case (asdf::operation-on-failure operation) + (:warn (warn "COMPILE-FILE failed while performing ~A on ~A" + c operation)) + (:error (error 'compile-failed :component c :operation operation)) + (:ignore nil))))) + +;;; +;;; This is thought to reduce reader-conditionals in the system definition +;;; +(defclass unportable-cl-source-file (cl-source-file) () + (:documentation + "This is for files which contain lisp-system dependent code. Until now those +are marked by a -system postfix but we could later change that to a directory per +lisp-system")) + +(defmethod perform ((op load-op) (c unportable-cl-source-file)) + (#+cmu ext:without-package-locks + #-(or cmu) progn + (call-next-method))) + +(defmethod perform ((op compile-op) (c unportable-cl-source-file)) + (#+cmu ext:without-package-locks + #-(or cmu) progn + (call-next-method))) + +(defmethod source-file-type ((c unportable-cl-source-file) (s module)) + "lisp") + + +(defun lisp-system-shortname () + #+allegro :allegro #+lispworks :lispworks #+cmu :cmucl + #+(or mcl openmcl) :mcl #+clisp :clisp #+scl :scl #+sbcl :sbcl) ;mcl/openmcl use the same directory + +(defmethod component-pathname ((component unportable-cl-source-file)) + (let ((pathname (call-next-method)) + (name (string-downcase (lisp-system-shortname)))) + (merge-pathnames + (make-pathname :directory (list :relative name)) + pathname))) + +;;;; system + +#+(and mcl (not openmcl)) (require :ansi-make-load-form) + +(defsystem acl-compat + :name "acl-compat" + :author "The acl-compat team" + :version "0.1.1" + :description + "A reimplementation of parts of the ACL API, mainly to get + AllegroServe running on various machines, but might be useful + in other projects as well." + :properties + ((("system" "author" "email") . "portableaserve-discuss@lists.sourceforge.net") + (("albert" "presentation" "output-dir") . "docs/") + (("albert" "presentation" "formats") . "docbook") + (("albert" "docbook" "dtd") . "/Users/Shared/DocBook/lib/docbook/docbook-dtd-412/docbookx.dtd") + (("albert" "docbook" "template") . "book")) + :components + ( + ;; packages + (:file "packages") + ;; Our stream class; support for buffering, chunking and (in the + ;; future) unified stream exceptions + #-(or lispworks (and mcl (not openmcl))) + (:file "lw-buffering" :depends-on ("packages")) + #-(or allegro (and mcl (not openmcl))) + (:legacy-cl-source-file "chunked-stream-mixin" + :depends-on ("packages" "acl-excl" + #-lispworks "lw-buffering")) + ;; Multiprocessing + #+(or mcl openmcl) (:unportable-cl-source-file "mcl-timers") + (:unportable-cl-source-file "acl-mp" + :depends-on ("packages" #+(or mcl openmcl) "mcl-timers")) + ;; Sockets, networking; TODO: de-frob this a bit + #-(or mcl openmcl) + (:unportable-cl-source-file + "acl-socket" :depends-on ("packages" "acl-excl" + #-(or allegro (and mcl (not openmcl))) "chunked-stream-mixin")) + #+(and mcl (not openmcl)) + (:unportable-cl-source-file "acl-socket-mcl" :depends-on ("packages")) + #+(and mcl (not openmcl) (not carbon-compat)) + (:unportable-cl-source-file + "mcl-stream-fix" :depends-on ("acl-socket-mcl")) + #+openmcl + (:unportable-cl-source-file + "acl-socket-openmcl" :depends-on ("packages" "chunked-stream-mixin")) + ;; Diverse macros, utility functions + #-allegro (:file "acl-excl-common" :depends-on ("packages")) + (:unportable-cl-source-file "acl-excl" :depends-on + #-allegro ("acl-excl-common") + #+allegro ("packages")) + (:unportable-cl-source-file "acl-sys" :depends-on ("packages")) + ;; SSL + #+(and ssl-available (not (or allegro mcl openmcl clisp))) + (:file "acl-ssl" :depends-on ("acl-ssl-streams" "acl-socket")) + #+(and ssl-available (not (or allegro mcl openmcl clisp))) + (:file "acl-ssl-streams" :depends-on ("packages"))) + ;; Dependencies + :depends-on (:puri + :cl-ppcre + #+sbcl :sb-bsd-sockets + #+sbcl :sb-posix + #+(and cmu (not gray-streams)) :cmucl-graystream + #+(and (or cmu lispworks) ssl-available) :cl-ssl + ) + :perform (load-op :after (op acl-compat) + (pushnew :acl-compat cl:*features*))) Added: branches/trunk-reorg/thirdparty/acl-compat/acl-excl-common.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/acl-compat/acl-excl-common.lisp Thu Feb 7 03:21:48 2008 @@ -0,0 +1,194 @@ +;;;; +;;;; ACL-COMPAT - EXCL +;;;; +;;;; This is a modified version of Chris Doubles ACL excl wrapper library +;;;; As stated in the changelogs of his original this file includes the +;;;; IF* macro placed in the public domain by John Foderaro. +;;;; See: http://www.franz.com/~jkf/ifstar.txt +;;;; + +;;;; This file was made by Rudi Schlatte to gather +;;;; not-implementation-specific parts of acl-compat in one place. + +;;;; This is the header of Chris Doubles original file. (but without Changelog) +;;;; +;;;; ACL excl wrapper library for Corman Lisp - Version 1.1 +;;;; +;;;; Copyright (C) 2000 Christopher Double. All Rights Reserved. +;;;; +;;;; License +;;;; ======= +;;;; This software is provided 'as-is', without any express or implied +;;;; warranty. In no event will the author be held liable for any damages +;;;; arising from the use of this software. +;;;; +;;;; Permission is granted to anyone to use this software for any purpose, +;;;; including commercial applications, and to alter it and redistribute +;;;; it freely, subject to the following restrictions: +;;;; +;;;; 1. The origin of this software must not be misrepresented; you must +;;;; not claim that you wrote the original software. If you use this +;;;; software in a product, an acknowledgment in the product documentation +;;;; would be appreciated but is not required. +;;;; +;;;; 2. Altered source versions must be plainly marked as such, and must +;;;; not be misrepresented as being the original software. +;;;; +;;;; 3. This notice may not be removed or altered from any source +;;;; distribution. +;;;; + +(in-package :acl-compat.excl) + +(defvar if*-keyword-list '("then" "thenret" "else" "elseif")) + +;this is not used in aserve, but is needed to use the franz xmlutils package with acl-compat +(defvar *current-case-mode* :case-insensitive-upper) + +(defmacro if* (&rest args) + (do ((xx (reverse args) (cdr xx)) + (state :init) + (elseseen nil) + (totalcol nil) + (lookat nil nil) + (col nil)) + ((null xx) + (cond ((eq state :compl) + `(cond ,@totalcol)) + (t (error "if*: illegal form ~s" args)))) + (cond ((and (symbolp (car xx)) + (member (symbol-name (car xx)) + if*-keyword-list + :test #'string-equal)) + (setq lookat (symbol-name (car xx))))) + + (cond ((eq state :init) + (cond (lookat (cond ((string-equal lookat "thenret") + (setq col nil + state :then)) + (t (error + "if*: bad keyword ~a" lookat)))) + (t (setq state :col + col nil) + (push (car xx) col)))) + ((eq state :col) + (cond (lookat + (cond ((string-equal lookat "else") + (cond (elseseen + (error + "if*: multiples elses"))) + (setq elseseen t) + (setq state :init) + (push `(t ,@col) totalcol)) + ((string-equal lookat "then") + (setq state :then)) + (t (error "if*: bad keyword ~s" + lookat)))) + (t (push (car xx) col)))) + ((eq state :then) + (cond (lookat + (error + "if*: keyword ~s at the wrong place " (car xx))) + (t (setq state :compl) + (push `(,(car xx) ,@col) totalcol)))) + ((eq state :compl) + (cond ((not (string-equal lookat "elseif")) + (error "if*: missing elseif clause "))) + (setq state :init))))) + +(defvar *initial-terminal-io* *terminal-io*) +(defvar *cl-default-special-bindings* nil) + +(defun filesys-size (stream) + (file-length stream)) + +(defun filesys-write-date (stream) + (file-write-date stream)) + +(defun frob-regexp (regexp) + "This converts from ACL regexps to Perl regexps. The escape + status of (, ) and | is toggled." + (let ((escapees '(#\) #\( #\| ))) + (with-input-from-string (in regexp) + (with-output-to-string (out) + (loop for c = (read-char in nil nil nil) + while c + do (cond ((and (char= c #\\) + (member (peek-char nil in nil nil nil) escapees)) + (setf c (read-char in))) + ((member c escapees) + (princ #\\ out))) + (princ c out)))))) + +;; TODO: a compiler macro for constant string regexps would be nice, +;; so that the create-scanner call at runtime can be evaded. +(defun match-regexp (string-or-regexp string-to-match + &key newlines-special case-fold return + (start 0) end shortest) + "Note: if a regexp compiled with compile-regexp is passed, the + options newlines-special and case-fold shouldn't be used, since + the underlying engine uses them when generating the scanner, + not when executing it." + (when shortest (error "match-regexp: shortest option not supported yet.")) + (unless end (setf end (length string-to-match))) + (let ((scanner (cl-ppcre:create-scanner (frob-regexp string-or-regexp) + :case-insensitive-mode case-fold + :single-line-mode newlines-special))) + (ecase return + (:string ; return t, list of strings + (multiple-value-bind (match regs) + (cl-ppcre:scan-to-strings scanner string-to-match + :start start :end end) + (if match + (apply #'values t match (coerce regs 'list)) + nil))) + (:index ; return (cons start end) + (multiple-value-bind (start end reg-starts reg-ends) + (cl-ppcre:scan scanner string-to-match :start start :end end) + (and start (apply #'values t (cons start end) + (map 'list #'cons reg-starts reg-ends))))) + ((nil) ; return t + (not (not (cl-ppcre:scan scanner string-to-match + :start start :end end))))))) + + +;; Caution Incompatible APIs! cl-ppcre has options case-insensitive, +;; single-line for create-scanner, ACL has it in match-regexp. +(defun compile-regexp (regexp) + "Note: Take care when using scanners compiled with this option + to not depend on options case-fold and newlines-special in match-regexp." + (cl-ppcre:create-scanner (frob-regexp regexp))) + +(defvar *current-case-mode* :case-insensitive-upper) + +(defun intern* (s len package) + (intern (subseq s 0 len) package)) + +(defmacro errorset (form &optional (announce nil) (catch-breaks nil)) + "This macro is incomplete. It was hacked to get AllegroServe +running, but the announce and catch-breaks arguments are ignored. See +documentation at +http://franz.com/support/documentation/6.1/doc/pages/operators/excl/errorset... +An implementation of the catch-breaks argument will necessarily be +implementation-dependent, since Ansi does not allow any +program-controlled interception of a break." + (declare (ignore announce catch-breaks)) + `(let* ((ok nil) + (results (ignore-errors + (prog1 (multiple-value-list ,form) + (setq ok t))))) + (if ok + (apply #'values t results) + nil))) + +(defmacro fast (&body forms) + `(locally (declare (optimize (speed 3) (safety 0) (debug 0))) + ,@forms)) + +#-cmu +(defun write-vector (sequence stream &key (start 0) end endian-swap) + (declare (ignore endian-swap)) + (check-type sequence (or string (array (unsigned-byte 8) 1) + (array (signed-byte 8) 1))) + (write-sequence sequence stream :start start :end end)) + Added: branches/trunk-reorg/thirdparty/acl-compat/acl-excl-corman.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/acl-compat/acl-excl-corman.lisp Thu Feb 7 03:21:48 2008 @@ -0,0 +1,233 @@ +;;;; +;;;; ACL-COMPAT - EXCL +;;;; +;;;; This is a modified version of Chris Doubles ACL excl wrapper library +;;;; As stated in the changelogs of his original this file includes the +;;;; IF* macro placed in the public domain by John Foderaro. +;;;; See: http://www.franz.com/~jkf/ifstar.txt +;;;; +;;;; It is not clear to this point if future releases will lead to a combined +;;;; effort - So you may find newer versions of *this* file at +;;;; http://www.dataheaven.de +;;;; + +;;;; This is the header of Chris Doubles original file. (but without Changelog) +;;;; +;;;; ACL excl wrapper library for Corman Lisp - Version 1.1 +;;;; +;;;; Copyright (C) 2000 Christopher Double. All Rights Reserved. +;;;; +;;;; License +;;;; ======= +;;;; This software is provided 'as-is', without any express or implied +;;;; warranty. In no event will the author be held liable for any damages +;;;; arising from the use of this software. +;;;; +;;;; Permission is granted to anyone to use this software for any purpose, +;;;; including commercial applications, and to alter it and redistribute +;;;; it freely, subject to the following restrictions: +;;;; +;;;; 1. The origin of this software must not be misrepresented; you must +;;;; not claim that you wrote the original software. If you use this +;;;; software in a product, an acknowledgment in the product documentation +;;;; would be appreciated but is not required. +;;;; +;;;; 2. Altered source versions must be plainly marked as such, and must +;;;; not be misrepresented as being the original software. +;;;; +;;;; 3. This notice may not be removed or altered from any source +;;;; distribution. +;;;; +;;;; Notes +;;;; ===== +;;;; A simple implementation of some of the EXCL package from Allegro +;;;; Common Lisp. Intended to be used for porting various ACL packages, +;;;; like AllegroServe. +;;;; +;;;; More recent versions of this software may be available at: +;;;; http://www.double.co.nz/cl +;;;; +;;;; Comments, suggestions and bug reports to the author, +;;;; Christopher Double, at: chris@double.co.nz + +(require 'nregex) +(require 'mp) + +(defpackage :excl + (:use :common-lisp :nregex) + (:import-from :common-lisp "FIXNUMP") + (:export + "IF*" + "*INITIAL-TERMINAL-IO*" + "*CL-DEFAULT-SPECIAL-BINDINGS*" + "FILESYS-SIZE" + "FILESYS-WRITE-DATE" + "STREAM-INPUT-FN" + "MATCH-REGEXP" + "COMPILE-REGEXP" + "*CURRENT-CASE-MODE*" + "INTERN*" + "FILESYS-TYPE" + "ERRORSET" + "ATOMICALLY" + "FAST" + "WITHOUT-PACKAGE-LOCKS" + "SOCKET-ERROR" + "RUN-SHELL-COMMAND" + "FIXNUMP" + )) + +(in-package :excl) + +(defvar if*-keyword-list '("then" "thenret" "else" "elseif")) + +(defmacro if* (&rest args) + (do ((xx (reverse args) (cdr xx)) + (state :init) + (elseseen nil) + (totalcol nil) + (lookat nil nil) + (col nil)) + ((null xx) + (cond ((eq state :compl) + `(cond ,@totalcol)) + (t (error "if*: illegal form ~s" args)))) + (cond ((and (symbolp (car xx)) + (member (symbol-name (car xx)) + if*-keyword-list + :test #'string-equal)) + (setq lookat (symbol-name (car xx))))) + + (cond ((eq state :init) + (cond (lookat (cond ((string-equal lookat "thenret") + (setq col nil + state :then)) + (t (error + "if*: bad keyword ~a" lookat)))) + (t (setq state :col + col nil) + (push (car xx) col)))) + ((eq state :col) + (cond (lookat + (cond ((string-equal lookat "else") + (cond (elseseen + (error + "if*: multiples elses"))) + (setq elseseen t) + (setq state :init) + (push `(t ,@col) totalcol)) + ((string-equal lookat "then") + (setq state :then)) + (t (error "if*: bad keyword ~s" + lookat)))) + (t (push (car xx) col)))) + ((eq state :then) + (cond (lookat + (error + "if*: keyword ~s at the wrong place " (car xx))) + (t (setq state :compl) + (push `(,(car xx) ,@col) totalcol)))) + ((eq state :compl) + (cond ((not (string-equal lookat "elseif")) + (error "if*: missing elseif clause "))) + (setq state :init))))) + +(defvar *initial-terminal-io* *terminal-io*) +(defvar *cl-default-special-bindings* nil) + +(defun filesys-size (stream) + (file-length stream)) + +(defun filesys-write-date (stream) + (file-write-date stream)) + +#+obsolete +(defun stream-input-fn (stream) + stream) + +(defmethod stream-input-fn ((stream stream)) + stream) + + +(defun match-regexp (pattern string &key (return :string)) + (let ((res (cond ((stringp pattern) + (regex pattern string)) + ((functionp pattern) (funcall pattern string)) + (t (error "Wrong type for pattern"))))) + (case return + (:string + (values-list (cons (not (null res)) + res))) + (:index (error "REGEXP: INDEX Not implemented")) + (otherwise (not (null res)))))) + +(defun compile-regexp (regexp) + (compile nil (regex-compile regexp))) + +(defvar *current-case-mode* :case-insensitive-upper) + +(defun intern* (s len package) + (intern (subseq s 0 len) package)) + +(defun filesys-type (file-or-directory-name) + (if (ccl::directory-p file-or-directory-name) + :directory + (if (probe-file file-or-directory-name) + :file + nil))) + +(defmacro errorset (form &optional (announce nil) (catch-breaks nil)) + "This macro is incomplete. It was hacked to get AllegroServe +running, but the announce and catch-breaks arguments are ignored. See +documentation at +http://franz.com/support/documentation/6.1/doc/pages/operators/excl/errorset... +An implementation of the catch-breaks argument will necessarily be +implementation-dependent, since Ansi does not allow any +program-controlled interception of a break." + (declare (ignore announce catch-breaks)) + `(let* ((ok nil) + (results (ignore-errors + (prog1 (multiple-value-list ,form) + (setq ok t))))) + (if ok + (apply #'values t results) + nil))) + + +(defmacro atomically (&body forms) + `(mp:without-scheduling ,@forms)) + +(defmacro fast (&body forms) + `(locally (declare (optimize (speed 3) (safety 0) (debug 0))) + ,@forms)) + +(defmacro without-package-locks (&body forms) + `(progn ,@forms)) + +(define-condition socket-error (error) + ((stream :initarg :stream) + (code :initarg :code :initform nil) + (action :initarg :action) + (identifier :initarg :identifier :initform nil)) + (:report (lambda (e s) + (with-slots (identifier code action stream) e + (format s "~S (errno ~A) occured while ~A" + (case identifier + (:connection-refused "Connection refused") + (t identifier)) + code action) + (when stream + (prin1 stream s)) + (format s "."))))) + +#| +(defun run-shell-command () + (with-open-stream (s (open-pipe "/bin/sh" + :direction :io + :buffered nil)) + (loop for var in environment + do (format stream "~A=~A~%" (car var) (cdr var))) +|# + + +(provide 'acl-excl) Added: branches/trunk-reorg/thirdparty/acl-compat/acl-mp-corman.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/acl-compat/acl-mp-corman.lisp Thu Feb 7 03:21:48 2008 @@ -0,0 +1,52 @@ +;;; This file implements the process functions for AllegroServe in Corman Lisp. + +(require 'mp) + +(defpackage :acl-compat-mp + (:use :common-lisp :mp :sys) + (:export + #:process-interrrupt + #:make-process + #:make-process-lock + #:process-add-run-reason + #:process-kill + #:process-property-list + #:process-revoke-run-reason + #:process-run-function + #:with-process-lock + #:with-timeout + #:without-scheduling + #:*current-process* + #:lock + #:process-allow-schedule + #:process-name + #:process-preset + #:process-run-reasons + #:process-wait + #:without-interrupts + )) + +(in-package :acl-compat-mp) + +; existing stuff from ccl we can reuse directly +;; The following process-property-list implementation was taken from +;; the acl-mp-scl.lisp implementation. +(defvar *process-plists* (make-hash-table :test #'eq) + "maps processes to their plists. +See the functions process-plist, (setf process-plist).") + +(defun process-property-list (process) + (gethash process *process-plists*)) + +(defun (setf process-property-list) (new-value process) + (setf (gethash process *process-plists*) new-value)) + +;; Dummy implementation of process-wait +(defun process-wait (whostate function &rest args) + "This function suspends the current process (the value of sys:*current-process*) + until applying function to arguments yields true. The whostate argument must be a + string which temporarily replaces the process' whostate for the duration of the wait. + This function returns nil." + (loop until (apply function args) do (sleep 0)) + nil) + Added: branches/trunk-reorg/thirdparty/acl-compat/acl-mp-package.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/acl-compat/acl-mp-package.lisp Thu Feb 7 03:21:48 2008 @@ -0,0 +1,80 @@ +;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Package: CL-USER; -*- +;;;; ; +;;;; (c) 2001 by Jochen Schmidt. +;;;; +;;;; File: acl-mp-package.lisp +;;;; Revision: 1.0.0 +;;;; Description: Package definition for ACL-COMPAT-MP +;;;; Date: 02.02.2002 +;;;; Authors: Jochen Schmidt +;;;; Tel: (+49 9 11) 47 20 603 +;;;; Email: jsc@dataheaven.de +;;;; +;;;; Redistribution and use in source and binary forms, with or without +;;;; modification, are permitted provided that the following conditions +;;;; are met: +;;;; 1. Redistributions of source code must retain the above copyright +;;;; notice, this list of conditions and the following disclaimer. +;;;; 2. Redistributions in binary form must reproduce the above copyright +;;;; notice, this list of conditions and the following disclaimer in the +;;;; documentation and/or other materials provided with the distribution. +;;;; +;;;; THIS SOFTWARE IS PROVIDED "AS IS" AND THERE ARE NEITHER +;;;; EXPRESSED NOR IMPLIED WARRANTIES - THIS INCLUDES, BUT +;;;; IS NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY +;;;; AND FITNESS FOR A PARTICULAR PURPOSE.IN NO WAY ARE THE +;;;; AUTHORS LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +;;;; SPECIAL, EXEMPLARY OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT +;;;; NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES ; +;;;; LOSS OF USE, DATA, OR PROFITS ; OR BUSINESS INTERRUPTION) +;;;; +;;;; For further details contact the authors of this software. +;;;; +;;;; Jochen Schmidt +;;;; Zuckmantelstr. 11 +;;;; 91616 Neusitz +;;;; GERMANY +;;;; +;;;; + +(defpackage :acl-compat-mp + (:use :common-lisp) + (:export + #:*current-process* ;* + #:process-kill ;* + #:process-preset ;* + #:process-name ;* + + #:process-wait-function + #:process-run-reasons + #:process-arrest-reasons + #:process-whostate + #:without-interrupts + #:process-wait + #:process-enable + #:process-disable + #:process-reset + #:process-interrupt + + #:process-run-function ;* + #:process-property-list ;* + #:without-scheduling ;* + #:process-allow-schedule ;* + #:make-process ;* + #:process-add-run-reason ;* + #:process-revoke-run-reason ;* + #:process-add-arrest-reason ;* + #:process-revoke-arrest-reason ;* + #:process-allow-schedule ;* + #:with-timeout ;* + #:make-process-lock ;* + #:with-process-lock ;* + #:process-active-p ; required by webactions + #:current-process + #:process-name-to-process + #:process-wait-with-timeout + #:wait-for-input-available + ) + (:nicknames :acl-mp)) + +;; * marked ones are used in Portable Allegroserve Added: branches/trunk-reorg/thirdparty/acl-compat/acl-socket-corman.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/acl-compat/acl-socket-corman.lisp Thu Feb 7 03:21:48 2008 @@ -0,0 +1,194 @@ +;;;; ACL socket wrapper library for Corman Lisp - Version 1.1 +;;;; +;;;; Copyright (C) 2000 Christopher Double. All Rights Reserved. +;;;; +;;;; License +;;;; ======= +;;;; This software is provided 'as-is', without any express or implied +;;;; warranty. In no event will the author be held liable for any damages +;;;; arising from the use of this software. +;;;; +;;;; Permission is granted to anyone to use this software for any purpose, +;;;; including commercial applications, and to alter it and redistribute +;;;; it freely, subject to the following restrictions: +;;;; +;;;; 1. The origin of this software must not be misrepresented; you must +;;;; not claim that you wrote the original software. If you use this +;;;; software in a product, an acknowledgment in the product documentation +;;;; would be appreciated but is not required. +;;;; +;;;; 2. Altered source versions must be plainly marked as such, and must +;;;; not be misrepresented as being the original software. +;;;; +;;;; 3. This notice may not be removed or altered from any source +;;;; distribution. +;;;; +;;;; Notes +;;;; ===== +;;;; A simple wrapper around the SOCKETS package to present an interface +;;;; similar to the Allegro Common Lisp SOCKET package. Based on a package +;;;; by David Bakhash for LispWorks. For documentation on the ACL SOCKET +;;;; package see: +;;;; +;;;; http://www.franz.com/support/documentation/5.0.1/doc/cl/socket.htm +;;;; +;;;; More recent versions of this software may be available at: +;;;; http://www.double.co.nz/cl +;;;; +;;;; Comments, suggestions and bug reports to the author, +;;;; Christopher Double, at: chris@double.co.nz +;;;; +;;;; 17/09/2000 - 1.0 +;;;; Initial release. +;;;; +;;;; 20/09/2000 - 1.1 +;;;; Added SOCKET-CONTROL function. +;;;; +;;;; 27/02/2001 - 1.2 +;;;; Added ability to create SSL sockets. Doesn't use +;;;; same interface as Allegro 6 - need to look into +;;;; how that works. +;;;; +;;;; 03/01/2003 - 1.3 +;;;; Added to PortableAllegroServe. + +(eval-when (:compile-toplevel :load-toplevel :execute) + (require :sockets) + (require :ssl-sockets)) + +(sockets:start-sockets) +(ssl-sockets:start-ssl-sockets) + +(defpackage socket + (:use "COMMON-LISP") + (:export + "MAKE-SOCKET" + "ACCEPT-CONNECTION" + "DOTTED-TO-IPADDR" + "IPADDR-TO-DOTTED" + "IPADDR-TO-HOSTNAME" + "LOOKUP-HOSTNAME" + "REMOTE-HOST" + "LOCAL-HOST" + "LOCAL-PORT" + "SOCKET-CONTROL" + )) + +(in-package :socket) + +(defmethod accept-connection ((server-socket sockets::server-socket) + &key (wait t)) + (unless wait + (error "WAIT keyword to ACCEPT-CONNECTION not implemented.")) + (sockets:make-socket-stream + (sockets:accept-socket server-socket))) + +(defun make-socket (&key + (remote-host "0.0.0.0") ;;localhost? + type + local-port + remote-port + (connect :active) + (format :text) + ssl + &allow-other-keys) + (check-type remote-host string) + (when (eq type :datagram) + (error ":DATAGRAM keyword to MAKE-SOCKET not implemented.")) + (when (eq format :binary) + (warn ":BINARY keyword to MAKE-SOCKET partially implemented.")) + + (ecase connect + (:passive + (sockets:make-server-socket + :host remote-host + :port local-port)) + (:active + (sockets:make-socket-stream + (if ssl + (ssl-sockets:make-client-ssl-socket + :host remote-host + :port remote-port) + (sockets:make-client-socket + :host remote-host + :port remote-port)))))) + + +(defun dotted-to-ipaddr (dotted &key errorp) + (when errorp + (warn ":ERRORP keyword to DOTTED-TO-IPADDR not supported.")) + (sockets:host-to-ipaddr dotted)) + +(defun ipaddr-to-dotted (ipaddr &key values) + (when values + (error ":VALUES keyword to IPADDR-TO-DOTTED not supported.")) + (sockets:ipaddr-to-dotted ipaddr)) + +(defun ipaddr-to-hostname (ipaddr &key ignore-cache) + (when ignore-cache + (warn ":IGNORE-CACHE keyword to IPADDR-TO-HOSTNAME not supported.")) + (sockets:ipaddr-to-name ipaddr)) + +(defun lookup-hostname (host &key ignore-cache) + (when ignore-cache + (warn ":IGNORE-CACHE keyword to IPADDR-TO-HOSTNAME not supported.")) + (if (stringp host) + (sockets:host-to-ipaddr host) + (dotted-to-ipaddr (ipaddr-to-dotted host)))) + +(defun remote-host (socket-or-stream) + (let ((socket (if (typep socket-or-stream 'sockets:base-socket) + socket-or-stream + (sockets:stream-socket-handle socket-or-stream)))) + (sockets::remote-socket-ipaddr socket))) + +(defun local-host (socket-or-stream) + (let ((socket (if (typep socket-or-stream 'sockets:base-socket) + socket-or-stream + (sockets:stream-socket-handle socket-or-stream)))) + (if (not (typep socket 'sockets:local-socket)) + 16777343 + (sockets::socket-host-ipaddr socket)))) + +(defun local-port (socket-or-stream) + (let ((socket (if (typep socket-or-stream 'sockets:base-socket) + socket-or-stream + (sockets:stream-socket-handle socket-or-stream)))) + (sockets:socket-port socket))) + +(defun socket-control (stream &key output-chunking output-chunking-eof input-chunking) + (declare (ignore stream output-chunking output-chunking-eof input-chunking)) + (warn "SOCKET-CONTROL function not implemented.")) + +;; Some workarounds to get combined text/binary socket streams working +(defvar old-read-byte #'cl::read-byte) + +(defun new-read-byte (stream &optional (eof-error-p t) (eof-value nil)) + "Replacement for Corman Lisp READ-BYTE to work with socket streams correctly." + (if (eq (cl::stream-subclass stream) 'sockets::socket-stream) + (char-int (read-char stream eof-error-p eof-value)) + (funcall old-read-byte stream eof-error-p eof-value))) + +(setf (symbol-function 'common-lisp::read-byte) #'new-read-byte) + +(in-package :cl) + +(defun write-sequence (sequence stream &key start end) + (let ((element-type (stream-element-type stream)) + (start (if start start 0)) + (end (if end end (length sequence)))) + (if (eq element-type 'character) + (do ((n start (+ n 1))) + ((= n end)) + (write-char (if (typep (elt sequence n) 'number) (ccl:int-char (elt sequence n)) (elt sequence n)) stream)) + (do ((n start (+ n 1))) + ((= n end)) + (write-byte (elt sequence n) stream)))) ;; recoded to avoid LOOP, because it isn't loaded yet + ;(loop for n from start below end do + ; (write-char (elt sequence n) stream)) + ;(loop for n from start below end do + ; (write-byte (elt sequence n) stream)) + (force-output stream)) + +(provide 'acl-socket) + Added: branches/trunk-reorg/thirdparty/acl-compat/acl-ssl-streams.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/acl-compat/acl-ssl-streams.lisp Thu Feb 7 03:21:48 2008 @@ -0,0 +1,293 @@ +;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Package: CL-USER; -*- +;;; +;;; Filename: gray-streams-integration.lisp +;;; Author: Jochen Schmidt <jsc@dataheaven.de> +;;; Description: Integrate ssl-sockets with the lisp +;;; stream system using gray-streams. +;;; + +(in-package :ssl) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Gray Streams integration ;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defclass ssl-stream-mixin () + ((ssl-socket :accessor ssl-socket :initarg :ssl-socket))) + +(defclass binary-ssl-stream + (ssl-stream-mixin + gray-stream:fundamental-binary-input-stream + gray-stream:fundamental-binary-output-stream) + ()) + +(defclass character-ssl-stream + (ssl-stream-mixin + gray-stream:fundamental-character-input-stream + gray-stream:fundamental-character-output-stream) + ()) + +(defmethod #-cormanlisp gray-stream::stream-element-type #+cormanlisp gray-stream::stream-stream-element-type ((socket-stream binary-ssl-stream)) + '(unsigned-byte 8)) + +(defmethod #-cormanlisp gray-stream::stream-element-type #+cormanlisp gray-stream::stream-stream-element-type ((socket-stream character-ssl-stream)) + 'character) + +(defmethod gray-stream:stream-line-column ((socket-stream character-ssl-stream)) + nil) + +(defmethod gray-stream:stream-line-column ((socket-stream binary-ssl-stream)) + nil) + +(defmethod gray-stream:stream-listen ((socket-stream ssl-stream-mixin)) + (with-slots (ssl-socket) socket-stream + (> (ssl-internal:ssl-pending (ssl-internal:ssl-socket-handle ssl-socket)) 0))) + +(defmethod gray-stream:stream-read-byte ((socket-stream binary-ssl-stream)) + (with-slots (ssl-socket) socket-stream + (ssl-internal:ssl-socket-read-byte ssl-socket))) + +(defmethod gray-stream:stream-write-byte ((socket-stream binary-ssl-stream) byte) + (with-slots (ssl-socket) socket-stream + (ssl-internal:ssl-socket-write-byte byte ssl-socket))) + +#| +(defmethod gray-stream:stream-read-char ((socket-stream character-ssl-stream)) + (with-slots (ssl-socket) socket-stream + (ssl-internal:ssl-socket-read-char ssl-socket))) + +(defmethod gray-stream:stream-read-char ((socket-stream binary-ssl-stream)) + (with-slots (ssl-socket) socket-stream + (ssl-internal:ssl-socket-read-char ssl-socket))) +|# + +; Bivalent +(defmethod gray-stream:stream-read-char ((socket-stream ssl-stream-mixin)) + (with-slots (ssl-socket) socket-stream + (ssl-internal:ssl-socket-read-char ssl-socket))) + + +(defmethod gray-stream:stream-read-char-no-hang ((socket-stream character-ssl-stream)) + (when (listen socket-stream) + (with-slots (ssl-socket) socket-stream + (ssl-internal:ssl-socket-read-char ssl-socket)))) + +#| +(defmethod gray-stream:stream-write-char ((socket-stream character-ssl-stream) char) + (with-slots (ssl-socket) socket-stream + (ssl-internal:ssl-socket-write-char char ssl-socket))) + +(defmethod gray-stream:stream-write-char ((socket-stream binary-ssl-stream) char) + (with-slots (ssl-socket) socket-stream + (ssl-internal:ssl-socket-write-char char ssl-socket))) +|# + +; Bivalent +(defmethod gray-stream:stream-write-char ((socket-stream ssl-stream-mixin) char) + (with-slots (ssl-socket) socket-stream + (ssl-internal:ssl-socket-write-char char ssl-socket))) + + + +; Bivalent +(defmethod gray-stream:stream-force-output ((socket-stream ssl-stream-mixin)) + (with-slots (ssl-socket) socket-stream + (ssl-internal:flush-output-buffer ssl-socket))) + +(defmethod gray-stream:stream-finish-output ((socket-stream ssl-stream-mixin)) + (with-slots (ssl-socket) socket-stream + (ssl-internal:flush-output-buffer ssl-socket))) + +(defmethod gray-stream:stream-clear-output ((socket-stream ssl-stream-mixin)) + (with-slots (ssl-socket) socket-stream + (with-slots (ssl-internal::output-offset) ssl-socket + (setf ssl-internal::output-offset 0)))) + +(defmethod gray-stream:stream-clear-input ((socket-stream ssl-stream-mixin)) + (with-slots (ssl-socket) socket-stream + (with-slots (ssl-internal::input-avail ssl-internal::input-offset) ssl-socket + (setf ssl-internal::input-avail 0) + (setf ssl-internal::input-offset 0)))) + +(defmethod #-cormanlisp common-lisp:close #+cormanlisp gray-stream:stream-close ((socket-stream ssl-stream-mixin) &key abort) + (with-slots (ssl-socket) socket-stream + (unless abort + (ssl-internal:flush-output-buffer ssl-socket)) + (ssl-internal:close-ssl-socket ssl-socket))) + +#| +(defmethod gray-stream:stream-force-output ((socket-stream character-ssl-stream)) + (with-slots (ssl-socket) socket-stream + (ssl-internal:flush-output-buffer ssl-socket))) + +(defmethod gray-stream:stream-finish-output ((socket-stream character-ssl-stream)) + (with-slots (ssl-socket) socket-stream + (ssl-internal:flush-output-buffer ssl-socket))) + +(defmethod gray-stream:stream-clear-output ((socket-stream character-ssl-stream)) + (with-slots (ssl-socket) socket-stream + (with-slots (ssl-internal::output-offset) ssl-socket + (setf ssl-internal::output-offset 0)))) + +(defmethod gray-stream:stream-clear-input ((socket-stream character-ssl-stream)) + (with-slots (ssl-socket) socket-stream + (with-slots (ssl-internal::input-avail ssl-internal::input-offset) ssl-socket + (setf ssl-internal::input-avail 0) + (setf ssl-internal::input-offset 0)))) + +(defmethod gray-stream:stream-read-sequence ((socket-stream character-ssl-stream) sequence start end) + (let* ((len (length sequence)) + (chars (- (min (or end len) len) start))) + ;(format t "Read ~A chars from index ~A on.~%" chars start) (force-output t) + (loop for i upfrom start + repeat chars + for char = (progn ;(format t "Read char on index ~A~%" i) + ;(force-output t) + (let ((c (gray-streams:stream-read-char socket-stream))) + ;(format t "The element read was ~A~%" c) + c)) + if (eq char :eof) do (progn ;(format t "premature return on index ~A~%" i) + ;(force-output t) + (return-from gray-streams:stream-read-sequence i)) + do (setf (elt sequence i) char)) + ;(format t "Normal return on index ~A~%" (+ start chars)) (force-output t) + (+ start chars))) + +|# + +;; +;; Why this argument ordering in CMUCL? LW has (stream sequence start end) +;; It would be interesting to know why it is a particular good idea to +;; reinvent APIs every second day in an incompatible way.... *grrr* +;; + +#+cmu +(defmethod gray-stream:stream-read-sequence ((socket-stream character-ssl-stream) (sequence sequence) &optional start end) + (let* ((len (length sequence)) + (chars (- (min (or end len) len) start))) + (loop for i upfrom start + repeat chars + for char = (gray-stream:stream-read-char socket-stream) + if (eq char :eof) do (return-from gray-stream:stream-read-sequence i) + do (setf (elt sequence i) char)) + (+ start chars))) + +#+cmu +(defmethod gray-stream:stream-read-sequence ((socket-stream binary-ssl-stream) (sequence sequence) &optional start end) + (let* ((len (length sequence)) + (chars (- (min (or end len) len) start))) + (loop for i upfrom start + repeat chars + for char = (gray-stream:stream-read-byte socket-stream) + if (eq char :eof) do (return-from gray-stream:stream-read-sequence i) + do (setf (elt sequence i) char)) + (+ start chars))) + +#| +(defmethod gray-stream:stream-read-sequence ((socket-stream binary-ssl-stream) sequence start end) + (let* ((len (length sequence)) + (chars (- (min (or end len) len) start))) + ;(format t "Read ~A chars from index ~A on.~%" chars start) (force-output t) + (loop for i upfrom start + repeat chars + for char = (progn ;(format t "Read char on index ~A~%" i) + ;(force-output t) + (let ((c (gray-streams:stream-read-byte socket-stream))) + ;(format t "The element read was ~A~%" c) + c)) + if (eq char :eof) do (progn ;(format t "premature return on index ~A~%" i) + ;(force-output t) + (return-from gray-streams:stream-read-sequence i)) + do (setf (elt sequence i) char)) + ;(format t "Normal return on index ~A~%" (+ start chars)) (force-output t) + (+ start chars))) +|# + +#| Alternative implementation? +(defmethod stream:stream-read-sequence ((socket-stream character-ssl-stream) sequence start end) + (let* ((len (length sequence)) + (chars (- (min (or end len) len) start))) + (format t "Read ~A chars from index ~A on.~%" chars start) (force-output t) + (loop for i upfrom start + repeat chars + for char = (progn (format t "Read char on index ~A~%" i) + (force-output t) + (let ((c (stream:stream-read-char socket-stream))) + (format t "The element read was ~A~%" c) c)) + if (eq char :eof) do (progn (format t "premature return on index ~A~%" i) + (force-output t) + (return-from stream:stream-read-sequence i)) + do (setf (elt sequence i) char)) + (format t "Normal return on index ~A~%" (+ start chars)) (force-output t) + (+ start chars))) +|# + +#| +(defmethod common-lisp:close ((socket-stream character-ssl-stream) &key abort) + (with-slots (ssl-socket) socket-stream + (unless abort + (ssl-internal:flush-output-buffer ssl-socket)) + (ssl-internal:close-ssl-socket ssl-socket))) +|# + +#+lispworks +(declaim (inline %reader-function-for-sequence)) +#+lispworks +(defun %reader-function-for-sequence (sequence) + (typecase sequence + (string #'read-char) + ((array unsigned-byte (*)) #'read-byte) + ((array signed-byte (*)) #'read-byte) + (otherwise #'read-byte))) + +#+lispworks +(declaim (inline %writer-function-for-sequence)) +#+lispworks +(defun %writer-function-for-sequence (sequence) + (typecase sequence + (string #'write-char) + ((array unsigned-byte (*)) #'write-byte) + ((array signed-byte (*)) #'write-byte) + (otherwise #'write-byte))) + +;; Bivalent socket support for READ-SEQUENCE / WRITE-SEQUENCE +#+lispworks +(defmethod gray-stream:stream-read-sequence ((stream ssl-stream-mixin) sequence start end) + (stream::read-elements stream sequence start end (%reader-function-for-sequence sequence))) + +#+lispworks +(defmethod gray-stream:stream-write-sequence ((stream ssl-stream-mixin) sequence start end) + (stream::write-elements stream sequence start end (typecase sequence + (string t) + ((array unsigned-byte (*)) nil) + ((array signed-byte (*)) nil) + (otherwise nil)))) + +#+lispworks +(in-package :acl-socket) + +#+lispworks +(defmethod remote-host ((socket ssl::ssl-stream-mixin)) + (comm:get-socket-peer-address (ssl-internal::ssl-socket-fd (ssl::ssl-socket socket)))) + +#+lispworks +(defmethod remote-port ((socket ssl::ssl-stream-mixin)) + (multiple-value-bind (host port) + (comm:get-socket-peer-address (ssl-internal::ssl-socket-fd (ssl::ssl-socket socket))) + (declare (ignore host)) + port)) + +#+lispworks +(defmethod local-host ((socket ssl::ssl-stream-mixin)) + (multiple-value-bind (host port) + (comm:get-socket-address (ssl-internal::ssl-socket-fd (ssl::ssl-socket socket))) + (declare (ignore port)) + host)) + +#+lispworks +(defmethod local-port ((socket ssl::ssl-stream-mixin)) + (multiple-value-bind (host port) + (comm:get-socket-address (ssl-internal::ssl-socket-fd (ssl::ssl-socket socket))) + (declare (ignore host)) + port)) + Added: branches/trunk-reorg/thirdparty/acl-compat/acl-ssl.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/acl-compat/acl-ssl.lisp Thu Feb 7 03:21:48 2008 @@ -0,0 +1,58 @@ +(in-package :ssl) +;;;;;;;;;;;;;;;;;;;;; +;;; ACL style API ;;; +;;;;;;;;;;;;;;;;;;;;; + +(defmethod make-ssl-client-stream ((socket integer) &rest options) + (destructuring-bind (&key (format :binary)) options + (when (minusp socket) + (error "not a proper socket descriptor")) + (let ((ssl-socket (make-instance 'ssl-internal:ssl-client-socket :fd socket))) + (case format + (:binary (make-instance 'binary-ssl-stream + :ssl-socket ssl-socket)) + (:text (make-instance 'character-ssl-stream + :ssl-socket ssl-socket)) + (otherwise (error "Unknown ssl-stream format")))))) + +#+lispworks +(defmethod make-ssl-client-stream ((lw-socket-stream comm:socket-stream) &rest options) + (apply #'make-ssl-client-stream (comm:socket-stream-socket lw-socket-stream) options)) + +#+cormanlisp +(defmethod make-ssl-client-stream (stream &rest options) + (apply #'make-ssl-client-stream (sockets:socket-descriptor (cl::stream-handle stream)) options)) + +(defmethod make-ssl-server-stream ((socket integer) &rest options) + (destructuring-bind (&key certificate key other-certificates (format :binary)) options + (when (minusp socket) + (error "not a proper socket descriptor")) + (let ((ssl-socket (make-instance 'ssl-internal:ssl-server-socket + :fd socket + :rsa-privatekey-file (or key certificate) + :certificate-file (or certificate key)))) + (case format + (:binary (make-instance 'binary-ssl-stream + :ssl-socket ssl-socket)) + (:text (make-instance 'character-ssl-stream + :ssl-socket ssl-socket)) + (otherwise (error "Unknown ssl-stream format")))))) + +(defmethod make-ssl-server-stream ((socket ssl-stream-mixin) &rest options) + (warn "SSL socket ~A reused" socket) + socket) + +#+lispworks +(defmethod make-ssl-server-stream ((lw-socket-stream comm:socket-stream) &rest options) + (apply #'make-ssl-server-stream (comm:socket-stream-socket lw-socket-stream) options)) + + +#+ignore +(defmethod make-ssl-server-stream ((acl-socket acl-socket::server-socket) &rest options) + (apply #'make-ssl-server-stream + (comm::get-fd-from-socket (acl-socket::passive-socket acl-socket)) options)) + +#+ignore +(defmethod make-ssl-server-stream ((lw-socket-stream acl-socket::chunked-socket-stream) &rest options) + (apply #'make-ssl-server-stream (comm:socket-stream-socket lw-socket-stream) options)) + Added: branches/trunk-reorg/thirdparty/acl-compat/allegro/acl-excl.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/acl-compat/allegro/acl-excl.lisp Thu Feb 7 03:21:48 2008 @@ -0,0 +1,3 @@ +;;;; ACL-COMPAT - EXCL +;;;; +;;;; Nothing needs to be done Added: branches/trunk-reorg/thirdparty/acl-compat/allegro/acl-mp.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/acl-compat/allegro/acl-mp.lisp Thu Feb 7 03:21:48 2008 @@ -0,0 +1,3 @@ +;;; This file implements the process functions for AllegroServe in MCL. + +(in-package :acl-compat.mp) Added: branches/trunk-reorg/thirdparty/acl-compat/allegro/acl-socket.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/acl-compat/allegro/acl-socket.lisp Thu Feb 7 03:21:48 2008 @@ -0,0 +1,6 @@ +;;; Allegro layer for ACL sockets. +;;; +(in-package :acl-compat.socket) + + + Added: branches/trunk-reorg/thirdparty/acl-compat/allegro/acl-sys.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/acl-compat/allegro/acl-sys.lisp Thu Feb 7 03:21:48 2008 @@ -0,0 +1,4 @@ +;;; Allegro System Package Compatibility file + +;;; Nothing to do +(in-package :acl-compat.system) Added: branches/trunk-reorg/thirdparty/acl-compat/chunked-stream-mixin.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/acl-compat/chunked-stream-mixin.lisp Thu Feb 7 03:21:48 2008 @@ -0,0 +1,275 @@ +;;;; ; +;;;; (c) 2002 by Jochen Schmidt. +;;;; +;;;; File: chunked-stream-mixin.lisp +;;;; Revision: 0.1 +;;;; Description: ACL style HTTP1.1 I/O chunking +;;;; Date: 08.04.2002 +;;;; Authors: Jochen Schmidt +;;;; Tel: (+49 9 11) 47 20 603 +;;;; Email: jsc@dataheaven.de +;;;; +;;;; Redistribution and use in source and binary forms, with or without +;;;; modification, are permitted provided that the following conditions +;;;; are met: +;;;; 1. Redistributions of source code must retain the above copyright +;;;; notice, this list of conditions and the following disclaimer. +;;;; 2. Redistributions in binary form must reproduce the above copyright +;;;; notice, this list of conditions and the following disclaimer in the +;;;; documentation and/or other materials provided with the distribution. +;;;; +;;;; THIS SOFTWARE IS PROVIDED "AS IS" AND THERE ARE NEITHER +;;;; EXPRESSED NOR IMPLIED WARRANTIES - THIS INCLUDES, BUT +;;;; IS NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY +;;;; AND FITNESS FOR A PARTICULAR PURPOSE.IN NO WAY ARE THE +;;;; AUTHORS LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +;;;; SPECIAL, EXEMPLARY OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT +;;;; NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES ; +;;;; LOSS OF USE, DATA, OR PROFITS ; OR BUSINESS INTERRUPTION) +;;;; +;;;; For further details contact the authors of this software. +;;;; +;;;; Jochen Schmidt +;;;; Zuckmantelstr. 11 +;;;; 91616 Neusitz +;;;; GERMANY +;;;; +;;;; Nuernberg, 08.Apr.2002 Jochen Schmidt +;;;; + +(in-package :de.dataheaven.chunked-stream-mixin) + +(defun buffer-ref (buffer index) + #+lispworks (schar buffer index) + #-lispworks (aref buffer index)) + +(defun (setf buffer-ref) (new-value buffer index) + #-lispworks (setf (aref buffer index) (char-code new-value)) + #+lispworks (setf (schar buffer index) new-value)) + +(defclass chunked-stream-mixin () + ((output-chunking-p :initform nil :accessor output-chunking-p) + (chunk-input-avail :initform nil + :documentation + "Number of octets of the current chunk that are +not yet read into the buffer, or nil if input chunking is disabled") + (real-input-limit :initform 0 + :documentation + "Index of last octet read into buffer +(input-limit points to index of last octet in the current chunk)"))) + +(defgeneric input-chunking-p (stream)) +(defmethod input-chunking-p ((stream chunked-stream-mixin)) + (not (null (slot-value stream 'chunk-input-avail)))) + +(defgeneric (setf input-chunking-p) (new-value stream)) +(defmethod (setf input-chunking-p) (new-value (stream chunked-stream-mixin)) + (setf (slot-value stream 'chunk-input-avail) (and new-value 0))) + +(define-condition acl-compat.excl::socket-chunking-end-of-file (condition) + ((acl-compat.excl::format-arguments :initform nil :initarg :format-arguments) + (acl-compat.excl::format-control :initform "A chunking end of file occured" + :initarg :format-control))) + + +;;;;;;;;;;;;;;;;;;;;;; +;;; Input chunking ;;; +;;;;;;;;;;;;;;;;;;;;;; + +;; Input chunking is not tested so far! + +(defgeneric initialize-input-chunking (stream)) +(defmethod initialize-input-chunking ((stream chunked-stream-mixin)) + "This method initializes input chunking. The real-input-limit is nil +in the beginnings because it got not saved yet. Chunk-input-avail is +obviously 0 because no chunk-data got read so far." + (gray-stream:with-stream-input-buffer (input-buffer input-index input-limit) + stream + (with-slots (real-input-limit chunk-input-avail) stream + (setf + ;; Bytes read from stream (valid data in buffer up to here) + real-input-limit input-limit + ;; Bytes available in current chunk block after buffer contents + ;; runs out (trivially zero before first chunk block read) + chunk-input-avail 0 + ;; Last buffer position that can be read before new data has to + ;; be fetched from stream (we must begin with parsing a chunk + ;; immediately; hence set to a value that guarantees this) + input-limit 0 ; or input-index? + )))) + +;; Lispworks fix by Edi Weitz (paserve-help 2003-11-28) +#+lispworks +(defmacro %with-stream-input-buffer ((input-buffer input-index input-limit) stream &body body) + `(with-slots ((,input-buffer stream::input-buffer) + (,input-index stream::input-index) + (,input-limit stream::input-limit)) + (slot-value ,stream 'stream::buffer-state) + ,@body)) + +(defmethod gray-stream:stream-fill-buffer ((stream chunked-stream-mixin)) + "Refill buffer from stream." + ;; STREAM-FILL-BUFFER gets called when the input-buffer contains no + ;; more data (the index is bigger than the limit). We call out to + ;; the real buffer filling mechanism by calling the next specialized + ;; method. This method is responsible to update the buffer state in + ;; coordination with the chunk-header. + (with-slots (chunk-input-avail real-input-limit) stream + (#-lispworks gray-stream:with-stream-input-buffer + #+lispworks %with-stream-input-buffer + (input-buffer input-index input-limit) stream + (labels + ((pop-char () + (when (and (>= input-index input-limit) ; need new data + (not (call-next-method))) ; couldn't get it + (error "Unexpected end-of-file while reading chunk block")) + (prog1 #-lispworks (code-char (buffer-ref input-buffer input-index)) + #+lispworks (buffer-ref input-buffer input-index) + (incf input-index))) + (read-chunk-header () + (let ((chunk-length 0)) + (tagbody + initial-crlf (let ((char (pop-char))) + (cond ((digit-char-p char 16) + (decf input-index) ; unread char + (go chunk-size)) + ((eq #\Return char) + (if (eq (pop-char) #\Linefeed) + (go chunk-size) + (error "End of chunk-header corrupted: Expected Linefeed"))) + (t (error "End of chunk-header corrupted: Expected Carriage Return or a digit")))) + + chunk-size (let ((char (pop-char))) + (cond ((digit-char-p char 16) + (setf chunk-length + (+ (* 16 chunk-length) + (digit-char-p char 16))) + (go chunk-size)) + (t (decf input-index) ; unread char + (go skip-rest)))) + + skip-rest (if (eq #\Return (pop-char)) + (go check-linefeed) + (go skip-rest)) + + check-linefeed (let ((char (pop-char))) + (case char + (#\Linefeed (go accept)) + (t (error "End of chunk-header corrupted: LF expected, ~A read." char)))) + + accept) + chunk-length))) + + (cond ((not (input-chunking-p stream)) + ;; Chunking not active; just fill buffer normally + (call-next-method)) + ((zerop chunk-input-avail) + ;; We are at the beginning of a new chunk. + (when real-input-limit (setf input-limit real-input-limit)) + (let* ((chunk-length (read-chunk-header)) + (end-of-chunk (+ input-index chunk-length))) + (if (zerop chunk-length) + ;; rfc2616 indicates that input chunking is + ;; turned off after zero-length chunk is read + ;; (see section 19.4.6) -- turn off chunking + (progn (signal 'acl-compat.excl::socket-chunking-end-of-file + :format-arguments stream) + (setf (input-chunking-p stream) nil) + ;; TODO: whoever handles + ;; socket-chunking-end-of-file (client.cl + ;; in AllegroServe's case) should read the + ;; trailer (see section 3.6). All we can + ;; reasonably do here is turn off + ;; chunking, or throw information away. + ) + ;; Now set up stream attributes so that read methods + ;; call refill-buffer both at end of chunk and end of + ;; buffer + (progn + (setf real-input-limit input-limit + input-limit (min real-input-limit end-of-chunk) + chunk-input-avail (max 0 (- end-of-chunk + real-input-limit))) + input-limit)))) + (t + ;; We are in the middle of a chunk; re-fill buffer + (if (call-next-method) + (progn + (setf real-input-limit input-limit) + (setf input-limit + (min real-input-limit chunk-input-avail)) + (setf chunk-input-avail + (max 0 (- chunk-input-avail real-input-limit))) + input-limit) + (error "Unexpected end-of-file in the middle of a chunk")))))))) + + +;;;;;;;;;;;;;;;;;;;;;;; +;;; Output chunking ;;; +;;;;;;;;;;;;;;;;;;;;;;; + +;; This constant is the amount of bytes the system reserves for the chunk-header +;; It is calculated as 4 bytes for the chunk-size in hexadecimal digits and a CR followed +;; by a LF +(defconstant +chunk-header-buffer-offset+ 6) + +(defgeneric initialize-output-chunking (stream)) +(defmethod initialize-output-chunking ((stream chunked-stream-mixin)) + "This method initializes output chunking. Actual contents in the output-buffer + get flushed first. A chunk has a header at the start and a CRLF at the end. + The header is the length of the (data) content in the chunk as a string in hexadecimal + digits and a trailing CRLF before the real content begins. We assume that the content + of a chunk is never bigger than #xFFFF and therefore reserve 6 bytes at the beginning + of the buffer for the header. We reduce the buffer limit by 2 so that we have always + room left in the buffer to attach a CRLF." + (unless (output-chunking-p stream) + (force-output stream) + (gray-stream:with-stream-output-buffer (buffer index limit) stream + (setf index +chunk-header-buffer-offset+) + (setf (buffer-ref buffer (- +chunk-header-buffer-offset+ 2)) #\Return + (buffer-ref buffer (1- +chunk-header-buffer-offset+)) #\Linefeed) + (decf limit 2) + (setf (output-chunking-p stream) t)))) + +(defmethod gray-stream:stream-flush-buffer ((stream chunked-stream-mixin)) + "When there is pending content in the output-buffer then compute the chunk-header and flush + the buffer" + (if (output-chunking-p stream) + (gray-stream:with-stream-output-buffer (output-buffer output-index output-limit) stream + (when (> output-index +chunk-header-buffer-offset+) + (let* ((chunk-header (format nil "~X" (- output-index +chunk-header-buffer-offset+))) + (start (- +chunk-header-buffer-offset+ 2 (length chunk-header)))) + (loop for c across chunk-header + for i upfrom start + do (setf (buffer-ref output-buffer i) c)) + (setf (buffer-ref output-buffer output-index) #\Return + (buffer-ref output-buffer (1+ output-index)) #\Linefeed) + (gray-stream:stream-write-buffer stream output-buffer start (+ output-index 2)) + (setf output-index +chunk-header-buffer-offset+)))) + (call-next-method))) + + +(defmethod close ((stream chunked-stream-mixin) &key abort) + (unless abort + (disable-output-chunking stream)) + (call-next-method)) + + +(defgeneric disable-output-chunking (stream)) +(defmethod disable-output-chunking ((stream chunked-stream-mixin)) + "When we disable chunking we first try to write out a last pending chunk and after that + reset the buffer-state to normal mode. To end the game we write out a chunk-header with + a chunk-size of zero to notify the peer that chunking ends." + (when (output-chunking-p stream) + (force-output stream) + (gray-stream:with-stream-output-buffer (buffer index limit) stream + (setf index 0) + (incf limit 2)) + (setf (output-chunking-p stream) nil + (input-chunking-p stream) nil) + (format stream "0~A~A~A~A" #\Return #\Linefeed #\Return #\Linefeed) + (force-output stream))) + + + + Added: branches/trunk-reorg/thirdparty/acl-compat/chunked.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/acl-compat/chunked.lisp Thu Feb 7 03:21:48 2008 @@ -0,0 +1,211 @@ +;;; +;;; Streams with support for "chunked" transfer coding. This module +;;; emulates the support for chunking found in Allegro Common Lisp's +;;; streams. See RFC 2616 for a description of the "chunked" transfer +;;; coding. +;;; +;;; TODO: +;;; - + +(defpackage :com.ljosa.chunked + (:use :common-lisp #+LISPWORKS :stream) + (:export :chunked-mixin :make-chunked-stream :*buffer-size* + :output-chunking :input-chunking :close-chunk)) + +(in-package :com.ljosa.chunked) + +(defparameter *buffer-size* 1024 "Maximum chunk size") + +(defvar *recursive* nil) + +(defclass chunked-mixin () + ((output-chunking :initform nil :accessor output-chunking) + (input-chunking :initform nil :accessor input-chunking) + (output-buffer) + (remaining-input :initform nil))) + +(defmethod shared-initialize :after ((stream chunked-mixin) slots-for-initform + &rest initargs) + (declare (ignore initargs slots-for-initform)) + (with-slots (output-buffer) stream + (setf output-buffer (make-array (list *buffer-size*) + :element-type 'unsigned-byte + :fill-pointer 0)))) + +(define-condition excl::socket-chunking-end-of-file (condition) + ((excl::format-arguments :initform nil) + (excl::format-control :initform "~1@<The stream ~s had a chunking end of file~:@>"))) + +;; (defmethod stream-element-type ((stream chunked-mixin)) +;; (call-next-method)) + +(defun read-chunk-header (stream &aux (x 0) (*recursive* t)) + (tagbody + s0 (let ((char (read-char stream))) + (cond ((digit-char-p char 16) (setf x (+ (* 16 x) (digit-char-p char 16))) + (go s0)) + ((eq #\; char) (go s1)) + ((eq #\; char) (go s2)) + (t (error "Parse error in state s0: ~S." char)))) + s1 (if (eq #\Return (read-char stream)) + (go s2) + (go s1)) + s2 (let ((char (read-char stream))) + (case char + (#\Linefeed (go accept)) + (t (error "Parse error in state s2: ~S." char)))) + accept) + x) + +;; FIXME: What do do when the chunked input stream can't be parsed? + +(defun gobble-crlf (stream &aux (*recursive* t)) + (flet ((expect (expected-char) + (let ((char (read-char stream))) + (unless (eq expected-char char) + (error "Expected ~C, got ~C." expected-char char))))) + (expect #\Return) + (expect #\Linefeed))) + +(defmethod stream-read-char ((stream chunked-mixin)) + (with-slots (input-chunking remaining-input output-chunking) stream + (cond (*recursive* (call-next-method)) + ((not input-chunking) (call-next-method)) + ((not remaining-input) (handler-case + (progn + (setf remaining-input (read-chunk-header stream)) + (stream-read-char stream)) + (end-of-file () :eof))) + ((> remaining-input 0) (decf remaining-input) + (call-next-method)) + ((zerop remaining-input) (handler-case + (progn + (gobble-crlf stream) + (setf remaining-input (read-chunk-header stream)) + (cond ((zerop remaining-input) + (setf input-chunking nil + output-chunking nil) + (signal 'excl::socket-chunking-end-of-file :format-arguments stream) + :eof) + (t (stream-read-char stream)))) + (end-of-file () :eof)))))) + +(defmethod stream-unread-char ((stream chunked-mixin) character) + (with-slots (input-chunking remaining-input) stream + (cond (*recursive* (call-next-method)) + (input-chunking (incf remaining-input) + (call-next-method)) + (t (call-next-method))))) + +(defmethod stream-read-line ((stream chunked-mixin)) + (loop + with chars = nil + for char = (stream-read-char stream) + until (eq char #\Linefeed) + do + (if (eq char :eof) + (if (null chars) + (error 'end-of-file :stream stream) + (return (coerce chars 'string))) + (push char chars)) + finally (return (coerce (nreverse chars) 'string)))) + +(defmethod stream-read-sequence ((stream chunked-mixin) sequence start end) + (loop + for i from start below end + do + (let ((char (stream-read-char stream))) + (case char + (:eof (return i)) + (t (setf (elt sequence i) char)))) + finally (return i))) + +(defmethod stream-clear-input ((stream chunked-mixin)) + (with-slots (input-chunking) stream + (cond (*recursive* (call-next-method)) + (input-chunking nil) + (t (call-next-method))))) + +(defmethod stream-write-byte ((stream chunked-mixin) byte) + (check-type byte unsigned-byte) + (if *recursive* + (call-next-method) + (with-slots (output-buffer) stream + (or (vector-push byte output-buffer) + (progn + (stream-force-output stream) + (stream-write-byte stream byte)))))) + +(defmethod stream-write-char ((stream chunked-mixin) character) + (if *recursive* + (call-next-method) + (stream-write-byte stream (char-code character)))) + +(defmethod stream-write-sequence ((stream chunked-mixin) sequence start end) + (loop + for i from start below end + do + (let ((e (elt sequence i))) + (etypecase e + (integer (stream-write-byte stream e)) + (character (stream-write-char stream e)))))) + +(defmethod stream-write-string ((stream chunked-mixin) string &optional + (start 0) (end (length string))) + (stream-write-sequence stream string start end)) + +(defmethod write-crlf ((stream stream)) + (let ((*recursive* t)) + (write-char #\Return stream) + (write-char #\Linefeed stream))) + +(defmethod stream-force-output ((stream chunked-mixin)) + (with-slots (output-chunking output-buffer) stream + (when (> (fill-pointer output-buffer) 0) + (let ((*recursive* t)) + (when output-chunking + (let ((*print-base* 16)) + (princ (fill-pointer output-buffer) stream)) + (write-crlf stream)) + (write-sequence output-buffer stream) + (setf (fill-pointer output-buffer) 0) + (when output-chunking + (write-crlf stream))))) + (call-next-method)) + +(defmethod stream-finish-output ((stream chunked-mixin)) + (unless *recursive* + (force-output stream)) + (call-next-method)) + +(defmethod stream-clear-output ((stream chunked-mixin)) + (with-slots (output-chunking output-buffer) stream + (if (and output-chunking (not *recursive*)) + (setf (fill-pointer output-buffer) 0) + (call-next-method)))) + +(defmethod close ((stream chunked-mixin) &key abort) + (unless abort + (finish-output stream)) + (with-slots (output-chunking output-buffer) stream + (when (and output-chunking + (> (fill-pointer output-buffer) 0)) + (close-chunk stream))) + (call-next-method)) + +(defmethod close-chunk ((stream chunked-mixin)) + (finish-output stream) + (with-slots (output-chunking input-chunking) stream + (if output-chunking + (let ((*recursive* t)) + (princ 0 stream) + (write-crlf stream) + (write-crlf stream) + (finish-output stream) + (setf output-chunking nil + input-chunking nil)) + (error "Chunking is not enabled for output on this stream: ~S." + stream)))) + +(provide :com.ljosa.chunked) + Added: branches/trunk-reorg/thirdparty/acl-compat/clisp/acl-excl.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/acl-compat/clisp/acl-excl.lisp Thu Feb 7 03:21:48 2008 @@ -0,0 +1,70 @@ +;;;; +;;;; ACL-COMPAT - EXCL +;;;; + +;;;; Implementation-specific parts of acl-compat.excl (see +;;;; acl-excl-common.lisp) + +(in-package :acl-compat.excl) + +(defun fixnump (x) + (sys::fixnump x)) + +(defun stream-input-fn (stream) + stream) + +(defun filesys-type (file-or-directory-name) + ;; Taken from clocc's port library, with thanks to Sam Steingold + (if (values + (ignore-errors + (#+lisp=cl ext:probe-directory #-lisp=cl lisp:probe-directory + file-or-directory-name))) + :directory + (if (probe-file file-or-directory-name) + :file + nil))) + +(defmacro atomically (&body forms) + ;; No multiprocessing here, move along... + `(progn ,@forms)) + +(defun unix-signal (signal pid) + (declare (ignore signal pid)) + (error "clisp unix-signal not implemented yet.")) + +(defmacro without-package-locks (&body forms) + `(ext:without-package-lock ,(list-all-packages) ,@forms)) + +(defun fixnump (x) + (sys::fixnump x)) + +(defun string-to-octets (string &key (null-terminate t) (start 0) + end mb-vector make-mb-vector? + (external-format :default)) + "This function returns a lisp-usb8-vector and the number of bytes copied." + (declare (ignore external-format)) + ;; The end parameter is different in ACL's lambda list, but this + ;; variant lets us give an argument :end nil explicitly, and the + ;; right thing will happen + (unless end (setf end (length string))) + (let* ((number-of-octets (if null-terminate (1+ (- end start)) + (- end start))) + (mb-vector (cond + ((and mb-vector (>= (length mb-vector) number-of-octets)) + mb-vector) + ((or (not mb-vector) make-mb-vector?) + (make-array (list number-of-octets) + :element-type '(unsigned-byte 8) + :initial-element 0)) + (t (error "Was given a vector of length ~A, ~ + but needed at least length ~A." + (length mb-vector) number-of-octets))))) + (declare (type (simple-array (unsigned-byte 8) (*)) mb-vector)) + (loop for from-index from start below end + for to-index upfrom 0 + do (progn + (setf (aref mb-vector to-index) + (char-code (aref string from-index))))) + (when null-terminate + (setf (aref mb-vector (1- number-of-octets)) 0)) + (values mb-vector number-of-octets))) Added: branches/trunk-reorg/thirdparty/acl-compat/clisp/acl-mp.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/acl-compat/clisp/acl-mp.lisp Thu Feb 7 03:21:48 2008 @@ -0,0 +1,74 @@ +;; Stubs for multiprocessing functions under clisp. Clisp does not +;; provide threads at the time of writing, so these functions are here +;; only to compile aserve with a minimum of changes in the main code. +;; +;; Written by Rudi Schlatte + + +(in-package :acl-compat-mp) + +(defvar *current-process*) + +(defun process-allow-schedule () + (values)) + +(defun process-allow-scheduling () + (values)) + +(defun process-plist (process) + (declare (ignore process)) + (error "Attempting to use multithreading with clisp.")) + +(defun (setf process-plist) (new-value process) + (declare (ignore new-value process)) + (error "Attempting to use multithreading with clisp.")) + +(defun process-run-reasons (process) + (declare (ignore process)) + (error "Attempting to use multithreading with clisp.")) + +(defun (setf process-run-reasons) (new-value process) + (declare (ignore new-value process)) + (error "Attempting to use multithreading with clisp.")) + +(defun process-revoke-run-reason (process object) + (declare (ignore process object)) + (error "Attempting to use multithreading with clisp.")) + +(defun process-add-run-reason (process object) + (declare (ignore process object)) + (error "Attempting to use multithreading with clisp.")) + +(defun process-run-function (name function &rest arguments) + (declare (ignore name function arguments)) + (error "Attempting to use multithreading with clisp.")) + +(defun process-kill (process) + (declare (ignore process)) + (error "Attempting to use multithreading with clisp.")) + +(defmacro with-gensyms (syms &body body) + "Bind symbols to gensyms. First sym is a string - `gensym' prefix. +Inspired by Paul Graham, <On Lisp>, p. 145." + `(let (,@(mapcar (lambda (sy) `(,sy (gensym ,(car syms)))) (cdr syms))) + ,@body)) + +(defun interrupt-process (process function &rest args) + (declare (ignore process function args)) + (error "Attempting to use multithreading with clisp.")) + +(defun make-process-lock (&key name) + (declare (ignore name)) + (error "Attempting to use multithreading with clisp.")) + +(defmacro with-process-lock ((lock &key norecursive whostate timeout) + &body forms) + (declare (ignore lock norecursive whostate timeout)) + `(progn ,@forms)) + +(defmacro with-timeout ((seconds &body timeout-forms) &body body) + (declare (ignore seconds timeout-forms)) + `(progn ,@body)) + +(defmacro without-scheduling (&body body) + `(progn ,@body)) Added: branches/trunk-reorg/thirdparty/acl-compat/clisp/acl-socket.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/acl-compat/clisp/acl-socket.lisp Thu Feb 7 03:21:48 2008 @@ -0,0 +1,174 @@ +;; This package is designed for clisp. It implements the +;; ACL-style socket interface on top of clisp. +;; +;; Written by Rudi Schlatte, based on the work done by Jochen Schmidt +;; for Lispworks and net.lisp in the port library of CLOCC. + +(in-package :acl-socket) + +(defclass server-socket () + ((port :type fixnum + :initarg :port + :reader port) + (stream-type :type (member :text :binary :bivalent) + :initarg :stream-type + :reader stream-type + :initform (error "No value supplied for stream-type")) + (clisp-socket-server :initarg :clisp-socket-server + :reader clisp-socket-server))) + +(defmethod print-object ((server-socket server-socket) stream) + (print-unreadable-object (server-socket stream :type t :identity nil) + (format stream "@port ~d" (port server-socket)))) + +(defun %get-element-type (format) + (ecase format + (:text 'character) + (:binary '(unsigned-byte 8)) + (:bivalent '(unsigned-byte 8))) ) + +(defgeneric accept-connection (server-socket &key wait)) +(defmethod accept-connection ((server-socket server-socket) + &key (wait t)) + "Return a bidirectional stream connected to socket, or nil if no +client wanted to initiate a connection and wait is nil." + (when (cond ((numberp wait) + (socket-wait (clisp-socket-server server-socket) wait)) + (wait (socket-wait (clisp-socket-server server-socket))) + (t (socket-wait (clisp-socket-server server-socket) 0))) + (let ((stream (socket-accept (clisp-socket-server server-socket) + :element-type (%get-element-type + (stream-type server-socket)) + ))) + (if (eq (stream-type server-socket) :bivalent) + (make-bivalent-stream stream) + stream)))) + + +(defun make-socket (&key (remote-host "localhost") + local-port + remote-port + (connect :active) + (format :text) + &allow-other-keys) + "Return a stream connected to remote-host if connect is :active, or +something listening on local-port that can be fed to accept-connection +if connect is :passive." + (check-type remote-host string) + (ecase connect + (:passive + (make-instance 'server-socket + :port local-port + :clisp-socket-server (socket-server local-port) + :stream-type format)) + (:active + (let ((stream (socket-connect + remote-port remote-host + :element-type (%get-element-type format) + ))) + (if (eq format :bivalent) + (make-bivalent-stream stream) + stream))))) + +(defmethod close ((server-socket server-socket) &key abort) + "Kill a passive (listening) socket. (Active sockets are actually +streams and handled by their close methods." + (declare (ignore abort)) + (socket-server-close (clisp-socket-server server-socket))) + +(declaim (ftype (function ((unsigned-byte 32)) (values simple-string)) + ipaddr-to-dotted)) +(defun ipaddr-to-dotted (ipaddr &key values) + (declare (type (unsigned-byte 32) ipaddr)) + (let ((a (logand #xff (ash ipaddr -24))) + (b (logand #xff (ash ipaddr -16))) + (c (logand #xff (ash ipaddr -8))) + (d (logand #xff ipaddr))) + (if values + (values a b c d) + (format nil "~d.~d.~d.~d" a b c d)))) + +(defun string-tokens (string) + (labels ((get-token (str pos1 acc) + (let ((pos2 (position #\Space str :start pos1))) + (if (not pos2) + (nreverse acc) + (get-token str (1+ pos2) (cons (read-from-string (subseq str pos1 pos2)) + acc)))))) + (get-token (concatenate 'string string " ") 0 nil))) + +(declaim (ftype (function (string &key (:errorp t)) + (values (unsigned-byte 32))) + dotted-to-ipaddr)) +(defun dotted-to-ipaddr (dotted &key (errorp t)) + (declare (string dotted)) + (if errorp + (let ((ll (string-tokens (substitute #\Space #\. dotted)))) + (+ (ash (first ll) 24) (ash (second ll) 16) + (ash (third ll) 8) (fourth ll))) + (ignore-errors + (let ((ll (string-tokens (substitute #\Space #\. dotted)))) + (+ (ash (first ll) 24) (ash (second ll) 16) + (ash (third ll) 8) (fourth ll)))))) + + +(defun ipaddr-to-hostname (ipaddr &key ignore-cache) + (when ignore-cache + (warn ":IGNORE-CACHE keyword in IPADDR-TO-HOSTNAME not supported.")) + (posix::hostent-name (posix:resolve-host-ipaddr ipaddr))) + +(defun lookup-hostname (host &key ignore-cache) + (when ignore-cache + (warn ":IGNORE-CACHE keyword in LOOKUP-HOSTNAME not supported.")) + (if (stringp host) + (car (posix::hostent-addr-list (posix:resolve-host-ipaddr host))) + (dotted-to-ipaddr (ipaddr-to-dotted host)))) + +(defgeneric get-clisp-stream (stream)) + +(defmethod get-clisp-stream ((stream gray-stream::native-lisp-stream-mixin)) + (gray-stream::native-lisp-stream stream)) + +(defmethod get-clisp-stream ((stream t)) + (the stream stream)) + +(defun remote-host (socket-stream) + (dotted-to-ipaddr + (nth-value 0 (socket-stream-peer (get-clisp-stream socket-stream) t)))) + +(defun remote-port (socket-stream) + (nth-value 1 (socket-stream-peer (get-clisp-stream socket-stream) t))) + +(defun local-host (socket-stream) + (dotted-to-ipaddr + (nth-value 0 (socket-stream-local (get-clisp-stream socket-stream) t)))) + +(defun local-port (socket-stream) + (nth-value 1 (socket-stream-local (get-clisp-stream socket-stream) t))) + +;; Now, throw chunking in the mix + +(defclass chunked-stream (de.dataheaven.chunked-stream-mixin::chunked-stream-mixin + gray-stream::buffered-bivalent-stream) + ((plist :initarg :plist :accessor stream-plist))) + + +(defun make-bivalent-stream (lisp-stream &key plist) + (make-instance 'chunked-stream :lisp-stream lisp-stream :plist plist)) + + +(defun socket-control (stream &key (output-chunking nil oc-p) output-chunking-eof (input-chunking nil ic-p)) + (when oc-p + (when output-chunking + (de.dataheaven.chunked-stream-mixin::initialize-output-chunking stream)) + (setf (de.dataheaven.chunked-stream-mixin::output-chunking-p stream) + output-chunking)) + (when output-chunking-eof + (de.dataheaven.chunked-stream-mixin::disable-output-chunking stream)) + (when ic-p + (when input-chunking + (de.dataheaven.chunked-stream-mixin::initialize-input-chunking stream)) + (setf (de.dataheaven.chunked-stream-mixin::input-chunking-p stream) + input-chunking))) + +(provide 'acl-socket) Added: branches/trunk-reorg/thirdparty/acl-compat/clisp/acl-sys.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/acl-compat/clisp/acl-sys.lisp Thu Feb 7 03:21:48 2008 @@ -0,0 +1,22 @@ + +(eval-when (:compile-toplevel :load-toplevel :execute) + (ext:without-package-lock () + (let ((sys-package (find-package "SYSTEM"))) + (export (list (intern "COMMAND-LINE-ARGUMENTS" sys-package) + (intern "COMMAND-LINE-ARGUMENT" sys-package) + (intern "REAP-OS-SUBPROCESS" sys-package)) + sys-package)))) + +(ext:without-package-lock () + (defun sys:command-line-arguments () + ext:*args*)) + +(ext:without-package-lock () + (defun sys:command-line-argument (n) + (nth n ext:*args*))) + +(ext:without-package-lock () + (defun sys:reap-os-subprocess (&key (wait nil)) + (declare (ignore wait)) + nil)) + Added: branches/trunk-reorg/thirdparty/acl-compat/cmucl/acl-excl.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/acl-compat/cmucl/acl-excl.lisp Thu Feb 7 03:21:48 2008 @@ -0,0 +1,71 @@ +;;;; +;;;; ACL-COMPAT - EXCL +;;;; + +;;;; Implementation-specific parts of acl-compat.excl (see +;;;; acl-excl-common.lisp) + +(in-package :acl-compat.excl) + +(defun stream-input-fn (stream) + stream) + +(defun filesys-type (file-or-directory-name) + (if (eq :directory (unix:unix-file-kind + (namestring file-or-directory-name))) + :directory + (if (probe-file file-or-directory-name) + :file + nil))) + +(defmacro atomically (&body forms) + `(mp:without-scheduling ,@forms)) + +(defun unix-signal (signal pid) + ;; fixxme: did I get the arglist right? only invocation I have seen + ;; is (excl::unix-signal 15 0) in net.aserve:start + (unix:unix-kill pid signal)) + +(defmacro without-package-locks (&body forms) + `(progn ,@forms)) + +(defun filesys-inode (path) + (multiple-value-bind (found ign inode) + (unix:unix-lstat path) + (if found + inode + (error "path ~s does not exist" path)))) + +(defun cl-internal-real-time () + (round (/ (get-internal-real-time) internal-time-units-per-second))) + +(defun string-to-octets (string &key (null-terminate t) (start 0) + end mb-vector make-mb-vector? + (external-format :default)) + "This function returns a lisp-usb8-vector and the number of bytes copied." + (declare (ignore external-format)) + ;; The end parameter is different in ACL's lambda list, but this + ;; variant lets us give an argument :end nil explicitly, and the + ;; right thing will happen + (unless end (setf end (length string))) + (let* ((number-of-octets (if null-terminate (1+ (- end start)) + (- end start))) + (mb-vector (cond + ((and mb-vector (>= (length mb-vector) number-of-octets)) + mb-vector) + ((or (not mb-vector) make-mb-vector?) + (make-array (list number-of-octets) + :element-type '(unsigned-byte 8) + :initial-element 0)) + (t (error "Was given a vector of length ~A, ~ + but needed at least length ~A." + (length mb-vector) number-of-octets))))) + (declare (type (simple-array (unsigned-byte 8) (*)) mb-vector)) + (loop for from-index from start below end + for to-index upfrom 0 + do (progn + (setf (aref mb-vector to-index) + (char-code (aref string from-index))))) + (when null-terminate + (setf (aref mb-vector (1- number-of-octets)) 0)) + (values mb-vector number-of-octets))) Added: branches/trunk-reorg/thirdparty/acl-compat/cmucl/acl-mp.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/acl-compat/cmucl/acl-mp.lisp Thu Feb 7 03:21:48 2008 @@ -0,0 +1,170 @@ +;; This package is designed for cmucl. It implements ACL-style +;; multiprocessing on top of cmucl (basically, process run reasons and +;; some function renames). +;; +;; Written by Rudi Schlatte, based on the work done by Jochen Schmidt +;; for Lispworks. + +(in-package :acl-compat.mp) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Import equivalent parts from the CMU MP package ;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(shadowing-import '(mp:*current-process* + ;; mp::process-preset + mp::process-reset + mp:process-interrupt + mp::process-name + mp::process-wait-function + mp:process-run-reasons + mp:process-add-run-reason + mp:process-revoke-run-reason + mp:process-arrest-reasons + mp:process-add-arrest-reason + mp:process-revoke-arrest-reason + mp:process-whostate + ; mp:without-interrupts + mp:process-wait + mp:with-timeout + mp:without-scheduling + mp:process-active-p + )) + +(export '(*current-process* + ;; process-preset + process-reset + process-interrupt + process-name + process-wait-function + process-whostate + process-wait + with-timeout + without-scheduling + process-run-reasons + process-add-run-reason + process-revoke-run-reason + process-arrest-reasons + process-add-arrest-reason + process-revoke-arrest-reason + process-active-p + )) + + +(defun process-allow-schedule () + (mp:process-yield)) + +(defvar *process-plists* (make-hash-table :test #'eq) + "maps processes to their plists. +See the functions process-plist, (setf process-plist).") + +(defun process-property-list (process) + (gethash process *process-plists*)) + +(defun (setf process-property-list) (new-value process) + (setf (gethash process *process-plists*) new-value)) + +#|| + +;;; rudi 2002-06-09: This is not needed as of cmucl 18d, thanks to Tim +;;; Moore who added run reasons to cmucl's multithreading. Left in +;;; for the time being just in case someone wants to get acl-compat +;;; running on older cmucl's. Can be deleted safely. + +(defvar *process-run-reasons* (make-hash-table :test #'eq) + "maps processes to their run-reasons. +See the functions process-run-reasons, (setf process-run-reasons), +process-add-run-reason, process-revoke-run-reason.") + +(defun process-run-reasons (process) + (gethash process *process-run-reasons*)) + +(defun (setf process-run-reasons) (new-value process) + (mp:without-scheduling + (prog1 + (setf (gethash process *process-run-reasons*) new-value) + (if new-value + (mp:enable-process process) + (mp:disable-process process))))) + +(defun process-revoke-run-reason (process object) + (without-scheduling + (setf (process-run-reasons process) + (remove object (process-run-reasons process)))) + (when (and (eq process mp:*current-process*)) + (mp:process-yield))) + +(defun process-add-run-reason (process object) + (setf (process-run-reasons process) + (pushnew object (process-run-reasons process)))) +||# + +(defun process-run-function (name-or-options preset-function + &rest preset-arguments) + (let ((process (etypecase name-or-options + (string (make-process :name name-or-options + :run-reasons '(t))) + (list (apply #'make-process :run-reasons '(t) + name-or-options))))) + (apply #'acl-mp::process-preset process preset-function preset-arguments) + process)) + +(defun process-preset (process preset-function &rest arguments) + (mp:process-preset process + #'(lambda () + (apply-with-bindings preset-function + arguments + (process-initial-bindings process))))) + +(defvar *process-initial-bindings* (make-hash-table :test #'eq)) + +(defun process-initial-bindings (process) + (gethash process *process-initial-bindings*)) + +(defun (setf process-initial-bindings) (bindings process) + (setf (gethash process *process-initial-bindings*) bindings)) + + +;;; ;;; +;;; Contributed by Tim Moore ;;; +;;; ;;; +(defun apply-with-bindings (function args bindings) + (if bindings + (progv + (mapcar #'car bindings) + (mapcar #'(lambda (binding) + (eval (cdr binding))) + bindings) + (apply function args)) + (apply function args))) + +(defun make-process (&key (name "Anonymous") reset-action run-reasons + arrest-reasons (priority 0) quantum resume-hook + suspend-hook initial-bindings run-immediately) + (declare (ignore priority quantum reset-action resume-hook suspend-hook + run-immediately)) + (mp:make-process nil :name name + :run-reasons run-reasons + :arrest-reasons arrest-reasons + :initial-bindings initial-bindings)) + +(defun process-kill (process) + (mp:destroy-process process)) + + +(defun make-process-lock (&key name) + (mp:make-lock name)) + +(defun process-lock (lock) + (mp::lock-wait lock (mp:process-whostate mp:*current-process*))) + +(defun process-unlock (lock) + (setf (mp::lock-process lock) nil)) + + +(defmacro with-process-lock ((lock &key norecursive whostate timeout) &body forms) + (declare (ignore norecursive)) + `(mp:with-lock-held (,lock + ,@(when whostate (list :whostate whostate)) + ,@(when timeout (list :timeout timeout))) + ,@forms)) Added: branches/trunk-reorg/thirdparty/acl-compat/cmucl/acl-socket.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/acl-compat/cmucl/acl-socket.lisp Thu Feb 7 03:21:48 2008 @@ -0,0 +1,208 @@ +;; This package is designed for cmucl. It implements the +;; ACL-style socket interface on top of cmucl. +;; +;; Written by Rudi Schlatte, based on the work done by Jochen Schmidt +;; for Lispworks and net.lisp in the port library of CLOCC. + +(in-package acl-compat.socket) + +(defclass socket () + ((fd :type fixnum + :initarg :fd + :reader fd))) + +(defmethod print-object ((socket socket) stream) + (print-unreadable-object (socket stream :type t :identity t) + (format stream "@~d" (fd socket)))) + +(defclass server-socket (socket) + ((element-type :type (member signed-byte unsigned-byte base-char) + :initarg :element-type + :reader element-type + :initform (error "No value supplied for element-type")) + (port :type fixnum + :initarg :port + :reader port + :initform (error "No value supplied for port")) + (stream-type :type (member :text :binary :bivalent) + :initarg :stream-type + :reader stream-type + :initform (error "No value supplied for stream-type")))) + +#+cl-ssl +(defmethod make-ssl-server-stream ((lisp-stream system:lisp-stream) + &rest options) + (apply #'make-ssl-server-stream (system:fd-stream-fd lisp-stream) options)) + +(defmethod print-object ((socket server-socket) stream) + (print-unreadable-object (socket stream :type t :identity nil) + (format stream "@~d on port ~d" (fd socket) (port socket)))) + +(defmethod accept-connection ((server-socket server-socket) + &key (wait t)) + "Return a bidirectional stream connected to socket, or nil if no +client wanted to initiate a connection and wait is nil." + ;; fixxme: perhaps check whether we run multiprocessing and use + ;; sys:wait-until-fd-usable instead of + ;; mp:process-wait-until-fd-usable here? + + ;; api pipe fitting: wait t ==> timeout nil + (when (mp:process-wait-until-fd-usable (fd server-socket) :input + (if wait nil 0)) + (let ((stream (sys:make-fd-stream + (ext:accept-tcp-connection (fd server-socket)) + :input t :output t + :element-type (element-type server-socket) + :auto-close t))) + (if (eq (stream-type server-socket) :bivalent) + (make-bivalent-stream stream) + stream)))) + +(defun make-socket (&key (remote-host "localhost") + local-port + remote-port + (connect :active) + (format :text) + (reuse-address t) + &allow-other-keys) + "Return a stream connected to remote-host if connect is :active, or +something listening on local-port that can be fed to accept-connection +if connect is :passive. + +This is an incomplete implementation of ACL's make-socket function! +It was written to provide the functionality necessary to port +AllegroServe. Refer to +http://franz.com/support/documentation/6.1/doc/pages/operators/socket/make-s... +to read about the missing parts." + (check-type remote-host string) + (let ((element-type (ecase format + (:text 'base-char) + (:binary 'signed-byte) + (:bivalent 'unsigned-byte)))) + (ecase connect + (:passive + (make-instance 'server-socket + :port local-port + :fd (ext:create-inet-listener local-port :stream :reuse-address reuse-address) + :element-type element-type + :stream-type format)) + (:active + (let ((stream (sys:make-fd-stream + (ext:connect-to-inet-socket remote-host remote-port) + :input t :output t :element-type element-type))) + (if (eq :bivalent format) + (make-bivalent-stream stream) + stream)))))) + +(defmethod close ((server server-socket) &key abort) + "Kill a passive (listening) socket. (Active sockets are actually +streams and handled by their close methods." + (declare (ignore abort)) + (unix:unix-close (fd server))) + +(declaim (ftype (function ((unsigned-byte 32) &key (:values t)) + (values simple-string)) + ipaddr-to-dotted)) +(defun ipaddr-to-dotted (ipaddr &key values) + (declare (type (unsigned-byte 32) ipaddr)) + (let ((a (logand #xff (ash ipaddr -24))) + (b (logand #xff (ash ipaddr -16))) + (c (logand #xff (ash ipaddr -8))) + (d (logand #xff ipaddr))) + (if values + (values a b c d) + (format nil "~d.~d.~d.~d" a b c d)))) + +(defun string-tokens (string) + (labels ((get-token (str pos1 acc) + (let ((pos2 (position #\Space str :start pos1))) + (if (not pos2) + (nreverse acc) + (get-token str (1+ pos2) (cons (read-from-string (subseq str pos1 pos2)) + acc)))))) + (get-token (concatenate 'string string " ") 0 nil))) + +(declaim (ftype (function (string &key (:errorp t)) + (values (unsigned-byte 32))) + dotted-to-ipaddr)) +(defun dotted-to-ipaddr (dotted &key (errorp t)) + (declare (string dotted)) + (if errorp + (let ((ll (string-tokens (substitute #\Space #\. dotted)))) + (+ (ash (first ll) 24) (ash (second ll) 16) + (ash (third ll) 8) (fourth ll))) + (ignore-errors + (let ((ll (string-tokens (substitute #\Space #\. dotted)))) + (+ (ash (first ll) 24) (ash (second ll) 16) + (ash (third ll) 8) (fourth ll)))))) + +(defun ipaddr-to-hostname (ipaddr &key ignore-cache) + (when ignore-cache + (warn ":IGNORE-CACHE keyword in IPADDR-TO-HOSTNAME not supported.")) + (ext:host-entry-name (ext:lookup-host-entry ipaddr))) + +(defun lookup-hostname (host &key ignore-cache) + (when ignore-cache + (warn ":IGNORE-CACHE keyword in LOOKUP-HOSTNAME not supported.")) + (if (stringp host) + (car (ext:host-entry-addr-list (ext:lookup-host-entry host))) + (dotted-to-ipaddr (ipaddr-to-dotted host)))) + +(defgeneric get-fd (stream)) + +(defmethod get-fd ((stream gray-stream::native-lisp-stream-mixin)) + (system:fd-stream-fd (gray-stream::native-lisp-stream stream))) + +(defmethod get-fd ((stream system:lisp-stream)) + (system:fd-stream-fd stream)) + +(defmethod get-fd ((stream server-socket)) + (fd stream)) + +(defun remote-host (socket-stream) + (ext:get-peer-host-and-port (get-fd socket-stream))) + +(defun remote-port (socket-stream) + (multiple-value-bind (host port) + (ext:get-peer-host-and-port (get-fd socket-stream)) + (declare (ignore host)) + port)) + +(defun local-host (socket-stream) + (ext:get-socket-host-and-port (get-fd socket-stream))) + +(defun local-port (socket-stream) + (if (typep socket-stream 'socket::server-socket) + (port socket-stream) + (multiple-value-bind (host port) + (ext:get-socket-host-and-port (get-fd socket-stream)) + (declare (ignore host)) + port))) + +;; Now, throw chunking in the mix + +(defclass chunked-stream (de.dataheaven.chunked-stream-mixin::chunked-stream-mixin + gray-stream::buffered-bivalent-stream) + ()) + + +(defun make-bivalent-stream (lisp-stream) + (make-instance 'chunked-stream :lisp-stream lisp-stream)) + + +(defun socket-control (stream &key (output-chunking nil oc-p) output-chunking-eof (input-chunking nil ic-p)) + (when oc-p + (when output-chunking + (de.dataheaven.chunked-stream-mixin::initialize-output-chunking stream)) + (setf (de.dataheaven.chunked-stream-mixin::output-chunking-p stream) + output-chunking)) + (when output-chunking-eof + (de.dataheaven.chunked-stream-mixin::disable-output-chunking stream)) + (when ic-p + (when input-chunking + (de.dataheaven.chunked-stream-mixin::initialize-input-chunking stream)) + (setf (de.dataheaven.chunked-stream-mixin::input-chunking-p stream) + input-chunking))) + + +(provide 'acl-socket) Added: branches/trunk-reorg/thirdparty/acl-compat/cmucl/acl-sys.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/acl-compat/cmucl/acl-sys.lisp Thu Feb 7 03:21:48 2008 @@ -0,0 +1,18 @@ +(in-package :acl-compat.system) + +(ignore-errors +(export 'command-line-arguments) +(export 'command-line-argument) +(export 'reap-os-subprocess) + +(defun command-line-arguments () + ext:*command-line-strings*) + +(defun command-line-argument (n) + (nth n ext:*command-line-strings*)) + +(defun reap-os-subprocess (&key (wait nil)) + (declare (ignore wait)) + nil) + +) Added: branches/trunk-reorg/thirdparty/acl-compat/defsys.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/acl-compat/defsys.lisp Thu Feb 7 03:21:48 2008 @@ -0,0 +1,50 @@ +(in-package "CL-USER") + +(defsystem "ACL-COMPAT" + (:default-pathname "ACL-COMPAT:") + :members + ("acl-compat-common-lisp-lw" + "nregex" + "acl-excl-lw" + "acl-mp-package" + "acl-mp-lw" + "gray-stream-package" + "acl-socket-lw" + "acl-sys-lw" + "meta" + "uri" + "chunked-stream-mixin") + + :rules + ((:in-order-to :compile "acl-excl-lw" + (:caused-by (:compile "nregex")) + (:requires (:load "nregex"))) + (:in-order-to :load "acl-excl-lw" + (:requires (:load "nregex"))) + + (:in-order-to :compile "acl-mp-lw" + (:caused-by (:compile "acl-mp-package" "acl-socket-lw")) + (:requires (:load "acl-mp-package" "acl-socket-lw"))) + (:in-order-to :load "acl-mp-lw" + (:requires (:load "acl-mp-package" "acl-socket-lw"))) + + (:in-order-to :compile "acl-socket-lw" + (:caused-by (:compile "chunked-stream-mixin")) + (:requires (:load "chunked-stream-mixin"))) + (:in-order-to :load "acl-socket-lw" + (:requires (:load "chunked-stream-mixin"))) + + (:in-order-to :compile "chunked-stream-mixin" + (:caused-by (:compile "acl-excl-lw" "gray-stream-package")) + (:requires (:load "acl-excl-lw" "gray-stream-package"))) + (:in-order-to :load "chunked-stream-mixin" + (:requires (:load "acl-excl-lw" "gray-stream-package"))) + + (:in-order-to :compile "uri" + (:caused-by (:compile "meta")) + (:requires (:load "meta"))) + (:in-order-to :load "uri" + (:requires (:load "meta"))))) + +(eval-when (:load-toplevel :execute) + (pushnew :acl-compat *features*)) Added: branches/trunk-reorg/thirdparty/acl-compat/lispworks/acl-excl.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/acl-compat/lispworks/acl-excl.lisp Thu Feb 7 03:21:48 2008 @@ -0,0 +1,85 @@ +;;;; +;;;; ACL-COMPAT - EXCL +;;;; + +;;;; Implementation-specific parts of acl-compat.excl (see +;;;; acl-excl-common.lisp) + +(in-package :acl-compat.excl) + +#+obsolete +(defun stream-input-fn (stream) + stream) + +(defmethod stream-input-fn ((stream stream)) + stream) + +(defun filesys-type (file-or-directory-name) + (if (lw::file-directory-p file-or-directory-name) + :directory + (if (probe-file file-or-directory-name) + :file + nil))) + +#-:win32 +(defun filesys-inode (path) + (let ((checked-path (probe-file path))) + (cond + (checked-path (let ((stat (system:get-file-stat checked-path))) + (system:file-stat-inode stat))) + (t (error "path ~a does not exist." path))))) + +(defmacro atomically (&body forms) + `(mp:without-preemption ,@forms)) + +(defmacro without-package-locks (&body forms) + `(progn ,@forms)) + + +#| +(defun run-shell-command () + (with-open-stream (s (open-pipe "/bin/sh" + :direction :io + :buffered nil)) + (loop for var in environment + do (format stream "~A=~A~%" (car var) (cdr var))) +|# + +;; NDL 2004-06-04 -- Missing definition & a package, to allow LispWorks to load webactions + +(defun cl-internal-real-time () + (round (/ (get-internal-real-time) 1000))) + +(defun string-to-octets (string &key (null-terminate t) (start 0) + end mb-vector make-mb-vector? + (external-format :default)) + "This function returns a lisp-usb8-vector and the number of bytes copied." + (declare (ignore external-format)) + ;; The end parameter is different in ACL's lambda list, but this + ;; variant lets us give an argument :end nil explicitly, and the + ;; right thing will happen + (unless end (setf end (length string))) + (let* ((number-of-octets (if null-terminate (1+ (- end start)) + (- end start))) + (mb-vector (cond + ((and mb-vector (>= (length mb-vector) number-of-octets)) + mb-vector) + ((or (not mb-vector) make-mb-vector?) + (make-array (list number-of-octets) + :element-type '(unsigned-byte 8) + :initial-element 0)) + (t (error "Was given a vector of length ~A, ~ + but needed at least length ~A." + (length mb-vector) number-of-octets))))) + (declare (type (simple-array (unsigned-byte 8) (*)) mb-vector)) + (loop for from-index from start below end + for to-index upfrom 0 + do (progn + (setf (aref mb-vector to-index) + (char-code (aref string from-index))))) + (when null-terminate + (setf (aref mb-vector (1- number-of-octets)) 0)) + (values mb-vector number-of-octets))) + + +(provide 'acl-excl) Added: branches/trunk-reorg/thirdparty/acl-compat/lispworks/acl-mp.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/acl-compat/lispworks/acl-mp.lisp Thu Feb 7 03:21:48 2008 @@ -0,0 +1,209 @@ +;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Package: CL-USER; -*- +;;;; ; +;;;; (c) 2001 by Jochen Schmidt. +;;;; +;;;; File: acl-mp-lw.lisp +;;;; Revision: 1.0.0 +;;;; Description: LispWorks implementation for ACL-COMPAT-MP +;;;; Date: 02.02.2002 +;;;; Authors: Jochen Schmidt +;;;; Tel: (+49 9 11) 47 20 603 +;;;; Email: jsc@dataheaven.de +;;;; +;;;; Redistribution and use in source and binary forms, with or without +;;;; modification, are permitted provided that the following conditions +;;;; are met: +;;;; 1. Redistributions of source code must retain the above copyright +;;;; notice, this list of conditions and the following disclaimer. +;;;; 2. Redistributions in binary form must reproduce the above copyright +;;;; notice, this list of conditions and the following disclaimer in the +;;;; documentation and/or other materials provided with the distribution. +;;;; +;;;; THIS SOFTWARE IS PROVIDED "AS IS" AND THERE ARE NEITHER +;;;; EXPRESSED NOR IMPLIED WARRANTIES - THIS INCLUDES, BUT +;;;; IS NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY +;;;; AND FITNESS FOR A PARTICULAR PURPOSE.IN NO WAY ARE THE +;;;; AUTHORS LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +;;;; SPECIAL, EXEMPLARY OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT +;;;; NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES ; +;;;; LOSS OF USE, DATA, OR PROFITS ; OR BUSINESS INTERRUPTION) +;;;; +;;;; For further details contact the authors of this software. +;;;; +;;;; Jochen Schmidt +;;;; Zuckmantelstr. 11 +;;;; 91616 Neusitz +;;;; GERMANY +;;;; +;;;; + +(eval-when (:compile-toplevel :load-toplevel :execute) + (require "comm")) + +(in-package :acl-compat-mp) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Import equivalent parts from the LispWorks MP package ;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(shadowing-import '( + mp:*current-process* + mp:process-kill + mp:process-enable + mp:process-disable + mp::process-preset + mp:process-reset + mp:process-interrupt + mp::process-name + mp:process-wait-function + mp:process-run-reasons + mp:process-arrest-reasons + mp:process-whostate + mp:without-interrupts + mp:process-wait + mp::process-active-p + )) + +(export '( *current-process* + process-kill + process-enable + process-disable + process-preset + process-reset + process-interrupt + process-name + process-wait-function + process-run-reasons + process-arrest-reasons + process-whostate + without-interrupts + process-wait + process-active-p + )) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Implement missing (and differing) functions ;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defun make-process (&key (name "Anonymous") reset-action run-reasons arrest-reasons (priority 0) quantum + resume-hook suspend-hook initial-bindings run-immediately) + (declare (ignore priority quantum reset-action resume-hook suspend-hook run-immediately)) + (let ((mp:*process-initial-bindings* initial-bindings)) + (mp:create-process name :run-reasons run-reasons :arrest-reasons arrest-reasons))) + +(defun process-run-function (name-or-options preset-function &rest preset-arguments) + (let ((process (ctypecase name-or-options + (string (make-process :name name-or-options)) + (list (apply #'make-process name-or-options))))) + (apply #'mp::process-preset process preset-function preset-arguments) + (push :enable (mp:process-run-reasons process)) + process)) + +(defun process-property-list (process) + (mp:process-plist process)) + +(defun (setf process-property-list) (new-value process) + (setf (mp:process-plist process) new-value)) + +(defun process-name-to-process (name &optional abbrev) + (if abbrev + (let ((length (length name))) + (dolist (process (mp:list-all-processes)) + (when (and (>= (length (process-name process)) length) + (string= name (process-name process) :end2 length)) + (return process)))) + (mp:find-process-from-name (ctypecase name + (symbol (symbol-name name)) + (string name))))) + +(defun process-wait-with-timeout (whostate seconds function &rest args) + (apply #'mp:process-wait-with-timeout whostate seconds function args)) + +(defun wait-for-input-available (streams &key (wait-function #'socket::stream-input-available) whostate timeout) + (let ((collected-fds nil)) + (flet ((fd (stream-or-fd) + (typecase stream-or-fd + (comm:socket-stream (comm:socket-stream-socket stream-or-fd)) + (socket::passive-socket (socket::socket-os-fd stream-or-fd)) + (fixnum stream-or-fd))) + (collect-fds () + (setf collected-fds + (remove-if-not wait-function streams)))) + + #+unix + (unwind-protect + (progn + (dolist (stream-or-fd streams) + (mp:notice-fd (fd stream-or-fd))) + (if timeout + (mp:process-wait-with-timeout (or whostate "Waiting for input") timeout #'collect-fds) + (mp:process-wait (or whostate "Waiting for input") #'collect-fds))) + (dolist (stream-or-fd streams) + (mp:unnotice-fd (fd stream-or-fd)))) + #-unix + (if timeout + (mp:process-wait-with-timeout (or whostate "Waiting for input") timeout #'collect-fds) + (mp:process-wait (or whostate "Waiting for input") #'collect-fds))) + collected-fds)) + +(defmacro without-scheduling (&body forms) + `(mp:without-preemption ,@forms)) + +(defun process-allow-schedule (&optional process) + (declare (ignore process)) + (mp:process-allow-scheduling)) + +(defun process-revoke-run-reason (process object) + (mp:without-preemption + (setf (mp:process-run-reasons process) + (remove object (mp:process-run-reasons process)))) + (when (and (eq process mp:*current-process*) + (not mp:*inhibit-scheduling-flag*)) + (mp:process-allow-scheduling))) + +(defun process-add-run-reason (process object) + (setf (mp:process-run-reasons process) (pushnew object (mp:process-run-reasons process)))) + +;revised version from alain picard +(defun invoke-with-timeout (timeout bodyfn timeoutfn) + (block timeout + (let* ((process mp:*current-process*) + (unsheduled? nil) + (timer (mp:make-timer + #'(lambda () + (mp:process-interrupt process + #'(lambda () + (unless unsheduled? + (return-from timeout + (funcall timeoutfn))))))))) + (mp:schedule-timer-relative timer timeout) + (unwind-protect (funcall bodyfn) + (without-interrupts + (mp:unschedule-timer timer) + (setf unsheduled? t)))))) + + +(defmacro with-timeout ((seconds &body timeout-forms) &body body) + "Execute BODY; if execution takes more than SECONDS seconds, terminate +and evaluate TIMEOUT-FORMS." + `(invoke-with-timeout ,seconds #'(lambda () ,@body) + #'(lambda () ,@timeout-forms))) + +(defun current-process () + "The current process." + mp:*current-process*) + +(defun interrupt-process (process function &rest args) + "Run FUNCTION in PROCESS." + (apply #'mp:process-interrupt process function args)) + +(defun make-process-lock (&key name) + (mp:make-lock :name name)) + +(defmacro with-process-lock ((lock &key norecursive timeout whostate) &body forms) + (declare (ignore norecursive)) + `(mp:with-lock (,lock + ,@(when whostate (list :whostate whostate)) + ,@(when timeout (list :timeout timeout))) + ,@forms)) + Added: branches/trunk-reorg/thirdparty/acl-compat/lispworks/acl-socket.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/acl-compat/lispworks/acl-socket.lisp Thu Feb 7 03:21:48 2008 @@ -0,0 +1,311 @@ +;; This package is designed for LispWorks. It implements the +;; ACL-style socket interface on top of LispWorks. + +(eval-when (:compile-toplevel :load-toplevel :execute) + (require "comm")) + +#+cl-ssl +(eval-when (:compile-toplevel :load-toplevel :execute) +(ssl-internal::initialize-ssl-library) +) + +(in-package acl-compat.socket) + +(define-condition stream-error (error) + ((acl-compat.excl::stream :initarg :stream + :reader stream-error-stream) + (acl-compat.excl::action :initarg :action + :reader stream-error-action) + (acl-compat.excl::code :initarg :code + :reader stream-error-code) + (acl-compat.excl::identifier :initarg :identifier + :reader stream-error-identifier)) + (:report (lambda (condition stream) + (format stream "A stream error occured (action=~A identifier=~A code=~A stream=~S)." + (stream-error-action condition) + (stream-error-identifier condition) + (stream-error-code condition) + (stream-error-stream condition))))) + +(define-condition socket-error (stream-error) + () + (:report (lambda (condition stream) + (format stream "A socket error occured (action=~A identifier=~A code=~A stream=~S)." + (stream-error-action condition) + (stream-error-identifier condition) + (stream-error-code condition) + (stream-error-stream condition))))) + +#+unix +(defun %socket-error-identifier (code) + (case code + (32 :x-broken-pipe) + (98 :address-in-use) + (99 :address-not-available) + (100 :network-down) + (102 :network-reset) + (103 :connection-aborted) + (104 :connection-reset) + (105 :no-buffer-space) + (108 :shutdown) + (110 :connection-timed-out) + (111 :connection-refused) + (112 :host-down) + (113 :host-unreachable) + (otherwise :unknown))) + +#+win32 +(defun %socket-error-identifier (code) + (case code + (10048 :address-in-use) + (10049 :address-not-available) + (10050 :network-down) + (10052 :network-reset) + (10053 :connection-aborted) + (10054 :connection-reset) + (10055 :no-buffer-space) + (10058 :shutdown) + (10060 :connection-timed-out) + (10061 :connection-refused) + (10064 :host-down) + (10065 :host-unreachable) + (otherwise :unknown))) + +(defun socket-error (stream error-code action format-string &rest format-args) + (declare (ignore format-string format-args)) ;no valid initargs for this with socket-error + (let ((code (if (numberp error-code) error-code #+unix(lw:errno-value)))) + (error 'socket-error :stream stream :code code + :identifier (if (keywordp error-code) + error-code + (%socket-error-identifier error-code)) + :action action))) + + +(defclass socket () + ((passive-socket :type fixnum + :initarg :passive-socket + :reader socket-os-fd))) + +(defclass passive-socket (socket) + ((element-type :type (member signed-byte unsigned-byte base-char) + :initarg :element-type + :reader element-type) + (port :type fixnum + :initarg :port + :reader local-port))) + +(defclass binary-socket-stream (de.dataheaven.chunked-stream-mixin:chunked-stream-mixin comm:socket-stream) ()) +(defclass input-binary-socket-stream (binary-socket-stream)()) +(defclass output-binary-socket-stream (binary-socket-stream)()) +(defclass bidirectional-binary-socket-stream (input-binary-socket-stream output-binary-socket-stream)()) + + +(defmethod comm::socket-error ((stream binary-socket-stream) error-code format-string &rest format-args) + (apply #'socket-error stream error-code :IO format-string format-args)) + + +(declaim (inline %reader-function-for-sequence)) +(defun %reader-function-for-sequence (sequence) + (typecase sequence + (string #'read-char) + ((array unsigned-byte (*)) #'read-byte) + ((array signed-byte (*)) #'read-byte) + (otherwise #'read-byte))) + +;; Bivalent socket support for READ-SEQUENCE +(defmethod gray-stream:stream-read-sequence ((stream input-binary-socket-stream) sequence start end) + (stream::read-elements stream sequence start end (%reader-function-for-sequence sequence))) + +;; NDL 2004-06-06 -- without this, emit-clp-entity tries writing a string down a binary stream, and LW barfs +(defmethod gray-stream:stream-write-sequence ((stream output-binary-socket-stream) (sequence string) start end) + (write-string sequence stream :start start :end end)) + +;; ACL Gray-Streams Enhancment Generic Functions + +(defmethod stream-input-fn ((stream input-binary-socket-stream)) + (comm:socket-stream-socket stream)) + +(defmethod stream-output-fn ((stream output-binary-socket-stream)) + (comm:socket-stream-socket stream)) + +(defmethod socket-os-fd ((socket comm:socket-stream)) + (comm:socket-stream-socket socket)) + +(defmethod print-object ((passive-socket passive-socket) stream) + (print-unreadable-object (passive-socket stream :type t :identity nil) + (format stream "@~d on port ~d" (socket-os-fd passive-socket) (local-port passive-socket)))) + +(defmethod stream-input-available ((fd fixnum)) + (comm::socket-listen fd)) + +(defmethod stream-input-available ((stream stream::os-file-handle-stream)) + (stream-input-available (stream::os-file-handle-stream-file-handle stream))) + +(defmethod stream-input-available ((stream comm:socket-stream)) + (or (comm::socket-listen (comm:socket-stream-socket stream)) + (listen stream))) + +(defmethod stream-input-available ((stream socket::passive-socket)) + (comm::socket-listen (socket::socket-os-fd stream))) + + +(defmethod accept-connection ((passive-socket passive-socket) + &key (wait t)) + (if (or wait (stream-input-available passive-socket)) + (make-instance 'bidirectional-binary-socket-stream + :socket (comm::get-fd-from-socket (socket-os-fd passive-socket)) + :direction :io + :element-type (element-type passive-socket)))) + +(defun %new-passive-socket (local-port) + (multiple-value-bind (socket error-location error-code) + (comm::create-tcp-socket-for-service local-port) + (cond (socket socket) + (t (error 'socket-error :action error-location :code error-code :identifier :unknown))))) + +(defun make-socket (&key (remote-host "localhost") + local-port + remote-port + (connect :active) + (format :text) + (reuse-address t) + &allow-other-keys) + (declare (ignore format)) + (check-type remote-host string) + (ecase connect + (:passive + (let ((comm::*use_so_reuseaddr* reuse-address)) + (make-instance 'passive-socket + :port local-port + :passive-socket (%new-passive-socket local-port) + :element-type '(unsigned-byte 8)))) + (:active + (handler-case + (let ((stream (comm:open-tcp-stream remote-host remote-port + :direction :io + :element-type '(unsigned-byte 8) + :errorp t))) + (change-class stream 'bidirectional-binary-socket-stream)) + (simple-error (condition) + (let ((code (first (last (simple-condition-format-arguments condition))))) + (socket-error condition code + :connect "~A occured while connecting (~?)" (simple-condition-format-arguments condition)))))))) + + +(defmethod close ((passive-socket passive-socket) &key abort) + (declare (ignore abort)) + (comm::close-socket (socket-os-fd passive-socket))) + +;(declaim (ftype (function ((unsigned-byte 32)) (values simple-string)) +; ipaddr-to-dotted)) +(defun ipaddr-to-dotted (ipaddr &key values) + ;(declare (type (unsigned-byte 32) ipaddr)) + (if ipaddr ;sometimes ipaddr is nil in the log call if client has broken the connection + (let ((a (logand #xff (ash ipaddr -24))) + (b (logand #xff (ash ipaddr -16))) + (c (logand #xff (ash ipaddr -8))) + (d (logand #xff ipaddr))) + (if values + (values a b c d) + (format nil "~d.~d.~d.~d" a b c d))) + (if values (values 0 0 0 0) "0.0.0.0"))) + +(defun string-tokens (string) + (labels ((get-token (str pos1 acc) + (let ((pos2 (position #\Space str :start pos1))) + (if (not pos2) + (nreverse acc) + (get-token str (1+ pos2) (cons (read-from-string (subseq str pos1 pos2)) + acc)))))) +(get-token (concatenate 'string string " ") 0 nil))) + +(declaim (ftype (function (string &key (:errorp t)) + (values (unsigned-byte 32))) + dotted-to-ipaddr)) +(defun dotted-to-ipaddr (dotted &key (errorp t)) + (declare (string dotted)) + (if errorp + (let ((ll (string-tokens (substitute #\Space #\. dotted)))) + (+ (ash (first ll) 24) (ash (second ll) 16) + (ash (third ll) 8) (fourth ll))) + (ignore-errors + (let ((ll (string-tokens (substitute #\Space #\. dotted)))) + (+ (ash (first ll) 24) (ash (second ll) 16) + (ash (third ll) 8) (fourth ll)))))) + +(defun ipaddr-to-hostname (ipaddr &key ignore-cache) + (declare (ignore ignore-cache)) + (multiple-value-bind (name) + (comm:get-host-entry (ipaddr-to-dotted ipaddr) :fields '(:name)) + name)) + +(defun lookup-hostname (host &key ignore-cache) + (when ignore-cache + (warn ":IGNORE-CACHE keyword in LOOKUP-HOSTNAME not supported.")) + (if (stringp host) + (multiple-value-bind (addr) + (comm:get-host-entry host :fields '(:address)) + addr) + (dotted-to-ipaddr (ipaddr-to-dotted host)))) + +(defmethod remote-host ((socket comm:socket-stream)) + (comm:socket-stream-peer-address socket)) + +(defmethod remote-port ((socket comm:socket-stream)) + (multiple-value-bind (host port) + (comm:socket-stream-peer-address socket) + (declare (ignore host)) + port)) + +(defmethod local-host ((socket comm:socket-stream)) + (multiple-value-bind (host port) + (comm:socket-stream-address socket) + (declare (ignore port)) + host)) + +(defmethod local-port ((socket comm:socket-stream)) + (multiple-value-bind (host port) + (comm:socket-stream-address socket) + (declare (ignore host)) + port)) + +(defun socket-control (stream &key (output-chunking nil oc-p) output-chunking-eof (input-chunking nil ic-p)) + (when oc-p + (when output-chunking + (de.dataheaven.chunked-stream-mixin::initialize-output-chunking stream)) + (setf (de.dataheaven.chunked-stream-mixin:output-chunking-p stream) output-chunking)) + (when output-chunking-eof + (de.dataheaven.chunked-stream-mixin::disable-output-chunking stream)) + (when ic-p + (when input-chunking + (de.dataheaven.chunked-stream-mixin::initialize-input-chunking stream)) + (setf (de.dataheaven.chunked-stream-mixin:input-chunking-p stream) input-chunking))) + +#+(and :lispworks4.4 (not :cl-ssl)) +(defmethod make-ssl-client-stream ((socket-stream bidirectional-binary-socket-stream) &rest options) + (declare (ignore options)) + (comm:attach-ssl socket-stream :ssl-ctx t :ssl-side :client) + socket-stream) + +#+(and :lispworks4.4 (not :cl-ssl)) +(defun initialize-ssl-library () + ;; Dunno how to force load yet + (comm:ensure-ssl)) + +#+(and :lispworks4.4 (not :cl-ssl)) +(defmethod make-ssl-server-stream ((socket-stream bidirectional-binary-socket-stream) &key certificate certificate-password) + (flet ((ctx-configure-callback (ctx) + (comm:ssl-ctx-use-privatekey-file ctx + certificate-password + comm:SSL_FILETYPE_PEM)) + (ssl-configure-callback (ssl) + (comm:ssl-use-certificate-file ssl + certificate + comm:SSL_FILETYPE_PEM))) + (comm:attach-ssl socket-stream + :ssl-side :server + :ctx-configure-callback #'ctx-configure-callback + :ssl-configure-callback #'ssl-configure-callback)) + socket-stream) + +(provide 'acl-socket) Added: branches/trunk-reorg/thirdparty/acl-compat/lispworks/acl-sys.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/acl-compat/lispworks/acl-sys.lisp Thu Feb 7 03:21:48 2008 @@ -0,0 +1,24 @@ +(in-package :sys) +(let ((*handle-warn-on-redefinition* :warn)) +; (*packages-for-warn-on-redefinition* nil)) + + (defun command-line-arguments () + system:*line-arguments-list*) + + (defun command-line-argument (n) + (nth n system:*line-arguments-list*)) + + (defun reap-os-subprocess (&key (wait nil)) + (declare (ignore wait)) + nil) + + (export 'command-line-arguments) + (export 'command-line-argument) + (export 'reap-os-subprocess)) + +;; Franz uses the MSWINDOWS feature conditional in some of their code; +;; thus, under Windows, ACL-COMPAT should probably push MSWINDOWS +;; onto the *features* list when it detects the presence of WIN32 +;; under Lispworks. +#+WIN32 (eval-when (:compile-toplevel :load-toplevel :execute) + (pushnew :mswindows *features*)) Added: branches/trunk-reorg/thirdparty/acl-compat/lw-buffering.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/acl-compat/lw-buffering.lisp Thu Feb 7 03:21:48 2008 @@ -0,0 +1,261 @@ +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; LW Style Buffer Protocol for other Lisps ;;; +;;; So far only 8bit byte and character IO works ;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(in-package :gray-stream) + +(defvar *default-input-buffer-size* 8192) +(defvar *default-output-buffer-size* 8192) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (defstruct buffer-state + (input-buffer (make-array *default-input-buffer-size* :element-type '(unsigned-byte 8)) :type (simple-array (unsigned-byte 8) (*))) + (input-index nil) + (input-limit *default-input-buffer-size* :type fixnum) + (output-buffer (make-array *default-output-buffer-size* :element-type '(unsigned-byte 8)) :type (simple-array (unsigned-byte 8) (*))) + (output-index 0) + (output-limit *default-output-buffer-size* :type fixnum))) + +;; Can be used to implement resourcing of buffers later +(defun %allocate-buffer-state (&optional (input-limit *default-input-buffer-size*) (output-limit *default-output-buffer-size*)) + (declare (ignore input-limit output-limit)) + (make-buffer-state)) + +(defun %deallocate-buffer-state (state) + (declare (ignore state))) + +;; Can be used to implement unbuffered encapsulating streams later +(defclass native-lisp-stream-mixin () + ((lisp-stream :initarg :lisp-stream + :reader native-lisp-stream)) + (:documentation "Stream mixin that encapsulates a native stream.")) + +(defclass buffered-stream-mixin (native-lisp-stream-mixin) + ((buffer-state :initform (%allocate-buffer-state))) + (:documentation "Stream mixin that provides buffering for a native lisp stream.")) + +;; fundamental-bivalent-xxx-streams can be used to implement buffered +;; and unbuffered bivalent streams. At the moment, we only implement +;; buffered ones. +(defclass fundamental-bivalent-input-stream + (fundamental-character-input-stream fundamental-binary-input-stream) + ()) + +(defclass fundamental-bivalent-output-stream + (fundamental-character-output-stream fundamental-binary-output-stream) + ()) + +(defclass buffered-bivalent-input-stream + (buffered-stream-mixin fundamental-bivalent-input-stream) + ()) + +(defclass buffered-bivalent-output-stream + (buffered-stream-mixin fundamental-bivalent-output-stream) + ()) + +(defclass buffered-bivalent-stream + (buffered-bivalent-input-stream buffered-bivalent-output-stream) + ()) + +(defmacro with-stream-output-buffer ((buffer index limit) stream &body forms) + (let ((state (gensym "BUFFER-STATE-"))) + `(let ((,state (slot-value ,stream 'buffer-state))) + (symbol-macrolet ((,buffer ,(list 'buffer-state-output-buffer state)) + (,index ,(list 'buffer-state-output-index state)) + (,limit ,(list 'buffer-state-output-limit state))) + ,@forms)))) + +;;; Encapsulated native streams + +(defmethod close ((stream native-lisp-stream-mixin) &key abort) + (close (native-lisp-stream stream) :abort abort)) + +(defmethod stream-listen ((stream native-lisp-stream-mixin)) + (listen (native-lisp-stream stream))) + +(defmethod open-stream-p ((stream native-lisp-stream-mixin)) + (common-lisp::open-stream-p (native-lisp-stream stream))) + +(defmethod stream-clear-output ((stream native-lisp-stream-mixin)) + (clear-output (native-lisp-stream stream))) + +;;; Input streams + +(declaim (inline %reader-function-for-sequence)) +(defun %reader-function-for-sequence (sequence) + (typecase sequence + (string #'read-char) + ((array unsigned-byte (*)) #'read-byte) + ((array signed-byte (*)) #'read-byte) + (otherwise #'read-byte))) + +(defun read-elements (socket-stream sequence start end reader-fn) + (let* ((len (length sequence)) + (chars (- (min (or end len) len) start))) + (loop for i upfrom start + repeat chars + for char = (funcall reader-fn socket-stream) + if (eq char :eof) do (return-from read-elements i) + do (setf (elt sequence i) char)) + (+ start chars))) + +(defmacro with-stream-input-buffer ((buffer index limit) stream &body forms) + (let ((state (gensym "BUFFER-STATE-"))) + `(let ((,state (slot-value ,stream 'buffer-state))) + (symbol-macrolet ((,buffer ,(list 'buffer-state-input-buffer state)) + (,index ,(list 'buffer-state-input-index state)) + (,limit ,(list 'buffer-state-input-limit state))) + ,@forms)))) + +(defgeneric stream-fill-buffer (stream)) +(defmethod stream-fill-buffer ((stream buffered-stream-mixin)) + ;; Implement b/nb semantics: block until at least one byte is read, + ;; but not until the whole buffer is filled. This means it takes at + ;; most n calls to this function to fill a buffer of length n, even + ;; with a slow connection. + (with-stream-input-buffer (buffer index limit) stream + (let* ((the-stream (native-lisp-stream stream)) + (read-bytes + (loop with byte + for n-read from 0 below limit + while (and (if (< 0 n-read) (listen the-stream) t) + (setf byte (read-byte the-stream nil nil))) + do (setf (aref buffer n-read) byte) + count t))) + (if (zerop read-bytes) + nil + (setf index 0 + limit read-bytes))))) + +(defmethod stream-read-byte ((stream buffered-bivalent-input-stream)) + (with-stream-input-buffer (buffer index limit) stream + (unless (and index (< index limit)) + (when (null (stream-fill-buffer stream)) + (return-from stream-read-byte :eof))) + (prog1 (aref buffer index) + (incf index)))) + +(defmethod stream-read-char ((stream buffered-bivalent-input-stream)) + (let ((byte (stream-read-byte stream))) + (if (eq byte :eof) + :eof + (code-char byte)))) + +(defmethod stream-read-char-no-hang ((stream buffered-bivalent-input-stream)) + (if (listen stream) + (read-char stream) + nil)) + +(defmethod stream-unread-char ((stream buffered-bivalent-input-stream) character) + (with-stream-input-buffer (buffer index limit) stream + (let ((new-index (1- index))) + (when (minusp new-index) + (error "Cannot unread char ~A" character)) + (setf (aref buffer new-index) (char-code character) + index new-index))) + nil) + +(defmethod stream-peek-char ((stream buffered-bivalent-input-stream)) + (let ((char (stream-read-char stream))) + (unless (eq char :eof) + (stream-unread-char stream char)) + char)) + + +(defmethod stream-read-line ((stream buffered-bivalent-input-stream)) + (let ((res (make-array 80 :element-type 'character :fill-pointer 0))) + (loop + (let ((ch (stream-read-char stream))) + (cond ((eq ch :eof) + (return (values (copy-seq res) t))) + ((char= ch #\Linefeed) + (return (values (copy-seq res) nil))) + (t + (vector-push-extend ch res))))))) + + +(defmethod stream-read-sequence ((stream buffered-bivalent-input-stream) sequence &optional start end) + (read-elements stream sequence start end (%reader-function-for-sequence sequence))) + +;;(defmethod stream-clear-input ((stream buffered-bivalent-input-stream)) +;; (clear-input (native-lisp-stream stream))) + +(defmethod stream-element-type ((stream fundamental-bivalent-input-stream)) + '(or character (unsigned-byte 8))) + +;;; Output streams + +(declaim (inline %writer-function-for-sequence)) +(defun %writer-function-for-sequence (sequence) + (typecase sequence + (string #'stream-write-char) + ((array unsigned-byte (*)) #'stream-write-byte) + ((array signed-byte (*)) #'stream-write-byte) + (otherwise #'stream-write-byte))) + +(defun write-elements (stream sequence start end writer-fn) + (let* ((len (length sequence)) + (start (or start 0)) + (end (or end len))) + (assert (<= 0 start end len)) + (etypecase sequence + (simple-vector (loop for i from start below end + do (funcall writer-fn stream (svref sequence i)))) + (vector (loop for i from start below end + do (funcall writer-fn stream (aref sequence i)))) + (list (loop for i from start below end + for c in (nthcdr start sequence) + do (funcall writer-fn stream c)))))) + +(defgeneric stream-write-buffer (stream buffer start end)) +(defmethod stream-write-buffer ((stream buffered-stream-mixin) buffer start end) + (let ((lisp-stream (native-lisp-stream stream))) + (write-sequence buffer lisp-stream :start start :end end))) + +(defgeneric stream-flush-buffer (stream)) +(defmethod stream-flush-buffer ((stream buffered-stream-mixin)) + (with-stream-output-buffer (buffer index limit) stream + (when (plusp index) + (stream-write-buffer stream buffer 0 index) + (setf index 0)))) + +(defmethod stream-write-byte ((stream buffered-bivalent-output-stream) byte) + (with-stream-output-buffer (buffer index limit) stream + (unless (< index limit) + (stream-flush-buffer stream)) + (setf (aref buffer index) byte) + (incf index))) + +(defmethod stream-write-char ((stream buffered-bivalent-output-stream) character) + (stream-write-byte stream (char-code character))) + +(defmethod stream-write-string ((stream buffered-bivalent-output-stream) string &optional (start 0) end) + (write-elements stream string start end #'stream-write-char)) + +(defmethod stream-write-sequence ((stream buffered-stream-mixin) sequence + &optional (start 0) end) + (write-elements stream sequence start end (%writer-function-for-sequence sequence))) + +(defmethod stream-element-type ((stream fundamental-bivalent-output-stream)) + '(or character (unsigned-byte 8))) + +(defmethod stream-line-column ((stream fundamental-bivalent-output-stream)) + nil) + +(defmethod stream-finish-output ((stream buffered-bivalent-output-stream)) + (stream-flush-buffer stream) + (finish-output (native-lisp-stream stream))) + +(defmethod stream-force-output ((stream buffered-bivalent-output-stream)) + (stream-flush-buffer stream) + (force-output (native-lisp-stream stream))) + +(defmethod stream-clear-output ((stream buffered-bivalent-output-stream)) + (with-stream-output-buffer (buffer index limit) stream + (setf index 0 + limit 0)) + (call-next-method) ; Clear native stream also + ) + + Added: branches/trunk-reorg/thirdparty/acl-compat/mcl/acl-excl.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/acl-compat/mcl/acl-excl.lisp Thu Feb 7 03:21:48 2008 @@ -0,0 +1,168 @@ +;;;; +;;;; ACL-COMPAT - EXCL +;;;; + +;;;; Implementation-specific parts of acl-compat.excl (see +;;;; acl-excl-common.lisp) + +(in-package :acl-compat.excl) + +;#-openmcl +;(defun fixnump (x) +; (ccl::fixnump x)) + +#-openmcl +(import 'ccl::fixnump) + +#+openmcl +(defun filesys-inode (path) + (or (nth-value 4 (ccl::%stat (ccl::native-translated-namestring path))) + (error "path ~s does not exist" path))) + +(defun cl-internal-real-time () + (round (/ (get-internal-real-time) 1000))) + +(defun stream-input-fn (stream) + stream) + +(defun filesys-type (file-or-directory-name) + (if (ccl:directory-pathname-p file-or-directory-name) + :directory + (if (probe-file file-or-directory-name) + :file + nil))) + +(defmacro atomically (&body forms) + `(ccl:without-interrupts ,@forms)) + +(defmacro without-package-locks (&body forms) + `(progn ,@forms)) + +(define-condition stream-error (error) + ((stream :initarg :stream + :reader stream-error-stream) + (action :initarg :action + :initform nil + :reader stream-error-action) + (code :initarg :code + :initform nil + :reader stream-error-code) + (identifier :initarg :identifier + :initform nil + :reader stream-error-identifier)) + (:report (lambda (condition stream) + (format stream "A stream error occured (action=~A identifier=~A code=~A stream=~S)." + (stream-error-action condition) + (stream-error-identifier condition) + (stream-error-code condition) + (stream-error-stream condition))))) + +(define-condition socket-error (stream-error) + () + (:report (lambda (condition stream) + (format stream "A socket error occured (action=~A identifier=~A code=~A stream=~S)." + (stream-error-action condition) + (stream-error-identifier condition) + (stream-error-code condition) + (stream-error-stream condition))))) + + + +;! Need to figure out what to do here +(defun fasl-read (filename) + (declare (ignore filename)) + (error "fasl-read not implemented for MCL.") ) + +(defun fasl-write (data stream opt) + (declare (ignore data stream opt)) + (error "fasl-write not implemented for MCL.") ) + + +(defmacro schedule-finalization (object function) + `(ccl:terminate-when-unreachable ,object ,function)) + +(defun run-shell-command (program + &key input output error-output separate-streams + if-input-does-not-exist if-output-exists + if-error-output-exists wait environment show-window) + (declare (ignore show-window)) + ;; KLUDGE: split borrowed from asdf, this shouldn't be done -- it + ;; would be better to use split-sequence or define one ourselves ... + ;; TODO: On Unix, acl also handles a vector of simple-strings as + ;; value for program, with different semantics. + (let* ((program-and-arguments + (delete "" (asdf::split program) :test #'string=)) + (program (car program-and-arguments)) + (arguments (cdr program-and-arguments))) + (when environment + #-unix (error "Don't know how to run program in an environment.") + (setf arguments (append + (list "-i") + (loop for (name . value) in environment + collecting (concatenate 'string name "=" value)) + (list program) + arguments)) + (setf program "env")) + + (let* ((process (run-program program arguments + :input input + :if-input-does-not-exist + if-input-does-not-exist + :output output + :if-output-exists if-output-exists + :error error-output + :if-error-exists if-error-output-exists + :wait wait)) + (in-stream (external-process-input-stream process)) + (out-stream (external-process-output-stream process)) + (err-stream (external-process-error-stream process)) + (pid (external-process-id process))) + (cond + ;; one value: exit status + (wait (nth-value 1 (external-process-status process))) + ;; four values: i/o/e stream, pid + (separate-streams + (values (if (eql input :stream) in-stream nil) + (if (eql output :stream) out-stream nil) + (if (eql error-output :stream) err-stream nil) + pid)) + ;; three values: normal stream, error stream, pid + (t (let ((normal-stream + (cond ((and (eql input :stream) (eql output :stream)) + (make-two-way-stream in-stream out-stream)) + ((eql input :stream) in-stream) + ((eql output :stream) out-stream) + (t nil))) + (error-stream (if (eql error-output :stream) err-stream nil))) + (values normal-stream error-stream pid))))))) + +(defun string-to-octets (string &key (null-terminate t) (start 0) + end mb-vector make-mb-vector? + (external-format :default)) + "This function returns a lisp-usb8-vector and the number of bytes copied." + (declare (ignore external-format)) + ;; The end parameter is different in ACL's lambda list, but this + ;; variant lets us give an argument :end nil explicitly, and the + ;; right thing will happen + (unless end (setf end (length string))) + (let* ((number-of-octets (if null-terminate (1+ (- end start)) + (- end start))) + (mb-vector (cond + ((and mb-vector (>= (length mb-vector) number-of-octets)) + mb-vector) + ((or (not mb-vector) make-mb-vector?) + (make-array (list number-of-octets) + :element-type '(unsigned-byte 8) + :initial-element 0)) + (t (error "Was given a vector of length ~A, ~ + but needed at least length ~A." + (length mb-vector) number-of-octets))))) + (declare (type (simple-array (unsigned-byte 8) (*)) mb-vector)) + (loop for from-index from start below end + for to-index upfrom 0 + do (progn + (setf (aref mb-vector to-index) + (char-code (aref string from-index))))) + (when null-terminate + (setf (aref mb-vector (1- number-of-octets)) 0)) + (values mb-vector number-of-octets))) Added: branches/trunk-reorg/thirdparty/acl-compat/mcl/acl-mp.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/acl-compat/mcl/acl-mp.lisp Thu Feb 7 03:21:48 2008 @@ -0,0 +1,183 @@ +;;; This file implements the process functions for AllegroServe in MCL. +;;; Based on the the work done for cmucl and Lispworks. +;;; +;;; John DeSoi, Ph.D. desoi@users.sourceforge.net + + +(in-package :acl-compat.mp) + +(eval-when (:compile-toplevel :load-toplevel :execute) + +; existing stuff from ccl we can reuse directly +(shadowing-import + '(ccl:*current-process* + ccl::lock + ccl:process-allow-schedule + ccl:process-name + ccl:process-preset + #-openmcl-native-threads ccl:process-run-reasons + ccl:process-wait + ccl:process-wait-with-timeout + ccl:without-interrupts)) +) + +(eval-when (:compile-toplevel :load-toplevel :execute) + +(export + '(*current-process* + lock + process-allow-schedule + process-name + process-preset + process-run-reasons + process-wait + process-wait-with-timeout + without-interrupts)) +) + +(eval-when (:compile-toplevel :load-toplevel :execute) + +(defmacro without-scheduling (&body forms) + `(ccl:without-interrupts ,@forms)) + +#| +; more ideas stolen from acl-mp-lw.lisp +(defun invoke-with-timeout (seconds bodyfn timeoutfn) + (block timeout + (let* ((process *current-process*) + (timer (ccl:process-run-function "with-timeout-timer" + #'(lambda () + (sleep seconds) + (ccl:process-interrupt process + #'(lambda () + (return-from timeout + (funcall timeoutfn)))))))) + (unwind-protect (funcall bodyfn) + (ccl:process-kill timer))))) + +|# + + + +(defun invoke-with-timeout (seconds bodyfn timeoutfn) + (block timeout + (let* ((timer (ccl::make-timer-request + seconds + #'(lambda () (return-from timeout (funcall timeoutfn)))))) + (ccl::enqueue-timer-request timer) + (unwind-protect (funcall bodyfn) + (ccl::dequeue-timer-request timer))))) + + +(defmacro with-timeout ((seconds &body timeout-forms) &body body) + "Execute BODY; if execution takes more than SECONDS seconds, terminate and evaluate TIMEOUT-FORMS." + `(invoke-with-timeout ,seconds #'(lambda () ,@body) + #'(lambda () ,@timeout-forms))) + + +#+openmcl-native-threads +(progn + +;;; The :INITIAL-BINDINGS arg to process creation functions seems to be +;;; quoted, even when it appears in a list (as in the case of +;;; (process-run-function <args>)) By the time that percolates down +;;; to OpenMCL's process creation functions, it should lose the quote. +;;; +;;; Perhaps I imagined that ... +;;; + +(defun ccl::openmcl-fix-initial-bindings (initial-bindings) + (if (and (consp initial-bindings) + (eq (car initial-bindings) 'quote)) + (cadr initial-bindings) + initial-bindings)) + +) + + +#-openmcl-native-threads +(defmacro process-revoke-run-reason (process reason) + `(ccl:process-disable-run-reason ,process ,reason) ) + +#-openmcl-native-threads +(defmacro process-add-run-reason (process reason) + `(ccl:process-enable-run-reason ,process ,reason) ) + + +(defmacro make-process-lock (&key name) + (if name + `(ccl:make-lock ,name) + `(ccl:make-lock))) + +(defmacro with-process-lock ((lock &key norecursive timeout whostate) &body forms) + (declare (ignore norecursive whostate timeout)) + `(ccl:with-lock-grabbed (,lock) ,@forms)) + + +(defmacro process-kill (process) + `(progn + #-openmcl-native-threads + (unless (ccl:process-active-p ,process) ;won't die unless enabled + (ccl:process-reset-and-enable ,process) ) + (ccl:process-kill ,process))) +) + +(defun process-active-p (process) + (ccl::process-active-p process)) + +(defun interrupt-process (process function &rest args) + "Run FUNCTION in PROCESS." +(apply #'ccl:process-interrupt process function args)) + +(defun current-process () + "The current process." + ccl:*current-process*) + + +;property list implementation from acl-mp-cmu.lisp +(defvar *process-plists* (make-hash-table :test #'eq) + "maps processes to their plists. +See the functions process-plist, (setf process-plist).") + +(defun process-property-list (process) + (gethash process *process-plists*)) + +(defun (setf process-property-list) (new-value process) + (setf (gethash process *process-plists*) new-value)) + +; from acl-mp-lw.lisp +(defun make-process (&key (name "Anonymous") reset-action run-reasons arrest-reasons (priority 0) quantum + resume-hook suspend-hook initial-bindings run-immediately) + (declare (ignore priority quantum reset-action resume-hook suspend-hook run-immediately)) + #-openmcl-native-threads + (declare (ignore initial-bindings)) ;! need separate lexical bindings for each process? + #+openmcl-native-threads + (declare (ignore run-reasons arrest-reasons)) + ;(let ((acl-mp:*process-initial-bindings* initial-bindings)) + #-openmcl-native-threads + (ccl:make-process name :run-reasons run-reasons :arrest-reasons arrest-reasons) + #+openmcl-native-threads + (ccl:make-process name :initial-bindings (ccl::openmcl-fix-initial-bindings initial-bindings))) + +(defun process-run-function (name-or-options preset-function &rest preset-arguments) + (let ((process (ctypecase name-or-options + (string (acl-mp:make-process :name name-or-options)) + (list (apply #'acl-mp:make-process name-or-options))))) + (apply #'acl-mp:process-preset process preset-function preset-arguments) + #+openmcl-native-threads (ccl:process-enable process) + #-openmcl-native-threads (process-add-run-reason process :enable) + process)) + +;;; Busy-waiting ... +(defun wait-for-input-available (streams + &key (wait-function #'ccl:stream-listen) + whostate timeout) + (let ((collected-fds nil)) + (flet ((collect-fds () + (setf collected-fds + (remove-if-not wait-function streams)))) + + (if timeout + (process-wait-with-timeout (or whostate "Waiting for input") timeout #'collect-fds) + (process-wait (or whostate "Waiting for input") #'collect-fds))) + collected-fds)) Added: branches/trunk-reorg/thirdparty/acl-compat/mcl/acl-socket-mcl.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/acl-compat/mcl/acl-socket-mcl.lisp Thu Feb 7 03:21:48 2008 @@ -0,0 +1,268 @@ +;;; MCL layer for ACL sockets. +;;; Based on acl-socket-cmu.lisp and acl-socket-lw.lisp. +;;; +;;; John DeSoi, Ph.D. desoi@users.sourceforge.net + + +(defpackage :acl-compat.socket + (:nicknames :socket :acl-socket) + (:use :common-lisp) + (:export #:make-socket + #:accept-connection + #:ipaddr-to-dotted + #:dotted-to-ipaddr + #:ipaddr-to-hostname + #:lookup-hostname + #:remote-host + #:remote-port + #:local-host + #:local-port + #:socket-control + )) + +(in-package :socket) + +(eval-when (:compile-toplevel :load-toplevel :execute) + +(require :opentransport) + +;OpenTransport.lisp does not export anything, so do this to make it look a bit cleaner. +(import '(ccl::open-tcp-stream + ccl::opentransport-tcp-stream + ccl::opentransport-binary-tcp-stream + ccl::stream-local-port + ccl::stream-local-host + ccl::stream-local-port + ccl::stream-remote-host + ccl::stream-remote-port + ccl::inet-host-name + ccl::tcp-host-address + ) ) + +(defmacro connection-state (s) + `(ccl::opentransport-stream-connection-state ,s)) + +(defmacro connection-established (s) + `(eq :dataxfer (connection-state ,s)) ) + +) + + +;;; There is a bug in MCL (4.3.1 tested) where read-sequence and +;;; write-sequence fail with binary tcp streams. These two methods +;;; provide a work-around. +#-carbon-compat ;should be fixed starting with first carbon version (4.3.5) +(defmethod ccl:stream-write-sequence ((s opentransport-binary-tcp-stream) + (sequence ccl::simple-unsigned-byte-vector) + &key (start 0) end) + (ccl::stream-write-vector s sequence start (or end (length sequence))) + s) + + + +#-carbon-compat ;should be fixed starting with first carbon version (4.3.5) +(defmethod ccl:stream-read-sequence ((s opentransport-binary-tcp-stream) + (sequence ccl::simple-unsigned-byte-vector) + &key (start 0) (end (length sequence))) + (ccl::stream-read-bytes-to-vector s sequence (- end start) start) + end) + + + +(defmethod port ((stream opentransport-tcp-stream)) + (stream-local-port stream) ) + +(defmethod local-host ((s opentransport-tcp-stream)) + (stream-local-host s)) + +(defmethod local-port ((s opentransport-tcp-stream)) + (stream-local-port s)) + +(defmethod remote-host ((s opentransport-tcp-stream)) + (stream-remote-host s)) + +(defmethod remote-port ((s opentransport-tcp-stream)) + (stream-remote-port s)) + +;? copied from lispworks - don't think it applies to mcl +(defmethod fd ((s opentransport-tcp-stream)) + (declare (ignore s)) + 42) + + + +(defvar *passive-socket-listener-count* 10 + "Default number of listen streams to use.") + +; With ACL, an unlimited number of connections can be made to the same passive +; socket instance. Nothing like that here, so we have to create our own stream +; listener to create the "real" sockets as connections are made. + + +; Create a class to monitor streams so we have a data structure to pass to process-wait +(defclass passive-socket (stream) ;inherit stream so we can handle close + ((port + :documentation "Port we are listening on." + :initform 80 + :initarg :port + :reader local-port) + (element-type + :documentation "Stream element type." + :initarg :element-type + :initform '(unsigned-byte 8)) + (count + :documentation "Number of listening streams to monitor." + :initform *passive-socket-listener-count*) + (streams + :documentation "Array of listen streams." + :initform nil) + (index + :documentation "Index of the last listen stream checked." + :initform *passive-socket-listener-count*) + (connect-index + :documentation "Index of a connected stream, next for processing." + :initform nil) + ) + (:documentation "Class used to manage listening streams and connections.") ) + + + +(defmethod initialize-instance :after ((listener passive-socket) &rest initargs) + (declare (ignore initargs)) + (with-slots (streams count port element-type) listener + (setf streams (make-array count :initial-element nil :adjustable t)) + (dotimes (i count) + (setf (elt streams i) (new-listen-stream listener)) ) ) ) + + +(defmethod ccl:stream-close ((listener passive-socket)) + (with-slots (streams count) listener + (dotimes (i count) + (close (elt streams i))) + (setf count 0))) + + +(defmethod new-listen-stream ((listener passive-socket)) + (with-slots (port element-type) listener + (open-tcp-stream nil port ;use nil host to get a passive connection + :element-type element-type) ) ) + + +(defmethod local-host ((listener passive-socket)) + (with-slots (streams count) listener + (when (> count 0) + (local-host (elt streams 0))))) + + + +; See if one of the streams is established. +(defmethod find-connection-index ((listener passive-socket)) + (with-slots (count streams index connect-index) listener + (let ((next (if (< (1+ index) count) (1+ index) 0))) + (when (connection-established (elt streams next)) + (setf index next + connect-index next) + connect-index)))) + + +(defmethod process-connected-stream ((listener passive-socket)) + (with-slots (streams connect-index) listener + (if (null connect-index) nil + (let ((s (elt streams connect-index))) ;return the connected stream and set a new one + (setf (elt streams connect-index) (new-listen-stream listener)) + (setf connect-index nil) + s) ) ) ) + + +;! future - determine how many connects we are getting an dynamically increase the number +; of listeners if necessary. +(defmethod accept-connection ((listener passive-socket) &key (wait t)) + (if wait + (ccl:process-wait "accept connection..." #'find-connection-index listener) ;apply repeatedly with process wait + (find-connection-index listener) ) + (process-connected-stream listener) ) + + +(defun make-socket (&key (remote-host "localhost") + local-port + remote-port + (connect :active) + (format :text) + &allow-other-keys) + (let ((element-type (ecase format + (:text 'base-char) + (:binary 'signed-byte) + (:bivalent 'unsigned-byte)))) + (ecase connect + (:passive + (make-instance 'passive-socket :port local-port :element-type element-type :direction :io)) + (:active + (let ((host (if (integerp remote-host) ;aparently the acl version also accepts an integer + (ipaddr-to-dotted remote-host) + remote-host))) + (check-type host string) + (open-tcp-stream host remote-port + :element-type element-type)))))) + + + +(declaim (ftype (function ((unsigned-byte 32)) (values simple-string)) + ipaddr-to-dotted)) + +(defun ipaddr-to-dotted (ipaddr &key values) + (declare (type (unsigned-byte 32) ipaddr)) + (let ((a (logand #xff (ash ipaddr -24))) + (b (logand #xff (ash ipaddr -16))) + (c (logand #xff (ash ipaddr -8))) + (d (logand #xff ipaddr))) + (if values + (values a b c d) + (format nil "~d.~d.~d.~d" a b c d)))) + +(defun string-tokens (string) + (labels ((get-token (str pos1 acc) + (let ((pos2 (position #\Space str :start pos1))) + (if (not pos2) + (nreverse acc) + (get-token str (1+ pos2) (cons (read-from-string (subseq str pos1 pos2)) + acc)))))) + (get-token (concatenate 'string string " ") 0 nil))) + +(declaim (ftype (function (string &key (:errorp t)) + (values (unsigned-byte 32))) + dotted-to-ipaddr)) + +(defun dotted-to-ipaddr (dotted &key (errorp t)) + (declare (string dotted)) + (if errorp + (let ((ll (string-tokens (substitute #\Space #\. dotted)))) + (+ (ash (first ll) 24) (ash (second ll) 16) + (ash (third ll) 8) (fourth ll))) + (ignore-errors + (let ((ll (string-tokens (substitute #\Space #\. dotted)))) + (+ (ash (first ll) 24) (ash (second ll) 16) + (ash (third ll) 8) (fourth ll)))))) + +(defun ipaddr-to-hostname (ipaddr &key ignore-cache) + (declare (ignore ignore-cache)) + (inet-host-name ipaddr) ) + +(defun lookup-hostname (host &key ignore-cache) + (when ignore-cache + (warn ":IGNORE-CACHE keyword in LOOKUP-HOSTNAME not supported.")) + (if (stringp host) + (tcp-host-address host) + (dotted-to-ipaddr (ipaddr-to-dotted host)))) + + +(defun socket-control (stream &key output-chunking output-chunking-eof input-chunking) + (declare (ignore stream)) + (warn "SOCKET-CONTROL function not implemented.") + (when (or output-chunking output-chunking-eof input-chunking) + (error "Chunking is not yet supported in MCL. Restart the server with argument :chunking nil (turns chunking off).") ) ) + + +(provide 'acl-socket) + + + Added: branches/trunk-reorg/thirdparty/acl-compat/mcl/acl-socket-openmcl.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/acl-compat/mcl/acl-socket-openmcl.lisp Thu Feb 7 03:21:48 2008 @@ -0,0 +1,145 @@ +;;; OpenMCL layer for ACL sockets. +;;; Most everything is already there, just needs to be in the socket package. +;;; +;;; John DeSoi, Ph.D. desoi@users.sourceforget.net + +(in-package :acl-compat.socket) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (shadowing-import + '(;ccl:make-socket ; use our own version + ccl:accept-connection + ccl:dotted-to-ipaddr + ccl:ipaddr-to-hostname + ccl:lookup-hostname + ccl:remote-host + ccl:remote-port + ccl:local-host + ccl:local-port)) +) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (export + '(accept-connection + ipaddr-to-dotted + dotted-to-ipaddr + ipaddr-to-hostname + lookup-hostname + remote-host + remote-port + local-host + local-port + socket-control)) + ) + + +(defclass server-socket () + ((socket :initarg :socket :reader socket + :initform (error "No value supplied for socket")) + (port :initarg :port + :reader port + :initform (error "No value supplied for port")))) + + +(defmethod print-object ((socket server-socket) stream) + (print-unreadable-object (socket stream :type t :identity nil) + (format stream "listening on port ~d" (port socket)))) + + +(defmethod accept-connection ((server-socket server-socket) + &key (wait t)) + "Return a bidirectional stream connected to socket." + (let ((stream (accept-connection (socket server-socket) :wait wait))) + (when stream (make-chunked-stream stream)))) + + +(defun make-socket (&rest args + &key (connect :active) port + &allow-other-keys) + "Return a stream connected to remote-host if connect is :active, or +something listening on local-port that can be fed to accept-connection +if connect is :passive. +" + (let ((socket-or-stream (apply #'ccl:make-socket args))) + (if (eq connect :active) + (make-chunked-stream socket-or-stream) + (make-instance 'server-socket :socket socket-or-stream :port port)))) + + +(defmethod close ((server-socket server-socket) &key abort) + "Kill a passive (listening) socket. (Active sockets are actually +streams and handled by their close methods." + (declare (ignore abort)) + (close (socket server-socket))) + +(defmethod local-host ((server-socket server-socket)) + (local-host (socket server-socket))) + +(defmethod local-port ((server-socket server-socket)) + (local-port (socket server-socket))) + +(defmethod ccl:stream-write-vector + ((stream gray-stream::buffered-bivalent-stream) vector start end) + (declare (fixnum start end)) + (let ((fn (gray-stream::%writer-function-for-sequence vector))) + (do* ((i start (1+ i))) + ((= i end)) + (declare (fixnum i)) + (funcall fn stream (ccl:uvref vector i))))) + +(defmethod ccl:stream-read-vector + ((stream gray-stream::buffered-bivalent-stream) vector start end) + (declare (fixnum start end)) + (let ((fn (gray-stream::%reader-function-for-sequence vector))) + (do* ((i start (1+ i))) + ((= i end) end) + (declare (fixnum i)) + (let* ((b (funcall fn stream))) + (if (eq b :eof) + (return i) + (setf (ccl:uvref vector i) b)))))) + +(defclass chunked-stream (de.dataheaven.chunked-stream-mixin::chunked-stream-mixin + gray-stream::buffered-bivalent-stream) + ((plist :initarg :plist :accessor stream-plist))) + +(defun make-chunked-stream (lisp-stream &key plist) + (make-instance 'chunked-stream :lisp-stream lisp-stream :plist plist)) + +(defmethod local-host ((chunked-stream chunked-stream)) + (local-host (gray-stream::native-lisp-stream chunked-stream))) + +(defmethod local-port ((chunked-stream chunked-stream)) + (local-port (gray-stream::native-lisp-stream chunked-stream))) + +(defmethod remote-host ((chunked-stream chunked-stream)) + (remote-host (gray-stream::native-lisp-stream chunked-stream))) + +(defmethod remote-port ((chunked-stream chunked-stream)) + (remote-port (gray-stream::native-lisp-stream chunked-stream))) + + +(defun socket-control (stream &key (output-chunking nil oc-p) output-chunking-eof (input-chunking nil ic-p)) + (when oc-p + (when output-chunking + (de.dataheaven.chunked-stream-mixin::initialize-output-chunking stream)) + (setf (de.dataheaven.chunked-stream-mixin::output-chunking-p stream) + output-chunking)) + (when output-chunking-eof + (de.dataheaven.chunked-stream-mixin::disable-output-chunking stream)) + (when ic-p + (when input-chunking + (de.dataheaven.chunked-stream-mixin::initialize-input-chunking stream)) + (setf (de.dataheaven.chunked-stream-mixin::input-chunking-p stream) + input-chunking))) + +; OpenMCL has a built-in ipaddr-to-dotted. But it appears that sometimes +; the log function is being called after the connection is closed and +; it causes nil to be passed to ipaddr-to-dotted. So we wrap ipaddr-to-dotten +; to ensure only non-nil values are passed. + +(defun ipaddr-to-dotted (ipaddr &key values) + (unless (null ipaddr) + (ccl:ipaddr-to-dotted ipaddr :values values))) + +(provide 'acl-socket) Added: branches/trunk-reorg/thirdparty/acl-compat/mcl/acl-sys.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/acl-compat/mcl/acl-sys.lisp Thu Feb 7 03:21:48 2008 @@ -0,0 +1,20 @@ + +(in-package :acl-compat.system) + + +(defun command-line-arguments () + #+openmcl (ccl::command-line-arguments) + #-openmcl nil) + +(defun command-line-argument (n) + #+openmcl (nth n (command-line-arguments)) + #-openmcl nil) + +;;; On acl, reap-os-subprocess is needed for (run-shell-command ... +;;; :wait nil), but not on OpenMCL. +(defun reap-os-subprocess (&key (wait nil)) + (declare (ignore wait)) + nil) + +#+nil +(export '(command-line-arguments command-line-argument reap-os-subprocess)) Added: branches/trunk-reorg/thirdparty/acl-compat/mcl/mcl-stream-fix.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/acl-compat/mcl/mcl-stream-fix.lisp Thu Feb 7 03:21:48 2008 @@ -0,0 +1,44 @@ + + +(in-package :ccl) + +;;; There are several bugs in MCL functions to read sequences prior to 4.3.5; this fixes them + + + +(eval-when (:compile-toplevel :load-toplevel :execute) + +(let ((ccl:*warn-if-redefine* nil)) + +(defun %io-buffer-read-bytes-to-vector (io-buffer vector bytes start) + (loop with fill-pointer = start + with bytes-remaining = bytes + until (eql 0 bytes-remaining) + while (if (eql 0 (io-buffer-incount io-buffer)) + (%io-buffer-advance io-buffer t t) ; eof may be signalled through this -- JCMa 5/13/1999. + t) + for buffer = (io-buffer-inptr io-buffer) + for read-bytes = (min (io-buffer-incount io-buffer) bytes-remaining) + do (%copy-ptr-to-ivector buffer 0 vector fill-pointer read-bytes) + (incf fill-pointer read-bytes) + (%incf-ptr (io-buffer-inptr io-buffer) read-bytes) ;; bug fix from akh on 7/28/2002 + (decf bytes-remaining read-bytes) + (decf (io-buffer-incount io-buffer) read-bytes) + (incf (io-buffer-bytes-read io-buffer) read-bytes))) + + +;This function is unchanged, but kept for completeness +(defun io-buffer-read-bytes-to-vector (io-buffer vector bytes &optional (start 0)) + (require-type io-buffer 'io-buffer) + (with-io-buffer-locked (io-buffer) + (multiple-value-bind (v v-offset) + (array-data-and-offset vector) + (%io-buffer-read-bytes-to-vector io-buffer v bytes (+ start v-offset))))) + + +(defmethod stream-read-bytes-to-vector ((stream buffered-output-stream-mixin) vector bytes &optional (start 0)) + (io-buffer-read-bytes-to-vector (stream-io-buffer stream) vector bytes start)) ;original fuction did not get the buffer from the stream + + +) +) \ No newline at end of file Added: branches/trunk-reorg/thirdparty/acl-compat/mcl/mcl-timers.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/acl-compat/mcl/mcl-timers.lisp Thu Feb 7 03:21:48 2008 @@ -0,0 +1,112 @@ +;;; mcl-timers contributed by Gary Byers + +(in-package "CCL") + + +;;; A simple timer mechanism for MCL/OpenMCL, which uses a +;;; PERIODIC-TASK to check for expired "timer requests". +;;; In MCL and OpenMCL, PERIODIC-TASKS run at specified +;;; intervals via the same preemption mechanism that the +;;; scheduler uses; they run in the execution context of +;;; whatever thread was preempted, and they're assumed to +;;; run pretty quickly. +;;; This code uses doubly-linked-list elements (DLL-NODEs) +;;; to represent a sorted list of "timer requests"; client +;;; processes use timer requests to schedule an interrupt +;;; action at a specified time. A periodic task walks this +;;; list once a second (by default), removing those requests +;;; whose time isn't in the future and interrupting the +;;; corresponding processes. + + +;;; The number of timer interrupts (ticks) per second. +(defmacro ticks-per-second () + #+OpenMCL '*ticks-per-second* + #-OpenMCL 60) + + +(defun expiration-tick-count (seconds) + (+ (round (* seconds (ticks-per-second))) + (get-tick-count))) + +(defstruct (timer-request (:include dll-node) + (:constructor %make-timer-request)) + expiration-tick ; when the timer expires + process ; what process to interrupt + function) ; how to interrupt it + + +(defun make-timer-request (seconds-from-now function) + (check-type seconds-from-now (and unsigned-byte fixnum)) + (check-type function function) + (%make-timer-request + :expiration-tick (expiration-tick-count seconds-from-now) + :process *current-process* + :function function)) + + +;;; the CCL::DEFLOADVAR construct ensures that the variable +;;; will be reinitialized when a saved image is restarted +(defloadvar *timer-request-queue* + #-openmcl-native-threads (make-dll-header) + #+openmcl-native-threads (make-locked-dll-header)) + +;;; Insert the timer request before the first element with a later +;;; expiration time (or at the end of the queue if there's no such +;;; element.) +(defun enqueue-timer-request (r) + (#-openmcl-native-threads without-interrupts + #+openmcl-native-threads with-locked-dll-header + #+openmcl-native-threads (*timer-request-queue*) + (if (dll-node-succ r) ; Already enqueued. + r ; Or signal an error. + (let* ((r-date (timer-request-expiration-tick r))) + (do* ((node *timer-request-queue* next) + (next (dll-node-succ node) (dll-node-succ next))) + ((or (eq next *timer-request-queue*) + (> (timer-request-expiration-tick next) r-date)) + (insert-dll-node-after r node))))))) + +;;; Remove a timer request. (It's a no-op if the request has already +;;; been removed.) +(defun dequeue-timer-request (r) + (#-openmcl-native-threads without-interrupts + #+openmcl-native-threads with-locked-dll-header + #+openmcl-native-threads (*timer-request-queue*) + (when (dll-node-succ r) ;enqueued + (remove-dll-node r)) + r)) + +;;; Since this runs in an arbitrary process, it tries to be a little +;;; careful with requests made by the current process (since running +;;; the interrupt function will probably transfer control out of the +;;; periodic task function.) The oldest (hopefully only) request for +;;; the current process is handled after all other pending requests. +(defun process-timer-requests () + (let* ((now (get-tick-count)) + (current-process *current-process*) + (current-process-action ())) + (#-openmcl-native-threads progn + #+openmcl-native-threads with-locked-dll-header + #+openmcl-native-threads (*timer-request-queue*) + + (do-dll-nodes (r *timer-request-queue*) + (when (> (timer-request-expiration-tick r) now) + (return)) ; Anything remaining is + ; in the future. + (dequeue-timer-request r) + (let* ((proc (timer-request-process r)) + (func (timer-request-function r))) + (if (eq proc current-process) + (if (null current-process-action) + (setq current-process-action func)) + (process-interrupt (timer-request-process r) + (timer-request-function r))))) + (when current-process-action + (funcall current-process-action))))) + +(%install-periodic-task + 'process-timer-requests ; Name of periodic task + 'process-timer-requests ; function to call + (ticks-per-second) ; Run once per second + ) Added: branches/trunk-reorg/thirdparty/acl-compat/packages.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/acl-compat/packages.lisp Thu Feb 7 03:21:48 2008 @@ -0,0 +1,272 @@ +;;;; -*- mode: lisp -*- +;;;; +;;;; Package definitions for acl-compat. +;;;; +;;;; Package names follow their Allegro CL counterparts -- for an ACL +;;;; package foo, acl-compat defines a package acl-compat.foo +;;;; +;;;; Some packages have nicknames, which were used as package names by +;;;; previous versions of paserve and acl-compat. The nicknames are +;;;; deprecated, but are kept for the benefit of people using +;;;; acl-compat in other projects. New projects should use the +;;;; package names starting with "acl-compat.". +;;;; + +(in-package :common-lisp-user) + +;;; general +(defpackage :acl-compat.excl + (:use #:common-lisp + #+cmu #:ext + #+clisp #:ext + #+sbcl #:sb-ext #+sbcl #:sb-gray + #+(or allegro cormanlisp) :excl + #+(or mcl openmcl) :ccl + ) + #+lispworks (:import-from :common-lisp #:fixnump) + #+sbcl (:import-from :sb-int #:fixnump) + #+sbcl (:import-from :sb-ext #:without-package-locks) + #+cmu (:import-from :ext #:without-package-locks) + #+allegro (:shadowing-import-from :excl #:filesys-size + #:filesys-write-date #:intern* #:filesys-type #:atomically #:fast) + (:export + #:if* + #:*initial-terminal-io* + #:*cl-default-special-bindings* + #:filesys-size + #:filesys-write-date + #:stream-input-fn + #:match-regexp + #:compile-regexp + #:*current-case-mode* + #:intern* + #:filesys-type + #:errorset + #:atomically + #:fast + #:without-package-locks + #:fixnump + #+(or lispworks mcl openmcl) #:socket-error + #+(or allegro lispworks mcl openmcl) #:run-shell-command + #+(or allegro mcl openmcl) #:fasl-read + #+(or allegro mcl openmcl) #:fasl-write + #+(or allegro cmu scl mcl lispworks openmcl) #:string-to-octets + #+(or allegro cmu scl mcl lispworks openmcl) #:write-vector + )) + + +;; general +(defpackage :acl-compat.mp + (:use :common-lisp #+cormanlisp :acl-compat-mp #+allegro :mp) + (:nicknames :acl-mp #-cormanlisp :acl-compat-mp) + #+allegro (:shadowing-import-from :mp #:process-interrupt #:lock) + #+allegro (:shadowing-import-from :excl #:without-interrupts) + (:export + #:*current-process* ;* + #:process-kill ;* + #:process-preset ;* + #:process-name ;* + + #:process-wait-function + #:process-run-reasons + #:process-arrest-reasons + #:process-whostate + #:without-interrupts + #:process-wait + #:process-enable + #:process-disable + #:process-reset + #:process-interrupt + + #:process-run-function ;* + #:process-property-list ;* + #:without-scheduling ;* + #:process-allow-schedule ;* + #:make-process ;* + #:process-add-run-reason ;* + #:process-revoke-run-reason ;* + #:process-add-arrest-reason ;* + #:process-revoke-arrest-reason ;* + #:process-allow-schedule ;* + #:with-timeout ;* + #:make-process-lock ;* + #:with-process-lock ;* + #:process-lock + #:process-unlock + + #:current-process + #:process-name-to-process + #:process-wait-with-timeout + #:wait-for-input-available + #:process-active-p + )) + +(defpackage :de.dataheaven.chunked-stream-mixin + (:use :common-lisp) + (:export #:chunked-stream-mixin + #:output-chunking-p #:input-chunking-p)) + +;; general +(defpackage acl-compat.socket + (:use #:common-lisp + #+(or cmu lispworks scl) #:acl-mp + #+(or lispworks cmu)#:acl-compat.excl + #+clisp #:socket + #+sbcl #:sb-bsd-sockets + #+(or lispworks cmu) #:de.dataheaven.chunked-stream-mixin + #+cormanlisp #:socket + ) + #+cl-ssl (:import-from :ssl #:MAKE-SSL-CLIENT-STREAM #:MAKE-SSL-SERVER-STREAM) + #+lispworks (:shadow socket-stream stream-error) + (:export + #+(or lispworks cmu) #:socket + #:make-socket + #:accept-connection + #:ipaddr-to-dotted + #:dotted-to-ipaddr + #:ipaddr-to-hostname + #:lookup-hostname + #:remote-host + #:remote-port + #:local-host + #:local-port + #:socket-control + #+cl-ssl #:make-ssl-client-stream + #+cl-ssl #:make-ssl-server-stream + #+(and :lispworks4.4 (not :cl-ssl)) #:make-ssl-client-stream + #+(and :lispworks4.4 (not :cl-ssl)) #:make-ssl-server-stream + #+lispworks #:socket-os-fd + ) + #-cormanlisp (:nicknames #-(or clisp allegro) socket #-allegro acl-socket)) + + +(defpackage acl-compat.system + (:nicknames :acl-compat.sys) + (:use :common-lisp) + (:export + #:command-line-arguments + #:command-line-argument + #:reap-os-subprocess + )) + + +; these are not all in the ccl package which causes an error +#+(and mcl (not openmcl)) +(shadowing-import '( + fundamental-binary-input-stream + fundamental-binary-output-stream + fundamental-character-input-stream + fundamental-character-output-stream + stream-element-type + stream-listen + stream-read-byte + stream-read-char + stream-peek-char + stream-write-byte + stream-write-char + stream-read-char-no-hang + stream-force-output + stream-finish-output + stream-clear-input + stream-clear-output + stream-line-column + stream-read-sequence + stream-unread-char + stream-read-line + stream-write-sequence + stream-write-string) + :ccl) + +#-cormanlisp +(defpackage :gray-stream + (:use #:common-lisp) + (:import-from #+lispworks :stream #+cmu :lisp #+clisp :gray #+cormanlisp :gray-streams + #+(or mcl openmcl) :ccl #+allegro :excl #+sbcl :sb-gray + #:fundamental-binary-input-stream + #:fundamental-binary-output-stream + #:fundamental-character-input-stream + #:fundamental-character-output-stream + #:stream-element-type + #:stream-listen + #:stream-read-byte + #:stream-read-char + #:stream-peek-char + #:stream-write-byte + #:stream-write-char + #:stream-read-char-no-hang + #:stream-force-output + #:stream-finish-output + #:stream-clear-input + #:stream-clear-output + #:stream-line-column + #-(or clisp openmcl) #:stream-read-sequence + #:stream-unread-char + #:stream-read-line + #-(or clisp openmcl) #:stream-write-sequence + #:stream-write-string + #+lispworks #:stream-write-buffer + #+lispworks #:stream-read-buffer + #+lispworks #:stream-fill-buffer + #+lispworks #:stream-flush-buffer + #+lispworks #:with-stream-input-buffer + #+lispworks #:with-stream-output-buffer) + (:export + #:fundamental-binary-input-stream + #:fundamental-binary-output-stream + #:fundamental-character-input-stream + #:fundamental-character-output-stream + #:stream-element-type + #:stream-listen + #:stream-read-byte + #:stream-read-char + #:stream-write-byte + #:stream-write-char + #:stream-read-char-no-hang + #:stream-force-output + #:stream-finish-output + #:stream-clear-input + #:stream-clear-output + #:stream-line-column + #-clisp #:stream-read-sequence + #:stream-unread-char + #:stream-read-line + #-clisp #:stream-write-sequence + #:stream-write-string + #:stream-write-buffer + #:stream-read-buffer + #:stream-fill-buffer + #:stream-flush-buffer + #:with-stream-input-buffer + #:with-stream-output-buffer)) + +#+cormanlisp +(defpackage :gray-stream + (:use #:common-lisp :gray-streams) + (:export + #:fundamental-binary-input-stream + #:fundamental-binary-output-stream + #:fundamental-character-input-stream + #:fundamental-character-output-stream + #:stream-element-type + #:stream-listen + #:stream-read-byte + #:stream-read-char + #:stream-write-byte + #:stream-write-char + #:stream-read-char-no-hang + #:stream-force-output + #:stream-finish-output + #:stream-clear-input + #:stream-clear-output + #:stream-line-column + #:stream-read-sequence + #:stream-unread-char + #:stream-read-line + #:stream-write-sequence + #:stream-write-string + #:stream-write-buffer + #:stream-read-buffer + #:stream-fill-buffer + #:stream-flush-buffer + #:with-stream-input-buffer + #:with-stream-output-buffer)) Added: branches/trunk-reorg/thirdparty/acl-compat/sbcl/acl-excl.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/acl-compat/sbcl/acl-excl.lisp Thu Feb 7 03:21:48 2008 @@ -0,0 +1,32 @@ +;;;; +;;;; ACL-COMPAT - EXCL +;;;; + +;;;; Implementation-specific parts of acl-compat.excl (see +;;;; acl-excl-common.lisp) + +(in-package :acl-compat.excl) + +(defun stream-input-fn (stream) + stream) + +(defun filesys-type (file-or-directory-name) + (let ((mode (sb-posix:stat-mode (sb-posix:stat file-or-directory-name)))) + (cond + ((sb-posix:s-isreg mode) :file) + ((sb-posix:s-isdir mode) :directory) + (t nil)))) + +(defmacro atomically (&body forms) + `(acl-mp:without-scheduling ,@forms)) + +(defun unix-signal (signal pid) + (declare (ignore signal pid)) + (error "unix-signal not implemented in acl-excl-sbcl.lisp")) + +(defun filesys-inode (path) + (sb-posix:stat-ino (sb-posix:lstat path))) + +(defun cl-internal-real-time () + (round (/ (get-internal-real-time) internal-time-units-per-second))) + Added: branches/trunk-reorg/thirdparty/acl-compat/sbcl/acl-mp.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/acl-compat/sbcl/acl-mp.lisp Thu Feb 7 03:21:48 2008 @@ -0,0 +1,294 @@ +;; Threading for sbcl, or stub functions for single-threaded sbcl. +;; +;; Written by Rudi Schlatte, intended to be distributed along with the +;; acl-compat library, under the same license as the rest of it. + +;; Inspirations taken from Dan Barlow<dan@metacircles.com>'s work for +;; McCLIM; cut, pasted and mutilated with permission. + +(in-package :acl-compat.mp) + +(defstruct (process + (:constructor %make-process) + (:predicate processp)) + name + state + whostate + function ; function wot will be run + arguments ; arguments to the function + id ; pid of unix thread or nil + %lock ; lock for process structure mutators + run-reasons ; primitive mailbox for IPC + %queue ; queue for condition-wait + initial-bindings ; special variable bindings + property-list) + +(defparameter *current-process* + #-sb-thread + (%make-process) + #+sb-thread + ;; We don't fill in the process id, so the process compiling this + ;; (the REPL, in most cases) can't be killed by accident. (loop for + ;; p in (all-processes) do (kill-process p)), anyone? + (%make-process :name "initial process" :function nil)) + +(defparameter *all-processes-lock* + (sb-thread:make-mutex :name "all processes lock")) + +(defparameter *all-processes* + (list *current-process*)) + +#-sb-thread +(defun make-process (&key (name "Anonymous") reset-action run-reasons + arrest-reasons (priority 0) quantum resume-hook + suspend-hook initial-bindings run-immediately) + (declare (ignore reset-action arrest-reasons priority quantum resume-hook + suspend-hook run-immediately)) + (%make-process :name "the only process" + :run-reasons run-reasons + :initial-bindings initial-bindings)) + +#+sb-thread +(defun make-process (&key (name "Anonymous") reset-action run-reasons + arrest-reasons (priority 0) quantum resume-hook + suspend-hook initial-bindings run-immediately) + (declare (ignore reset-action arrest-reasons priority quantum resume-hook + suspend-hook run-immediately)) + (let ((p (%make-process + :name name + :run-reasons run-reasons + :initial-bindings initial-bindings + :%lock (sb-thread:make-mutex + :name (format nil "Internal lock for ~A" name)) + :%queue (sb-thread:make-waitqueue + :name (format nil "Blocking queue for ~A" name))))) + (sb-thread:with-mutex (*all-processes-lock*) + (push p *all-processes*)) + p)) + +(defmacro defun/sb-thread (name args &body body) + #-sb-thread (declare (ignore body)) + `(defun ,name ,args + #-sb-thread + (declare (ignore ,@(remove-if + (lambda (x) + (member x '(&optional &rest &key &allow-other-keys + &aux))) + (mapcar (lambda (x) (if (consp x) (car x) x)) + args)))) + #-sb-thread + (error + "~A: Calling a multiprocessing function on a single-threaded sbcl build" + ',name) + #+sb-thread + ,@body)) + +(defun/sb-thread process-interrupt (process function) + (sb-thread:interrupt-thread (process-id process) function)) + +;; TODO: why no such function was in +sb-thread part? +(defun/sb-thread process-wait-function (process) + (declare (ignore process))) + +(defun/sb-thread process-wait (reason predicate &rest arguments) + (declare (type function predicate)) + (let ((old-state (process-whostate *current-process*))) + (unwind-protect + (progn + (setf old-state (process-whostate *current-process*) + (process-whostate *current-process*) reason) + (loop + (let ((it (apply predicate arguments))) + (when it (return it))) + (process-allow-schedule))) + (setf (process-whostate *current-process*) old-state)))) + +(defun/sb-thread process-allow-schedule (&optional process) + (declare (ignore process)) + (sleep .01)) + +(defun/sb-thread process-revoke-run-reason (process object) + (sb-thread:with-recursive-lock ((process-%lock process)) + (prog1 + (setf (process-run-reasons process) + (delete object (process-run-reasons process))) + (when (and (process-id process) (not (process-run-reasons process))) + (disable-process process))))) + +(defun/sb-thread process-add-run-reason (process object) + (sb-thread:with-recursive-lock ((process-%lock process)) + (prog1 + (push object (process-run-reasons process)) + (if (process-id process) + (enable-process process) + (restart-process process))))) + +(defun/sb-thread process-run-function (name-or-options preset-function + &rest preset-arguments) + (let* ((make-process-args (etypecase name-or-options + (list name-or-options) + (string (list :name name-or-options)))) + (process (apply #'make-process make-process-args))) + (apply #'process-preset process preset-function preset-arguments) + (setf (process-run-reasons process) :enable) + (restart-process process) + process)) + +(defun/sb-thread process-preset (process function &rest arguments) + (setf (process-function process) function + (process-arguments process) arguments) + (when (process-id process) (restart-process process))) + +(defun/sb-thread process-kill (process) + (when (process-id process) + (sb-thread:destroy-thread (process-id process)) + (setf (process-id process) nil)) + (sb-thread:with-mutex (*all-processes-lock*) + (setf *all-processes* (delete process *all-processes*)))) + +#+sb-thread +(defun make-process-lock (&key name) + (sb-thread:make-mutex :name name)) +#-sb-thread +(defun make-process-lock (&key name) + (declare (ignore name)) + nil) + +(defun/sb-thread process-lock (lock &optional lock-value whostate timeout) + (declare (ignore whostate timeout)) + (sb-thread:get-mutex lock lock-value)) + +(defun/sb-thread process-unlock (lock &optional lock-value) + (declare (ignore lock-value)) + (sb-thread:release-mutex lock)) + +#-sb-thread +(defmacro with-process-lock ((lock &key norecursive timeout whostate) + &body forms) + (declare (ignore lock norecursive timeout whostate)) + `(progn ,@forms)) + +#+sb-thread +(defmacro with-process-lock ((place &key timeout whostate norecursive) + &body body) + (declare (ignore norecursive timeout)) + (let ((old-whostate (gensym "OLD-WHOSTATE"))) + `(sb-thread:with-recursive-lock (,place) + (let (,old-whostate) + (unwind-protect + (progn + (when ,whostate + (setf ,old-whostate (process-whostate *current-process*)) + (setf (process-whostate *current-process*) ,whostate)) + ,@body) + (setf (process-whostate *current-process*) ,old-whostate)))))) + + +#-sb-thread +(defmacro without-scheduling (&body forms) + `(progn ,@forms)) ; * + +;;; FIXME but, of course, we can't. Fix whoever wants to use it, +;;; instead +#+sb-thread +(defmacro without-scheduling (&body body) + `(progn ,@body)) + +;;; Same implementation for multi- and uni-thread +(defmacro with-timeout ((seconds &body timeout-forms) &body body) + (let ((c (gensym "TIMEOUT-"))) + `(handler-case + (sb-ext::with-timeout ,seconds (progn ,@body)) + (sb-ext::timeout (,c) (declare (ignore ,c)) ,@timeout-forms)))) + +(defun/sb-thread restart-process (process) + (labels ((boing () + (let ((*current-process* process) + (bindings (process-initial-bindings process)) + (function (process-function process)) + (arguments (process-arguments process))) + (declare (type function function)) + (if bindings + (progv + (mapcar #'car bindings) + (mapcar #'(lambda (binding) + (eval (cdr binding))) + bindings) + (apply function arguments)) + (apply function arguments))))) + (when (process-id process) + (sb-thread:terminate-thread (process-id process))) + ;; XXX handle run-reasons in some way? Should a process continue + ;; running if all run reasons are taken away before + ;; restart-process is called? (process-revoke-run-reason handles + ;; this, so let's say (setf (process-run-reasons process) nil) is + ;; not guaranteed to do the Right Thing.) + (when (setf (process-id process) + (sb-thread:make-thread #'boing :name (process-name process))) + process))) + +(defun current-process () + *current-process*) + +(defun all-processes () + (copy-list *all-processes*)) + +(defun/sb-thread process-wait-with-timeout (reason timeout predicate) + (declare (type function predicate)) + (let ((old-state (process-whostate *current-process*)) + (end-time (+ (get-universal-time) timeout))) + (unwind-protect + (progn + (setf old-state (process-whostate *current-process*) + (process-whostate *current-process*) reason) + (loop + (let ((it (funcall predicate))) + (when (or (> (get-universal-time) end-time) it) + (return it))) + (sleep .01))) + (setf (process-whostate *current-process*) old-state)))) + +(defun/sb-thread disable-process (process) + ;; TODO: set process-whostate + ;; Can't figure out how to safely block a thread from a different one + ;; and handle all the locking nastiness. So punt for now. + (if (eq sb-thread:*current-thread* (process-id process)) + ;; Keep waiting until we have a reason to run. GC and other + ;; things can break a wait prematurely. Don't know if this is + ;; expected or not. + (do () + ((process-run-reasons process) nil) + (sb-thread:with-recursive-lock ((process-%lock process)) + (sb-thread:condition-wait (process-%queue process) + (process-%lock process)))) + (error "Can't safely disable-process from another thread"))) + +(defun/sb-thread enable-process (process) + ;; TODO: set process-whostate + (sb-thread:with-recursive-lock ((process-%lock process)) + (sb-thread:condition-notify (process-%queue process)))) + +;;; TODO: integrate with McCLIM / system-wide queue for such things +#+sb-thread +(defvar *atomic-spinlock* (sb-thread::make-spinlock)) + +#-sb-thread +(defmacro atomic-incf (place) + `(incf ,place)) + +#+sb-thread +(defmacro atomic-incf (place) + `(sb-thread::with-spinlock (*atomic-spinlock*) + (incf ,place))) + +#-sb-thread +(defmacro atomic-decf (place) + `(decf ,place)) + +#+sb-thread +(defmacro atomic-decf (place) + `(sb-thread::with-spinlock (*atomic-spinlock*) + (decf ,place))) + +(defun process-active-p (process) + (sb-thread:thread-alive-p (process-id process))) Added: branches/trunk-reorg/thirdparty/acl-compat/sbcl/acl-socket.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/acl-compat/sbcl/acl-socket.lisp Thu Feb 7 03:21:48 2008 @@ -0,0 +1,283 @@ +;; This package is designed for sbcl. It implements the +;; ACL-style socket interface on top of sbcl. +;; +;; Written by Rudi Schlatte, based on the work done by Jochen Schmidt +;; for Lispworks and net.lisp in the port library of CLOCC. + +(in-package #:acl-compat.socket) + +(defclass server-socket () + ((socket :initarg :socket :reader socket + :initform (error "No value supplied for socket")) + (element-type :type (member signed-byte unsigned-byte base-char) + :initarg :element-type + :reader element-type + :initform (error "No value supplied for element-type")) + (port :type fixnum + :initarg :port + :reader port + :initform (error "No value supplied for port")) + (stream-type :type (member :text :binary :bivalent) + :initarg :stream-type + :reader stream-type + :initform (error "No value supplied for stream-type")))) + +(defclass datagram-socket (server-socket) + ()) + + +(defmethod print-object ((socket server-socket) stream) + (print-unreadable-object (socket stream :type t :identity nil) + (format stream "listening on port ~d" (port socket)))) + +(defmethod print-object ((socket datagram-socket) stream) + (print-unreadable-object (socket stream :type t :identity nil) + (format stream "datagram socket listening on port ~d" (port socket)))) + +(defgeneric accept-connection (socket &key wait)) +(defmethod accept-connection ((server-socket server-socket) + &key (wait t)) + "Return a bidirectional stream connected to socket." + (if (sb-sys:wait-until-fd-usable (socket-file-descriptor (socket server-socket)) + :input (if (numberp wait) wait nil)) + (let* ((socket (socket-accept (socket server-socket))) + (stream (socket-make-stream socket + :input t :output t + ; :buffering :none + :element-type + (element-type server-socket) + :auto-close t))) + (if (eq (stream-type server-socket) :bivalent) + ;; HACK: remember socket, so we can do peer lookup + (make-bivalent-stream stream :plist `(:socket ,socket)) + stream)) + nil)) + +(defmethod receive-from ((socket datagram-socket) size &key buffer extract) + (multiple-value-bind (rbuf len address port) + (socket-receive (socket socket) buffer size) + (declare (ignore port)) + (let ((buf + (if (not extract) + rbuf + (subseq rbuf 0 len)))) ;; FIXME: am I right? + (when buffer + (replace buffer buf :end2 len)) + (values + (if buffer buffer buf) + len + address)))) + +(defmethod send-to ((socket datagram-socket) buffer size &key remote-host remote-port) + (let* ((rhost (typecase remote-host + (string (lookup-hostname remote-host)) + (otherwise remote-host))) + (s (socket socket)) + (stream (progn + (socket-connect s rhost remote-port) + (socket-make-stream s :input t :output t :buffering :none)))) + (write-sequence buffer stream) + size)) + + + +(defun make-socket (&key + (type :stream) + (remote-host "localhost") + local-port + remote-port + (connect :active) + (format :text) + (reuse-address t) + &allow-other-keys) + "Return a stream connected to remote-host if connect is :active, or +something listening on local-port that can be fed to accept-connection +if connect is :passive. + +This is an incomplete implementation of ACL's make-socket function! +It was written to provide the functionality necessary to port +AllegroServe. Refer to +http://franz.com/support/documentation/6.1/doc/pages/operators/socket/make-s... +to read about the missing parts." + (check-type remote-host string) + (let ((element-type (ecase format + (:text 'base-char) + (:binary 'signed-byte) + (:bivalent 'unsigned-byte))) + (socket + (if (eq type :datagram) + (progn + (setf connect :passive-udp) + (make-instance 'inet-socket :type :datagram :protocol :udp)) + (make-instance 'inet-socket :type :stream :protocol :tcp)))) + (ecase connect + (:passive-udp + (setf (sockopt-reuse-address socket) reuse-address) + (if local-port + (socket-bind socket #(0 0 0 0) local-port)) + (make-instance 'datagram-socket + :port (nth-value 1 (socket-name socket)) + :socket socket + :element-type element-type + :stream-type format)) + (:passive + (setf (sockopt-reuse-address socket) reuse-address) + (if local-port + (socket-bind socket #(0 0 0 0) local-port)) + (socket-listen socket 10) ;Arbitrarily chosen backlog value + (make-instance 'server-socket + :port (nth-value 1 (socket-name socket)) + :socket socket + :element-type element-type + :stream-type format)) + (:active + (socket-connect socket (lookup-hostname remote-host) remote-port) + (let ((stream (socket-make-stream socket :input t :output t + :element-type element-type + ; :buffering :none + ))) + (if (eq :bivalent format) + ;; HACK: remember socket, so we can do peer lookup + (make-bivalent-stream stream :plist `(:socket ,socket)) + stream)))))) + +(defmethod close ((server server-socket) &key abort) + "Kill a passive (listening) socket. (Active sockets are actually +streams and handled by their close methods." + (declare (ignore abort)) + (socket-close (socket server))) + +#+ignore +(declaim (ftype (function ((unsigned-byte 32) &key (:values t)) + (or (values fixnum fixnum fixnum fixnum) + (values simple-string))) + ipaddr-to-dotted)) +(defun ipaddr-to-dotted (ipaddr &key values) + "Convert from 32-bit integer to dotted string." + (declare (type (unsigned-byte 32) ipaddr)) + (let ((a (logand #xff (ash ipaddr -24))) + (b (logand #xff (ash ipaddr -16))) + (c (logand #xff (ash ipaddr -8))) + (d (logand #xff ipaddr))) + (if values + (values a b c d) + (format nil "~d.~d.~d.~d" a b c d)))) + +(defun ipaddr-to-vector (ipaddr) + "Convert from 32-bit integer to a vector of octets." + (declare (type (unsigned-byte 32) ipaddr)) + (let ((a (logand #xff (ash ipaddr -24))) + (b (logand #xff (ash ipaddr -16))) + (c (logand #xff (ash ipaddr -8))) + (d (logand #xff ipaddr))) + (make-array 4 :initial-contents (list a b c d)))) + +(declaim (ftype (function (vector) + (values (unsigned-byte 32))) + vector-to-ipaddr)) +(defun vector-to-ipaddr (sensible-ipaddr) + "Convert from 4-integer vector to 32-bit integer." + (loop with result = 0 + for component across sensible-ipaddr + do (setf result (+ (ash result 8) component)) + finally (return result))) + +(defun string-tokens (string) + (labels ((get-token (str pos1 acc) + (let ((pos2 (position #\Space str :start pos1))) + (if (not pos2) + (nreverse acc) + (get-token str (1+ pos2) (cons (read-from-string (subseq str pos1 pos2)) + acc)))))) + (get-token (concatenate 'string string " ") 0 nil))) + +(declaim (ftype (function (string &key (:errorp t)) + (or null (unsigned-byte 32))) + dotted-to-ipaddr)) +(defun dotted-to-ipaddr (dotted &key (errorp t)) + "Convert from dotted string to 32-bit integer." + (declare (string dotted)) + (if errorp + (let ((ll (string-tokens (substitute #\Space #\. dotted)))) + (+ (ash (first ll) 24) (ash (second ll) 16) + (ash (third ll) 8) (fourth ll))) + (ignore-errors + (let ((ll (string-tokens (substitute #\Space #\. dotted)))) + (+ (ash (first ll) 24) (ash (second ll) 16) + (ash (third ll) 8) (fourth ll)))))) + +(defun ipaddr-to-hostname (ipaddr &key ignore-cache) + (when ignore-cache + (warn ":IGNORE-CACHE keyword in IPADDR-TO-HOSTNAME not supported.")) + (host-ent-name (get-host-by-address (ipaddr-to-vector ipaddr)))) + +(defun lookup-hostname (host &key ignore-cache) + (when ignore-cache + (warn ":IGNORE-CACHE keyword in LOOKUP-HOSTNAME not supported.")) + (if (stringp host) + (host-ent-address (get-host-by-name host)) + (dotted-to-ipaddr (ipaddr-to-dotted host)))) + +(defun remote-host (socket-stream) + (let (socket) + (if (and (typep socket-stream 'chunked-stream) + (setf socket (getf (stream-plist socket-stream) :socket))) + (vector-to-ipaddr (socket-peername socket)) + (progn (warn "Could not get remote host for ~S" socket-stream) + 0)))) + +(defun remote-port (socket-stream) + (let (socket) + (if (and (typep socket-stream 'chunked-stream) + (setq socket (getf (stream-plist socket-stream) :socket))) + (nth-value 1 (socket-peername socket)) + (progn (warn "Could not get remote port for ~S" socket-stream) + 0)))) + +(defun local-host (thing) + (typecase thing + (chunked-stream (let ((socket (getf (stream-plist thing) :socket))) + (if socket (vector-to-ipaddr (socket-name socket)) + (progn (warn "Socket not in plist of ~S -- could not get local host" thing) + 0)))) + (server-socket (vector-to-ipaddr #(127 0 0 1))) + (t (progn (warn "Could not get local host for ~S" thing) + 0)))) + +(defun local-port (thing) + (typecase thing + (chunked-stream (let ((socket (getf (stream-plist thing) :socket))) + (if socket (nth-value 1 (socket-name socket)) + (progn (warn "Socket not in plist of ~S -- could not get local port" thing) + 0)))) + (server-socket (port thing)) + (t (progn (warn "Could not get local port for ~S" thing) + 0)))) + +;; Now, throw chunking in the mix + +(defclass chunked-stream (de.dataheaven.chunked-stream-mixin::chunked-stream-mixin + gray-stream::buffered-bivalent-stream) + ((plist :initarg :plist :accessor stream-plist))) + + +(defun make-bivalent-stream (lisp-stream &key plist) + (make-instance 'chunked-stream :lisp-stream lisp-stream :plist plist)) + + +(defun socket-control (stream &key (output-chunking nil oc-p) output-chunking-eof (input-chunking nil ic-p)) + (when oc-p + (when output-chunking + (de.dataheaven.chunked-stream-mixin::initialize-output-chunking stream)) + (setf (de.dataheaven.chunked-stream-mixin::output-chunking-p stream) + output-chunking)) + (when output-chunking-eof + (de.dataheaven.chunked-stream-mixin::disable-output-chunking stream)) + (when ic-p + (when input-chunking + (de.dataheaven.chunked-stream-mixin::initialize-input-chunking stream)) + (setf (de.dataheaven.chunked-stream-mixin::input-chunking-p stream) + input-chunking))) + + +(provide 'acl-socket) Added: branches/trunk-reorg/thirdparty/acl-compat/sbcl/acl-sys.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/acl-compat/sbcl/acl-sys.lisp Thu Feb 7 03:21:48 2008 @@ -0,0 +1,11 @@ +(in-package :acl-compat.system) + +(defun command-line-arguments () + sb-ext:*posix-argv*) + +(defun command-line-argument (n) + (nth n sb-ext:*posix-argv*)) + +(defun reap-os-subprocess (&key (wait nil)) + (declare (ignore wait)) + nil) Added: branches/trunk-reorg/thirdparty/acl-compat/scl/acl-excl.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/acl-compat/scl/acl-excl.lisp Thu Feb 7 03:21:48 2008 @@ -0,0 +1,264 @@ +;;;; +;;;; ACL-COMPAT - EXCL +;;;; + +;;;; Implementation-specific parts of acl-compat.excl (see +;;;; acl-excl-common.lisp) + +(defpackage :acl-compat.excl + (:use #:common-lisp #:ext) + (:export + #:if* + #:*initial-terminal-io* + #:*cl-default-special-bindings* + #:filesys-size + #:filesys-write-date + #:stream-input-fn + #:match-regexp + #:compile-regexp + #:*current-case-mode* + #:intern* + #:filesys-type + #:errorset + #:atomically + #:fast + #:without-package-locks + #:string-to-octets + #:write-vector + + ;; TODO: find better place for bivalent stream classes + #:bivalent-input-stream + #:bivalent-output-stream + #:bivalent-stream + #:make-bivalent-input-stream + #:make-bivalent-output-stream + #:make-bivalent-stream + )) + +(in-package :acl-compat.excl) + +(defun stream-input-fn (stream) + stream) + +(defun filesys-type (file-or-directory-name) + (if (eq :directory (unix:unix-file-kind + (namestring file-or-directory-name))) + :directory + (if (probe-file file-or-directory-name) + :file + nil))) + +(defmacro atomically (&body forms) + `(mp:without-scheduling ,@forms)) + +(defun unix-signal (signal pid) + ;; fixxme: did I get the arglist right? only invocation I have seen + ;; is (excl::unix-signal 15 0) in net.aserve:start + (unix:unix-kill pid signal)) + +(defmacro without-package-locks (&body forms) + `(progn ,@forms)) + + +;;; Bivalent Gray streams + + +(defclass lisp-stream-mixin () + ;; For bivalent streams, lisp-stream must be a stream of type + ;; unsigned-byte + ((lisp-stream :initarg :lisp-stream + :accessor lisp-stream))) + +(defclass bivalent-input-stream (lisp-stream-mixin + fundamental-character-input-stream + fundamental-binary-input-stream)) + +(defclass bivalent-output-stream (lisp-stream-mixin + fundamental-character-output-stream + fundamental-binary-output-stream)) + +(defclass bivalent-stream (bivalent-input-stream bivalent-output-stream)) + + +(defun make-bivalent-input-stream (lisp-stream) + (declare (type system:lisp-stream lisp-stream)) + (make-instance 'bivalent-input-stream :lisp-stream lisp-stream)) + +(defun make-bivalent-output-stream (lisp-stream) + (declare (type system:lisp-stream lisp-stream)) + (make-instance 'bivalent-output-stream :lisp-stream lisp-stream)) + +(defun make-bivalent-stream (lisp-stream) + (declare (type system:lisp-stream lisp-stream)) + (make-instance 'bivalent-stream :lisp-stream lisp-stream)) + + +(defmethod open-stream-p ((stream lisp-stream-mixin)) + (common-lisp::open-stream-p (lisp-stream stream))) + +(defmethod close ((stream lisp-stream-mixin) &key abort) + (close (lisp-stream stream) :abort abort)) + +(defmethod input-stream-p ((stream lisp-stream-mixin)) + (input-stream-p (lisp-stream stream))) + +(defmethod output-stream-p ((stream lisp-stream-mixin)) + (output-stream-p (lisp-stream stream))) + +(defmethod stream-element-type ((stream bivalent-input-stream)) + '(or character (unsigned-byte 8))) + +(defmethod stream-read-char ((stream bivalent-input-stream)) + (code-char (read-byte (lisp-stream stream) nil :eof))) + +(defmethod stream-read-byte ((stream bivalent-input-stream)) + (read-byte (lisp-stream stream) nil :eof)) + +;; stream-unread-char + +(defmethod stream-read-char-no-hang ((stream bivalent-input-stream)) + (if (listen (lisp-stream stream)) + (code-char (read-byte (lisp-stream stream))) + nil)) + +;; stream-peek-char + +(defmethod stream-listen ((stream bivalent-input-stream)) + (listen (lisp-stream stream))) + +(defmethod stream-clear-input ((stream bivalent-input-stream)) + (clear-input (lisp-stream stream))) + +(defmethod stream-read-sequence ((stream bivalent-input-stream) + (seq vector) &optional start end) + (unless start (setf start 0)) + (unless end (setf end (length seq))) + (assert (<= end (length seq))) + (if (subtypep (array-element-type seq) 'character) + (loop for count upfrom start + for i from start below end + do (setf (aref seq i) (code-char (read-byte stream))) + finally (return count)) + (read-sequence seq (lisp-stream stream) + :start start :end end))) + +(defmethod stream-read-sequence ((stream bivalent-input-stream) + (seq cons) &optional (start 0) end) + (unless start (setf start 0)) + (unless end (setf end (length seq))) + (let ((seq (nthcdr start seq))) + (loop for count upfrom start + for head on seq + for i below (- end start) + while head + do (setf (car head) (read-byte stream)) + finally (return count)))) + +(defmethod stream-read-sequence ((stream bivalent-input-stream) + (seq null) &optional (start 0) end) + (declare (ignore end)) + start) + +(defmethod stream-element-type ((stream bivalent-output-stream)) + '(or character (unsigned-byte 8))) + +(defmethod stream-write-char ((stream bivalent-output-stream) character) + (write-byte (char-code character) (lisp-stream stream))) + +(defmethod stream-write-byte ((stream bivalent-output-stream) byte) + (write-byte byte (lisp-stream stream))) + +(defmethod stream-line-column ((stream bivalent-output-stream)) + nil) + +(defmethod stream-finish-output ((stream bivalent-output-stream)) + (finish-output (lisp-stream stream))) + +(defmethod stream-force-output ((stream bivalent-output-stream)) + (force-output (lisp-stream stream))) + +(defmethod stream-clear-output ((stream bivalent-output-stream)) + (clear-output (lisp-stream stream))) + +(defmethod stream-write-sequence ((stream bivalent-output-stream) + (seq vector) &optional (start 0) end) + (let ((length (length seq))) + (unless end (setf end length)) + (assert (<= end length))) + (unless start (setf start 0)) + (when (< end start) + (cerror "Continue with switched start and end ~s <-> ~s" + "Stream-write-sequence: start (~S) and end (~S) exchanged." + start end seq) + (rotatef start end)) + (cond + ((subtypep (array-element-type seq) '(unsigned-byte 8)) + (write-sequence seq (lisp-stream stream) :start start :end end)) + ((subtypep (array-element-type seq) 'character) + (loop for i from start below end + do (stream-write-char stream (aref seq i)))) + ((subtypep (array-element-type seq) 'integer) + (loop for i from start below end + do (stream-write-byte stream (aref seq i))))) + seq) + +(defmethod stream-write-sequence ((stream bivalent-output-stream) + (seq cons) &optional (start 0) end) + (let ((length (length seq))) + (unless end (setf end length)) + (assert (<= end length))) + (unless start (setf start 0)) + (when (< end start) + (cerror "Continue with switched start and end ~s <-> ~s" + "Stream-write-sequence: start (~S) and end (~S) exchanged." + start end seq) + (rotatef start end)) + (let ((seq (nthcdr start seq))) + (loop for element in seq + for i below (- end start) + while seq + do (etypecase element + (character (stream-write-char stream element)) + (integer (stream-write-byte stream element))))) + seq) + +(defmethod stream-write-sequence ((stream bivalent-output-stream) + (seq null) &optional (start 0) end) + (declare (ignore start end)) + seq) + +;;; End bivalent Gray streams + +(defun string-to-octets (string &key (null-terminate t) (start 0) + end mb-vector make-mb-vector? + (external-format :default)) + "This function returns a lisp-usb8-vector and the number of bytes copied." + (declare (ignore external-format)) + ;; The end parameter is different in ACL's lambda list, but this + ;; variant lets us give an argument :end nil explicitly, and the + ;; right thing will happen + (unless end (setf end (length string))) + (let* ((number-of-octets (if null-terminate (1+ (- end start)) + (- end start))) + (mb-vector (cond + ((and mb-vector (>= (length mb-vector) number-of-octets)) + mb-vector) + ((or (not mb-vector) make-mb-vector?) + (make-array (list number-of-octets) + :element-type '(unsigned-byte 8) + :initial-element 0)) + (t (error "Was given a vector of length ~A, ~ + but needed at least length ~A." + (length mb-vector) number-of-octets))))) + (declare (type (simple-array (unsigned-byte 8) (*)) mb-vector)) + (loop for from-index from start below end + for to-index upfrom 0 + do (progn + (setf (aref mb-vector to-index) + (char-code (aref string from-index))))) + (when null-terminate + (setf (aref mb-vector (1- number-of-octets)) 0)) + (values mb-vector number-of-octets))) + + +(provide 'acl-excl) Added: branches/trunk-reorg/thirdparty/acl-compat/scl/acl-mp.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/acl-compat/scl/acl-mp.lisp Thu Feb 7 03:21:48 2008 @@ -0,0 +1,155 @@ +;; This package is designed for cmucl. It implements ACL-style +;; multiprocessing on top of cmucl (basically, process run reasons and +;; some function renames). +;; +;; Written by Rudi Schlatte, based on the work done by Jochen Schmidt +;; for Lispworks. + +(in-package :acl-compat-mp) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Import equivalent parts from the CMU MP package ;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(shadowing-import '(mp:*current-process* + ;; mp::process-preset + mp::process-reset + mp:process-interrupt + mp::process-name + mp::process-wait-function + mp:process-run-reasons + mp:process-add-run-reason + mp:process-revoke-run-reason + mp:process-arrest-reasons + mp:process-add-arrest-reason + mp:process-revoke-arrest-reason + mp:process-whostate + ; mp:without-interrupts + mp:process-wait + mp:with-timeout + mp:without-scheduling + )) + +(export '(*current-process* + ;; process-preset + process-reset + process-interrupt + process-name + process-wait-function + process-whostate + process-wait + with-timeout + without-scheduling + process-run-reasons + process-add-run-reason + process-revoke-run-reason + process-arrest-reasons + process-add-arrest-reason + process-revoke-arrest-reason + )) + + +(defun process-allow-schedule () + (mp:process-yield)) + +(defvar *process-plists* (make-hash-table :test #'eq) + "maps processes to their plists. +See the functions process-plist, (setf process-plist).") + +(defun process-property-list (process) + (gethash process *process-plists*)) + +(defun (setf process-property-list) (new-value process) + (setf (gethash process *process-plists*) new-value)) + +#|| + +;;; rudi 2002-06-09: This is not needed as of cmucl 18d, thanks to Tim +;;; Moore who added run reasons to cmucl's multithreading. Left in +;;; for the time being just in case someone wants to get acl-compat +;;; running on older cmucl's. Can be deleted safely. + +(defvar *process-run-reasons* (make-hash-table :test #'eq) + "maps processes to their run-reasons. +See the functions process-run-reasons, (setf process-run-reasons), +process-add-run-reason, process-revoke-run-reason.") + +(defun process-run-reasons (process) + (gethash process *process-run-reasons*)) + +(defun (setf process-run-reasons) (new-value process) + (mp:without-scheduling + (prog1 + (setf (gethash process *process-run-reasons*) new-value) + (if new-value + (mp:enable-process process) + (mp:disable-process process))))) + +(defun process-revoke-run-reason (process object) + (without-scheduling + (setf (process-run-reasons process) + (remove object (process-run-reasons process)))) + (when (and (eq process mp:*current-process*)) + (mp:process-yield))) + +(defun process-add-run-reason (process object) + (setf (process-run-reasons process) + (pushnew object (process-run-reasons process)))) +||# + +(defun process-run-function (name-or-options preset-function + &rest preset-arguments) + (let ((process (ctypecase name-or-options + (string (make-process :name name-or-options)) + (list (apply #'make-process name-or-options))))) + (apply #'acl-mp::process-preset process preset-function preset-arguments) + process)) + +(defun process-preset (process preset-function &rest arguments) + (mp:process-preset process + #'(lambda () + (apply-with-bindings preset-function + arguments + (process-initial-bindings process))))) + +(defvar *process-initial-bindings* (make-hash-table :test #'eq)) + +(defun process-initial-bindings (process) + (gethash process *process-initial-bindings*)) + +(defun (setf process-initial-bindings) (bindings process) + (setf (gethash process *process-initial-bindings*) bindings)) + + +;;; ;;; +;;; Contributed by Tim Moore ;;; +;;; ;;; +(defun apply-with-bindings (function args bindings) + (if bindings + (progv + (mapcar #'car bindings) + (mapcar #'(lambda (binding) + (eval (cdr binding)))) + (apply function args)) + (apply function args))) + +(defun make-process (&key (name "Anonymous") reset-action run-reasons + arrest-reasons (priority 0) quantum resume-hook + suspend-hook initial-bindings run-immediately) + (declare (ignore priority quantum reset-action resume-hook suspend-hook + run-immediately)) + (mp:make-process nil :name name + :run-reasons run-reasons + :arrest-reasons arrest-reasons + :initial-bindings initial-bindings)) + +(defun process-kill (process) + (mp:destroy-process process)) + + +(defun make-process-lock (&key name) + (mp:make-lock name)) + +(defmacro with-process-lock ((lock &key norecursive) &body forms) + (declare (ignore norecursive)) + `(mp:with-lock-held (,lock) ,@forms)) Added: branches/trunk-reorg/thirdparty/acl-compat/scl/acl-socket.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/acl-compat/scl/acl-socket.lisp Thu Feb 7 03:21:48 2008 @@ -0,0 +1,196 @@ +;; This package is designed for scl. It implements the +;; ACL-style socket interface on top of scl. +;; +;; Written by Rudi Schlatte, based on the work done by Jochen Schmidt +;; for Lispworks and net.lisp in the port library of CLOCC. +;; +;; This was modified for SCL by Kevin Rosenberg + +(defpackage acl-socket + (:use "MP" "COMMON-LISP") + #+cl-ssl (:import-from :ssl "MAKE-SSL-CLIENT-STREAM" "MAKE-SSL-SERVER-STREAM") + (:export #:socket #:make-socket #:accept-connection + #:ipaddr-to-dotted #:dotted-to-ipaddr #:ipaddr-to-hostname #:lookup-hostname + #:remote-host #:remote-port #:local-host #:local-port #:socket-control + #+cl-ssl #:make-ssl-client-stream #+cl-ssl #:make-ssl-server-stream) + (:nicknames socket)) + +(in-package socket) + +(defclass socket () + ((fd :type fixnum + :initarg :fd + :reader fd))) + +(defmethod print-object ((socket socket) stream) + (print-unreadable-object (socket stream :type t :identity t) + (format stream "@~d" (fd socket)))) + +(defclass server-socket (socket) + ((element-type :type (member signed-byte unsigned-byte base-char) + :initarg :element-type + :reader element-type + :initform (error "No value supplied for element-type")) + (port :type fixnum + :initarg :port + :reader port + :initform (error "No value supplied for port")) + (stream-type :type (member :text :binary :bivalent) + :initarg :stream-type + :reader stream-type + :initform (error "No value supplied for stream-type")))) + +#+cl-ssl +(defmethod make-ssl-server-stream ((lisp-stream system:lisp-stream) + &rest options) + (apply #'make-ssl-server-stream (system:fd-stream-fd lisp-stream) options)) + +(defmethod print-object ((socket server-socket) stream) + (print-unreadable-object (socket stream :type t :identity nil) + (format stream "@~d on port ~d" (fd socket) (port socket)))) + +(defmethod accept-connection ((server-socket server-socket) + &key (wait t)) + "Return a bidirectional stream connected to socket, or nil if no +client wanted to initiate a connection and wait is nil." + ;; fixxme: perhaps check whether we run multiprocessing and use + ;; sys:wait-until-fd-usable instead of + ;; mp:process-wait-until-fd-usable here? + + ;; api pipe fitting: wait t ==> timeout nil + (when (mp:process-wait-until-fd-usable (fd server-socket) :input + (if wait nil 0)) + (let ((stream (sys:make-fd-stream + (ext:accept-tcp-connection (fd server-socket)) + :input t :output t + :element-type (element-type server-socket) + :auto-close t))) + (if (eq (stream-type server-socket) :bivalent) + (excl:make-bivalent-stream stream) + stream)))) + +(defun make-socket (&key (remote-host "localhost") + local-port + remote-port + (connect :active) + (format :text) + &allow-other-keys) + "Return a stream connected to remote-host if connect is :active, or +something listening on local-port that can be fed to accept-connection +if connect is :passive. + +This is an incomplete implementation of ACL's make-socket function! +It was written to provide the functionality necessary to port +AllegroServe. Refer to +http://franz.com/support/documentation/6.1/doc/pages/operators/socket/make-s... +to read about the missing parts." + (check-type remote-host string) + (let ((element-type (ecase format + (:text 'base-char) + (:binary 'signed-byte) + (:bivalent 'unsigned-byte)))) + (ecase connect + (:passive + (make-instance 'server-socket + :port local-port + :fd (ext:create-inet-listener local-port) + :element-type element-type + :stream-type format)) + (:active + (let ((stream (sys:make-fd-stream + (ext:connect-to-inet-socket remote-host remote-port) + :input t :output t :element-type element-type))) + (if (eq :bivalent format) + (excl:make-bivalent-stream stream) + stream)))))) + +(defmethod close ((server server-socket) &key abort) + "Kill a passive (listening) socket. (Active sockets are actually +streams and handled by their close methods." + (declare (ignore abort)) + (unix:unix-close (fd server))) + +(declaim (ftype (function ((unsigned-byte 32) &key (:values t)) + (values simple-string)) + ipaddr-to-dotted)) +(defun ipaddr-to-dotted (ipaddr &key values) + (declare (type (unsigned-byte 32) ipaddr)) + (let ((a (logand #xff (ash ipaddr -24))) + (b (logand #xff (ash ipaddr -16))) + (c (logand #xff (ash ipaddr -8))) + (d (logand #xff ipaddr))) + (if values + (values a b c d) + (format nil "~d.~d.~d.~d" a b c d)))) + +(defun string-tokens (string) + (labels ((get-token (str pos1 acc) + (let ((pos2 (position #\Space str :start pos1))) + (if (not pos2) + (nreverse acc) + (get-token str (1+ pos2) (cons (read-from-string (subseq str pos1 pos2)) + acc)))))) + (get-token (concatenate 'string string " ") 0 nil))) + +(declaim (ftype (function (string &key (:errorp t)) + (values (unsigned-byte 32))) + dotted-to-ipaddr)) +(defun dotted-to-ipaddr (dotted &key (errorp t)) + (declare (string dotted)) + (if errorp + (let ((ll (string-tokens (substitute #\Space #\. dotted)))) + (+ (ash (first ll) 24) (ash (second ll) 16) + (ash (third ll) 8) (fourth ll))) + (ignore-errors + (let ((ll (string-tokens (substitute #\Space #\. dotted)))) + (+ (ash (first ll) 24) (ash (second ll) 16) + (ash (third ll) 8) (fourth ll)))))) + +(defun ipaddr-to-hostname (ipaddr &key ignore-cache) + (when ignore-cache + (warn ":IGNORE-CACHE keyword in IPADDR-TO-HOSTNAME not supported.")) + (ext:host-entry-name (ext:lookup-host-entry ipaddr))) + +(defun lookup-hostname (host &key ignore-cache) + (when ignore-cache + (warn ":IGNORE-CACHE keyword in LOOKUP-HOSTNAME not supported.")) + (if (stringp host) + (car (ext:host-entry-addr-list (ext:lookup-host-entry host))) + (dotted-to-ipaddr (ipaddr-to-dotted host)))) + +(defgeneric get-fd (stream)) + +(defmethod get-fd ((stream excl::lisp-stream-mixin)) + (system:fd-stream-fd (excl::lisp-stream stream))) + +(defmethod get-fd ((stream system:lisp-stream)) + (system:fd-stream-fd stream)) + +(defun remote-host (socket-stream) + (ext:get-peer-host-and-port (get-fd socket-stream))) + +(defun remote-port (socket-stream) + (multiple-value-bind (host port) + (ext:get-peer-host-and-port (get-fd socket-stream)) + (declare (ignore host)) + port)) + +(defun local-host (socket-stream) + (ext:get-socket-host-and-port (get-fd socket-stream))) + +(defun local-port (socket-stream) + (if (typep socket-stream 'socket::server-socket) + (port socket-stream) + (multiple-value-bind (host port) + (ext:get-socket-host-and-port (get-fd socket-stream)) + (declare (ignore host)) + port))) + +(defun socket-control (stream &key output-chunking output-chunking-eof input-chunking) + (declare (ignore stream)) + (warn "SOCKET-CONTROL function not implemented.") + (when (or output-chunking output-chunking-eof input-chunking) + (error "Chunking is not yet supported in scl. Restart the server with chunking off."))) + + +(provide 'acl-socket) Added: branches/trunk-reorg/thirdparty/acl-compat/scl/acl-sys.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/acl-compat/scl/acl-sys.lisp Thu Feb 7 03:21:48 2008 @@ -0,0 +1,18 @@ +(in-package :sys) + +(ignore-errors +(export 'command-line-arguments) +(export 'command-line-argument) +(export 'reap-os-subprocess) + +(defun command-line-arguments () + ext:*command-line-strings*) + +(defun command-line-argument (n) + (nth n ext:*command-line-strings*)) + +(defun reap-os-subprocess (&key (wait nil)) + (declare (ignore wait)) + nil) + +) Added: branches/trunk-reorg/thirdparty/acl-compat/test-acl-socket.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/acl-compat/test-acl-socket.lisp Thu Feb 7 03:21:48 2008 @@ -0,0 +1,61 @@ +;;; Unit tests for the ACL-SOCKET compatibility package. + +(in-package cl-user) + +(require :acl-socket) + +(use-package '(acl-socket)) + +(defun test1 () + (let ((stream (make-socket :connect :active :remote-host "127.0.0.1" :remote-port 2500))) + (when stream + (read-line stream) + (format stream "helo foo") + (write-char #\Return stream) + (write-char #\Linefeed stream) + (finish-output stream) + (read-line stream) + (close stream)))) + +(defun test2 () + (let ((stream (make-socket :connect :active :remote-host "127.0.0.1" :remote-port 2500))) + (when stream + (socket-control stream :output-chunking t) + (read-line stream) + (format stream "helo foo") + (write-char #\Return stream) + (write-char #\Linefeed stream) + (finish-output stream) + (read-line stream) + (close stream)))) + +(defun test3 () + (let ((stream (make-socket :connect :active :remote-host "127.0.0.1" :remote-port 2500))) + (when stream + (socket-control stream :input-chunking t) + (prog1 + (read-line stream) + (close stream))))) + +(defun test4 () + (let ((stream (or (make-socket :connect :active :remote-host "127.0.0.1" :remote-port 2500) + (error "Failed to connect.")))) + (socket-control stream :input-chunking t) + (format t "File number 1: ") + #1=(handler-case + (loop + for char = (read-char stream nil stream) + until (eq char stream) + do (write-char char)) + (excl::socket-chunking-end-of-file (e) (socket-control stream :input-chunking t))) + (format t "~%File number 2: ") + #1# + (terpri) + (values))) + + + + + + +