usocket-cvs July 2008

usocket-cvs@common-lisp.net

2 participants
52 discussions

[usocket-cvs] r371 - usocket/branches/new-wfi/backend
by ehuelsmann＠common-lisp.net 19 Jul '08

19 Jul '08

Author: ehuelsmann Date: Sat Jul 19 18:38:17 2008 New Revision: 371 Modified: usocket/branches/new-wfi/backend/lispworks.lisp Log: Add documentation to the LispWorks backend. Modified: usocket/branches/new-wfi/backend/lispworks.lisp ============================================================================== --- usocket/branches/new-wfi/backend/lispworks.lisp (original) +++ usocket/branches/new-wfi/backend/lispworks.lisp Sat Jul 19 18:38:17 2008 @@ -243,6 +243,23 @@ (defconstant fionread 1074030207) + + ;; Note: + ;; + ;; If special finalization has to occur for a given + ;; system resource (handle), an associated object should + ;; be created. A special cleanup action should be added + ;; to the system and a special cleanup action should + ;; be flagged on all objects created for resources like it + ;; + ;; We have 2 functions to do so: + ;; * hcl:add-special-free-action (function-symbol) + ;; * hcl:flag-special-free-action (object) + ;; + ;; Note that the special free action will be called on all + ;; objects which have been flagged for special free, so be + ;; sure to check for the right argument type! + (fli:define-foreign-type ws-socket () '(:unsigned :int)) (fli:define-foreign-type win32-handle () '(:unsigned :int)) (fli:define-c-struct wsa-network-events (network-events :long)

1 0

[usocket-cvs] r370 - in usocket/branches/hans: . backend doc notes test
by hhubner＠common-lisp.net 19 Jul '08

19 Jul '08

Author: hhubner Date: Sat Jul 19 08:00:01 2008 New Revision: 370 Added: usocket/branches/hans/ (props changed) usocket/branches/hans/LICENSE usocket/branches/hans/Makefile usocket/branches/hans/README usocket/branches/hans/TODO usocket/branches/hans/backend/ usocket/branches/hans/backend/allegro.lisp usocket/branches/hans/backend/armedbear.lisp usocket/branches/hans/backend/clisp.lisp usocket/branches/hans/backend/cmucl.lisp usocket/branches/hans/backend/lispworks.lisp usocket/branches/hans/backend/openmcl.lisp usocket/branches/hans/backend/sbcl.lisp usocket/branches/hans/backend/scl.lisp usocket/branches/hans/condition.lisp usocket/branches/hans/doc/ usocket/branches/hans/doc/backends.txt usocket/branches/hans/doc/design.txt usocket/branches/hans/notes/ usocket/branches/hans/notes/abcl-socket.txt usocket/branches/hans/notes/active-sockets-apis.txt usocket/branches/hans/notes/address-apis.txt usocket/branches/hans/notes/allegro-socket.txt usocket/branches/hans/notes/clisp-sockets.txt usocket/branches/hans/notes/cmucl-sockets.txt usocket/branches/hans/notes/errors.txt usocket/branches/hans/notes/lw-sockets.txt usocket/branches/hans/notes/openmcl-sockets.txt usocket/branches/hans/notes/sb-bsd-sockets.txt usocket/branches/hans/notes/usock-sockets.txt usocket/branches/hans/package.lisp usocket/branches/hans/run-usocket-tests.sh (contents, props changed) usocket/branches/hans/test/ usocket/branches/hans/test/abcl.conf.in usocket/branches/hans/test/allegro.conf.in usocket/branches/hans/test/clisp.conf.in usocket/branches/hans/test/cmucl.conf.in usocket/branches/hans/test/package.lisp usocket/branches/hans/test/sbcl.conf.in usocket/branches/hans/test/test-usocket.lisp usocket/branches/hans/test/usocket-test.asd usocket/branches/hans/test/your-lisp.conf.in usocket/branches/hans/usocket.asd usocket/branches/hans/usocket.lisp Log: Update from bknr repository. Added: usocket/branches/hans/LICENSE ============================================================================== --- (empty file) +++ usocket/branches/hans/LICENSE Sat Jul 19 08:00:01 2008 @@ -0,0 +1,24 @@ +(This is the MIT / X Consortium license as taken from + http://www.opensource.org/licenses/mit-license.html) + +Copyright (c) 2003 Erik Enge +Copyright (c) 2006-2007 Erik Huelsmann + +Permission is hereby granted, free of charge, to any person obtaining +a copy of this software and associated documentation files (the +"Software"), to deal in the Software without restriction, including +without limitation the rights to use, copy, modify, merge, publish, +distribute, sublicense, and/or sell copies of the Software, and to +permit persons to whom the Software is furnished to do so, subject to +the following conditions: + +The above copyright notice and this permission notice shall be +included in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE +LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION +OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION +WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. Added: usocket/branches/hans/Makefile ============================================================================== --- (empty file) +++ usocket/branches/hans/Makefile Sat Jul 19 08:00:01 2008 @@ -0,0 +1,9 @@ +# $Id: Makefile 80 2006-02-12 10:09:49Z ehuelsmann $ +# $URL: svn://common-lisp.net/project/usocket/svn/usocket/branches/hans/Makefile $ + +clean: + find -name -o -name "*~" -o -name "*.err" -o -name "*.x86f" -o -name "*.lib" -o -name "*.fas" -o -name "*.fasl" -o -name "*.faslmt" -o -name "*.ufsl" -o -name "*.abcl" | xargs rm + +commit: + make clean; svn up; svn ci + Added: usocket/branches/hans/README ============================================================================== --- (empty file) +++ usocket/branches/hans/README Sat Jul 19 08:00:01 2008 @@ -0,0 +1,175 @@ + -*- text -*- + +$Id: README 334 2008-04-23 21:24:15Z hhubner $ + +Content +======= + + * Introduction + * Remarks on licensing + * Non-support for :external-format + * API definition + * Test suite + * Known problems + +Introduction +============ +This is the usocket Common Lisp sockets library: a library to bring +sockets access to the broadest of common lisp implementations as possible. + + +The library currently supports: + + - SBCL + - CMUCL + - ArmedBear (post feb 11th, 2006 CVS or 0.0.10 and higher) + - clisp + - Allegro Common Lisp + - LispWorks + - OpenMCL + - ECL + - Scieneer Common Lisp + - <Your favorite Common Lisp here?> + +If your favorite common lisp misses in the list above, please contact +usocket-devel(a)common-lisp.net and submit a request. Please include +references to available sockets functions in your lisp implementation. + +The library has been ASDF (http://cliki.net/ASDF) enabled, meaning +that you can tar up a checkout and use that to ASDF-INSTALL:INSTALL +the package in your system package site. (Or use your usual ASDF +tricks to use the checkout directly.) + + +Remarks on licensing +==================== + +Even though the source code has an MIT style license attached to it, +when compiling this code with some of the supported lisp implementations +you may not end up with an MIT style binary version due to the licensing +of the implementations themselves. ECL is such an example and - when +it will become supported - GCL is like that too. + + +Non-support of :external-format +=============================== + +Because of its definition in the hyperspec, there's no common +external-format between lisp implementations: every vendor has chosen +a different way to solve the problem of newline translation or +character set recoding. + +Because there's no way to avoid platform specific code in the application +when using external-format, the purpose of a portability layer gets +defeated. So, for now, usocket doesn't support external-format. + +The workaround to get reasonably portable external-format support is to +layer a flexi-stream (from flexi-streams) on top of a usocket stream. + + +API definition +============== + + - usocket (class) + - stream-usocket (class; usocket derivative) + - stream-server-usocket (class; usocket derivative) + - socket-connect (function) [ to create an active/connected socket ] + socket-connect host port &key element-type + where `host' is a vectorized ip + or a string representation of a dotted ip address + or a hostname for lookup in the DNS system + - socket-listen (function) [ to create a passive/listening socket ] + socket-listen host port &key reuseaddress backlog element-type + where `host' has the same definition as above + - socket-accept (method) [ to create an active/connected socket ] + socket-accept socket &key element-type + returns (server side) a connected socket derived from a + listening/passive socket. + - socket-close (method) + socket-close socket + where socket a previously returned socket + - socket (usocket slot accessor), + the internal/implementation defined socket representation + - socket-stream (usocket slot accessor), + socket-stream socket + the return value of which satisfies the normal stream interface + + +Errors: + - address-in-use-error + - address-not-available-error + - bad-file-descriptor-error + - connection-refused-error + - connection-aborted-error + - connection-reset-error + - invalid-argument-error + - no-buffers-error + - operation-not-supported-error + - operation-not-permitted-error + - protocol-not-supported-error + - socket-type-not-supported-error + - network-unreachable-error + - network-down-error + - network-reset-error + - host-down-error + - host-unreachable-error + - shutdown-error + - timeout-error + - unkown-error + +Non-fatal conditions: + - interrupted-condition + - unkown-condition + +(for a description of the API methods and functions see + http://common-lisp.net/project/usocket/api-docs.shtml.) + +Test suite +========== + +The test suite unfortunately isn't mature enough yet to run without +some manual configuration. Several elements are required which are +hard to programatically detect. Please adjust the test file before +running the tests, for these variables: + +- +non-existing-host+: The stringified IP address of a host on the + same subnet. No physical host may be present. +- +unused-local-port+: A port number of a port not in use on the + machine the tests run on. +- +common-lisp-net+: A vector with 4 integer elements which make up + an IP address. This must be the IP "common-lisp.net" resolves to. + + +Known problems +============== +- CMUCL error reporting wrt sockets raises only simple-errors + meaning there's no way to tell different error conditions apart. + All errors are mapped to unknown-error on CMUCL. + +- The ArmedBear backend doesn't do any error mapping (yet). Java + defines exceptions at the wrong level (IMO), since the exception + reported bares a relation to the function failing, not the actual + error that occurred: for example 'Address already in use' (when + creating a passive socket) is reported as a BindException with + an error text of 'Address already in use'. There's no way to sanely + map 'BindException' to a meaningfull error in usocket. [This does not + mean the backend should not at least map to 'unknown-error'!] + +- When using the library with ECL, you need the C compiler installed + to be able to compile and load the Foreign Function Interface. + Not all ECL targets support DFFI yet, so on some targets this would + be the case anyway. By depending on this technique, usocket can + reuse the FFI code on all platforms (including Windows). This benefit + currently outweighs the additional requirement. (hey, it's *Embeddable* + Common Lisp, so, you probably wanted to embed it all along, right?) + +- LispWorks has a bug(?) in wait-for-input-streams which make it + unsuited for waiting for input on stream socket servers, making it + necessary to resort to different means. With the absence of notice-fd + on Windows, that currenty leaves Windows unsupported. + +- SBCL can't use select() on Windows because it would mean porting + the FD_* macros and the select structures which I'm not sure + is the right way yet (if I need to write custom Win32 code anyway...) + The alternative is to use WSAEventSelect() and friends (which don't + have a limited number of sockets). Added: usocket/branches/hans/TODO ============================================================================== --- (empty file) +++ usocket/branches/hans/TODO Sat Jul 19 08:00:01 2008 @@ -0,0 +1,18 @@ + +- Implement wait-for-input-internal for + * SBCL Win32 + * LispWorks Win32 + +- Implement errors for (the alien interface code of) + * SBCL Unix + * CMUCL Unix + * OpenMCL + + +- Extend ABCL socket support with the 4 java errors in java.net.* + so that they can map to our usocket errors instead of mapping + all errors to unknown-error. + +- Add INET6 support. + +For more TODO items, see http://trac.common-lisp.net/usocket/report. Added: usocket/branches/hans/backend/allegro.lisp ============================================================================== --- (empty file) +++ usocket/branches/hans/backend/allegro.lisp Sat Jul 19 08:00:01 2008 @@ -0,0 +1,147 @@ +;;;; $Id: allegro.lisp 335 2008-04-23 21:29:50Z hhubner $ +;;;; $URL: svn://common-lisp.net/project/usocket/svn/usocket/branches/hans/backend/all… $ + +;;;; See LICENSE for licensing information. + +(in-package :usocket) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (require :sock) + ;; for wait-for-input: + (require :process) + ;; note: the line below requires ACL 6.2+ + (require :osi)) + +(defun get-host-name () + ;; note: the line below requires ACL 7.0+ to actually *work* on windows + (excl.osi:gethostname)) + +(defparameter +allegro-identifier-error-map+ + '((:address-in-use . address-in-use-error) + (:address-not-available . address-not-available-error) + (:network-down . network-down-error) + (:network-reset . network-reset-error) + (:network-unreachable . network-unreachable-error) + (:connection-aborted . connection-aborted-error) + (:connection-reset . connection-reset-error) + (:no-buffer-space . no-buffers-error) + (:shutdown . shutdown-error) + (:connection-timed-out . timeout-error) + (:connection-refused . connection-refused-error) + (:host-down . host-down-error) + (:host-unreachable . host-unreachable-error))) + +(defun handle-condition (condition &optional (socket nil)) + "Dispatch correct usocket condition." + (typecase condition + (excl:socket-error + (let ((usock-err + (cdr (assoc (excl:stream-error-identifier condition) + +allegro-identifier-error-map+)))) + (if usock-err + (error usock-err :socket socket) + (error 'unknown-error + :real-error condition + :socket socket)))))) + +(defun to-format (element-type) + (if (subtypep element-type 'character) + :text + :binary)) + +(defun socket-connect (host port &key (element-type 'character) timeout nodelay) + (declare (ignore nodelay)) + (when timeout + (warn "SOCKET-CONNECT timeout not supported in Allegro CL")) + (let ((socket)) + (setf socket + (with-mapped-conditions (socket) + (socket:make-socket :remote-host (host-to-hostname host) + :remote-port port + :format (to-format element-type)))) + (make-stream-socket :socket socket :stream socket))) + + +;; One socket close method is sufficient, +;; because socket-streams are also sockets. +(defmethod socket-close ((usocket usocket)) + "Close socket." + (with-mapped-conditions (usocket) + (close (socket usocket)))) + +(defun socket-listen (host port + &key reuseaddress + (reuse-address nil reuse-address-supplied-p) + (backlog 5) + (element-type 'character)) + ;; Allegro and OpenMCL socket interfaces bear very strong resemblence + ;; whatever you change here, change it also for OpenMCL + (let* ((reuseaddress (if reuse-address-supplied-p reuse-address reuseaddress)) + (sock (with-mapped-conditions () + (apply #'socket:make-socket + (append (list :connect :passive + :reuse-address reuseaddress + :local-port port + :backlog backlog + :format (to-format element-type) + ;; allegro now ignores :format + ) + (when (ip/= host *wildcard-host*) + (list :local-host host))))))) + (make-stream-server-socket sock :element-type element-type))) + +(defmethod socket-accept ((socket stream-server-usocket) &key element-type) + (declare (ignore element-type)) ;; allegro streams are multivalent + (let ((stream-sock + (with-mapped-conditions (socket) + (socket:accept-connection (socket socket))))) + (make-stream-socket :socket stream-sock :stream stream-sock))) + +(defmethod get-local-address ((usocket usocket)) + (hbo-to-vector-quad (socket:local-host (socket usocket)))) + +(defmethod get-peer-address ((usocket stream-usocket)) + (hbo-to-vector-quad (socket:remote-host (socket usocket)))) + +(defmethod get-local-port ((usocket usocket)) + (socket:local-port (socket usocket))) + +(defmethod get-peer-port ((usocket stream-usocket)) + (socket:remote-port (socket usocket))) + +(defmethod get-local-name ((usocket usocket)) + (values (get-local-address usocket) + (get-local-port usocket))) + +(defmethod get-peer-name ((usocket stream-usocket)) + (values (get-peer-address usocket) + (get-peer-port usocket))) + + +(defun get-host-by-address (address) + (with-mapped-conditions () + (socket:ipaddr-to-hostname (host-to-hbo address)))) + +(defun get-hosts-by-name (name) + ;;###FIXME: ACL has the acldns module which returns all A records + ;; only problem: it doesn't fall back to tcp (from udp) if the returned + ;; structure is too long. + (with-mapped-conditions () + (list (hbo-to-vector-quad (socket:lookup-hostname + (host-to-hostname name)))))) + +(defun wait-for-input-internal (sockets &key timeout) + (with-mapped-conditions () + (let ((active-internal-sockets + (if timeout + (mp:wait-for-input-available (mapcar #'socket sockets) + :timeout timeout) + (mp:wait-for-input-available (mapcar #'socket sockets))))) + ;; this is quadratic, but hey, the active-internal-sockets + ;; list is very short and it's only quadratic in the length of that one. + ;; When I have more time I could recode it to something of linear + ;; complexity. + ;; [Same code is also used in lispworks.lisp, openmcl.lisp] + (remove-if #'(lambda (x) + (not (member (socket x) active-internal-sockets))) + sockets)))) Added: usocket/branches/hans/backend/armedbear.lisp ============================================================================== --- (empty file) +++ usocket/branches/hans/backend/armedbear.lisp Sat Jul 19 08:00:01 2008 @@ -0,0 +1,420 @@ +;;;; $Id: armedbear.lisp 335 2008-04-23 21:29:50Z hhubner $ +;;;; $URL: svn://common-lisp.net/project/usocket/svn/usocket/branches/hans/backend/arm… $ + +;;;; See LICENSE for licensing information. + +(in-package :usocket) + + +;;;;; Proposed contribution to the JAVA package + +(defpackage :jdi + (:use :cl) + (:export #:jcoerce + #:jop-deref + #:do-jmethod-call + #:do-jmethod + #:do-jstatic-call + #:do-jstatic + #:do-jnew-call + #:do-jfield + #:jequals)) +;; but still requires the :java package. + +(in-package :jdi) + +(defstruct (java-object-proxy (:conc-name :jop-) + :copier) + value + class) + +(defvar *jm-get-return-type* + (java:jmethod "java.lang.reflect.Method" "getReturnType")) + +(defvar *jf-get-type* + (java:jmethod "java.lang.reflect.Field" "getType")) + +(defvar *jc-get-declaring-class* + (java:jmethod "java.lang.reflect.Constructor" "getDeclaringClass")) + +(declaim (inline make-return-type-proxy)) +(defun make-return-type-proxy (jmethod jreturned-value) + (if (java:java-object-p jreturned-value) + (let ((rt (java:jcall *jm-get-return-type* jmethod))) + (make-java-object-proxy :value jreturned-value + :class rt)) + jreturned-value)) + +(defun make-field-type-proxy (jfield jreturned-value) + (if (java:java-object-p jreturned-value) + (let ((rt (java:jcall *jf-get-type* jfield))) + (make-java-object-proxy :value jreturned-value + :class rt)) + jreturned-value)) + +(defun make-constructor-type-proxy (jconstructor jreturned-value) + (if (java:java-object-p jreturned-value) + (let ((rt (java:jcall *jc-get-declaring-class* jconstructor))) + (make-java-object-proxy :value jreturned-value + :class rt)) + jreturned-value)) + +(defun jcoerce (instance &optional output-type-spec) + (cond + ((java-object-proxy-p instance) + (let ((new-instance (copy-structure (the java-object-proxy instance)))) + (setf (jop-class new-instance) + (java:jclass output-type-spec)) + new-instance)) + ((java:java-object-p instance) + (make-java-object-proxy :class (java:jclass output-type-spec) + :value instance)) + ((stringp instance) + (make-java-object-proxy :class "java.lang.String" + :value instance)) + ((keywordp output-type-spec) + ;; all that remains is creating an immediate type... + (let ((jval (java:make-immediate-object instance output-type-spec))) + (make-java-object-proxy :class output-type-spec + :value jval))) + )) + +(defun jtype-of (instance) ;;instance must be a jop + (cond + ((stringp instance) + "java.lang.String") + ((keywordp (jop-class instance)) + (string-downcase (symbol-name (jop-class instance)))) + (t + (java:jclass-name (jop-class instance))))) + +(defun jop-deref (instance) + (if (java-object-proxy-p instance) + (jop-value instance) + instance)) + +(defun java-value-and-class (object) + (values (jop-deref object) + (jtype-of object))) + +(defun do-jmethod-call (object method-name &rest arguments) + (multiple-value-bind + (instance class-name) + (java-value-and-class object) + (let* ((argument-types (mapcar #'jtype-of arguments)) + (jm (apply #'java:jmethod class-name method-name argument-types)) + (rv (apply #'java:jcall jm instance + (mapcar #'jop-deref arguments)))) + (make-return-type-proxy jm rv)))) + +(defun do-jstatic-call (class-name method-name &rest arguments) + (let* ((argument-types (mapcar #'jtype-of arguments)) + (jm (apply #'java:jmethod class-name method-name argument-types)) + (rv (apply #'java:jstatic jm (java:jclass class-name) + (mapcar #'jop-deref arguments)))) + (make-return-type-proxy jm rv))) + +(defun do-jnew-call (class-name &rest arguments) + (let* ((argument-types (mapcar #'jtype-of arguments)) + (jm (apply #'java:jconstructor class-name argument-types)) + (rv (apply #'java:jnew jm (mapcar #'jop-deref arguments)))) + (make-constructor-type-proxy jm rv))) + +(defun do-jfield (class-or-instance-or-name field-name) + (let* ((class (cond + ((stringp class-or-instance-or-name) + (java:jclass class-or-instance-or-name)) + ((java:java-object-p class-or-instance-or-name) + (java:jclass-of class-or-instance-or-name)) + ((java-object-proxy-p class-or-instance-or-name) + (java:jclass (jtype-of class-or-instance-or-name))))) + (jf (java:jcall (java:jmethod "java.lang.Class" "getField" + "java.lang.String") + class field-name))) + (make-field-type-proxy jf + (java:jfield class field-name)))) ;;class)))) + +(defmacro do-jstatic (&rest arguments) + `(do-jstatic-call ,@arguments)) + +(defmacro do-jmethod (&rest arguments) + `(do-jmethod-call ,@arguments)) + +;; + +(defmacro jstatic-call (class-name (method-name &rest arg-spec) + &rest args) + (let ((class-sym (gensym))) + `(let ((,class-sym ,class-name)) + (java:jstatic + (java:jmethod ,class-sym ,method-name ,@arg-spec) + (java:jclass ,class-sym) ,@args)))) + +(defmacro jmethod-call (instance-and-class (method &rest arg-spec) &rest args) + (let ((isym (gensym))) + (multiple-value-bind + (instance class-name) + (if (listp instance-and-class) + (values (first instance-and-class) + (second instance-and-class)) + (values instance-and-class)) + (when (null class-name) + (setf class-name `(java:jclass-name (java:jclass-of ,isym)))) + `(let* ((,isym ,instance)) + (java:jcall (java:jmethod ,class-name ,method ,@arg-spec) + ,isym ,@args))))) + +(defun jequals (x y) + (do-jmethod-call (jcoerce x "java.lang.Object") "equals" + (jcoerce y "java.lang.Object"))) + +(defmacro jnew-call ((class &rest arg-spec) &rest args) + `(java:jnew (java:jconstructor ,class ,@arg-spec) + ,@args)) + + + +(in-package :usocket) + +(defun get-host-name () + (jdi:do-jmethod-call (jdi:do-jstatic-call "java.net.InetAddress" + "getLocalHost") + "getHostName")) + +(defun handle-condition (condition &optional socket) + (typecase condition + (error (error 'unknown-error :socket socket :real-error condition)))) + +(defun socket-connect (host port &key (element-type 'character) timeout nodelay) + (declare (ignore nodelay)) + (when timeout + (warn "SOCKET-CONNECT timeout not supported in ABCL")) + (let ((usock)) + (with-mapped-conditions (usock) + (let* ((sock-addr (jdi:jcoerce + (jdi:do-jnew-call "java.net.InetSocketAddress" + (host-to-hostname host) + (jdi:jcoerce port :int)) + "java.net.SocketAddress")) + (jchan (jdi:do-jstatic-call "java.nio.channels.SocketChannel" + "open" sock-addr)) + (sock (jdi:do-jmethod-call jchan "socket"))) + (describe sock) + (setf usock + (make-stream-socket + :socket jchan + :stream (ext:get-socket-stream (jdi:jop-deref sock) + :element-type element-type))))))) + +(defun socket-listen (host port + &key reuseaddress + (reuse-address nil reuse-address-supplied-p) + (backlog 5) + (element-type 'character)) + (let* ((reuseaddress (if reuse-address-supplied-p reuse-address reuseaddress)) + (sock-addr (jdi:do-jnew-call "java.net.InetSocketAddress" + (host-to-hostname host) + (jdi:jcoerce port :int))) + (chan (jdi:do-jstatic-call "java.nio.channels.ServerSocketChannel" + "open")) + (sock (jdi:do-jmethod-call chan "socket"))) + (when reuseaddress + (with-mapped-conditions () + (jdi:do-jmethod-call sock + "setReuseAddress" + (jdi:jcoerce reuseaddress :boolean)))) + (with-mapped-conditions () + (jdi:do-jmethod-call sock + "bind" + (jdi:jcoerce sock-addr + "java.net.SocketAddress") + (jdi:jcoerce backlog :int))) + (make-stream-server-socket chan :element-type element-type))) + +(defmethod socket-accept ((socket stream-server-usocket) &key element-type) + (let* ((jsock (socket socket)) + (jacc-chan (with-mapped-conditions (socket) + (jdi:do-jmethod-call jsock "accept"))) + (jacc-stream + (ext:get-socket-stream (jdi:jop-deref + (jdi:do-jmethod-call jacc-chan "socket")) + :element-type (or element-type + (element-type socket))))) + (make-stream-socket :socket jacc-chan + :stream jacc-stream))) + +;;(defun print-java-exception (e) +;; (let* ((native-exception (java-exception-cause e))) +;; (print (jcall (jmethod "java.net.BindException" "getMessage") native-exception)))) + +(defmethod socket-close ((usocket usocket)) + (with-mapped-conditions (usocket) + (jdi:do-jmethod (socket usocket) "close"))) + +;; Socket streams are different objects than +;; socket streams. Closing the stream flushes +;; its buffers *and* closes the socket. +(defmethod socket-close ((usocket stream-usocket)) + (with-mapped-conditions (usocket) + (close (socket-stream usocket)))) + +(defmethod get-local-address ((usocket usocket)) + (dotted-quad-to-vector-quad (ext:socket-local-address (socket usocket)))) + +(defmethod get-peer-address ((usocket stream-usocket)) + (dotted-quad-to-vector-quad (ext:socket-peer-address (socket usocket)))) + +(defmethod get-local-port ((usocket usocket)) + (ext:socket-local-port (socket usocket))) + +(defmethod get-peer-port ((usocket stream-usocket)) + (ext:socket-peer-port (socket usocket))) + +(defmethod get-local-name ((usocket usocket)) + (values (get-local-address usocket) + (get-local-port usocket))) + +(defmethod get-peer-name ((usocket stream-usocket)) + (values (get-peer-address usocket) + (get-peer-port usocket))) + + +#| +Pseudo code version of what we're trying to do: + +We're being called with 2 args: + + - sockets (list) + - timeout (non-negative real) + +Selector := java.nio.channels.Selector.open() + +For all usockets + get the java socket + get its channel + register the channel with the selector + with ops (operations) OP_READ and OP_ACCEPT + +make the selector wait trunc(timeout*1000) miliseconds, + unless (null timeout), because then: + selectNow() + +retrieve the selectedKeys() set from the selector + unless select() returned 0 selected keys. + +for set-iterator.hasNextKey() + with that key + retrieve the channel + retrieve the channel's socket + add the retrieved socket to the list of ready sockets + +for all usockets + check if the associated java object + is in the list of ready sockets + it is? add it to the function result list + +close() the selector + +return the function result list. + +|# + +(defun op-read () + (jdi:do-jfield "java.nio.channels.SelectionKey" + "OP_READ")) + +(defun op-accept () + (jdi:do-jfield "java.nio.channels.SelectionKey" + "OP_ACCEPT")) + +(defun op-connect () + (jdi:do-jfield "java.nio.channels.SelectionKey" + "OP_CONNECT")) + +(defun valid-ops (jchannel) + (jdi:do-jmethod-call jchannel "validOps")) + +(defun channel-class (jchannel) + (let ((valid-ops (valid-ops jchannel))) + (cond ((/= 0 (logand valid-ops (op-connect))) + "java.nio.channels.SocketChannel") + ((/= 0 (logand valid-ops (op-accept))) + "java.nio.channels.ServerSocketChannel") + (t + "java.nio.channels.DatagramChannel")))) + +(defun socket-channel-class (socket) + (cond + ((stream-usocket-p socket) + "java.nio.channels.SocketChannel") + ((stream-server-usocket-p socket) + "java.nio.channels.ServerSocketChannel") + ((datagram-usocket-p socket) + "java.nio.channels.DatagramChannel"))) + +(defun wait-for-input-internal (sockets &key timeout) + (let* ((ops (logior (op-read) (op-accept))) + (selector (jdi:do-jstatic "java.nio.channels.Selector" "open")) + (channels (mapcar #'socket sockets))) + (unwind-protect + (with-mapped-conditions () + (let ((jfalse (java:make-immediate-object nil :boolean)) + (sel (jdi:jop-deref selector))) + (dolist (channel channels) + (let ((chan (jdi:jop-deref channel))) + (java:jcall (java:jmethod "java.nio.channels.SelectableChannel" + "configureBlocking" + "boolean") + chan jfalse) + (java:jcall (java:jmethod "java.nio.channels.SelectableChannel" + "register" + "java.nio.channels.Selector" "int") + chan sel (logand ops (valid-ops channel))))) + (let ((ready-count + (java:jcall (java:jmethod "java.nio.channels.Selector" + "select" + "long") + sel (truncate (* timeout 1000))))) + (when (< 0 ready-count) + ;; we actually have work to do + (let* ((selkeys (jdi:do-jmethod selector "selectedKeys")) + (selkey-iterator (jdi:do-jmethod selkeys "iterator")) + ready-sockets) + (loop while (java:jcall + (java:jmethod "java.util.Iterator" "hasNext") + (jdi:jop-deref selkey-iterator)) + do (let* ((key (jdi:jcoerce + (jdi:do-jmethod selkey-iterator "next") + "java.nio.channels.SelectionKey")) + (chan (jdi:jop-deref + (jdi:do-jmethod key "channel")))) + (push chan ready-sockets))) + (remove-if #'(lambda (s) + (not (member (jdi:jop-deref (socket s)) + ready-sockets + :test #'(lambda (x y) + (java:jcall (java:jmethod "java.lang.Object" + "equals" + "java.lang.Object") + x y))))) + sockets)))))) + ;; cancel all Selector registrations + (let* ((keys (jdi:do-jmethod selector "keys")) + (iter (jdi:do-jmethod keys "iterator"))) + (loop while (java:jcall (java:jmethod "java.util.Iterator" "hasNext") + (jdi:jop-deref iter)) + do (java:jcall + (java:jmethod "java.nio.channels.SelectionKey" "cancel") + (java:jcall (java:jmethod "java.util.Iterator" "next") + (jdi:jop-deref iter))))) + ;; close the selector + (java:jcall (java:jmethod "java.nio.channels.Selector" "close") + (jdi:jop-deref selector)) + ;; make all sockets blocking again. + (let ((jtrue (java:make-immediate-object t :boolean))) + (dolist (chan channels) + (java:jcall (java:jmethod "java.nio.channels.SelectableChannel" + "configureBlocking" + "boolean") + (jdi:jop-deref chan) jtrue)))))) + Added: usocket/branches/hans/backend/clisp.lisp ============================================================================== --- (empty file) +++ usocket/branches/hans/backend/clisp.lisp Sat Jul 19 08:00:01 2008 @@ -0,0 +1,232 @@ +;;;; $Id: clisp.lisp 335 2008-04-23 21:29:50Z hhubner $ +;;;; $URL: svn://common-lisp.net/project/usocket/svn/usocket/branches/hans/backend/cli… $ + +;;;; See LICENSE for licensing information. + +(in-package :usocket) + + +;; utility routine for looking up the current host name +(FFI:DEF-CALL-OUT get-host-name-internal + (:name "gethostname") + (:arguments (name (FFI:C-PTR (FFI:C-ARRAY-MAX ffi:character 256)) + :OUT :ALLOCA) + (len ffi:int)) + #+win32 (:library "WS2_32") + (:language #-win32 :stdc + #+win32 :stdc-stdcall) + (:return-type ffi:int)) + + +(defun get-host-name () + (multiple-value-bind (retcode name) + (get-host-name-internal 256) + (when (= retcode 0) + name))) + + +#+win32 +(defun remap-maybe-for-win32 (z) + (mapcar #'(lambda (x) + (cons (mapcar #'(lambda (y) + (+ 10000 y)) + (car x)) + (cdr x))) + z)) + +(defparameter +clisp-error-map+ + #+win32 + (append (remap-maybe-for-win32 +unix-errno-condition-map+) + (remap-maybe-for-win32 +unix-errno-error-map+)) + #-win32 + (append +unix-errno-condition-map+ + +unix-errno-error-map+)) + +(defun handle-condition (condition &optional (socket nil)) + "Dispatch correct usocket condition." + (typecase condition + (system::simple-os-error + (let ((usock-err + (cdr (assoc (car (simple-condition-format-arguments condition)) + +clisp-error-map+ :test #'member)))) + (when usock-err ;; don't claim the error if we don't know + ;; it's actually a socket error ... + (if (subtypep usock-err 'error) + (error usock-err :socket socket) + (signal usock-err :socket socket))))))) + +(defun socket-connect (host port &key (element-type 'character) timeout nodelay) + (declare (ignore nodelay)) + (when timeout + (warn "SOCKET-CONNECT timeout not supported in CLISP")) + (let ((socket) + (hostname (host-to-hostname host))) + (with-mapped-conditions (socket) + (setf socket + (socket:socket-connect port hostname + :element-type element-type + :buffered t))) + (make-stream-socket :socket socket + :stream socket))) ;; the socket is a stream too + +(defun socket-listen (host port + &key reuseaddress + (reuse-address nil reuse-address-supplied-p) + (backlog 5) + (element-type 'character)) + ;; clisp 2.39 sets SO_REUSEADDRESS to 1 by default; no need to + ;; to explicitly turn it on; unfortunately, there's no way to turn it off... + (declare (ignore reuseaddress reuse-address reuse-address-supplied-p)) + (let ((sock (apply #'socket:socket-server + (append (list port + :backlog backlog) + (when (ip/= host *wildcard-host*) + (list :interface host)))))) + (with-mapped-conditions () + (make-stream-server-socket sock :element-type element-type)))) + +(defmethod socket-accept ((socket stream-server-usocket) &key element-type) + (let ((stream + (with-mapped-conditions (socket) + (socket:socket-accept (socket socket) + :element-type (or element-type + (element-type socket)))))) + (make-stream-socket :socket stream + :stream stream))) + +;; Only one close method required: +;; sockets and their associated streams +;; are the same object +(defmethod socket-close ((usocket usocket)) + "Close socket." + (with-mapped-conditions (usocket) + (close (socket usocket)))) + +(defmethod socket-close ((usocket stream-server-usocket)) + (socket:socket-server-close (socket usocket))) + +(defmethod get-local-name ((usocket usocket)) + (multiple-value-bind + (address port) + (socket:socket-stream-local (socket usocket) t) + (values (dotted-quad-to-vector-quad address) port))) + +(defmethod get-peer-name ((usocket stream-usocket)) + (multiple-value-bind + (address port) + (socket:socket-stream-peer (socket usocket) t) + (values (dotted-quad-to-vector-quad address) port))) + +(defmethod get-local-address ((usocket usocket)) + (nth-value 0 (get-local-name usocket))) + +(defmethod get-peer-address ((usocket stream-usocket)) + (nth-value 0 (get-peer-name usocket))) + +(defmethod get-local-port ((usocket usocket)) + (nth-value 1 (get-local-name usocket))) + +(defmethod get-peer-port ((usocket stream-usocket)) + (nth-value 1 (get-peer-name usocket))) + + +(defmethod wait-for-input-internal (sockets &key timeout) + (with-mapped-conditions () + (multiple-value-bind + (secs musecs) + (split-timeout (or timeout 1)) + (let* ((request-list (mapcar #'(lambda (x) + (if (stream-server-usocket-p x) + (socket x) + (list (socket x) :input))) + sockets)) + (status-list (if timeout + (socket:socket-status request-list secs musecs) + (socket:socket-status request-list)))) + (remove nil + (mapcar #'(lambda (x y) + (when y x)) + sockets status-list)))))) + + +;; +;; UDP/Datagram sockets! +;; + +#+rawsock +(progn + + (defun make-sockaddr_in () + (make-array 16 :element-type '(unsigned-byte 8) :initial-element 0)) + + (declaim (inline fill-sockaddr_in)) + (defun fill-sockaddr_in (sockaddr_in ip port) + (port-to-octet-buffer sockaddr_in port) + (ip-to-octet-buffer sockaddr_in ip :start 2) + sockaddr_in) + + (defun socket-create-datagram (local-port + &key (local-host *wildcard-host*) + remote-host + remote-port) + (let ((sock (rawsock:socket :inet :dgram 0)) + (lsock_addr (fill-sockaddr_in (make-sockaddr_in) + local-host local-port)) + (rsock_addr (when remote-host + (fill-sockaddr_in (make-sockaddr_in) + remote-host (or remote-port + local-port))))) + (bind sock lsock_addr) + (when rsock_addr + (connect sock rsock_addr)) + (make-datagram-socket sock :connected-p (if rsock_addr t nil)))) + + (defun socket-receive (socket buffer &key (size (length buffer))) + "Returns the buffer, the number of octets copied into the buffer (received) +and the address of the sender as values." + (let* ((sock (socket socket)) + (sockaddr (when (not (connected-p socket)) + (rawsock:make-sockaddr))) + (rv (if sockaddr + (rawsock:recvfrom sock buffer sockaddr + :start 0 + :end size) + (rawsock:recv sock buffer + :start 0 + :end size)))) + (values buffer + rv + (list (ip-from-octet-buffer (sockaddr-data sockaddr) 4) + (port-from-octet-buffer (sockaddr-data sockaddr) 2))))) + + (defun socket-send (socket buffer &key address (size (length buffer))) + "Returns the number of octets sent." + (let* ((sock (socket socket)) + (sockaddr (when address + (rawsock:make-sockaddr :INET + (fill-sockaddr_in + (make-sockaddr_in) + (host-byte-order + (second address)) + (first address))))) + (rv (if address + (rawsock:sendto sock buffer sockaddr + :start 0 + :end size) + (rawsock:send sock buffer + :start 0 + :end size)))) + rv)) + + (defmethod socket-close ((usocket datagram-usocket)) + (rawsock:sock-close (socket usocket))) + + ) + +#-rawsock +(progn + (warn "This image doesn't contain the RAWSOCK package. +To enable UDP socket support, please be sure to use the -Kfull parameter +at startup, or to enable RAWSOCK support during compilation.") + + ) Added: usocket/branches/hans/backend/cmucl.lisp ============================================================================== --- (empty file) +++ usocket/branches/hans/backend/cmucl.lisp Sat Jul 19 08:00:01 2008 @@ -0,0 +1,190 @@ +;;;; $Id: cmucl.lisp 335 2008-04-23 21:29:50Z hhubner $ +;;;; $URL: svn://common-lisp.net/project/usocket/svn/usocket/branches/hans/backend/cmu… $ + +;;;; See LICENSE for licensing information. + +(in-package :usocket) + +#+win32 +(defun remap-for-win32 (z) + (mapcar #'(lambda (x) + (cons (mapcar #'(lambda (y) + (+ 10000 y)) + (car x)) + (cdr x))) + z)) + +(defparameter +cmucl-error-map+ + #+win32 + (append (remap-for-win32 +unix-errno-condition-map+) + (remap-for-win32 +unix-errno-error-map+)) + #-win32 + (append +unix-errno-condition-map+ + +unix-errno-error-map+)) + +(defun cmucl-map-socket-error (err &key condition socket) + (let ((usock-err + (cdr (assoc err +cmucl-error-map+ :test #'member)))) + (if usock-err + (if (subtypep usock-err 'error) + (error usock-err :socket socket) + (signal usock-err :socket socket)) + (error 'unknown-error + :socket socket + :real-error condition)))) + +;; CMUCL error handling is brain-dead: it doesn't preserve any +;; information other than the OS error string from which the +;; error can be determined. The OS error string isn't good enough +;; given that it may have been localized (l10n). +;; +;; The above applies to versions pre 19b; 19d and newer are expected to +;; contain even better error reporting. +;; +;; +;; Just catch the errors and encapsulate them in an unknown-error +(defun handle-condition (condition &optional (socket nil)) + "Dispatch correct usocket condition." + (typecase condition + (ext::socket-error (cmucl-map-socket-error (ext::socket-errno condition) + :socket socket + :condition condition)))) + +(defun socket-connect (host port &key (element-type 'character) timeout nodelay) + (declare (ignore nodelay)) + (when timeout + (warn "SOCKET-CONNECT timeout not supported in CMUCL")) + (let* ((socket)) + (setf socket + (with-mapped-conditions (socket) + (ext:connect-to-inet-socket (host-to-hbo host) port :stream))) + (if socket + (let* ((stream (sys:make-fd-stream socket :input t :output t + :element-type element-type + :buffering :full)) + ;;###FIXME the above line probably needs an :external-format + (usocket (make-stream-socket :socket socket + :stream stream))) + usocket) + (let ((err (unix:unix-errno))) + (when err (cmucl-map-socket-error err)))))) + +(defun socket-listen (host port + &key reuseaddress + (reuse-address nil reuse-address-supplied-p) + (backlog 5) + (element-type 'character)) + (let* ((reuseaddress (if reuse-address-supplied-p reuse-address reuseaddress)) + (server-sock + (with-mapped-conditions () + (apply #'ext:create-inet-listener + (append (list port :stream + :backlog backlog + :reuse-address reuseaddress) + (when (ip/= host *wildcard-host*) + (list :host + (host-to-hbo host)))))))) + (make-stream-server-socket server-sock :element-type element-type))) + +(defmethod socket-accept ((usocket stream-server-usocket) &key element-type) + (with-mapped-conditions (usocket) + (let* ((sock (ext:accept-tcp-connection (socket usocket))) + (stream (sys:make-fd-stream sock :input t :output t + :element-type (or element-type + (element-type usocket)) + :buffering :full))) + (make-stream-socket :socket sock :stream stream)))) + +;; Sockets and socket streams are represented +;; by different objects. Be sure to close the +;; socket stream when closing a stream socket. +(defmethod socket-close ((usocket stream-usocket)) + "Close socket." + (with-mapped-conditions (usocket) + (close (socket-stream usocket)))) + +(defmethod socket-close ((usocket usocket)) + "Close socket." + (with-mapped-conditions (usocket) + (ext:close-socket (socket usocket)))) + +(defmethod get-local-name ((usocket usocket)) + (multiple-value-bind + (address port) + (ext:get-socket-host-and-port (socket usocket)) + (values (hbo-to-vector-quad address) port))) + +(defmethod get-peer-name ((usocket stream-usocket)) + (multiple-value-bind + (address port) + (ext:get-peer-host-and-port (socket usocket)) + (values (hbo-to-vector-quad address) port))) + +(defmethod get-local-address ((usocket usocket)) + (nth-value 0 (get-local-name usocket))) + +(defmethod get-peer-address ((usocket stream-usocket)) + (nth-value 0 (get-peer-name usocket))) + +(defmethod get-local-port ((usocket usocket)) + (nth-value 1 (get-local-name usocket))) + +(defmethod get-peer-port ((usocket stream-usocket)) + (nth-value 1 (get-peer-name usocket))) + + +(defun lookup-host-entry (host) + (multiple-value-bind + (entry errno) + (ext:lookup-host-entry host) + (if entry + entry + ;;###The constants below work on *most* OSes, but are defined as the + ;; constants mentioned in C + (let ((exception + (second (assoc errno + '((1 ns-host-not-found-error) ;; HOST_NOT_FOUND + (2 ns-no-recovery-error) ;; NO_DATA + (3 ns-no-recovery-error) ;; NO_RECOVERY + (4 ns-try-again)))))) ;; TRY_AGAIN + (when exception + (error exception)))))) + + +(defun get-host-by-address (address) + (handler-case (ext:host-entry-name + (lookup-host-entry (host-byte-order address))) + (condition (condition) (handle-condition condition)))) + +(defun get-hosts-by-name (name) + (handler-case (mapcar #'hbo-to-vector-quad + (ext:host-entry-addr-list + (lookup-host-entry name))) + (condition (condition) (handle-condition condition)))) + +(defun get-host-name () + (unix:unix-gethostname)) + +(defun wait-for-input-internal (sockets &key timeout) + (with-mapped-conditions () + (alien:with-alien ((rfds (alien:struct unix:fd-set))) + (unix:fd-zero rfds) + (dolist (socket sockets) + (unix:fd-set (socket socket) rfds)) + (multiple-value-bind + (secs musecs) + (split-timeout (or timeout 1)) + (multiple-value-bind + (count err) + (unix:unix-fast-select (1+ (reduce #'max sockets + :key #'socket)) + (alien:addr rfds) nil nil + (when timeout secs) musecs) + (if (<= 0 count) + ;; process the result... + (remove-if #'(lambda (x) + (not (unix:fd-isset (socket x) rfds))) + sockets) + (progn + ;;###FIXME generate an error, except for EINTR + ))))))) Added: usocket/branches/hans/backend/lispworks.lisp ============================================================================== --- (empty file) +++ usocket/branches/hans/backend/lispworks.lisp Sat Jul 19 08:00:01 2008 @@ -0,0 +1,353 @@ +;;;; $Id: lispworks.lisp 335 2008-04-23 21:29:50Z hhubner $ +;;;; $URL: svn://common-lisp.net/project/usocket/svn/usocket/branches/hans/backend/lis… $ + +;;;; See LICENSE for licensing information. + +(in-package :usocket) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (require "comm")) + +#+win32 +(fli:register-module "ws2_32") + +(fli:define-foreign-function (get-host-name-internal "gethostname" :source) + ((return-string (:reference-return (:ef-mb-string :limit 257))) + (namelen :int)) + :lambda-list (&aux (namelen 256) return-string) + :result-type :int + #+win32 :module + #+win32 "ws2_32") + +(defun get-host-name () + (multiple-value-bind (retcode name) + (get-host-name-internal) + (when (= 0 retcode) + name))) + +#+win32 +(defun remap-maybe-for-win32 (z) + (mapcar #'(lambda (x) + (cons (mapcar #'(lambda (y) + (+ 10000 y)) + (car x)) + (cdr x))) + z)) + +(defparameter +lispworks-error-map+ + #+win32 + (append (remap-maybe-for-win32 +unix-errno-condition-map+) + (remap-maybe-for-win32 +unix-errno-error-map+)) + #-win32 + (append +unix-errno-condition-map+ + +unix-errno-error-map+)) + +(defun raise-or-signal-socket-error (errno socket) + (let ((usock-err + (cdr (assoc errno +lispworks-error-map+ :test #'member)))) + (if usock-err + (if (subtypep usock-err 'error) + (error usock-err :socket socket) + (signal usock-err :socket)) + (error 'unknown-error + :socket socket + :real-condition nil)))) + +(defun raise-usock-err (errno socket &optional condition) + (let* ((usock-err + (cdr (assoc errno +lispworks-error-map+ + :test #'member)))) + (if usock-err + (if (subtypep usock-err 'error) + (error usock-err :socket socket) + (signal usock-err :socket)) + (error 'unknown-error + :socket socket + :real-error condition)))) + +(defun handle-condition (condition &optional (socket nil)) + "Dispatch correct usocket condition." + (typecase condition + (simple-error (destructuring-bind (&optional host port err-msg errno) + (simple-condition-format-arguments condition) + (declare (ignore host port err-msg)) + (raise-usock-err errno socket condition))))) + +(defun socket-connect (host port &key (element-type 'base-char) timeout nodelay) + (declare (ignore nodelay)) + (when timeout + (warn "SOCKET-CONNECT timeout not supported in Lispworks")) + (let ((hostname (host-to-hostname host)) + (stream)) + (setf stream + (with-mapped-conditions () + (comm:open-tcp-stream hostname port + :element-type element-type))) + (if stream + (make-stream-socket :socket (comm:socket-stream-socket stream) + :stream stream) + (error 'unknown-error)))) + +(defun socket-listen (host port + &key reuseaddress + (reuse-address nil reuse-address-supplied-p) + (backlog 5) + (element-type 'base-char)) + (let* ((reuseaddress (if reuse-address-supplied-p reuse-address reuseaddress)) + (comm::*use_so_reuseaddr* reuseaddress) + (hostname (host-to-hostname host)) + (sock (with-mapped-conditions () + #-lispworks4.1 (comm::create-tcp-socket-for-service + port :address hostname :backlog backlog) + #+lispworks4.1 (comm::create-tcp-socket-for-service port)))) + (make-stream-server-socket sock :element-type element-type))) + +(defmethod socket-accept ((usocket stream-server-usocket) &key element-type) + (let* ((sock (with-mapped-conditions (usocket) + (comm::get-fd-from-socket (socket usocket)))) + (stream (make-instance 'comm:socket-stream + :socket sock + :direction :io + :element-type (or element-type + (element-type usocket))))) + #+win32 + (when sock + (setf (%ready-p usocket) nil)) + (make-stream-socket :socket sock :stream stream))) + +;; Sockets and their streams are different objects +;; close the stream in order to make sure buffers +;; are correctly flushed and the socket closed. +(defmethod socket-close ((usocket stream-usocket)) + "Close socket." + (close (socket-stream usocket))) + +(defmethod socket-close ((usocket usocket)) + (with-mapped-conditions (usocket) + (comm::close-socket (socket usocket)))) + +(defmethod get-local-name ((usocket usocket)) + (multiple-value-bind + (address port) + (comm:get-socket-address (socket usocket)) + (values (hbo-to-vector-quad address) port))) + +(defmethod get-peer-name ((usocket stream-usocket)) + (multiple-value-bind + (address port) + (comm:get-socket-peer-address (socket usocket)) + (values (hbo-to-vector-quad address) port))) + +(defmethod get-local-address ((usocket usocket)) + (nth-value 0 (get-local-name usocket))) + +(defmethod get-peer-address ((usocket stream-usocket)) + (nth-value 0 (get-peer-name usocket))) + +(defmethod get-local-port ((usocket usocket)) + (nth-value 1 (get-local-name usocket))) + +(defmethod get-peer-port ((usocket stream-usocket)) + (nth-value 1 (get-peer-name usocket))) + +(defun get-hosts-by-name (name) + (with-mapped-conditions () + (mapcar #'hbo-to-vector-quad + (comm:get-host-entry name :fields '(:addresses))))) + +(defun os-socket-handle (usocket) + (socket usocket)) + +(defun usocket-listen (usocket) + (if (stream-usocket-p usocket) + (when (listen (socket usocket)) + usocket) + (when (comm::socket-listen (socket usocket)) + usocket))) + +;;; +;;; Non Windows implementation +;;; The Windows implementation needs to resort to the Windows API in order +;;; to achieve what we want (what we want is waiting without busy-looping) +;;; + +#-win32 +(defun wait-for-input-internal (sockets &key timeout) + (with-mapped-conditions () + ;; unfortunately, it's impossible to share code between + ;; non-win32 and win32 platforms... + ;; Can we have a sane -pref. complete [UDP!?]- API next time, please? + (mapcar #'mp:notice-fd sockets + :key #'os-socket-handle) + (mp:process-wait-with-timeout "Waiting for a socket to become active" + (truncate timeout) + #'(lambda (socks) + (some #'usocket-listen socks)) + sockets) + (mapcar #'mp:unnotice-fd sockets + :key #'os-socket-handle) + (remove nil (mapcar #'usocket-listen sockets)))) + + +;;; +;;; The Windows side of the story +;;; We want to wait without busy looping +;;; This code only works in threads which don't have (hidden) +;;; windows which need to receive messages. There are workarounds in the Windows API +;;; but are those available to 'us'. +;;; + + +#+win32 +(progn + + ;; LispWorks doesn't provide an interface to wait for a socket + ;; to become ready (under Win32, that is) meaning that we need + ;; to resort to system calls to achieve the same thing. + ;; Luckily, it provides us access to the raw socket handles (as we + ;; wrote the code above. + (defconstant fd-read 1) + (defconstant fd-read-bit 0) + (defconstant fd-write 2) + (defconstant fd-write-bit 1) + (defconstant fd-oob 4) + (defconstant fd-oob-bit 2) + (defconstant fd-accept 8) + (defconstant fd-accept-bit 3) + (defconstant fd-connect 16) + (defconstant fd-connect-bit 4) + (defconstant fd-close 32) + (defconstant fd-close-bit 5) + (defconstant fd-qos 64) + (defconstant fd-qos-bit 6) + (defconstant fd-group-qos 128) + (defconstant fd-group-qos-bit 7) + (defconstant fd-routing-interface 256) + (defconstant fd-routing-interface-bit 8) + (defconstant fd-address-list-change 512) + (defconstant fd-address-list-change-bit 9) + + (defconstant fd-max-events 10) + + (defconstant fionread 1074030207) + + (fli:define-foreign-type ws-socket () '(:unsigned :int)) + (fli:define-foreign-type win32-handle () '(:unsigned :int)) + (fli:define-c-struct wsa-network-events (network-events :long) + (error-code (:c-array :int 10))) + + (fli:define-foreign-function (wsa-event-create "WSACreateEvent" :source) + () + :lambda-list nil + :result-type :int + :module "ws2_32") + (fli:define-foreign-function (wsa-event-close "WSACloseEvent" :source) + ((event-object win32-handle)) + :result-type :int + :module "ws2_32") + (fli:define-foreign-function (wsa-enum-network-events "WSAEnumNetworkEvents" :source) + ((socket ws-socket) + (event-object win32-handle) + (network-events (:reference-return wsa-network-events))) + :result-type :int + :module "ws2_32") + + (fli:define-foreign-function (wsa-event-select "WSAEventSelect" :source) + ((socket ws-socket) + (event-object win32-handle) + (network-events :long)) + :result-type :int + :module "ws2_32") + + (fli:define-foreign-function (wsa-get-last-error "WSAGetLastError" :source) + () + :result-type :int + :module "ws2_32") + + (fli:define-foreign-function (wsa-ioctlsocket "ioctlsocket" :source) + ((socket :long) (cmd :long) (argp (:ptr :long))) + :result-type :int + :module "ws2_32") + + + ;; The Windows system + + + ;; Now that we have access to the system calls, this is the plan: + + ;; 1. Receive a list of sockets to listen to + ;; 2. Add all those sockets to an event handle + ;; 3. Listen for an event on that handle (we have a LispWorks system:: internal for that) + ;; 4. After listening, detect if there are errors + ;; (this step is different from Unix, where we can have only one error) + ;; 5. If so, raise one of them + ;; 6. If not so, return the sockets which have input waiting for them + + + (defun maybe-wsa-error (rv &optional socket) + (unless (zerop rv) + (raise-usock-err (wsa-get-last-error) socket))) + + (defun bytes-available-for-read (socket) + (fli:with-dynamic-foreign-objects ((int-ptr :long)) + (let ((rv (wsa-ioctlsocket (os-socket-handle socket) fionread int-ptr))) + (if (= 0 rv) + (fli:dereference int-ptr) + 0)))) + + (defun add-socket-to-event (socket event-object) + (let ((events (etypecase socket + (stream-server-usocket (logior fd-connect fd-accept fd-close)) + (stream-usocket (logior fd-connect fd-read fd-oob fd-close))))) + (maybe-wsa-error + (wsa-event-select (os-socket-handle socket) event-object events) + socket))) + + (defun socket-ready-p (socket) + (if (typep socket 'stream-usocket) + (< 0 (bytes-available-for-read socket)) + (%ready-p socket))) + + (defun waiting-required (sockets) + (notany #'socket-ready-p sockets)) + + (defun wait-for-input-internal (sockets &key timeout) + (let ((event-object (wsa-event-create))) + (unwind-protect + (progn + (when (waiting-required sockets) + (dolist (socket sockets) + (add-socket-to-event socket event-object)) + (system:wait-for-single-object event-object + "Waiting for socket activity" timeout)) + (update-ready-slots sockets) + (sockets-ready sockets)) + (wsa-event-close event-object)))) + + (defun map-network-events (func network-events) + (let ((event-map (fli:foreign-slot-value network-events 'network-events)) + (error-array (fli:foreign-slot-pointer network-events 'error-code))) + (unless (zerop event-map) + (dotimes (i fd-max-events) + (unless (zerop (ldb (byte 1 i) event-map)) + (funcall func (fli:foreign-aref error-array i))))))) + + (defun update-ready-slots (sockets) + (dolist (socket sockets) + (unless (or (stream-usocket-p socket) ;; no need to check status for streams + (%ready-p socket)) ;; and sockets already marked ready + (multiple-value-bind + (rv network-events) + (wsa-enum-network-events (os-socket-handle socket) 0 t) + (if (zerop rv) + (map-network-events #'(lambda (err-code) + (if (zerop err-code) + (setf (%ready-p socket) t) + (raise-usock-err err-code socket))) + network-events) + (maybe-wsa-error rv socket)))))) + + (defun sockets-ready (sockets) + (remove-if-not #'socket-ready-p sockets)) + + );; end of WIN32-block Added: usocket/branches/hans/backend/openmcl.lisp ============================================================================== --- (empty file) +++ usocket/branches/hans/backend/openmcl.lisp Sat Jul 19 08:00:01 2008 @@ -0,0 +1,162 @@ +;;;; $Id: openmcl.lisp 335 2008-04-23 21:29:50Z hhubner $ +;;;; $URL: svn://common-lisp.net/project/usocket/svn/usocket/branches/hans/backend/ope… $ + +;;;; See LICENSE for licensing information. + +(in-package :usocket) + +(defun get-host-name () + (ccl::%stack-block ((resultbuf 256)) + (when (zerop (#_gethostname resultbuf 256)) + (ccl::%get-cstring resultbuf)))) + +(defparameter +openmcl-error-map+ + '((:address-in-use . address-in-use-error) + (:connection-aborted . connection-aborted-error) + (:no-buffer-space . no-buffers-error) + (:connection-timed-out . timeout-error) + (:connection-refused . connection-refused-error) + (:host-unreachable . host-unreachable-error) + (:host-down . host-down-error) + (:network-down . network-down-error) + (:address-not-available . address-not-available-error) + (:network-reset . network-reset-error) + (:connection-reset . connection-reset-error) + (:shutdown . shutdown-error) + (:access-denied . operation-not-permitted-error))) + + +;; we need something which the openmcl implementors 'forgot' to do: +;; wait for more than one socket-or-fd + +(defun input-available-p (sockets &optional ticks-to-wait) + (ccl::rletZ ((tv :timeval)) + (ccl::ticks-to-timeval ticks-to-wait tv) + (ccl::%stack-block ((infds ccl::*fd-set-size*)) + (ccl::fd-zero infds) + (let ((max-fd -1)) + (dolist (sock sockets) + (let ((fd (openmcl-socket:socket-os-fd sock))) + (setf max-fd (max max-fd fd)) + (ccl::fd-set fd infds))) + (let* ((res (#_select (1+ max-fd) + infds (ccl::%null-ptr) (ccl::%null-ptr) + (if ticks-to-wait tv (ccl::%null-ptr))))) + (when (> res 0) + (remove-if #'(lambda (x) + (not (ccl::fd-is-set (openmcl-socket:socket-os-fd x) + infds))) + sockets))))))) + +(defun raise-error-from-id (condition-id socket real-condition) + (let ((usock-err (cdr (assoc condition-id +openmcl-error-map+)))) + (if usock-err + (error usock-err :socket socket) + (error 'unknown-error :socket socket :real-error real-condition)))) + +(defun handle-condition (condition &optional socket) + (typecase condition + (openmcl-socket:socket-error + (raise-error-from-id (openmcl-socket:socket-error-identifier condition) + socket condition)) + (ccl:input-timeout + (error 'timeout-error :socket socket :real-error condition)) + (ccl:communication-deadline-expired + (error 'timeout-error :socket socket :real-error condition)) + (ccl::socket-creation-error #| ugh! |# + (raise-error-from-id (ccl::socket-creation-error-identifier condition) + socket condition)))) + +(defun to-format (element-type) + (if (subtypep element-type 'character) + :text + :binary)) + +(defun socket-connect (host port &key (element-type 'character) timeout deadline nodelay) + (with-mapped-conditions () + (let ((mcl-sock + (openmcl-socket:make-socket :remote-host (host-to-hostname host) + :remote-port port + :format (to-format element-type) + :deadline deadline + :nodelay nodelay + :connect-timeout (and timeout + (* timeout internal-time-units-per-second))))) + (openmcl-socket:socket-connect mcl-sock) + (make-stream-socket :stream mcl-sock :socket mcl-sock)))) + +(defun socket-listen (host port + &key reuseaddress + (reuse-address nil reuse-address-supplied-p) + (backlog 5) + (element-type 'character)) + (let* ((reuseaddress (if reuse-address-supplied-p reuse-address reuseaddress)) + (sock (with-mapped-conditions () + (apply #'openmcl-socket:make-socket + (append (list :connect :passive + :reuse-address reuseaddress + :local-port port + :backlog backlog + :format (to-format element-type)) + (when (ip/= host *wildcard-host*) + (list :local-host host))))))) + (make-stream-server-socket sock :element-type element-type))) + +(defmethod socket-accept ((usocket stream-server-usocket) &key element-type) + (declare (ignore element-type)) ;; openmcl streams are bi/multivalent + (let ((sock (with-mapped-conditions (usocket) + (openmcl-socket:accept-connection (socket usocket))))) + (make-stream-socket :socket sock :stream sock))) + +;; One close method is sufficient because sockets +;; and their associated objects are represented +;; by the same object. +(defmethod socket-close ((usocket usocket)) + (with-mapped-conditions (usocket) + (close (socket usocket)))) + +(defmethod get-local-address ((usocket usocket)) + (hbo-to-vector-quad (openmcl-socket:local-host (socket usocket)))) + +(defmethod get-peer-address ((usocket stream-usocket)) + (hbo-to-vector-quad (openmcl-socket:remote-host (socket usocket)))) + +(defmethod get-local-port ((usocket usocket)) + (openmcl-socket:local-port (socket usocket))) + +(defmethod get-peer-port ((usocket stream-usocket)) + (openmcl-socket:remote-port (socket usocket))) + +(defmethod get-local-name ((usocket usocket)) + (values (get-local-address usocket) + (get-local-port usocket))) + +(defmethod get-peer-name ((usocket stream-usocket)) + (values (get-peer-address usocket) + (get-peer-port usocket))) + +(defun get-host-by-address (address) + (with-mapped-conditions () + (openmcl-socket:ipaddr-to-hostname (host-to-hbo address)))) + +(defun get-hosts-by-name (name) + (with-mapped-conditions () + (list (hbo-to-vector-quad (openmcl-socket:lookup-hostname + (host-to-hostname name)))))) + +(defun wait-for-input-internal (sockets &key timeout) + (with-mapped-conditions () + (let* ((ticks-timeout (truncate (* (or timeout 1) ccl::*ticks-per-second*))) + (active-internal-sockets + (input-available-p (mapcar #'socket sockets) + (when timeout ticks-timeout)))) + ;; this is quadratic, but hey, the active-internal-sockets + ;; list is very short and it's only quadratic in the length of that one. + ;; When I have more time I could recode it to something of linear + ;; complexity. + ;; [Same code is also used in lispworks.lisp, allegro.lisp] + (remove-if #'(lambda (x) + (not (member (socket x) active-internal-sockets))) + sockets)))) + + Added: usocket/branches/hans/backend/sbcl.lisp ============================================================================== --- (empty file) +++ usocket/branches/hans/backend/sbcl.lisp Sat Jul 19 08:00:01 2008 @@ -0,0 +1,332 @@ +;;;; $Id: sbcl.lisp 335 2008-04-23 21:29:50Z hhubner $ +;;;; $URL: svn://common-lisp.net/project/usocket/svn/usocket/branches/hans/backend/sbc… $ + +;;;; See LICENSE for licensing information. + +(in-package :usocket) + +;; There's no way to preload the sockets library other than by requiring it +;; +;; ECL sockets has been forked off sb-bsd-sockets and implements the +;; same interface. We use the same file for now. +#+ecl +(eval-when (:compile-toplevel :load-toplevel :execute) + (require :sockets)) + +#+sbcl +(progn + #-win32 + (defun get-host-name () + (sb-unix:unix-gethostname)) + + ;; we assume winsock has already been loaded, after all, + ;; we already loaded sb-bsd-sockets and sb-alien + #+win32 + (defun get-host-name () + (sb-alien:with-alien ((buf (sb-alien:array sb-alien:char 256))) + (let ((result (sb-alien:alien-funcall + (sb-alien:extern-alien "gethostname" + (sb-alien:function sb-alien:int + (* sb-alien:char) + sb-alien:int)) + (sb-alien:cast buf (* sb-alien:char)) + 256))) + (when (= result 0) + (sb-alien:cast buf sb-alien:c-string)))))) + + +#+ecl +(progn + #-:wsock + (ffi:clines + "#include <errno.h>" + "#include <sys/socket.h>") + #+:wsock + (ffi:clines + "#ifndef FD_SETSIZE" + "#define FD_SETSIZE 1024" + "#endif" + "#include <winsock2.h>") + + (ffi:clines + "#include <ecl/ecl-inl.h>") + + #+:prefixed-api + (ffi:clines + "#define CONS(x, y) ecl_cons((x), (y))" + "#define MAKE_INTEGER(x) ecl_make_integer((x))") + #-:prefixed-api + (ffi:clines + "#define CONS(x, y) make_cons((x), (y))" + "#define MAKE_INTEGER(x) make_integer((x))") + + (defun fd-setsize () + (ffi:c-inline () () :fixnum + "FD_SETSIZE" :one-liner t)) + + (defun get-host-name () + (ffi:c-inline + () () :object + "{ char *buf = GC_malloc(256); + + if (gethostname(buf,256) == 0) + @(return) = make_simple_base_string(buf); + else + @(return) = Cnil; + }" :one-liner nil :side-effects nil)) + + (defun read-select (read-fds to-secs &optional (to-musecs 0)) + (ffi:c-inline (read-fds to-secs to-musecs) (t t :unsigned-int) (values t t) + "{ + fd_set rfds; + cl_object cur_fd = #0; + int count; + int max_fd = -1; + struct timeval tv; + + FD_ZERO(&rfds); + while (CONSP(cur_fd)) { + int fd = fixint(CAR(cur_fd)); + max_fd = (max_fd > fd) ? max_fd : fd; + FD_SET(fd, &rfds); + cur_fd = CDR(cur_fd); + } + + if (#1 != Cnil) { + tv.tv_sec = fixnnint(#1); + tv.tv_usec = #2; + } + count = select(max_fd + 1, &rfds, NULL, NULL, + (#1 != Cnil) ? &tv : NULL); + + if (count == 0) { + @(return 0) = Cnil; + @(return 1) = Cnil; + } else if (count < 0) { + /*###FIXME: We should be raising an error here... + + except, ofcourse in case of EINTR or EAGAIN */ + + @(return 0) = Cnil; + @(return 1) = MAKE_INTEGER(errno); + } else + { + cl_object rv = Cnil; + cur_fd = #0; + + /* when we're going to use the same code on Windows, + as well as unix, we can't be sure it'll fit into + a fixnum: these aren't unix filehandle bitmaps sets on + Windows... */ + + while (CONSP(cur_fd)) { + int fd = fixint(CAR(cur_fd)); + if (FD_ISSET(fd, &rfds)) + rv = CONS(MAKE_INTEGER(fd), rv); + + cur_fd = CDR(cur_fd); + } + @(return 0) = rv; + @(return 1) = Cnil; + } +}")) + +) + +(defun map-socket-error (sock-err) + (map-errno-error (sb-bsd-sockets::socket-error-errno sock-err))) + +(defparameter +sbcl-condition-map+ + '((interrupted-error . interrupted-condition))) + +(defparameter +sbcl-error-map+ + `((sb-bsd-sockets:address-in-use-error . address-in-use-error) + (sb-bsd-sockets::no-address-error . address-not-available-error) + (sb-bsd-sockets:bad-file-descriptor-error . bad-file-descriptor-error) + (sb-bsd-sockets:connection-refused-error . connection-refused-error) + (sb-bsd-sockets:invalid-argument-error . invalid-argument-error) + (sb-bsd-sockets:no-buffers-error . no-buffers-error) + (sb-bsd-sockets:operation-not-supported-error + . operation-not-supported-error) + (sb-bsd-sockets:operation-not-permitted-error + . operation-not-permitted-error) + (sb-bsd-sockets:protocol-not-supported-error + . protocol-not-supported-error) + #-ecl + (sb-bsd-sockets:unknown-protocol + . protocol-not-supported-error) + (sb-bsd-sockets:socket-type-not-supported-error + . socket-type-not-supported-error) + (sb-bsd-sockets:network-unreachable-error . network-unreachable-error) + (sb-bsd-sockets:operation-timeout-error . timeout-error) + (sb-bsd-sockets:socket-error . ,#'map-socket-error) + + ;; Nameservice errors: mapped to unknown-error + #-ecl #-ecl #-ecl + (sb-bsd-sockets:no-recovery-error . ns-no-recovery-error) + (sb-bsd-sockets:try-again-error . ns-try-again-condition) + (sb-bsd-sockets:host-not-found-error . ns-host-not-found-error))) + +(defun handle-condition (condition &optional (socket nil)) + "Dispatch correct usocket condition." + (typecase condition + (error (let* ((usock-error (cdr (assoc (type-of condition) + +sbcl-error-map+))) + (usock-error (if (functionp usock-error) + (funcall usock-error condition) + usock-error))) + (when usock-error + (error usock-error :socket socket)))) + (condition (let* ((usock-cond (cdr (assoc (type-of condition) + +sbcl-condition-map+))) + (usock-cond (if (functionp usock-cond) + (funcall usock-cond condition) + usock-cond))) + (if usock-cond + (signal usock-cond :socket socket)))))) + + +(defun socket-connect (host port &key (element-type 'character) timeout deadline nodelay) + (declare (ignore nodelay)) + (declare (ignore deadline)) + (when timeout + (warn "SOCKET-CONNECT timeout not supported in SBCL")) + (let* ((socket (make-instance 'sb-bsd-sockets:inet-socket + :type :stream :protocol :tcp)) + (stream (sb-bsd-sockets:socket-make-stream socket + :input t + :output t + :buffering :full + :element-type element-type)) + ;;###FIXME: The above line probably needs an :external-format + (usocket (make-stream-socket :stream stream :socket socket)) + (ip (host-to-vector-quad host))) + (with-mapped-conditions (usocket) + (sb-bsd-sockets:socket-connect socket ip port)) + usocket)) + +(defun socket-listen (host port + &key reuseaddress + (reuse-address nil reuse-address-supplied-p) + (backlog 5) + (element-type 'character)) + (let* ((reuseaddress (if reuse-address-supplied-p reuse-address reuseaddress)) + (ip (host-to-vector-quad host)) + (sock (make-instance 'sb-bsd-sockets:inet-socket + :type :stream :protocol :tcp))) + (with-mapped-conditions () + (setf (sb-bsd-sockets:sockopt-reuse-address sock) reuseaddress) + (sb-bsd-sockets:socket-bind sock ip port) + (sb-bsd-sockets:socket-listen sock backlog) + (make-stream-server-socket sock :element-type element-type)))) + +(defmethod socket-accept ((socket stream-server-usocket) &key element-type) + (with-mapped-conditions (socket) + (let ((sock (sb-bsd-sockets:socket-accept (socket socket)))) + (make-stream-socket + :socket sock + :stream (sb-bsd-sockets:socket-make-stream + sock + :input t :output t :buffering :full + :element-type (or element-type + (element-type socket))))))) + +;; Sockets and their associated streams are modelled as +;; different objects. Be sure to close the stream (which +;; closes the socket too) when closing a stream-socket. +(defmethod socket-close ((usocket usocket)) + (with-mapped-conditions (usocket) + (sb-bsd-sockets:socket-close (socket usocket)))) + +(defmethod socket-close ((usocket stream-usocket)) + (with-mapped-conditions (usocket) + (close (socket-stream usocket)))) + +(defmethod get-local-name ((usocket usocket)) + (sb-bsd-sockets:socket-name (socket usocket))) + +(defmethod get-peer-name ((usocket stream-usocket)) + (sb-bsd-sockets:socket-peername (socket usocket))) + +(defmethod get-local-address ((usocket usocket)) + (nth-value 0 (get-local-name usocket))) + +(defmethod get-peer-address ((usocket stream-usocket)) + (nth-value 0 (get-peer-name usocket))) + +(defmethod get-local-port ((usocket usocket)) + (nth-value 1 (get-local-name usocket))) + +(defmethod get-peer-port ((usocket stream-usocket)) + (nth-value 1 (get-peer-name usocket))) + + +(defun get-host-by-address (address) + (with-mapped-conditions () + (sb-bsd-sockets::host-ent-name + (sb-bsd-sockets:get-host-by-address address)))) + +(defun get-hosts-by-name (name) + (with-mapped-conditions () + (sb-bsd-sockets::host-ent-addresses + (sb-bsd-sockets:get-host-by-name name)))) + +#+sbcl +(progn + #-win32 + (defun wait-for-input-internal (sockets &key timeout) + (with-mapped-conditions () + (sb-alien:with-alien ((rfds (sb-alien:struct sb-unix:fd-set))) + (sb-unix:fd-zero rfds) + (dolist (socket sockets) + (sb-unix:fd-set + (sb-bsd-sockets:socket-file-descriptor (socket socket)) + rfds)) + (multiple-value-bind + (secs musecs) + (split-timeout (or timeout 1)) + (multiple-value-bind + (count err) + (sb-unix:unix-fast-select + (1+ (reduce #'max (mapcar #'socket sockets) + :key #'sb-bsd-sockets:socket-file-descriptor)) + (sb-alien:addr rfds) nil nil + (when timeout secs) musecs) + (if (null count) + (unless (= err sb-unix:EINTR) + (error (map-errno-error err))) + (when (< 0 count) + ;; process the result... + (remove-if + #'(lambda (x) + (not (sb-unix:fd-isset + (sb-bsd-sockets:socket-file-descriptor (socket x)) + rfds))) + sockets)))))))) + + #+win32 + (warn "wait-for-input not (yet!) supported...") + ) + +#+ecl +(progn + (defun wait-for-input-internal (sockets &key timeout) + (with-mapped-conditions () + (multiple-value-bind + (secs usecs) + (split-timeout (or timeout 1)) + (let* ((sock-fds (mapcar #'sb-bsd-sockets:socket-file-descriptor + (mapcar #'socket sockets)))) + (multiple-value-bind + (result-fds err) + (read-select sock-fds (when timeout secs) usecs) + (if (null err) + (remove-if #'(lambda (s) + (not + (member + (sb-bsd-sockets:socket-file-descriptor + (socket s)) + result-fds))) + sockets) + (error (map-errno-error err)))))))) + ) Added: usocket/branches/hans/backend/scl.lisp ============================================================================== --- (empty file) +++ usocket/branches/hans/backend/scl.lisp Sat Jul 19 08:00:01 2008 @@ -0,0 +1,170 @@ +;;;; $Id: scl.lisp 335 2008-04-23 21:29:50Z hhubner $ +;;;; $URL: svn://common-lisp.net/project/usocket/svn/usocket/branches/hans/backend/scl… $ + +;;;; See LICENSE for licensing information. + +(in-package :usocket) + +(defparameter +scl-error-map+ + (append +unix-errno-condition-map+ + +unix-errno-error-map+)) + +(defun scl-map-socket-error (err &key condition socket) + (let ((usock-err (cdr (assoc err +scl-error-map+ :test #'member)))) + (cond (usock-err + (if (subtypep usock-err 'error) + (error usock-err :socket socket) + (signal usock-err :socket socket))) + (t + (error 'unknown-error + :socket socket + :real-error condition))))) + +(defun handle-condition (condition &optional (socket nil)) + "Dispatch correct usocket condition." + (etypecase condition + (ext::socket-error + (scl-map-socket-error (ext::socket-errno condition) + :socket socket + :condition condition)))) + +(defun socket-connect (host port &key (element-type 'character) timeout nodelay) + (declare (ignore nodelay)) + (when timeout + (warn "SOCKET-CONNECT timeout not supported in SCL")) + (let* ((socket (with-mapped-conditions () + (ext:connect-to-inet-socket (host-to-hbo host) port + :kind :stream))) + (stream (sys:make-fd-stream socket :input t :output t + :element-type element-type + :buffering :full))) + (make-stream-socket :socket socket :stream stream))) + +(defun socket-listen (host port + &key reuseaddress + (reuse-address nil reuse-address-supplied-p) + (backlog 5) + (element-type 'character)) + (let* ((reuseaddress (if reuse-address-supplied-p reuse-address reuseaddress)) + (host (if (ip= host *wildcard-host*) + 0 + (host-to-hbo host))) + (server-sock + (with-mapped-conditions () + (ext:create-inet-listener port :stream + :host host + :reuse-address reuseaddress + :backlog backlog)))) + (make-stream-server-socket server-sock :element-type element-type))) + +(defmethod socket-accept ((usocket stream-server-usocket) &key element-type) + (with-mapped-conditions (usocket) + (let* ((sock (ext:accept-tcp-connection (socket usocket))) + (stream (sys:make-fd-stream sock :input t :output t + :element-type (or element-type + (element-type usocket)) + :buffering :full))) + (make-stream-socket :socket sock :stream stream)))) + +;; Sockets and their associated streams are modelled as +;; different objects. Be sure to close the socket stream +;; when closing stream-sockets; it makes sure buffers +;; are flushed and the socket is closed correctly afterwards. +(defmethod socket-close ((usocket usocket)) + "Close socket." + (with-mapped-conditions (usocket) + (ext:close-socket (socket usocket)))) + +(defmethod socket-close ((usocket stream-usocket)) + "Close socket." + (with-mapped-conditions (usocket) + (close (socket-stream usocket)))) + +(defmethod get-local-name ((usocket usocket)) + (multiple-value-bind (address port) + (with-mapped-conditions (usocket) + (ext:get-socket-host-and-port (socket usocket))) + (values (hbo-to-vector-quad address) port))) + +(defmethod get-peer-name ((usocket stream-usocket)) + (multiple-value-bind (address port) + (with-mapped-conditions (usocket) + (ext:get-peer-host-and-port (socket usocket))) + (values (hbo-to-vector-quad address) port))) + +(defmethod get-local-address ((usocket usocket)) + (nth-value 0 (get-local-name usocket))) + +(defmethod get-peer-address ((usocket stream-usocket)) + (nth-value 0 (get-peer-name usocket))) + +(defmethod get-local-port ((usocket usocket)) + (nth-value 1 (get-local-name usocket))) + +(defmethod get-peer-port ((usocket stream-usocket)) + (nth-value 1 (get-peer-name usocket))) + + +(defun get-host-by-address (address) + (multiple-value-bind (host errno) + (ext:lookup-host-entry (host-byte-order address)) + (cond (host + (ext:host-entry-name host)) + (t + (let ((condition (cdr (assoc errno +unix-ns-error-map+)))) + (cond (condition + (error condition :host-or-ip address)) + (t + (error 'ns-unknown-error :host-or-ip address + :real-error errno)))))))) + +(defun get-hosts-by-name (name) + (multiple-value-bind (host errno) + (ext:lookup-host-entry name) + (cond (host + (mapcar #'hbo-to-vector-quad + (ext:host-entry-addr-list host))) + (t + (let ((condition (cdr (assoc errno +unix-ns-error-map+)))) + (cond (condition + (error condition :host-or-ip name)) + (t + (error 'ns-unknown-error :host-or-ip name + :real-error errno)))))))) + +(defun get-host-name () + (unix:unix-gethostname)) + +(defun wait-for-input-internal (sockets &key timeout) + (let* ((pollfd-size (alien:alien-size (alien:struct unix::pollfd) :bytes)) + (nfds (length sockets)) + (bytes (* nfds pollfd-size))) + (alien:with-bytes (fds-sap bytes) + (do ((sockets sockets (rest sockets)) + (base 0 (+ base 8))) + ((endp sockets)) + (let ((fd (socket (first sockets)))) + (setf (sys:sap-ref-32 fds-sap base) fd) + (setf (sys:sap-ref-16 fds-sap (+ base 4)) unix::pollin))) + (multiple-value-bind (result errno) + (let ((thread:*thread-whostate* "Poll wait") + (timeout (if timeout + (truncate (* timeout 1000)) + -1))) + (declare (inline unix:unix-poll)) + (unix:unix-poll (alien:sap-alien fds-sap + (* (alien:struct unix::pollfd))) + nfds timeout)) + (cond ((not result) + (error "~@<Polling error: ~A~:@>" + (unix:get-unix-error-msg errno))) + (t + (do ((sockets sockets (rest sockets)) + (base 0 (+ base 8)) + (ready nil)) + ((endp sockets) + (nreverse ready)) + (let ((flags (sys:sap-ref-16 fds-sap (+ base 6)))) + (unless (zerop (logand flags unix::pollin)) + (push (first sockets) ready)))))))))) + Added: usocket/branches/hans/condition.lisp ============================================================================== --- (empty file) +++ usocket/branches/hans/condition.lisp Sat Jul 19 08:00:01 2008 @@ -0,0 +1,168 @@ +;;;; $Id: condition.lisp 325 2008-04-11 21:12:29Z ehuelsmann $ +;;;; $URL: svn://common-lisp.net/project/usocket/svn/usocket/branches/hans/condition.l… $ + +;;;; See LICENSE for licensing information. + +(in-package :usocket) + +;; Condition raised by operations with unsupported arguments +;; For trivial-sockets compatibility. + +(define-condition unsupported (error) + ((feature :initarg :feature :reader unsupported-feature))) + + +;; Conditions raised by sockets operations + +(define-condition socket-condition (condition) + ((socket :initarg :socket + :accessor usocket-socket)) + ;;###FIXME: no slots (yet); should at least be the affected usocket... + (:documentation "Parent condition for all socket related conditions.")) + +(define-condition socket-error (socket-condition error) + () ;; no slots (yet) + (:documentation "Parent error for all socket related errors")) + +(define-condition ns-condition (condition) + ((host-or-ip :initarg :host-or-ip + :accessor host-or-ip)) + (:documentation "Parent condition for all name resolution conditions.")) + +(define-condition ns-error (ns-condition error) + () + (:documentation "Parent error for all name resolution errors.")) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (defun define-usocket-condition-class (class &rest parents) + `(progn + (define-condition ,class ,parents ()) + (export ',class)))) + +(defmacro define-usocket-condition-classes (class-list parents) + `(progn ,@(mapcar #'(lambda (x) + (apply #'define-usocket-condition-class + x parents)) + class-list))) + +;; Mass define and export our conditions +(define-usocket-condition-classes + (interrupted-condition) + (socket-condition)) + +(define-condition unknown-condition (socket-condition) + ((real-condition :initarg :real-condition + :accessor usocket-real-condition)) + (:documentation "Condition raised when there's no other - more applicable - +condition available.")) + + +;; Mass define and export our errors +(define-usocket-condition-classes + (address-in-use-error + address-not-available-error + bad-file-descriptor-error + connection-refused-error + connection-aborted-error + connection-reset-error + invalid-argument-error + no-buffers-error + operation-not-supported-error + operation-not-permitted-error + protocol-not-supported-error + socket-type-not-supported-error + network-unreachable-error + network-down-error + network-reset-error + host-down-error + host-unreachable-error + shutdown-error + timeout-error + invalid-socket-error + invalid-socket-stream-error) + (socket-error)) + +(define-condition unknown-error (socket-error) + ((real-error :initarg :real-error + :accessor usocket-real-error)) + (:documentation "Error raised when there's no other - more applicable - +error available.")) + + +(define-usocket-condition-classes + (ns-try-again) + (ns-condition)) + +(define-condition ns-unknown-condition (ns-condition) + ((real-error :initarg :real-condition + :accessor ns-real-condition)) + (:documentation "Condition raised when there's no other - more applicable - +condition available.")) + +(define-usocket-condition-classes + ;; the no-data error code in the Unix 98 api + ;; isn't really an error: there's just no data to return. + ;; with lisp, we just return NIL (indicating no data) instead of + ;; raising an exception... + (ns-host-not-found-error + ns-no-recovery-error) + (ns-error)) + +(define-condition ns-unknown-error (ns-error) + ((real-error :initarg :real-error + :accessor ns-real-error)) + (:documentation "Error raised when there's no other - more applicable - +error available.")) + +(defmacro with-mapped-conditions ((&optional socket) &body body) + `(handler-bind ((condition #'(lambda (c) (handle-condition c ,socket)))) + ,@body)) + +(defparameter +unix-errno-condition-map+ + `(((11) . retry-condition) ;; EAGAIN + ((35) . retry-condition) ;; EDEADLCK + ((4) . interrupted-condition))) ;; EINTR + +(defparameter +unix-errno-error-map+ + ;;### the first column is for non-(linux or srv4) systems + ;; the second for linux + ;; the third for srv4 + ;;###FIXME: How do I determine on which Unix we're running + ;; (at least in clisp and sbcl; I know about cmucl...) + ;; The table below works under the assumption we'll *only* see + ;; socket associated errors... + `(((48 98) . address-in-use-error) + ((49 99) . address-not-available-error) + ((9) . bad-file-descriptor-error) + ((61 111) . connection-refused-error) + ((64 131) . connection-reset-error) + ((130) . connection-aborted-error) + ((22) . invalid-argument-error) + ((55 105) . no-buffers-error) + ((12) . out-of-memory-error) + ((45 95) . operation-not-supported-error) + ((1) . operation-not-permitted-error) + ((43 92) . protocol-not-supported-error) + ((44 93) . socket-type-not-supported-error) + ((51 101) . network-unreachable-error) + ((50 100) . network-down-error) + ((52 102) . network-reset-error) + ((58 108) . already-shutdown-error) + ((60 110) . timeout-error) + ((64 112) . host-down-error) + ((65 113) . host-unreachable-error))) + + +(defun map-errno-condition (errno) + (cdr (assoc errno +unix-errno-error-map+ :test #'member))) + + +(defun map-errno-error (errno) + (cdr (assoc errno +unix-errno-error-map+ :test #'member))) + + +(defparameter +unix-ns-error-map+ + `((1 . ns-host-not-found-error) + (2 . ns-try-again-condition) + (3 . ns-no-recovery-error))) + Added: usocket/branches/hans/doc/backends.txt ============================================================================== --- (empty file) +++ usocket/branches/hans/doc/backends.txt Sat Jul 19 08:00:01 2008 @@ -0,0 +1,59 @@ + -*- text -*- + +$Id: backends.txt 182 2007-01-19 23:43:12Z ehuelsmann $ + +A document to describe which APIs a backend should implement. + + +Each backend should implement: + +Functions: + + - handle-condition + - socket-connect + - socket-listen + - get-hosts-by-name [ optional ] + - get-host-by-address [ optional ] + + +Methods: + + - socket-close + - socket-accept + - get-local-name + - get-peer-name + + and - for ip sockets - these methods: + + - get-local-address + - get-local-port + - get-peer-address + - get-peer-port + + +An error-handling function, resolving implementation specific errors +to this list of errors: + + - address-in-use-error + - address-not-available-error + - bad-file-descriptor-error + - connection-refused-error + - invalid-argument-error + - no-buffers-error + - operation-not-supported-error + - operation-not-permitted-error + - protocol-not-supported-error + - socket-type-not-supported-error + - network-unreachable-error + - network-down-error + - network-reset-error + - host-down-error + - host-unreachable-error + - shutdown-error + - timeout-error + - unkown-error + +and these conditions: + + - interrupted-condition + - unkown-condition Added: usocket/branches/hans/doc/design.txt ============================================================================== --- (empty file) +++ usocket/branches/hans/doc/design.txt Sat Jul 19 08:00:01 2008 @@ -0,0 +1,136 @@ + + -*- text -*- + +$Id: design.txt 122 2006-10-22 08:42:00Z ehuelsmann $ + + + usocket: Universal sockets library + ================================== + +Contents +======== + + * Motivation + * Design goal + * Functional requirements + * Class structure + + + +Motivation +========== + +There are 2 other portability sockets packages [that I know of] +out there: + + 1) trivial-sockets + 2) acl-compat (which is a *lot* broader, but contains sockets too) + +The first misses some functionality which is fundamental when +the requirements stop being 'trivial', such as finding out the +addresses of either side connected to the tcp/ip stream. + +The second, being a complete compatibility library for Allegro, +contains much more than only sockets. Next to that, as the docs +say, is it mainly directed at providing the functionality required +to port portable-allegroserve - meaning it may be (very) incomplete +on some platforms. + +So, that's why I decided to inherit Erik Enge's project to build +a library with the intention to provide portability code in only +1 area of programming, targeted at 'not so trivial' programming. + +Also, I need this library to extend cl-irc with full DCC functionality. + + + +Design goal +=========== + +To provide a portable TCP/IP socket interface for as many +implementations as possible, while keeping the portability layer +as thin as possible. + + + +Functional requirements +======================= + +The interface provided should allow: + - 'client'/active sockets + - 'server'/listening sockets + - provide the usual stream methods to operate on the connection stream + (not necessarily the socket itself; maybe a socket slot too) + +For now, as long as there are no possibilities to have UDP sockets +to write a DNS client library: (which in the end may work better, +because in this respect all implementations are different...) + - retrieve IP addresses/ports for both sides of the connection + +Several relevant support functionalities will have to be provided too: + - long <-> quad-vector operators + - quad-vector <-> string operators + - hostname <-> quad-vector operators (hostname resolution) + + +Minimally, I'd like to support: + - SBCL + - CMUCL + - ABCL (ArmedBear) + - clisp + - Allegro + - LispWorks + - OpenMCL + + +Comments on the design above +============================ + +I don't think it's a good idea to implement name lookup in the +very first of steps: we'll see if this is required to get the +package accepted; not all implementations support it. + +Name resolution errors ... +Since there is no name resolution library (yet), nor standardized +hooks into the standard C library to do it the same way on +all platforms, name resolution errors can manifest themselves +in a lot of different ways. How to marshall these to the +library users? + +Several solutions come to mind: + +1) Map them to 'unknown-error +2) Give them their own errors and map to those + ... which implies that they are actually supported atm. +3) ... + +Given that the library doesn't now, but may in the future, +include name resolution officially, I tend to think (1) is the +right answer: it leaves it all undecided. + +These errors can be raised by the nameresolution service +(netdb.h) as values for 'int h_errno': + +- HOST_NOT_FOUND (1) +- TRY_AGAIN (2) /* Server fail or non-authoritive Host not found */ +- NO_RECOVERY (3) /* Failed permanently */ +- NO_DATA (4) /* Valid address, no data for requested record */ + +int *__h_errno_location(void) points to thread local h_errno on +threaded glibc2 systems. + + +Class structure +=============== + + usocket + | + +- datagram-usocket + +- stream-usocket + \- stream-server-usocket + +The usocket class will have methods to query local properties, such +as: + + - get-local-name: to query to which interface the socket is bound + - <other socket and protocol options such as SO_REUSEADDRESS> Added: usocket/branches/hans/notes/abcl-socket.txt ============================================================================== --- (empty file) +++ usocket/branches/hans/notes/abcl-socket.txt Sat Jul 19 08:00:01 2008 @@ -0,0 +1,18 @@ + +ABCL provides a callback interface to java objects, next to these calls: + + - ext:make-socket + - ext:socket-close + - ext:make-server-socket + - ext:socket-accept + - ext:get-socket-stream (returning an io-stream) + +abcl-swank (see SLIME) shows how to call directly into java. + + +See for the sockets implementation: + + - src/org/armedbear/lisp + * socket.lisp + * socket_stream.java + * SocketStream.java Added: usocket/branches/hans/notes/active-sockets-apis.txt ============================================================================== --- (empty file) +++ usocket/branches/hans/notes/active-sockets-apis.txt Sat Jul 19 08:00:01 2008 @@ -0,0 +1,75 @@ + -*- text -*- + +A document to summarizing which API's of the different implementations +are associated with 'Step 1'. + +Interface to be implemented in step 1: + + - socket-connect + - socket-close + - get-host-by-address + - get-hosts-by-name + +(and something to do with errors; maybe move this to step 1a?) + +SBCL +==== + + sockets: + - socket-bind + - make-instance 'inet-socket + - socket-make-stream + - socket-connect (ip vector-quad) port + - socket-close + + DNS name resolution: + - get-host-by-name + - get-host-by-address + - ::host-ent-addresses + - host-ent-name + + +CMUCL +===== + + sockets: + - ext:connect-to-inet-socket (ip integer) port + - sys:make-fd-stream + - ext:close-socket + + DNS name resolution: + - ext:host-entry-name + - ext::lookup-host-entry + - ext:host-entry-addr-list + - ext:lookup-host-entry + + +ABCL +==== + + sockets + - ext:socket-connect (hostname string) port + - ext:get-socket-stream + - ext:socket-close + + +clisp +===== + + sockets + - socket-connect port (hostname string) + - close (socket) + + +Allegro +======= + + sockets + - make-socket + - socket-connect + - close + + DNS resolution + - lookup-hostname + - ipaddr-to-hostname + Added: usocket/branches/hans/notes/address-apis.txt ============================================================================== --- (empty file) +++ usocket/branches/hans/notes/address-apis.txt Sat Jul 19 08:00:01 2008 @@ -0,0 +1,73 @@ + + -*- text -*- + +Step 2 of the master plan: Implementing (get-local-address sock) and +(get-peer-address sock). + + +Step 2 is about implementing: + + (get-local-address sock) -> ip + (get-peer-address sock) -> ip + (get-local-port sock) -> port + (get-peer-port sock) -> port + (get-local-name sock) -> ip, port + (get-peer-name sock) -> ip, port + + +ABCL +==== + + FFI / J-calls to "getLocalAddress"+"getAddress", "getLocalPort" (local) + FFI / J-calls to "getInetAddress"+"getAddress", "getPort" (peer) + + (see SLIME / swank-abcl.lisp for an example on how to do that) + + +Allegro +======= + + (values (socket:remote-host sock) + (socket:remote-port)) -> 32bit ip, port + + (values (socket:local-host sock) + (socket:local-port sock)) -> 32bit ip, port + +CLISP +===== + + (socket:socket-stream-local sock nil) -> address (as dotted quad), port + (socket:socket-stream-peer sock nil) -> address (as dotted quad), port + + +CMUCL +===== + + (ext:get-peer-host-and-port sock-fd) -> 32-bit-addr, port (peer) + (ext:get-socket-host-and-port sock-fd) -> 32-bit-addr, port (local) + + +LispWorks +========= + + (comm:socket-stream-address sock-stream) -> 32-bit-addr, port + or: (comm:get-socket-address sock) -> 32-bit-addr, port + + (comm:socket-stream-peer-address sock-stream) -> 32-bit-addr, port + or: (comm:get-socket-peer-address sock) -> 32-bit-addr, port + + +OpenMCL +======= + + (values (ccl:local-host sock) (ccl:local-port sock)) -> 32-bit ip, port + (values (ccl:remote-host sock) (ccl:remote-port sock)) -> 32-bit ip, port + + +SBCL +==== + + (sb-bsd-sockets:socket-name sock) -> vector-quad, port + (sb-bsd-sockets:socket-peer-name sock) -> vector-quad, port + + Added: usocket/branches/hans/notes/allegro-socket.txt ============================================================================== --- (empty file) +++ usocket/branches/hans/notes/allegro-socket.txt Sat Jul 19 08:00:01 2008 @@ -0,0 +1,46 @@ + + +(require :sock) + +accept-connection (sock passive-socket) &key wait Generic function. +dotted-to-ipaddr dotted &key errorp Function. +ipaddr-to-dotted ipaddr &key values Function. +ipaddr-to-hostname ipaddr Function. +lookup-hostname hostname +lookup-port portname protocol Function. +make-socket &key type format address-family connect &allow-other-keys Function. +with-pending-connect &body body Macro. +receive-from (sock datagram-socket) size &key buffer extract Generic function. +send-to sock &key +shutdown sock &key direction +socket-control stream &key output-chunking output-chunking-eof input-chunking +socket-os-fd sock Generic function. + +remote-host socket Generic function. +local-host socket Generic function. +local-port socket + +remote-filename socket +local-filename socket +remote-port socket +socket-address-family socket +socket-connect socket +socket-format socket +socket-type socket + +errors + +:address-in-use Local socket address already in use +:address-not-available Local socket address not available +:network-down Network is down +:network-reset Network has been reset +:connection-aborted Connection aborted +:connection-reset Connection reset by peer +:no-buffer-space No buffer space +:shutdown Connection shut down +:connection-timed-out Connection timed out +:connection-refused Connection refused +:host-down Host is down +:host-unreachable Host is unreachable +:unknown Unknown error + Added: usocket/branches/hans/notes/clisp-sockets.txt ============================================================================== --- (empty file) +++ usocket/branches/hans/notes/clisp-sockets.txt Sat Jul 19 08:00:01 2008 @@ -0,0 +1,38 @@ +http://clisp.cons.org/impnotes.html#socket + +(SOCKET:SOCKET-SERVER &OPTIONAL [port-or-socket]) +(SOCKET:SOCKET-SERVER-HOST socket-server) +(SOCKET:SOCKET-SERVER-PORT socket-server) +(SOCKET:SOCKET-WAIT socket-server &OPTIONAL [seconds [microseconds]]) +(SOCKET:SOCKET-ACCEPT socket-server &KEY :ELEMENT-TYPE :EXTERNAL-FORMAT :BUFFERED :TIMEOUT) +(SOCKET:SOCKET-CONNECT port &OPTIONAL [host] &KEY :ELEMENT-TYPE :EXTERNAL-FORMAT :BUFFERED :TIMEOUT) +(SOCKET:SOCKET-STATUS socket-stream-or-list &OPTIONAL [seconds [microseconds]]) +(SOCKET:SOCKET-STREAM-HOST socket-stream) +(SOCKET:SOCKET-STREAM-PORT socket-stream) +(SOCKET:SOCKET-SERVICE-PORT &OPTIONAL service-name (protocol "tcp")) +(SOCKET:SOCKET-STREAM-PEER socket-stream [do-not-resolve-p]) +(SOCKET:SOCKET-STREAM-LOCAL socket-stream [do-not-resolve-p]) +(SOCKET:SOCKET-STREAM-SHUTDOWN socket-stream direction) +(SOCKET:SOCKET-OPTIONS socket-server &REST {option}*) + + +(posix:resolve-host-ipaddr &optional host) + +with the host-ent structure: + + name - host name + aliases - LIST of aliases + addr-list - LIST of IPs as dotted quads (IPv4) or coloned octets (IPv6) + addrtype - INTEGER address type IPv4 or IPv6 + + +Errors are of type + +SYSTEM::SIMPLE-OS-ERROR + with a 1 element (integer) SYSTEM::$FORMAT-ARGUMENTS list + +This integer stores the OS error reported; meaning WSA* codes on Win32 +and E* codes on *nix, only: unix.lisp in CMUCL shows +BSD, Linux and SRV4 have different number assignments for the same +E* constant names :-( + Added: usocket/branches/hans/notes/cmucl-sockets.txt ============================================================================== --- (empty file) +++ usocket/branches/hans/notes/cmucl-sockets.txt Sat Jul 19 08:00:01 2008 @@ -0,0 +1,69 @@ +http://cvs2.cons.org/ftp-area/cmucl/doc/cmu-user/internet.html + +$Id: cmucl-sockets.txt 91 2006-02-13 08:01:51Z ehuelsmann $ + +extensions:lookup-host-entry host + +[structure] +host-entry + + name aliases addr-type addr-list + +[Function] +extensions:create-inet-listener port &optional kind &key :reuse-address :backlog :interface + => socket fd + +[Function] +extensions:accept-tcp-connection unconnected + => socket fd, address + +[Function] +extensions:connect-to-inet-socket host port &optional kind + => socket fd + +[Function] +extensions:close-socket socket + + + +[Private function] +extensions::get-peer-host-and-port socket-fd + +[Private function] +extentsions::get-socket-host-and-port socket-fd + + + +There's currently only 1 condition to be raised: + + SOCKET-ERROR (derived from SIMPLE-ERROR) + which has a SOCKET-ERRNO slot containing the unix error number. + + + + +[Function] +extensions:add-oob-handler fd char handler + +[Function] +extensions:remove-oob-handler fd char + +[Function] +extensions:remove-all-oob-handlers fd + +[Function] +extensions:send-character-out-of-band fd char + +[Function] +extensions:create-inet-socket &optional type + => socket fd + +[Function] +extensions:get-socket-option socket level optname + +[Function] +extensions:set-socket-option socket level optname optval + +[Function] +extensions:ip-string addr + Added: usocket/branches/hans/notes/errors.txt ============================================================================== --- (empty file) +++ usocket/branches/hans/notes/errors.txt Sat Jul 19 08:00:01 2008 @@ -0,0 +1,20 @@ +EADDRINUSE 48 address-in-use-error +EADDRNOTAVAIL 49 address-not-available-error +EAGAIN interrupted-error ;; not 1 error code: bsd == 11; non-bsd == 35 +EBADF 9 bad-file-descriptor-error +ECONNREFUSED 61 connection-refused-error +EINTR 4 interrupted-error +EINVAL 22 invalid-argument-error +ENOBUFS 55 no-buffers-error +ENOMEM 12 out-of-memory-error +EOPNOTSUPP 45 operation-not-supported-error +EPERM 1 operation-not-permitted-error +EPROTONOSUPPORT 43 protocol-not-supported-error +ESOCKTNOSUPPORT 44 socket-type-not-supported-error +ENETUNREACH 51 network-unreachable-error +ENETDOWN 50 network-down-error +ENETRESET 52 network-reset-error +ESHUTDOWN 58 already-shutdown-error +ETIMEDOUT 60 connection-timeout-error +EHOSTDOWN 64 host-down-error +EHOSTUNREACH 65 host-unreachable-error Added: usocket/branches/hans/notes/lw-sockets.txt ============================================================================== --- (empty file) +++ usocket/branches/hans/notes/lw-sockets.txt Sat Jul 19 08:00:01 2008 @@ -0,0 +1,41 @@ + +$Id: lw-sockets.txt 91 2006-02-13 08:01:51Z ehuelsmann $ + +http://www.lispworks.com/reference/lwu41/lwref/LWRM_37.HTM + +Package: COMM + +ip-address-string +socket-stream-address +socket-stream-peer-address +start-up-server +start-up-server-and-mp +string-ip-address +with-noticed-socket-stream + +Needed components for usocket: + +comm::get-fd-from-socket socket-fd + => socket-fd + +comm::accept-connection-to-socket socket-fd + => socket-fd + +comm::close-socket +comm::create-tcp-socket-for-service + => socket-fd + +open-tcp-stream peer-host peer-port &key direction element-type + => socket-stream + +get-host-entry (see http://www.lispworks.com/documentation/lw445/LWRM/html/lwref-30.htm#pgfId-8…) +get-socket-address + +get-socket-peer-address + => address, port + +socket-stream socket-fd + => stream + +socket socket-stream (guessed from http://www.lispworks.com/documentation/lw445/LWRM/html/lwref-43.htm) + => socket-fd Added: usocket/branches/hans/notes/openmcl-sockets.txt ============================================================================== --- (empty file) +++ usocket/branches/hans/notes/openmcl-sockets.txt Sat Jul 19 08:00:01 2008 @@ -0,0 +1,27 @@ +http://openmcl.clozure.com/Doc/sockets.html + + make-socket [Function] + accept-connection [Function] + dotted-to-ipaddr [Function] + ipaddr-to-dotted [Function] + ipaddr-to-hostname [Function] + lookup-hostname [Function] + lookup-port [Function] + receive-from [Function] + send-to [Function] + shutdown [Function] + socket-os-fd [Function] + remote-port [Function] + local-host [Function] + local-port [Function] + + socket-address-family [Function] + + socket-connect [Function] + socket-format [Function] + socket-type [Function] + socket-error [Class] + socket-error-code [Function] + socket-error-identifier [Function] + socket-error-situation [Function] + close [method] Added: usocket/branches/hans/notes/sb-bsd-sockets.txt ============================================================================== --- (empty file) +++ usocket/branches/hans/notes/sb-bsd-sockets.txt Sat Jul 19 08:00:01 2008 @@ -0,0 +1,114 @@ +http://www.xach.com/sbcl/sb-bsd-sockets.html + +$Id: sb-bsd-sockets.txt 91 2006-02-13 08:01:51Z ehuelsmann $ + +package: sb-bsd-sockets + +class: socket + +slots: + + * file-descriptor : + * family : + * protocol : + * type : + * stream : + +operators: + + (socket-bind (s socket) &rest address) Generic Function + (socket-accept (socket socket)) Method + (socket-connect (s socket) &rest address) Generic Function + (socket-peername (socket socket)) Method + (socket-name (socket socket)) Method + (socket-receive (socket socket) buffer length &key oob peek waitall (element-type 'character)) Method + (socket-listen (socket socket) backlog) Method + (socket-close (socket socket)) Method + (socket-make-stream (socket socket) &rest args) Method + + (sockopt-reuse-address (socket socket) argument) Accessor + (sockopt-keep-alive (socket socket) argument) Accessor + (sockopt-oob-inline (socket socket) argument) Accessor + (sockopt-bsd-compatible (socket socket) argument) Accessor + (sockopt-pass-credentials (socket socket) argument) Accessor + (sockopt-debug (socket socket) argument) Accessor + (sockopt-dont-route (socket socket) argument) Accessor + (sockopt-broadcast (socket socket) argument) Accessor + (sockopt-tcp-nodelay (socket socket) argument) Accessor + +inet-domain sockets + +class: inet-socket + +slots: + + * family : + +operators: + + (make-inet-address dotted-quads) Function + (get-protocol-by-name name) Function + (make-inet-socket type protocol) Function + +file-domain sockets + +class: unix-socket + +slots: + + * family : + +class: host-ent + +Slots: + + * name : + * aliases : + * address-type : + * addresses : + + (host-ent-address (host-ent host-ent)) Method + (get-host-by-name host-name) Function + (get-host-by-address address) Function + (name-service-error where) Function + (non-blocking-mode (socket socket)) Method + +(define-socket-condition sockint::EADDRINUSE address-in-use-error) +(define-socket-condition sockint::EAGAIN interrupted-error) +(define-socket-condition sockint::EBADF bad-file-descriptor-error) +(define-socket-condition sockint::ECONNREFUSED connection-refused-error) +(define-socket-condition sockint::EINTR interrupted-error) +(define-socket-condition sockint::EINVAL invalid-argument-error) +(define-socket-condition sockint::ENOBUFS no-buffers-error) +(define-socket-condition sockint::ENOMEM out-of-memory-error) +(define-socket-condition sockint::EOPNOTSUPP operation-not-supported-error) +(define-socket-condition sockint::EPERM operation-not-permitted-error) +(define-socket-condition sockint::EPROTONOSUPPORT protocol-not-supported-error) +(define-socket-condition sockint::ESOCKTNOSUPPORT socket-type-not-supported-error) +(define-socket-condition sockint::ENETUNREACH network-unreachable-error) + +Exported errors: +* (apropos "ERROR" :sb-bsd-sockets) + +SB-BSD-SOCKETS:INTERRUPTED-ERROR +SB-BSD-SOCKETS:TRY-AGAIN-ERROR +* SB-BSD-SOCKETS:NO-RECOVERY-ERROR (EFAIL?) +SB-BSD-SOCKETS:CONNECTION-REFUSED-ERROR +SB-BSD-SOCKETS:INVALID-ARGUMENT-ERROR +* SB-BSD-SOCKETS:HOST-NOT-FOUND-ERROR +SB-BSD-SOCKETS:OPERATION-NOT-PERMITTED-ERROR +SB-BSD-SOCKETS:OPERATION-NOT-SUPPORTED-ERROR +SB-BSD-SOCKETS:PROTOCOL-NOT-SUPPORTED-ERROR +SB-BSD-SOCKETS:OPERATION-TIMEOUT-ERROR +SB-BSD-SOCKETS:SOCKET-TYPE-NOT-SUPPORTED-ERROR +SB-BSD-SOCKETS:NO-BUFFERS-ERROR +SB-BSD-SOCKETS:NETWORK-UNREACHABLE-ERROR +SB-BSD-SOCKETS:BAD-FILE-DESCRIPTOR-ERROR +SB-BSD-SOCKETS:ADDRESS-IN-USE-ERROR +SB-BSD-SOCKETS:OUT-OF-MEMORY-ERROR + +And 1 non-exported error: + +SB-BSD-SOCKETS::NO-ADDRESS-ERROR + +*-ed errors aren't yet addressed in the errorlist supported by usocket Added: usocket/branches/hans/notes/usock-sockets.txt ============================================================================== --- (empty file) +++ usocket/branches/hans/notes/usock-sockets.txt Sat Jul 19 08:00:01 2008 @@ -0,0 +1,28 @@ +Package: + + clisp : socket + cmucl : extensions + sbcl : sb-bsd-sockets + lw : comm + openmcl: openmcl-socket + allegro: sock + +Connecting (TCP/inet only) + + clisp : socket-connect port &optional [host] &key :element-type :external-format :buffered :timeout = > socket-stream + cmucl : connect-to-inet-socket host port &optional kind => file descriptor + sbcl : sb-socket-connect socket &rest address => socket + lw : open-tcp-stream hostname service &key direction element-type buffered => stream-object + openmcl: socket-connect socket => :active, :passive or nil + allegro: make-socket (&rest args &key type format connect address-family eol) => socket + +Closing + + clisp : close socket + cmucl : close-socket socket + sbcl : socket-close socket + lw : close socket + openmcl: close socket + allegro: close socket + +Errors \ No newline at end of file Added: usocket/branches/hans/package.lisp ============================================================================== --- (empty file) +++ usocket/branches/hans/package.lisp Sat Jul 19 08:00:01 2008 @@ -0,0 +1,62 @@ +;;;; $Id: package.lisp 326 2008-04-11 21:13:40Z ehuelsmann $ +;;;; $URL: svn://common-lisp.net/project/usocket/svn/usocket/branches/hans/package.lisp $ + +;;;; See the LICENSE file for licensing information. + +#+lispworks (cl:require "comm") + +(cl:eval-when (:execute :load-toplevel :compile-toplevel) + (cl:defpackage :usocket + (:use :cl) + (:export #:*wildcard-host* + #:*auto-port* + + #:socket-connect ; socket constructors and methods + #:socket-listen + #:socket-accept + #:socket-close + #:wait-for-input + #:get-local-address + #:get-peer-address + #:get-local-port + #:get-peer-port + #:get-local-name + #:get-peer-name + + #:with-connected-socket ; convenience macros + #:with-server-socket + #:with-client-socket + #:with-socket-listener + + #:usocket ; socket object and accessors + #:stream-usocket + #:stream-server-usocket + #:socket + #:socket-stream + #:datagram-usocket + + #:host-byte-order ; IP(v4) utility functions + #:hbo-to-dotted-quad + #:hbo-to-vector-quad + #:vector-quad-to-dotted-quad + #:dotted-quad-to-vector-quad + #:ip= + #:ip/= + + #:integer-to-octet-buffer ; Network utility functions + #:octet-buffer-to-integer + #:port-to-octet-buffer + #:port-from-octet-buffer + #:ip-to-octet-buffer + #:ip-from-octet-buffer + + #:with-mapped-conditions + #:socket-condition ; conditions + #:ns-condition + #:socket-error ; errors + #:ns-error + #:unknown-condition + #:ns-unknown-condition + #:unknown-error + #:ns-unknown-error))) + Added: usocket/branches/hans/run-usocket-tests.sh ============================================================================== --- (empty file) +++ usocket/branches/hans/run-usocket-tests.sh Sat Jul 19 08:00:01 2008 @@ -0,0 +1,57 @@ +#!/bin/sh + +# Test script to be run from the usocket source root +# +# Unfortunately, it currently works only with SBCL +# in my setup... +# +# I need to figure out how to setup ASDF with the other lisps +# I have installed: cmucl, ABCL, clisp, allegro and lispworks + +cd `dirname $0`/test +rm tests.log + +if test -z "$1" ; then + lisps=*.conf +else + lisps=$1 +fi + +for my_lisp_conf in $lisps ; do + + +args= +lisp_bin= +lisp_name= +lisp_exit="(quit result)" + +. $my_lisp_conf + +if test -z "$lisp_bin" ; then + echo "YOU NEED TO SET A LISP BINARY IN YOUR CONF FILE" + exit 1 +fi + +if test -z "$lisp_name" ; then + lisp_name="`basename \"$lisp_bin\"`" +fi + +echo " +#-sbcl (load \"asdf.lisp\") + +(asdf:operate #-sbcl 'asdf:load-source-op + #+sbcl 'asdf:load-op :usocket-test) + +(let ((result (if (usocket-test:do-tests) 1 0))) + $lisp_exit) +" | $lisp_bin $args + +if test $? -eq 1 ; then + echo "PASS: $lisp_name" >> tests.log +else + echo "FAIL: $lisp_name" >> tests.log +fi + +echo "Above the test results gathered for $lisp_name." + +done Added: usocket/branches/hans/test/abcl.conf.in ============================================================================== --- (empty file) +++ usocket/branches/hans/test/abcl.conf.in Sat Jul 19 08:00:01 2008 @@ -0,0 +1,10 @@ +# lisp binary test setup file + +args= + +# lisp_bin is required! +lisp_bin=~/src/abcl-0.0.9/abcl +lisp_name=ArmedBear + +# lisp_exit is required! +lisp_exit="(quit :status result)" Added: usocket/branches/hans/test/allegro.conf.in ============================================================================== --- (empty file) +++ usocket/branches/hans/test/allegro.conf.in Sat Jul 19 08:00:01 2008 @@ -0,0 +1,10 @@ +# lisp binary test setup file + +args="-batch" + +# lisp_bin is required! +lisp_bin="~/src/acl/acl70_trial/alisp" +lisp_name=Allegro + +# lisp_exit is required! +lisp_exit="(exit result :no-unwind t)" Added: usocket/branches/hans/test/clisp.conf.in ============================================================================== --- (empty file) +++ usocket/branches/hans/test/clisp.conf.in Sat Jul 19 08:00:01 2008 @@ -0,0 +1,10 @@ +# lisp binary test setup file + +args= + +# lisp_bin is required! +lisp_bin=clisp +lisp_name=clisp + +# lisp_exit is required! +lisp_exit="(quit result)" Added: usocket/branches/hans/test/cmucl.conf.in ============================================================================== --- (empty file) +++ usocket/branches/hans/test/cmucl.conf.in Sat Jul 19 08:00:01 2008 @@ -0,0 +1,10 @@ +# lisp binary test setup file + +args= + +# lisp_bin is required! +lisp_bin="~/src/bin/lisp" +lisp_name=CMUCL + +# lisp_exit is required! +lisp_exit="(unix:unix-exit result)" Added: usocket/branches/hans/test/package.lisp ============================================================================== --- (empty file) +++ usocket/branches/hans/test/package.lisp Sat Jul 19 08:00:01 2008 @@ -0,0 +1,13 @@ +;;;; $Id: package.lisp 57 2006-02-07 19:39:46Z ehuelsmann $ +;;;; $URL: svn://common-lisp.net/project/usocket/svn/usocket/branches/hans/test/packag… $ + +;;;; See the LICENSE file for licensing information. + +(in-package :cl-user) + +(eval-when (:execute :load-toplevel :compile-toplevel) + (defpackage :usocket-test + (:use :cl :regression-test) + (:nicknames :usoct) + (:export :do-tests :run-usocket-tests))) + Added: usocket/branches/hans/test/sbcl.conf.in ============================================================================== --- (empty file) +++ usocket/branches/hans/test/sbcl.conf.in Sat Jul 19 08:00:01 2008 @@ -0,0 +1,10 @@ +# lisp binary test setup file + +args= + +# lisp_bin is required! +lisp_bin=sbcl +lisp_name=SBCL + +# lisp_exit is required! +lisp_exit="(quit status :recklessly-p t)" Added: usocket/branches/hans/test/test-usocket.lisp ============================================================================== --- (empty file) +++ usocket/branches/hans/test/test-usocket.lisp Sat Jul 19 08:00:01 2008 @@ -0,0 +1,161 @@ +;;;; $Id: test-usocket.lisp 228 2007-04-08 21:56:25Z ehuelsmann $ +;;;; $URL: svn://common-lisp.net/project/usocket/svn/usocket/branches/hans/test/test-u… $ + +;;;; See LICENSE for licensing information. + +(in-package :usocket-test) + +;; The parameters below may need adjustments to match the system +;; the tests are run on. +(defparameter +non-existing-host+ "192.168.1.1") +(defparameter +unused-local-port+ 15213) +(defparameter *soc1* (usocket::make-stream-socket :socket :my-socket + :stream :my-stream)) +(eval-when (:compile-toplevel :load-toplevel :execute) + (defparameter +common-lisp-net+ #(80 68 86 115))) ;; common-lisp.net IP + +(defmacro with-caught-conditions ((expect throw) &body body) + `(catch 'caught-error + (handler-case + (progn ,@body) + (usocket:unknown-error (c) (if (typep c ,expect) + (throw 'caught-error ,throw) + (progn + (describe c) + (describe + (usocket::usocket-real-error c)) + c))) + (error (c) (if (typep c ,expect) + (throw 'caught-error ,throw) + (progn + (describe c) + c))) + (usocket:unknown-condition (c) (if (typep c ,expect) + (throw 'caught-error ,throw) + (progn + (describe c) + (describe + (usocket::usocket-real-condition c)) + c))) + (condition (c) (if (typep c ,expect) + (throw 'caught-error ,throw) + (progn + (describe c) + c)))))) + +(deftest make-socket.1 (usocket:socket *soc1*) :my-socket) +(deftest make-socket.2 (usocket:socket-stream *soc1*) :my-stream) + +(deftest socket-no-connect.1 + (with-caught-conditions ('usocket:socket-error nil) + (usocket:socket-connect "127.0.0.0" +unused-local-port+) + t) + nil) +(deftest socket-no-connect.2 + (with-caught-conditions ('usocket:socket-error nil) + (usocket:socket-connect #(127 0 0 0) +unused-local-port+) + t) + nil) +(deftest socket-no-connect.3 + (with-caught-conditions ('usocket:socket-error nil) + (usocket:socket-connect 2130706432 +unused-local-port+) ;; == #(127 0 0 0) + t) + nil) + +(deftest socket-failure.1 + (with-caught-conditions (#-(or cmu lispworks armedbear openmcl) + 'usocket:network-unreachable-error + #+(or cmu lispworks armedbear) + 'usocket:unknown-error + #+openmcl + 'usocket:timeout-error + nil) + (usocket:socket-connect 2130706432 +unused-local-port+) ;; == #(127 0 0 0) + :unreach) + nil) +(deftest socket-failure.2 + (with-caught-conditions (#+(or lispworks armedbear) + 'usocket:unknown-error + #+cmu + 'usocket:network-unreachable-error + #+openmcl + 'usocket:timeout-error + #-(or lispworks armedbear cmu openmcl) + 'usocket:host-unreachable-error + nil) + (usocket:socket-connect +non-existing-host+ 80) ;; 80 = just a port + :unreach) + nil) + + +;; let's hope c-l.net doesn't move soon, or that people start to +;; test usocket like crazy.. +(deftest socket-connect.1 + (with-caught-conditions (nil nil) + (let ((sock (usocket:socket-connect "common-lisp.net" 80))) + (unwind-protect + (typep sock 'usocket:usocket) + (usocket:socket-close sock)))) + t) +(deftest socket-connect.2 + (with-caught-conditions (nil nil) + (let ((sock (usocket:socket-connect +common-lisp-net+ 80))) + (unwind-protect + (typep sock 'usocket:usocket) + (usocket:socket-close sock)))) + t) +(deftest socket-connect.3 + (with-caught-conditions (nil nil) + (let ((sock (usocket:socket-connect (usocket::host-byte-order +common-lisp-net+) 80))) + (unwind-protect + (typep sock 'usocket:usocket) + (usocket:socket-close sock)))) + t) + +;; let's hope c-l.net doesn't change its software any time soon +(deftest socket-stream.1 + (with-caught-conditions (nil nil) + (let ((sock (usocket:socket-connect "common-lisp.net" 80))) + (unwind-protect + (progn + (format (usocket:socket-stream sock) + "GET / HTTP/1.0~A~A~A~A" + #\Return #\Newline #\Return #\Newline) + (force-output (usocket:socket-stream sock)) + (read-line (usocket:socket-stream sock))) + (usocket:socket-close sock)))) + #+clisp "HTTP/1.1 200 OK" + #-clisp #.(format nil "HTTP/1.1 200 OK~A" #\Return) nil) + +(deftest socket-name.1 + (with-caught-conditions (nil nil) + (let ((sock (usocket:socket-connect +common-lisp-net+ 80))) + (unwind-protect + (usocket::get-peer-address sock) + (usocket:socket-close sock)))) + #.+common-lisp-net+) +(deftest socket-name.2 + (with-caught-conditions (nil nil) + (let ((sock (usocket:socket-connect +common-lisp-net+ 80))) + (unwind-protect + (usocket::get-peer-port sock) + (usocket:socket-close sock)))) + 80) +(deftest socket-name.3 + (with-caught-conditions (nil nil) + (let ((sock (usocket:socket-connect +common-lisp-net+ 80))) + (unwind-protect + (usocket::get-peer-name sock) + (usocket:socket-close sock)))) + #.+common-lisp-net+ 80) +(deftest socket-name.4 + (with-caught-conditions (nil nil) + (let ((sock (usocket:socket-connect +common-lisp-net+ 80))) + (unwind-protect + (usocket::get-local-address sock) + (usocket:socket-close sock)))) + #(192 168 1 65)) + + +(defun run-usocket-tests () + (do-tests)) Added: usocket/branches/hans/test/usocket-test.asd ============================================================================== --- (empty file) +++ usocket/branches/hans/test/usocket-test.asd Sat Jul 19 08:00:01 2008 @@ -0,0 +1,22 @@ +;;;; $Id: usocket-test.asd 46 2006-02-06 20:50:07Z ehuelsmann $ +;;;; $URL: svn://common-lisp.net/project/usocket/svn/usocket/branches/hans/test/usocke… $ + +;;;; See the LICENSE file for licensing information. + +(in-package #:cl-user) + +(defpackage #:usocket-test-system + (:use #:cl #:asdf)) + +(in-package #:usocket-test-system) + +(defsystem usocket-test + :name "usocket-test" + :author "Erik Enge" + :version "0.1.0" + :licence "MIT" + :description "Tests for usocket" + :depends-on (:usocket :rt) + :components ((:file "package") + (:file "test-usocket" + :depends-on ("package")))) Added: usocket/branches/hans/test/your-lisp.conf.in ============================================================================== --- (empty file) +++ usocket/branches/hans/test/your-lisp.conf.in Sat Jul 19 08:00:01 2008 @@ -0,0 +1,10 @@ +# lisp binary test setup file + +args= + +# lisp_bin is required! +lisp_bin=<path-to-your-lisp-binary-here> +lisp_name= + +# lisp_exit is required! +lisp_exit= Added: usocket/branches/hans/usocket.asd ============================================================================== --- (empty file) +++ usocket/branches/hans/usocket.asd Sat Jul 19 08:00:01 2008 @@ -0,0 +1,43 @@ + +;;;; $Id: usocket.asd 320 2008-02-21 20:29:19Z ehuelsmann $ +;;;; $URL: svn://common-lisp.net/project/usocket/svn/usocket/branches/hans/usocket.asd $ + +;;;; See the LICENSE file for licensing information. + +(in-package #:cl-user) + +(defpackage #:usocket-system + (:use #:cl #:asdf)) + +(in-package #:usocket-system) + +(defsystem usocket + :name "usocket" + :author "Erik Enge & Erik Huelsmann" + :version "0.5.0-dev" + :licence "MIT" + :description "Universal socket library for Common Lisp" + :depends-on (:split-sequence + #+sbcl :sb-bsd-sockets) + :components ((:file "package") + (:file "usocket" + :depends-on ("package")) + (:file "condition" + :depends-on ("usocket")) + #+clisp (:file "clisp" :pathname "backend/clisp" + :depends-on ("condition")) + #+cmu (:file "cmucl" :pathname "backend/cmucl" + :depends-on ("condition")) + #+scl (:file "scl" :pathname "backend/scl" + :depends-on ("condition")) + #+(or sbcl ecl) (:file "sbcl" :pathname "backend/sbcl" + :depends-on ("condition")) + #+lispworks (:file "lispworks" :pathname "backend/lispworks" + :depends-on ("condition")) + #+openmcl (:file "openmcl" :pathname "backend/openmcl" + :depends-on ("condition")) + #+allegro (:file "allegro" :pathname "backend/allegro" + :depends-on ("condition")) + #+armedbear (:file "armedbear" :pathname "backend/armedbear" + :depends-on ("condition")) + )) Added: usocket/branches/hans/usocket.lisp ============================================================================== --- (empty file) +++ usocket/branches/hans/usocket.lisp Sat Jul 19 08:00:01 2008 @@ -0,0 +1,456 @@ +;;;; $Id: usocket.lisp 335 2008-04-23 21:29:50Z hhubner $ +;;;; $URL: svn://common-lisp.net/project/usocket/svn/usocket/branches/hans/usocket.lisp $ + +;;;; See LICENSE for licensing information. + +(in-package :usocket) + +(defparameter *wildcard-host* #(0 0 0 0) + "Hostname to pass when all interfaces in the current system are to be bound.") + +(defparameter *auto-port* 0 + "Port number to pass when an auto-assigned port number is wanted.") + +(defclass usocket () + ((socket + :initarg :socket + :accessor socket + :documentation "Implementation specific socket object instance.")) + (:documentation +"The main socket class. + +Sockets should be closed using the `socket-close' method.")) + +(defclass stream-usocket (usocket) + ((stream + :initarg :stream + :accessor socket-stream + :documentation "Stream instance associated with the socket." +;; +;;Iff an external-format was passed to `socket-connect' or `socket-listen' +;;the stream is a flexi-stream. Otherwise the stream is implementation +;;specific." +)) + (:documentation +"Stream socket class. + +Contrary to other sockets, these sockets may be closed either +with the `socket-close' method or by closing the associated stream +(which can be retrieved with the `socket-stream' accessor).")) + +(defclass stream-server-usocket (usocket) + ((element-type + :initarg :element-type + :initform #-lispworks 'character + #+lispworks 'base-char + :reader element-type + :documentation "Default element type for streams created by +`socket-accept'.") + #+(and lispworks win32) + (%ready-p + :initform nil + :accessor %ready-p + :documentation "Indicates whether the socket has been signalled +as ready for reading a new connection. + +The value will be set to T by `wait-for-input-internal' (given the +right conditions) and reset to NIL by `socket-accept'. + +Don't modify this slot or depend on it as it is really intended +to be internal only. +" + )) + (:documentation "Socket which listens for stream connections to +be initiated from remote sockets.")) + +(defun usocket-p (socket) + (typep socket 'usocket)) + +(defun stream-usocket-p (socket) + (typep socket 'stream-usocket)) + +(defun stream-server-usocket-p (socket) + (typep socket 'stream-server-usocket)) + +(defun datagram-usocket-p (socket) + (typep socket 'datagram-usocket)) + +(defclass datagram-usocket (usocket) + ((connected-p :initarg :connected-p :accessor connected-p)) + (:documentation "")) + +(defun make-socket (&key socket) + "Create a usocket socket type from implementation specific socket." + (unless socket + (error 'invalid-socket)) + (make-stream-socket :socket socket)) + +(defun make-stream-socket (&key socket stream) + "Create a usocket socket type from implementation specific socket +and stream objects. + +Sockets returned should be closed using the `socket-close' method or +by closing the stream associated with the socket. +" + (unless socket + (error 'invalid-socket-error)) + (unless stream + (error 'invalid-socket-stream-error)) + (make-instance 'stream-usocket + :socket socket + :stream stream)) + +(defun make-stream-server-socket (socket &key (element-type + #-lispworks 'character + #+lispworks 'base-char)) + "Create a usocket-server socket type from an +implementation-specific socket object. + +The returned value is a subtype of `stream-server-usocket'. +" + (unless socket + (error 'invalid-socket-error)) + (make-instance 'stream-server-usocket + :socket socket + :element-type element-type)) + +(defun make-datagram-socket (socket &key connected-p) + (unless socket + (error 'invalid-socket-error)) + (make-instance 'datagram-usocket + :socket socket + :connected-p connected-p)) + +(defgeneric socket-accept (socket &key element-type) + (:documentation + "Accepts a connection from `socket', returning a `stream-socket'. + +The stream associated with the socket returned has `element-type' when +explicitly specified, or the element-type passed to `socket-listen' otherwise.")) + +(defgeneric socket-close (usocket) + (:documentation "Close a previously opened `usocket'.")) + +(defgeneric get-local-address (socket) + (:documentation "Returns the IP address of the socket.")) + +(defgeneric get-peer-address (socket) + (:documentation + "Returns the IP address of the peer the socket is connected to.")) + +(defgeneric get-local-port (socket) + (:documentation "Returns the IP port of the socket. + +This function applies to both `stream-usocket' and `server-stream-usocket' +type objects.")) + +(defgeneric get-peer-port (socket) + (:documentation "Returns the IP port of the peer the socket to.")) + +(defgeneric get-local-name (socket) + (:documentation "Returns the IP address and port of the socket as values. + +This function applies to both `stream-usocket' and `server-stream-usocket' +type objects.")) + +(defgeneric get-peer-name (socket) + (:documentation + "Returns the IP address and port of the peer +the socket is connected to as values.")) + +(defgeneric set-socket-timeouts (socket read-timeout write-timeout) + (:documentation "Set the SO_RCVTIMEO and SO_SNDTIMEO socket options +for the SOCKET. Both READ-TIMEOUT and WRITE-TIMEOUT are speficied in +\(fractional) seconds.") + (:method ((usocket usocket) read-timeout write-timeout) + (set-socket-timeouts (socket usocket) read-timeout write-timeout))) + +(defmacro with-connected-socket ((var socket) &body body) + "Bind `socket' to `var', ensuring socket destruction on exit. + +`body' is only evaluated when `var' is bound to a non-null value. + +The `body' is an implied progn form." + `(let ((,var ,socket)) + (unwind-protect + (when ,var + (with-mapped-conditions (,var) + ,@body)) + (when ,var + (socket-close ,var))))) + +(defmacro with-client-socket ((socket-var stream-var &rest socket-connect-args) + &body body) + "Bind the socket resulting from a call to `socket-connect' with +the arguments `socket-connect-args' to `socket-var' and if `stream-var' is +non-nil, bind the associated socket stream to it." + `(with-connected-socket (,socket-var (socket-connect ,@socket-connect-args)) + ,(if (null stream-var) + `(progn ,@body) + `(let ((,stream-var (socket-stream ,socket-var))) + ,@body)))) + +(defmacro with-server-socket ((var server-socket) &body body) + "Bind `server-socket' to `var', ensuring socket destruction on exit. + +`body' is only evaluated when `var' is bound to a non-null value. + +The `body' is an implied progn form." + `(with-connected-socket (,var ,server-socket) + ,@body)) + +(defmacro with-socket-listener ((socket-var &rest socket-listen-args) + &body body) + "Bind the socket resulting from a call to `socket-listen' with arguments +`socket-listen-args' to `socket-var'." + `(with-server-socket (,socket-var (socket-listen ,@socket-listen-args)) + ,@body)) + + +(defgeneric wait-for-input (socket-or-sockets + &key timeout) + (:documentation +"Waits for one or more streams to become ready for reading from +the socket. When `timeout' (a non-negative real number) is +specified, wait `timeout' seconds, or wait indefinitely when +it isn't specified. A `timeout' value of 0 (zero) means polling. + +Returns two values: the first value is the list of streams which +are readable (or in case of server streams acceptable). NIL may +be returned for this value either when waiting timed out or when +it was interrupted (EINTR). The second value is a real number +indicating the time remaining within the timeout period or NIL if +none.")) + + +(defmethod wait-for-input (socket-or-sockets &key timeout) + (let* ((start (get-internal-real-time)) + (sockets (if (listp socket-or-sockets) + socket-or-sockets + (list socket-or-sockets))) + ;; retrieve a list of all sockets which are ready without waiting + (ready-sockets + (remove-if (complement #'(lambda (x) + (and (stream-usocket-p x) + (listen (socket-stream x))))) + sockets)) + ;; the internal routine is responsibe for + ;; making sure the wait doesn't block on socket-streams of + ;; which the socket isn't ready, but there's space left in the + ;; buffer + (result (wait-for-input-internal + sockets + :timeout (if (null ready-sockets) timeout 0)))) + (values (union ready-sockets result) + (when timeout + (let ((elapsed (/ (- (get-internal-real-time) start) + internal-time-units-per-second))) + (when (< elapsed timeout) + (- timeout elapsed))))))) + + +;; +;; Data utility functions +;; + +(defun integer-to-octet-buffer (integer buffer octets &key (start 0)) + (do ((b start (1+ b)) + (i (ash (1- octets) 3) ;; * 8 + (- i 8))) + ((> 0 i) buffer) + (setf (aref buffer b) + (ldb (byte 8 i) integer)))) + +(defun octet-buffer-to-integer (buffer octets &key (start 0)) + (let ((integer 0)) + (do ((b start (1+ b)) + (i (ash (1- octets) 3) ;; * 8 + (- i 8))) + ((> 0 i) + integer) + (setf (ldb (byte 8 i) integer) + (aref buffer b))))) + + +(defmacro port-to-octet-buffer (port buffer &key (start 0)) + `(integer-to-octet-buffer ,port ,buffer 2 ,start)) + +(defmacro ip-to-octet-buffer (ip buffer &key (start 0)) + `(integer-to-octet-buffer (host-byte-order ,ip) ,buffer 4 ,start)) + +(defmacro port-from-octet-buffer (buffer &key (start 0)) + `(octet-buffer-to-integer ,buffer 2 ,start)) + +(defmacro ip-from-octet-buffer (buffer &key (start 0)) + `(octet-buffer-to-integer ,buffer 4 ,start)) + +;; +;; IP(v4) utility functions +;; + +(defun list-of-strings-to-integers (list) + "Take a list of strings and return a new list of integers (from +parse-integer) on each of the string elements." + (let ((new-list nil)) + (dolist (element (reverse list)) + (push (parse-integer element) new-list)) + new-list)) + +(defun hbo-to-dotted-quad (integer) + "Host-byte-order integer to dotted-quad string conversion utility." + (let ((first (ldb (byte 8 24) integer)) + (second (ldb (byte 8 16) integer)) + (third (ldb (byte 8 8) integer)) + (fourth (ldb (byte 8 0) integer))) + (format nil "~A.~A.~A.~A" first second third fourth))) + +(defun hbo-to-vector-quad (integer) + "Host-byte-order integer to dotted-quad string conversion utility." + (let ((first (ldb (byte 8 24) integer)) + (second (ldb (byte 8 16) integer)) + (third (ldb (byte 8 8) integer)) + (fourth (ldb (byte 8 0) integer))) + (vector first second third fourth))) + +(defun vector-quad-to-dotted-quad (vector) + (format nil "~A.~A.~A.~A" + (aref vector 0) + (aref vector 1) + (aref vector 2) + (aref vector 3))) + +(defun dotted-quad-to-vector-quad (string) + (let ((list (list-of-strings-to-integers (split-sequence:split-sequence #\. string)))) + (vector (first list) (second list) (third list) (fourth list)))) + +(defgeneric host-byte-order (address)) +(defmethod host-byte-order ((string string)) + "Convert a string, such as 192.168.1.1, to host-byte-order, +such as 3232235777." + (let ((list (list-of-strings-to-integers (split-sequence:split-sequence #\. string)))) + (+ (* (first list) 256 256 256) (* (second list) 256 256) + (* (third list) 256) (fourth list)))) + +(defmethod host-byte-order ((vector vector)) + "Convert a vector, such as #(192 168 1 1), to host-byte-order, such as +3232235777." + (+ (* (aref vector 0) 256 256 256) (* (aref vector 1) 256 256) + (* (aref vector 2) 256) (aref vector 3))) + +(defmethod host-byte-order ((int integer)) + int) + +(defun host-to-hostname (host) + "Translate a string or vector quad to a stringified hostname." + (etypecase host + (string host) + ((vector t 4) (vector-quad-to-dotted-quad host)) + (integer (hbo-to-dotted-quad host)))) + +(defun ip= (ip1 ip2) + (etypecase ip1 + (string (string= ip1 (host-to-hostname ip2))) + ((vector t 4) (or (eq ip1 ip2) + (and (= (aref ip1 0) (aref ip2 0)) + (= (aref ip1 1) (aref ip2 1)) + (= (aref ip1 2) (aref ip2 2)) + (= (aref ip1 3) (aref ip2 3))))) + (integer (= ip1 (host-byte-order ip2))))) + +(defun ip/= (ip1 ip2) + (not (ip= ip1 ip2))) + +;; +;; DNS helper functions +;; + +#-(or clisp armedbear) +(progn + (defun get-host-by-name (name) + (let ((hosts (get-hosts-by-name name))) + (car hosts))) + + (defun get-random-host-by-name (name) + (let ((hosts (get-hosts-by-name name))) + (when hosts + (elt hosts (random (length hosts)))))) + + (defun host-to-vector-quad (host) + "Translate a host specification (vector quad, dotted quad or domain name) +to a vector quad." + (etypecase host + (string (let* ((ip (ignore-errors + (dotted-quad-to-vector-quad host)))) + (if (and ip (= 4 (length ip))) + ;; valid IP dotted quad? + ip + (get-random-host-by-name host)))) + ((vector t 4) host) + (integer (hbo-to-vector-quad host)))) + + (defun host-to-hbo (host) + (etypecase host + (string (let ((ip (ignore-errors + (dotted-quad-to-vector-quad host)))) + (if (and ip (= 4 (length ip))) + (host-byte-order ip) + (host-to-hbo (get-host-by-name host))))) + ((vector t 4) (host-byte-order host)) + (integer host)))) + +;; +;; Other utility functions +;; + +(defun split-timeout (timeout &optional (fractional 1000000)) + "Split real value timeout into seconds and microseconds. +Optionally, a different fractional part can be specified." + (multiple-value-bind + (secs sec-frac) + (truncate timeout 1) + (values secs + (truncate (* fractional sec-frac) 1)))) + + + + +;; +;; Setting of documentation for backend defined functions +;; + +;; Documentation for the function +;; +;; (defun SOCKET-CONNECT (host port &key element-type) ..) +;; + +(setf (documentation 'socket-connect 'function) + "Connect to `host' on `port'. `host' is assumed to be a string or +an IP address represented in vector notation, such as #(192 168 1 1). +`port' is assumed to be an integer. + +`element-type' specifies the element type to use when constructing the +stream associated with the socket. The default is 'character. + +Returns a usocket object.") + +;; Documentation for the function +;; +;; (defun SOCKET-LISTEN (host port &key reuseaddress backlog element-type) ..) +;;###FIXME: extend with default-element-type +(setf (documentation 'socket-listen 'function) + "Bind to interface `host' on `port'. `host' should be the +representation of an interface address. The implementation is not +required to do an address lookup, making no guarantees that hostnames +will be correctly resolved. If `*wildcard-host*' is passed for `host', +the socket will be bound to all available interfaces for the IPv4 +protocol in the system. `port' can be selected by the IP stack by +passing `*auto-port*'. + +Returns an object of type `stream-server-usocket'. + +`reuse-address' and `backlog' are advisory parameters for setting socket +options at creation time. `element-type' is the element type of the +streams to be created by `socket-accept'. `reuseaddress' is supported for +backward compatibility (but deprecated); when both `reuseaddress' and +`reuse-address' have been specified, the latter takes precedence. +")

1 0

[usocket-cvs] r369 - usocket/branches/hans
by hhubner＠common-lisp.net 19 Jul '08

19 Jul '08

Author: hhubner Date: Sat Jul 19 07:54:23 2008 New Revision: 369 Removed: usocket/branches/hans/ Log: delete obsolete branch

1 0

[usocket-cvs] r368 - public_html
by ehuelsmann＠common-lisp.net 13 Jul '08

13 Jul '08

Author: ehuelsmann Date: Sun Jul 13 15:00:50 2008 New Revision: 368 Modified: public_html/index.shtml Log: Add quick-link to the faq. Modified: public_html/index.shtml ============================================================================== --- public_html/index.shtml (original) +++ public_html/index.shtml Sun Jul 13 15:00:50 2008 @@ -16,6 +16,7 @@ <ul> <li><a href="#goal">Goal</a></li> <li><a href="#documentation">Documentation</a></li> +<li><a href="api-docs.shtml#faqs"><i>FAQ</i></a></li> <li><a href="#implementations">Supported implementations</a></li> <li><a href="#community">Community</a></li> <li><a href="#development">Development</a></li>

1 0

[usocket-cvs] r367 - public_html
by ehuelsmann＠common-lisp.net 13 Jul '08

13 Jul '08

Author: ehuelsmann Date: Sun Jul 13 14:59:36 2008 New Revision: 367 Modified: public_html/api-docs.shtml Log: Update FAQ. Modified: public_html/api-docs.shtml ============================================================================== --- public_html/api-docs.shtml (original) +++ public_html/api-docs.shtml Sun Jul 13 14:59:36 2008 @@ -159,6 +159,16 @@ <h1><a name="faqs">How do I ...</a></h1> <dl class="faq"> +<dt>... force the output to be written to the network? +</dt> +<dd>When you write output to the stream, it may be buffered before + sent over the network - for optimal performance of small writes. You + can force the buffer to be flushed the same way as with normal streams: + +<pre>(format (socket-stream socket) "Hello there~%") ;; output into buffers +(force-output (socket-stream socket)) ;; <== flush the buffers, if any +</pre> +</dd> <dt>... check whether the other end has closed my socket stream? </dt> <dd>Reading from a stream which has been closed at the remote end

1 0

[usocket-cvs] r366 - public_html/releases/old
by ehuelsmann＠common-lisp.net 13 Jul '08

13 Jul '08

Author: ehuelsmann Date: Sun Jul 13 14:22:27 2008 New Revision: 366 Added: public_html/releases/old/ public_html/releases/old/trivial-sockets.tar.gz (contents, props changed) Log: Make trivial-sockets available online again, asdf-install friendliness. Added: public_html/releases/old/trivial-sockets.tar.gz ============================================================================== Binary file. No diff available.

1 0

[usocket-cvs] r365 - trivial-sockets
by ehuelsmann＠common-lisp.net 13 Jul '08

13 Jul '08

Author: ehuelsmann Date: Sun Jul 13 14:19:33 2008 New Revision: 365 Modified: trivial-sockets/README Log: Update trivial-sockets/README. Modified: trivial-sockets/README ============================================================================== --- trivial-sockets/README (original) +++ trivial-sockets/README Sun Jul 13 14:19:33 2008 @@ -1,19 +1,31 @@ -Trivial-sockets: + +* +* NOTE NOTE ***** IMPORTANT ***** +* +* +* This package is no longer maintained. If you're looking for a sockets +* library which does receive maintenance, check out usocket. +* +* You can find usocket at http://common-lisp.net/project/usocket/ +* + + +Trivial-sockets: server and client stream sockets for undemanding network applications Usage examples: -(with-open-stream (s (trivial-sockets:open-stream "www.google.com" 80)) - (format s "HEAD / HTTP/1.0~%Host: www.google.com~%~%") - (force-output s) - (loop - (let ((l (read-line s nil nil))) - (unless l (return)) +(with-open-stream (s (trivial-sockets:open-stream "www.google.com" 80)) + (format s "HEAD / HTTP/1.0~%Host: www.google.com~%~%") + (force-output s) + (loop + (let ((l (read-line s nil nil))) + (unless l (return)) (princ l) (terpri)))) (trivial-sockets:with-server (s (:port 8913 :reuse-address t)) (loop - (with-open-stream (c (trivial-sockets:accept-connection s)) + (with-open-stream (c (trivial-sockets:accept-connection s)) (read-line c) (format c "Hi there!~%")))) @@ -26,7 +38,7 @@ Installation: -Use asdf-install. +Use asdf-install. * (asdf:operate 'asdf:load-op 'asdf-install) * (asdf-install:install 'trivial-sockets)

1 0

[usocket-cvs] r364 - trivial-sockets
by ehuelsmann＠common-lisp.net 13 Jul '08

13 Jul '08

Author: ehuelsmann Date: Sun Jul 13 14:16:19 2008 New Revision: 364 Added: trivial-sockets/ trivial-sockets/README trivial-sockets/abcl.lisp trivial-sockets/allegro.lisp trivial-sockets/clisp.lisp trivial-sockets/cmucl.lisp trivial-sockets/defpackage.lisp trivial-sockets/errors.lisp trivial-sockets/lispworks.lisp trivial-sockets/openmcl.lisp trivial-sockets/sbcl.lisp trivial-sockets/server.lisp trivial-sockets/trivial-sockets.asd trivial-sockets/trivial-sockets.texi Log: Trivial sockets imported as gotten from the clbuild project mirror. Added: trivial-sockets/README ============================================================================== --- (empty file) +++ trivial-sockets/README Sun Jul 13 14:16:19 2008 @@ -0,0 +1,58 @@ +Trivial-sockets: + server and client stream sockets for undemanding network applications + +Usage examples: + +(with-open-stream (s (trivial-sockets:open-stream "www.google.com" 80)) + (format s "HEAD / HTTP/1.0~%Host: www.google.com~%~%") + (force-output s) + (loop + (let ((l (read-line s nil nil))) + (unless l (return)) + (princ l) (terpri)))) + +(trivial-sockets:with-server (s (:port 8913 :reuse-address t)) + (loop + (with-open-stream (c (trivial-sockets:accept-connection s)) + (read-line c) + (format c "Hi there!~%")))) + + +Proper documentation is in trivial-sockets.texi. If you have Texinfo +installed you can convert this to DVI or PDF using texi2dvi or +texi2pdf, or use makeinfo to create an Info file for use with Emacs or +the standalone info reader. + + +Installation: + +Use asdf-install. + + * (asdf:operate 'asdf:load-op 'asdf-install) + * (asdf-install:install 'trivial-sockets) + +Or if you don't have asdf-install but you do have asdf, create a +symlink from a directory in your asdf:*central-registry* and run + + * (asdf:operate 'asdf:load-op 'trivial-sockets) + +Or if you don't have asdf, either (a) get it, or (b) compile the files by +hand in an order that satisfies the dependencies in trivial-sockets.asd + + +References: + +http://www.cliki.net/asdf-install +http://www.cliki.net/asdf + + +Thanks to: (alphabetical order) + +- Andras Simon for Armed Bear CL support +- Edi Weitz, by whose asdf-install work some of the code was inspired +- Oliver Markovic, for OpenMCL support +- Rudi Schlatte, for a ton of stuff including OpenMCL and CMUCL server + support, work on the manual, and also the Stevens justification I + needed to make SO_REUSEADDR default +- Sven Van Caekenberghe provided Lispworks support + Added: trivial-sockets/abcl.lisp ============================================================================== --- (empty file) +++ trivial-sockets/abcl.lisp Sun Jul 13 14:16:19 2008 @@ -0,0 +1,60 @@ + +(in-package :trivial-sockets) + +(defun resolve-hostname (name) + (cond + ((eql name :any) "0.0.0.0") + ((typep name '(vector * 4)) (format nil "~{~A~^.~}" (coerce name 'list))) + (t name))) + +(defun open-stream (peer-host peer-port + &key (local-host :any) (local-port 0) + (external-format :default) + (element-type 'character) + (protocol :tcp)) + (unless (and (eql local-host :any) (eql local-port 0)) + (error 'unsupported :feature :bind)) + (unless (eql protocol :tcp) + (error 'unsupported :feature `(:protocol ,protocol))) + (unless (eql external-format :default) + (error 'unsupported :feature :external-format)) + (handler-bind ((error (lambda (c) (error 'socket-error :nested-error c)))) + (ext:get-socket-stream + (ext:make-socket (resolve-hostname peer-host) peer-port) + :element-type element-type))) + + +(defun open-server (&key (host :any) (port 0) + (reuse-address t) + (backlog 50) + (protocol :tcp)) + "Returns a SERVER object and the port that was bound, as multiple values" + (unless (eql protocol :tcp) + (error 'unsupported :feature `(:protocol ,protocol))) + (unless (equal (resolve-hostname host) "0.0.0.0") + (error 'unsupported :feature :bind)) + (unless (= backlog 50) + ;; the default, as of jdk 1.4.2 + (error 'unsupported :feature :backlog)) + (handler-bind ((error (lambda (c) (error 'socket-error :nested-error c)))) + (let ((sock (ext:make-server-socket port))) + (java:jcall (java:jmethod "java.net.ServerSocket" "setReuseAddress" "boolean") + sock + (java:make-immediate-object reuse-address :boolean)) + (values sock + (java:jcall (java:jmethod "java.net.ServerSocket" "getLocalPort") + sock))))) + +(defun close-server (server) + (ext:server-socket-close server)) + +(defun accept-connection (socket + &key + (external-format :default) + (element-type 'character)) + (unless (eql external-format :default) + (error 'unsupported :feature :external-format)) + (handler-bind ((error (lambda (c) (error 'socket-error :nested-error c)))) + (ext:get-socket-stream (ext:socket-accept socket) + :element-type element-type))) + Added: trivial-sockets/allegro.lisp ============================================================================== --- (empty file) +++ trivial-sockets/allegro.lisp Sun Jul 13 14:16:19 2008 @@ -0,0 +1,60 @@ +(in-package :trivial-sockets) + +(defun resolve-hostname (name) + (cond + ((eql name :any) "0.0.0.0") + ((typep name '(vector * 4)) (format nil "~{~A~^.~}" (coerce name 'list))) + (t name))) + +(defun open-stream (peer-host peer-port + &key (local-host :any) (local-port 0) + (external-format :default) + (element-type 'character) + (protocol :tcp)) + (declare (ignore element-type)) + (unless (eql protocol :tcp) + (error 'unsupported :feature `(:protocol ,protocol))) + (unless (eql external-format :default) + (error 'unsupported :feature :external-format)) + (handler-bind ((error (lambda (c) (error 'socket-error :nested-error c)))) + (socket:make-socket :address-family :internet + :connect :active + :type :stream + :remote-host (resolve-hostname peer-host) + :remote-port peer-port + :local-host (resolve-hostname local-host) + :local-port local-port))) + + +(defun open-server (&key (host :any) (port 0) + (reuse-address t) + (backlog 1) + (protocol :tcp)) + "Returns a SERVER object and the port that was bound, as multiple values" + (unless (eql protocol :tcp) + (error 'unsupported :feature `(:protocol ,protocol))) + (handler-bind ((error + (lambda (c) (error 'socket-error :nested-error c)))) + (let* ((host (if (eql host :any) nil host)) + (socket (socket:make-socket :address-family :internet + :type :stream + :connect :passive + :local-host host + :local-port port + :reuse-address reuse-address + :backlog backlog))) + (values socket (socket:local-port socket))))) + +(defun close-server (server) + (close server)) + +(defun accept-connection (socket + &key + (external-format :default) + (element-type 'character)) + (declare (ignore element-type)) ; bivalent streams + (unless (eql external-format :default) + (error 'unsupported :feature :external-format)) + (handler-bind ((error + (lambda (c) (error 'socket-error :nested-error c)))) + (socket:accept-connection socket :wait t))) Added: trivial-sockets/clisp.lisp ============================================================================== --- (empty file) +++ trivial-sockets/clisp.lisp Sun Jul 13 14:16:19 2008 @@ -0,0 +1,56 @@ +(in-package :trivial-sockets) + +(defun resolve-hostname (name) + (cond + ((eql name :any) "0.0.0.0") + ((typep name '(vector * 4)) (format nil "~{~A~^.~}" (coerce name 'list))) + (t name))) + +(defun open-stream (peer-host peer-port + &key (local-host :any) (local-port 0) + (external-format :default) + (element-type 'character) + (protocol :tcp)) + (unless (and (eql local-host :any) (eql local-port 0)) + (error 'unsupported :feature :bind)) + (unless (eql protocol :tcp) + (error 'unsupported :feature `(:protocol ,protocol))) + ;; FIXME I wish there were a smarter way to detect only the errors + ;; we're interested in, but CLISP impnotes don't say what to look for + (handler-bind ((error (lambda (c) (error 'socket-error :nested-error c)))) + (socket:socket-connect peer-port (resolve-hostname peer-host) + :element-type element-type + :external-format external-format + :buffered nil + ))) + + +(defun open-server (&key (host :any) (port 0) + (reuse-address t) + (backlog 1) + (protocol :tcp)) + (unless (eql protocol :tcp) + (error 'unsupported :feature `(:protocol ,protocol))) + (unless (equal (resolve-hostname host) "0.0.0.0") + (error 'unsupported :feature :bind)) + (unless (= backlog 1) + ;; we established that the default backlog is 1 by stracing clisp + ;; 2.33.2 (2004-06-02) (built 3304881526) + (error 'unsupported :feature :backlog)) + (unless reuse-address + (error 'unsupported :feature :nil-reuse-address)) + (handler-bind ((error (lambda (c) (error 'socket-error :nested-error c)))) + (let ((s (socket:socket-server port))) + (values s (socket:socket-server-port s))))) + +(defun close-server (server) + (socket:socket-server-close server)) + +(defun accept-connection (socket + &key + (external-format :default) + (element-type 'character)) + (handler-bind ((error (lambda (c) (error 'socket-error :nested-error c)))) + (socket:socket-accept socket :external-format external-format + :element-type element-type + :buffered nil))) Added: trivial-sockets/cmucl.lisp ============================================================================== --- (empty file) +++ trivial-sockets/cmucl.lisp Sun Jul 13 14:16:19 2008 @@ -0,0 +1,72 @@ +(in-package :trivial-sockets) + +(defun resolve-hostname (name) + (cond + ((eql name :any) "0.0.0.0") + ((typep name '(vector * 4)) (format nil "~{~A~^.~}" (coerce name 'list))) + (t name))) + +(defun pretty-stream-name (host port) + (format nil "~A:~A" (resolve-hostname host) port)) + +(defun open-stream (peer-host peer-port + &key (local-host :any) (local-port 0) + (external-format :default) + (element-type 'character) + (protocol :tcp)) + (unless (eql external-format :default) + (error 'unsupported :feature :external-format)) + (unless (and (eql local-host :any) (eql local-port 0)) + (error 'unsupported :feature :bind)) + (unless (eql protocol :tcp) + (error 'unsupported :feature `(:protocol ,protocol))) + ;; connect-to-inet-socket signals simple-erors. not great + (handler-bind ((error (lambda (c) (error 'socket-error :nested-error c)))) + (let ((s (ext:connect-to-inet-socket + (resolve-hostname peer-host) peer-port))) + (sys:make-fd-stream s :input t :output t :element-type element-type + :buffering :full + :name (pretty-stream-name peer-host peer-port))))) + +(defun open-server (&key (host :any) (port 0) + (reuse-address t) + (backlog 1) + (protocol :tcp)) + "Returns a SERVER object and the port that was bound, as multiple values" + (unless (eql protocol :tcp) + (error 'unsupported :feature `(:protocol ,protocol))) + (handler-bind ((error (lambda (c) (error 'socket-error :nested-error c)))) + (let ((socket (if (equal (resolve-hostname host) "0.0.0.0") + ;; create-inet-listener barfs on `:host nil' + (ext:create-inet-listener port :stream + :reuse-address reuse-address + :backlog backlog) + (ext:create-inet-listener port :stream + :reuse-address reuse-address + :backlog backlog + :host host)))) + (multiple-value-bind (host port) + (ext:get-socket-host-and-port socket) + (declare (ignore host)) + (values socket port))))) + +(defun close-server (server) + (unix:unix-close server)) + +(defun accept-connection (socket + &key + (external-format :default) + (element-type 'character)) + (unless (eql external-format :default) + (error 'unsupported :feature :external-format)) + (handler-bind ((error (lambda (c) (error 'socket-error :nested-error c)))) + (let ((fd (ext:accept-tcp-connection socket))) + (multiple-value-bind (peer-host peer-port) + (ext:get-peer-host-and-port fd) + (sys:make-fd-stream fd + :input t :output t + :element-type element-type + :auto-close t + :buffering :full + :name (pretty-stream-name peer-host peer-port)))))) + Added: trivial-sockets/defpackage.lisp ============================================================================== --- (empty file) +++ trivial-sockets/defpackage.lisp Sun Jul 13 14:16:19 2008 @@ -0,0 +1,8 @@ +(in-package :cl-user) +(defpackage trivial-sockets + (:use :CL) + (:export #:open-stream #:socket-error #:socket-nested-error + #:unsupported #:unsupported-feature + #:open-server #:close-server #:accept-connection + #:with-server)) + Added: trivial-sockets/errors.lisp ============================================================================== --- (empty file) +++ trivial-sockets/errors.lisp Sun Jul 13 14:16:19 2008 @@ -0,0 +1,11 @@ +(in-package :trivial-sockets) + +;; you're using a part of the interface that the implementation doesn't do +(define-condition unsupported (error) + ((feature :initarg :feature :reader unsupported-feature))) + +;; all-purpose error: host not found, host not responding, +;; no service on that port, etc +(define-condition socket-error (error) + ((nested-error :initarg :nested-error :reader socket-nested-error))) + Added: trivial-sockets/lispworks.lisp ============================================================================== --- (empty file) +++ trivial-sockets/lispworks.lisp Sun Jul 13 14:16:19 2008 @@ -0,0 +1,114 @@ +(in-package :trivial-sockets) + +(defun resolve-hostname (name) + (cond + ((eql name :any) "0.0.0.0") + ((typep name '(vector * 4)) (format nil "~{~A~^.~}" (coerce name 'list))) + (t name))) + +(defun open-stream (peer-host peer-port + &key (local-host :any) (local-port 0) + (external-format :default) + (element-type 'base-char) + (protocol :tcp)) + (unless (eql protocol :tcp) + (error 'unsupported :feature `(:protocol ,protocol))) + (unless (eql external-format :default) + (error 'unsupported :feature `(:external-format ,external-format))) + (unless (eql local-host :any) + (error 'unsupported :feature `(:local-host ,local-host))) + (unless (eql local-port 0) + (error 'unsupported :feature `(:local-port ,local-port))) + (handler-bind ((error (lambda (c) (error 'socket-error :nested-error c)))) + (comm:open-tcp-stream (resolve-hostname peer-host) + peer-port + :element-type element-type + :errorp t))) + +;; there is no (published) way to make a server socket in lispworks +;; this server implementation is a hack around the otherwise elegant +;; lispworks #'comm:start-up-server functionality + +(defun make-queue () + (cons nil nil)) + +(defun queue-empty-p (queue) + (null (car queue))) + +(defun enqueue (x queue) + (if (null (car queue)) + (setf (cdr queue) (setf (car queue) (list x))) + (setf (cdr (cdr queue)) (list x) + (cdr queue) (cdr (cdr queue)))) + (car queue)) + +(defun dequeue (queue) + (pop (car queue))) + +(defclass server () + ((process :reader get-process) + (lock :initform (mp:make-lock)) + (clients :initform (make-queue)))) + +(defun open-server (&key (host :any) (port 0) + (reuse-address t) + (backlog 5) + (protocol :tcp)) + "Returns a SERVER object and the port that was bound, as multiple values" + (unless (eql host :any) + ;; not in the manual, appears in arglist, maybe not on all platforms + (error 'unsupported :feature `(:host ,host))) + (unless (eql protocol :tcp) + (error 'unsupported :feature `(:protocol ,protocol))) + (unless (eql backlog 5) + ;; not in the manual, appears in arglist, maybe not on all platforms + (error 'unsupported :feature `(:backlog ,backlog))) + (let ((server (make-instance 'server))) + (with-slots (process lock clients) + server + (multiple-value-bind (new-process condition) + ;; we enqueue all incoming connections until #'accept-connection retrieves them + (let ((comm::*use_so_reuseaddr* reuse-address)) + (comm:start-up-server :function #'(lambda (socket) + (mp:with-lock (lock) + (enqueue socket clients))) + :service port + :wait t)) + (when condition + (error 'socket-error :nested-error condition)) + (setf process new-process))) + (values server port))) ;; we do not return the actual port when port was 0 + +(defun close-server (server) + (with-slots (process) + server + (mp:process-kill process) + (setf process nil))) + +(defun accept-connection (server + &key + (external-format :default) + (element-type 'base-char)) + (unless (eql external-format :default) + (error 'unsupported :feature `(:external-format, external-format))) + (let (client-socket) + (with-slots (process lock clients) + server + (unless process + (error 'socket-error :nested-error (make-instance 'simple-error :format-string "Server closed"))) + (loop + (mp:with-lock (lock) + (unless (queue-empty-p clients) + (setf client-socket (dequeue clients)) + (return))) + (mp:process-wait "Waiting for incoming connections" + #'(lambda (server) + (with-slots (lock clients) + server + (mp:with-lock (lock) + (not (queue-empty-p clients))))) + server))) + (make-instance 'comm:socket-stream + :socket client-socket + :direction :io + :element-type element-type))) Added: trivial-sockets/openmcl.lisp ============================================================================== --- (empty file) +++ trivial-sockets/openmcl.lisp Sun Jul 13 14:16:19 2008 @@ -0,0 +1,60 @@ +(in-package :trivial-sockets) + +(defun resolve-hostname (name) + (cond + ((eql name :any) "0.0.0.0") + ((typep name '(vector * 4)) (format nil "~{~A~^.~}" (coerce name 'list))) + (t name))) + +(defun open-stream (peer-host peer-port + &key (local-host :any) (local-port 0) + (external-format :default) + (element-type 'character) + (protocol :tcp)) + (declare (ignore element-type)) + (unless (eql protocol :tcp) + (error 'unsupported :feature `(:protocol ,protocol))) + (unless (eql external-format :default) + (error 'unsupported :feature :external-format)) + (handler-bind ((ccl::socket-creation-error + (lambda (c) (error 'socket-error :nested-error c)))) + (ccl:make-socket :address-family :internet + :connect :active + :type :stream + :remote-host (resolve-hostname peer-host) + :remote-port peer-port + :local-host (resolve-hostname local-host) + :local-port local-port))) + +(defun open-server (&key (host :any) (port 0) + (reuse-address t) + (backlog 1) + (protocol :tcp)) + "Returns a SERVER object and the port that was bound, as multiple values" + (unless (eql protocol :tcp) + (error 'unsupported :feature `(:protocol ,protocol))) + (handler-bind ((ccl::socket-creation-error + (lambda (c) (error 'socket-error :nested-error c)))) + (let* ((host (if (eql host :any) nil host)) + (socket (ccl:make-socket :address-family :internet + :type :stream + :connect :passive + :local-host host + :local-port port + :reuse-address reuse-address + :backlog backlog))) + (values socket (ccl:local-port socket))))) + +(defun close-server (server) + (close server)) + +(defun accept-connection (socket + &key + (external-format :default) + (element-type 'character)) + (declare (ignore element-type)) ; openmcl streams are bivalent. + (unless (eql external-format :default) + (error 'unsupported :feature :external-format)) + (handler-bind ((ccl:socket-error + (lambda (c) (error 'socket-error :nested-error c)))) + (ccl:accept-connection socket :wait t))) \ No newline at end of file Added: trivial-sockets/sbcl.lisp ============================================================================== --- (empty file) +++ trivial-sockets/sbcl.lisp Sun Jul 13 14:16:19 2008 @@ -0,0 +1,63 @@ +(in-package :trivial-sockets) + +(defun resolve-hostname (name) + (cond + ((eql name :any) #(0 0 0 0)) + ((typep name '(vector * 4)) name) + (t (car (sb-bsd-sockets:host-ent-addresses + (sb-bsd-sockets:get-host-by-name name)))))) + +(defun open-stream (peer-host peer-port + &key (local-host :any) (local-port 0) + (external-format :default) + (element-type 'character) + (protocol :tcp)) + (unless (eql external-format :default) + (error 'unsupported :feature :external-format)) + (handler-bind ((sb-bsd-sockets:socket-error + (lambda (c) (error 'socket-error :nested-error c))) + (sb-bsd-sockets:name-service-error + (lambda (c) (error 'socket-error :nested-error c)))) + (let ((s (make-instance 'sb-bsd-sockets:inet-socket + :type :stream + :protocol protocol)) + (me (resolve-hostname local-host))) + (unless (and (equal me #(0 0 0 0)) (eql local-port 0)) + (sb-bsd-sockets:socket-bind s me local-port)) + (sb-bsd-sockets:socket-connect + s (resolve-hostname peer-host) peer-port) + (sb-bsd-sockets:socket-make-stream s :input t :output t + :element-type element-type + :buffering :full)))) + +(defun open-server (&key (host :any) (port 0) + (reuse-address t) + (backlog 1) + (protocol :tcp)) + "Returns a SERVER object and the port that was bound, as multiple values" + (let ((sock (make-instance 'sb-bsd-sockets:inet-socket + :type :stream + :protocol protocol))) + (when reuse-address + (setf (sb-bsd-sockets:sockopt-reuse-address sock) t)) + (sb-bsd-sockets:socket-bind sock (resolve-hostname host) port) + (sb-bsd-sockets:socket-listen sock backlog) + (multiple-value-bind (h p) (sb-bsd-sockets:socket-name sock) + (declare (ignore h)) + (values sock p)))) + +(defun close-server (server) + (sb-bsd-sockets:socket-close server)) + +(defun accept-connection (socket + &key + (external-format :default) + (element-type 'character)) + (unless (eql external-format :default) + (error 'unsupported :feature :external-format)) + (let ((s (sb-bsd-sockets:socket-accept socket))) + (sb-bsd-sockets:socket-make-stream s + :input t :output t + :element-type element-type + :buffering :full))) + Added: trivial-sockets/server.lisp ============================================================================== --- (empty file) +++ trivial-sockets/server.lisp Sun Jul 13 14:16:19 2008 @@ -0,0 +1,10 @@ +(in-package :trivial-sockets) + +(defmacro with-server ((name arguments) &body forms) + `(let (,name) + (unwind-protect + (progn + (setf ,name (open-server ,@arguments)) + (locally + ,@forms)) + (when ,name (close-server ,name))))) Added: trivial-sockets/trivial-sockets.asd ============================================================================== --- (empty file) +++ trivial-sockets/trivial-sockets.asd Sun Jul 13 14:16:19 2008 @@ -0,0 +1,21 @@ +;;; -*- Lisp -*- +(defpackage #:trivial-sockets-system (:use #:asdf #:cl)) +(in-package #:trivial-sockets-system ) + +(defsystem trivial-sockets + :version "0.3" + :depends-on (#+sbcl sb-bsd-sockets) + :components ((:file "defpackage") + (:file "errors" :depends-on ("defpackage")) + (:file + #+sbcl "sbcl" + #+cmu "cmucl" + #+clisp "clisp" + #+acl-socket "allegro" + #+openmcl "openmcl" + #+lispworks "lispworks" + #+armedbear "abcl" + :depends-on ("defpackage")) + (:file "server" :depends-on ("defpackage")) + )) + Added: trivial-sockets/trivial-sockets.texi ============================================================================== --- (empty file) +++ trivial-sockets/trivial-sockets.texi Sun Jul 13 14:16:19 2008 @@ -0,0 +1,444 @@ +\input texinfo @c -*- texinfo -*- +@c %**start of header +@setfilename trivial-sockets.info +@settitle TRIVIAL-SOCKETS Manual +@c %**end of header + +@c merge type index into function index +@syncodeindex tp fn +@c ... and concept index, too. +@synindex cp fn + +@c for install-info +@dircategory Software development +@direntry +* trivial-sockets: (trivial-sockets). CL socket interface for scripting/interactive use +@end direntry + +@copying +This manual describes TRIVIAL-SOCKETS, a simple socket interface for Common +Lisp programs and libraries. + +Copyright @copyright{} 2004 Daniel Barlow and contributors + +Permission is hereby granted, free of charge, to any person obtaining +a copy of this software and associated documentation files (the +``Software''), to deal in the Software without restriction, including +without limitation the rights to use, copy, modify, merge, publish, +distribute, sublicense, and/or sell copies of the Software, and to +permit persons to whom the Software is furnished to do so, subject to +the following conditions: + +The above copyright notice and this permission notice shall be +included in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED ``AS IS'', WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE +LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION +OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION +WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. + +@end copying + + + +@titlepage +@title TRIVIAL-SOCKETS + +@c The following two commands start the copyright page. +@page +@vskip 0pt plus 1filll +@insertcopying +@end titlepage + +@c Output the table of contents at the beginning. +@contents + +@c ------------------- + +@ifnottex + +@node Top +@top TRIVIAL-SOCKETS: a socket interface for scripting and interactive use + +@insertcopying + +@menu +* Introduction:: Design goals and target audience +* Installation:: How to download and install +* API:: +* Index:: +@end menu + +@end ifnottex + +@c ------------------- + +@node Introduction +@chapter Introduction + +TRIVIAL-SOCKETS is a portable socket interface that allows CL programs +to open connected (client) stream sockets to network services +(e.g. HTTP, FTP, SMTP servers) and communicate with them. It's +intended mostly for use by small ``script'' programs and for +interactive use where the effort involved in writing one's own +portable wrapper layer for several Lisp implementations would outweigh +that spent on the actual application. + +In the interests of simplicity and ease of porting, the functionality +available through TRIVIAL-SOCKETS has been deliberately restricted. +For a more general sockets interface which may allow access to more +functionality, the reader is encouraged to consult his Lisp +implementation's documentation. + +@node Installation +@chapter Installation +@cindex{Installation} + +TRIVIAL-SOCKETS is distributed via asdf-install. If you are on the +Internet and your Lisp implementation has asdf-install available, you +may download and compile this package with an invocation like + +@lisp +(asdf-install:install 'trivial-sockets) +@end lisp + +The trivial-sockets package has been PGP-signed by Daniel Barlow, and +asdf-install will by default check that the signature is good and that +a trust path exists between you and him. If not, you will be prompted +for a decision on whether to install anyway. See asdf-install +documentation for more details on how this works. + +Once you have installed trivial-sockets, the next time you wish to +load it you need only evaluate + +@lisp +(asdf:operate 'asdf:load-op 'trivial-sockets) +@end lisp + +or if you have an asdf system that uses it, add +@code{trivial-sockets} to the @code{:depends-on} clause of that system +and it will be loaded whenever your system is. + +@chapter API +@node API + +@section Types +@cindex{Host designator} +@cindex{IP address} +@cindex{Address} +@cindex{Protocol} + +A @emph{host designator} is one of the following: + +@enumerate +@item A string, which is resolved as a hostname by the system resolver, +typically using DNS or YP or some other implementation-defined +mechanism. For example, @code{"www.google.com"} + +@item An IPv4 address in "dotted quad" notation: e.g. @code{"127.0.0.1"} + +@item (Implementation-defined): An IPv4 address in whatever ``native'' +format the implementation uses to represent same, if applicable. +For example, @code{#(127 0 0 1)} or @code{2130706433} + +@item The keyword @code{:ANY}, which corresponds to INADDR_ANY or "0.0.0.0" +@end enumerate + +A @emph{protocol specifier} is a keyword naming an +@uref{http://www.iana.org/assignments/protocol-numbers,,IANA protocol +number} (as typically found in @file{/etc/protocols} on Unix-like +systems) or the corresponding number. Implementations must support +@code{:TCP} at a minimum. + +@section Functions + +@anchor{Function open-stream} +@defun open-stream peer-host peer-port &key local-host local-port external-format element-type protocol +@result{} stream + +@strong{Arguments and Values:} + +@var{peer-host}--a host designator. + +@var{peer-port}--an integer. + +@var{local-host}--a host designator. The default is @code{:any}. + +@var{local-port}--an integer. The default is @code{0}. + +@var{external-format}--an external file format designator. The default +is @code{:default}. + +@var{element-type}--a type specifier; see the Common Lisp function +@code{open} for valid values. The default is @code{'character}. + +@var{protocol}--a protocol specifier. The default is @code{:tcp}. + +@strong{Description:} + +Return a stream to the named service, open for both reading and writing. +The stream is usually buffered, so be sure to use @code{force-output} +where necessary. + +If the stream cannot be created for any reason, an error of type +@code{socket-error} is signaled. + +The stream should be closed in the usual way when no longer needed: +see the Common Lisp functions @code{close}, @code{with-open-stream} +@end defun + +@anchor{Function open-server} +@defun open-server &key host port reuse-address backlog protocol +@result{} server socket + +@strong{Arguments and Values:} + +@var{host}--a host designator. The default is @code{:any}. + +@var{port}--an integer. The default is @code{0}. + +@var{reuse-address}--@code{t} or @code{nil}. The default is @code{t}. + +@var{backlog}--an integer. The default is @code{1}. + +@var{protocol}--a protocol specifier. The default is @code{:tcp}. + +@strong{Description:} + +Create a listening server socket. If @var{port} is 0, an unused port +will be chosen by the implementation/operating system. @var{Host} +may be set to the address of any local network interface to restrict +the socket to that interface. + +If @var{reuse-address} is true (the default, as recommended by Stevens) +then the @code{SO_REUSEADDR} socket option will be set, which allows the +the port to be reused immediately after it has been closed, without +waiting for a timeout (``2*MSL'') to expire. + +@var{Backlog} sets how many pending connections are queued by the +operating system. + +If the socket cannot be created for any reason, an error of type +@code{socket-error} is signaled. + +The nature of the object returned is implementation-dependent. When +the socket is no longer needed it should be closed with +@code{close-server}. + +@xref{Macro with-server}. +@end defun + +@c <3dqes6$e49(a)bosnia.pop.psu.edu> or see 242-246 of +@c "TCP/IP Illustrated, Volume 1" + +@anchor{Function close-server} +@defun close-server server +@result{} result + +@strong{Arguments and Values:} + +@var{server}--a server socket. + +@var{result}--implementation-dependent. + +@strong{Description:} + +Close @var{server} and release all resources associated with it. +Note that opening a new server on the same address/port will not be +immediately possible unless the earlier server was created with the +@code{:reuse-address} argument. +@end defun + +@anchor{Macro with-server} +@defmac with-server (server args) declaration* form* +@result{} results + +@strong{Arguments and Values:} + +@var{server}--a variable. + +@var{args}--a list of arguments. + +@var{declaration}--a declare expression. + +@var{forms}--an implicit @code{progn}. + +@var{results}--the values returned by the @var{forms}. + +@strong{Description:} + +@code{with-server} uses @code{open-server} to create a server socket +named by @var{server}. @var{Args} are used as keyword arguments to +@code{open-server}. + +@code{with-server} evaluates the @var{forms} as an implicit progn with +@var{server} bound to the value returned by @code{open-server}. + +When control leaves the body, either normally or abnormally (such as by +use of @code{throw}), the server socket is automatically closed. + +The consequences are undefined if an attempt is made to assign to +the variable @var{server} within the body forms. +@end defmac + +@anchor{Function accept-connection} +@defun accept-connection server &key external-format element-type +@result{} stream + +@strong{Arguments and Values:} + +@var{server}--a server socket. + +@var{external-format}--an external file format designator. The default +is @code{:default}. + +@var{element-type}--a type specifier; see the Common Lisp function +@code{open} for valid values. The default is @code{'character}. + +@strong{Description:} + +Accept a connection to @var{server}, returning a stream connected to +the client which is open for both reading and writing. The stream is +usually buffered, so be sure to use @code{force-output} where +necessary. + +If no connection is pending, @code{accept-connection} waits until one +arrives. + +If anything goes wrong, an error of type @code{socket-error} is +signaled. +@end defun + +@section Examples + +@subsection Simple client + +@lisp +;; this is not HTTP compliant, really. But it's good enough +;; for a demonstration +(with-open-stream (s (trivial-sockets:open-stream "www.google.com" 80)) + (format s "HEAD / HTTP/1.0~%Host: www.google.com~%~%") + (force-output s) + (loop + (let ((l (read-line s nil nil))) + (unless l (return)) + (princ l) (terpri)))) +@end lisp + +@subsection Simple (single-threaded) server + +@lisp +(trivial-sockets:with-server (s (:port 8913 :reuse-address t)) + (loop + (with-open-stream (c (trivial-sockets:accept-connection s)) + (read-line c) + (format c "This is a compliant though pointless implementation ~ +of the finger protocol~%")))) +@end lisp + + +@section Errors + +@anchor{Condition unsupported} +@deftp {Condition} unsupported +Class precedence list: @w{error} + +This exists so that partial implementations of this interface may be +created for environments which are incapable of supporting the full +API. An @code{unsupported} error is signaled if the user requests +functionality that is not implemented for the Lisp environment in use. +@end deftp + +@anchor{Condition socket-error} +@deftp {Condition} socket-error +Class precedence list: @w{error} + +A @code{socket-error} error is signaled when an error situation occurs +during opening of the stream. If you need more detail, this is +probably a sign that you have outgrown this interface and will have to +resort to unportable code (error codes vary between systems:were you +expecting @code{HOST_UNREACH} or @code{NET_UNREACH}?). With that in +mind, you can access the implementation-specific error using + +@lisp +(socket-nested-error condition) +@end lisp + +@end deftp + +@chapter Implementation-dependent +@node Implementation-dependent + +Not all features in this interface are supported on all platforms, +owing to deficiencies in the underlying socket layers that it uses. + +Many implementations signal socket-related errors using non-specific +error classes such as ERROR or SIMPLE-ERROR. (Some others, perhaps, +signal more specific errors but the code in trivial-sockets does not +know that. Patches welcome). Where we don't know of a specific +error, we catch the general ones and resignal @code{SOCKET-ERROR}, so +it's possible sometimes that errors shich are nothing at all to do +with sockets (e.g. keyboard interrupts or external signals) also get +presented as SOCKET-ERRORs. This applies in all implementations +listed except where noted. + +@itemize + +@item Armed Bear CL currently supports only client sockets, and only +for TCP, with unspecified local endpoint, and with the default +external-format. + +@item Allegro CL (tested in Allegro 6.2. trial) has no support for +protocols other than @code{:tcp} or non-default external-formats. +Allegro sockets are multivalent, so it ignores the +@code{:element-type}. + +@item CLISP has no support for protocols that are not @code{:tcp}, or for +binding the local address/port. Its streams are unbuffered, as CLISP +buffered streams do not return any data at all on reads until the +buffer is full - making them no use for any protocol in which one side +sends less than 4k at a time. (CLISP ``interactively buffered'' +streams are likely to fix this, but as of October 2004 have not yet +been implemented). + +@item CMUCL has no support for external-formats other than +@code{:default}, for protocols that are not @code{:tcp}, or for +binding the local address/port. + +@item Lispworks supports TCP only, It doesn't do +non-default local address in server sockets, or listen backlog length. +It doesn't do non-default external-formats. If the local port is 0, +@code{open-server} doesn't return the real port number. It also uses +an odd construction involving multiple threads for server sockets +which in principle should be transparent but don't say we didn't warn +you. + +@item OpenMCL socket support is very similar to that of Allegro: all +implementation notes applicable to Allegro also hold for OpenMCL. +Additionally, errors signaled by instances of @code{ccl:socket-error} +are caught and resignaled as @code{socket-error}. + +@item SBCL has no support for external-formats other than @code{:default}. +Errors signaled by @code{sb-bsd-sockets:socket-error} and @code +{sb-bsd-sockets:name-service-error} are caught and resignaled as +@code{socket-error}. + +@end itemize + +Patches to improve per-implementation support for this interface are +welcome. Patches which include an appropriate update for the manual +are doubly if not sevenfoldly so. + +@c ------------------- + + +@node Index, +@unnumbered Index + +@printindex fn + +@bye +

1 0

[usocket-cvs] r363 - usocket/trunk/backend
by ehuelsmann＠common-lisp.net 13 Jul '08

13 Jul '08

Author: ehuelsmann Date: Sun Jul 13 07:05:40 2008 New Revision: 363 Modified: usocket/trunk/backend/sbcl.lisp Log: Commit change to trunk which should have been there all the time, but got committed to the 0.3.x branch only, for some reason. Modified: usocket/trunk/backend/sbcl.lisp ============================================================================== --- usocket/trunk/backend/sbcl.lisp (original) +++ usocket/trunk/backend/sbcl.lisp Sun Jul 13 07:05:40 2008 @@ -67,7 +67,7 @@ (defun get-host-name () (ffi:c-inline () () :object - "{ char *buf = GC_malloc(256); + "{ char *buf = cl_alloc_atomic(257); if (gethostname(buf,256) == 0) @(return) = make_simple_base_string(buf);

1 0

[usocket-cvs] r362 - usocket/branches/new-wfi/backend
by ehuelsmann＠common-lisp.net 04 Jul '08

04 Jul '08

Author: ehuelsmann Date: Fri Jul 4 19:19:05 2008 New Revision: 362 Modified: usocket/branches/new-wfi/backend/clisp.lisp Log: Fix CLISP backend. Modified: usocket/branches/new-wfi/backend/clisp.lisp ============================================================================== --- usocket/branches/new-wfi/backend/clisp.lisp (original) +++ usocket/branches/new-wfi/backend/clisp.lisp Fri Jul 4 19:19:05 2008 @@ -144,14 +144,15 @@ (split-timeout (or timeout 1)) (dolist (x (wait-list-%wait wait-list)) (setf (cdr x) :INPUT)) - (let* ((status-list (if timeout + (let* ((request-list (wait-list-%wait wait-list)) + (status-list (if timeout (socket:socket-status request-list secs musecs) (socket:socket-status request-list))) (sockets (wait-list-waiters wait-list))) (do* ((x (pop sockets) (pop sockets)) (y (pop status-list) (pop status-list))) - ((or (null sockets) (null status-list))) - (when y + ((null x)) + (when (eq y :INPUT) (setf (state x) :READ))) wait-list))))

1 0

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

usocket-cvs July 2008