[usocket-cvs] r370 - in usocket/branches/hans: . backend doc notes test

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@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/allegro.lisp $ + +;;;; 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/armedbear.lisp $ + +;;;; 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/clisp.lisp $ + +;;;; 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/cmucl.lisp $ + +;;;; 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/lispworks.lisp $ + +;;;; 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/openmcl.lisp $ + +;;;; 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/sbcl.lisp $ + +;;;; 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.lisp $ + +;;;; 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.lisp $ + +;;;; 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-89...) +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/package.lisp $ + +;;;; 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-usocket.lisp $ + +;;;; 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/usocket-test.asd $ + +;;;; 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. +")