[usocket-cvs] r370 - in usocket/branches/hans: . backend doc notes test
hhubner at common-lisp.net
hhubner at common-lisp.net
Sat Jul 19 12:00:08 UTC 2008
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 at 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 , at arguments))
+
+(defmacro do-jmethod (&rest arguments)
+ `(do-jmethod-call , at 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 , at arg-spec)
+ (java:jclass ,class-sym) , at 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 , at arg-spec)
+ ,isym , at 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 , at arg-spec)
+ , at 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))))
+ , at 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-897837)
+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 , at 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)
+ , at 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 , at socket-connect-args))
+ ,(if (null stream-var)
+ `(progn , at body)
+ `(let ((,stream-var (socket-stream ,socket-var)))
+ , at 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)
+ , at 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 , at socket-listen-args))
+ , at 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.
+")
More information about the usocket-cvs
mailing list