[usocket-cvs] r305 - in usocket/trunk: . backend
ehuelsmann at common-lisp.net
ehuelsmann at common-lisp.net
Sun Feb 10 20:29:25 UTC 2008
Author: ehuelsmann
Date: Sun Feb 10 15:29:25 2008
New Revision: 305
Modified:
usocket/trunk/backend/allegro.lisp (props changed)
usocket/trunk/backend/armedbear.lisp (props changed)
usocket/trunk/backend/clisp.lisp (props changed)
usocket/trunk/backend/cmucl.lisp (props changed)
usocket/trunk/backend/lispworks.lisp (contents, props changed)
usocket/trunk/backend/openmcl.lisp (props changed)
usocket/trunk/backend/sbcl.lisp (contents, props changed)
usocket/trunk/backend/scl.lisp (props changed)
usocket/trunk/condition.lisp (props changed)
usocket/trunk/package.lisp (props changed)
usocket/trunk/usocket.asd (props changed)
usocket/trunk/usocket.lisp (props changed)
Log:
Add native eol-style property for better cooperation between Windows and Unix.
Modified: usocket/trunk/backend/lispworks.lisp
==============================================================================
--- usocket/trunk/backend/lispworks.lisp (original)
+++ usocket/trunk/backend/lispworks.lisp Sun Feb 10 15:29:25 2008
@@ -42,7 +42,28 @@
(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."
@@ -50,16 +71,7 @@
(simple-error (destructuring-bind (&optional host port err-msg errno)
(simple-condition-format-arguments condition)
(declare (ignore host port err-msg))
- (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 socket))
- (error 'unknown-error
- :socket socket
- :real-error condition)))))))
+ (raise-usock-err errno socket condition)))))
(defun socket-connect (host port &key (element-type 'base-char))
(let ((hostname (host-to-hostname host))
@@ -149,6 +161,12 @@
(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 ()
@@ -165,3 +183,159 @@
(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)
+
+ (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")
+
+ ;; 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 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 wait-for-sockets (sockets timeout)
+ (let ((event-object (wsa-event-create)))
+ (unwind-protect
+ (progn
+ (dolist (socket sockets)
+ (add-socket-to-event socket event-object))
+ (system:wait-for-single-object event-object
+ "Waiting for socket activity" timeout))
+ (maybe-wsa-error
+ (wsa-event-close event-object)
+ nil))))
+
+
+ (defun map-network-errors (func network-events)
+ (let ((event-map (fli:foreign-slot-value network-events 'network-events))
+ (error-array (fli:foreign-slot-value network-events 'error-code)))
+ (dotimes (i fd-max-events)
+ (unless (zerop (ldb (byte 1 i) event-map))
+ (funcall func (fli:foreign-aref error-array i))))))
+
+ (defun has-network-errors-p (network-events)
+ (let ((network-events (fli:foreign-slot-value network-events 'network-events))
+ (error-array (fli:foreign-slot-value network-events 'error-code)))
+ ;; We need to check the bits before checking the error:
+ ;; the api documents the consumer can only assume valid values for
+ ;; fields which have the corresponding bit set
+ (do ((i 0 (1+ i)))
+ ((and (< i fd-max-events)
+ (not (zerop (ldb (byte 1 i) network-events)))
+ (zerop (fli:foreign-aref error-array i)))
+ (< i fd-max-events)))))
+
+ (defun socket-ready-p (network-events)
+ (and (not (zerop (fli:foreign-slot-value network-events 'network-events)))
+ (not (has-network-errors-p network-events))))
+
+ (defun sockets-ready (sockets)
+ (remove-if-not #'(lambda (socket)
+ (multiple-value-bind
+ (rv network-events)
+ (wsa-enum-network-events (os-socket-handle socket) 0)
+ (if (zerop rv)
+ (socket-ready-p network-events)
+ (maybe-wsa-error rv socket))))
+ sockets))
+
+ (defun wait-for-input-internal (sockets &key timeout)
+ (wait-for-sockets sockets
+ (if (some #'(lambda (x)
+ (and (stream-usocket-p x)
+ (listen (socket-stream x))))
+ sockets)
+ 0 ;; don't wait: there are streams which
+ ;; can be read from, even if not from the socket
+ timeout)
+ (sockets-ready sockets))
+
+ );; end of WIN32-block
Modified: usocket/trunk/backend/sbcl.lisp
==============================================================================
--- usocket/trunk/backend/sbcl.lisp (original)
+++ usocket/trunk/backend/sbcl.lisp Sun Feb 10 15:29:25 2008
@@ -1,324 +1,324 @@
-;;;; $Id$
-;;;; $URL$
-
-;;;; 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 <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) 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(cur_fd->cons.car);
- max_fd = (max_fd > fd) ? max_fd : fd;
- FD_SET(fd, &rfds);
- cur_fd = cur_fd->cons.cdr;
- }
-
- 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) = Cnil;
- else if (count < 0)
- /*###FIXME: We should be raising an error here...
-
- except, ofcourse in case of EINTR or EAGAIN */
-
- @(return) = Cnil;
- 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(cur_fd->cons.car);
- if (FD_ISSET(fd, &rfds))
- rv = CONS(MAKE_INTEGER(fd), rv);
-
- cur_fd = cur_fd->cons.cdr;
- }
- @(return) = rv;
- }
-}"))
-
-)
-
-(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)
- (sb-bsd-sockets:protocol-unknown
- . 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
-;; (sb-bsd-sockets:no-recovery-error . network-reset-error)
-;; (sb-bsd-sockets:try-again-condition ...)
-;; (sb-bsd-sockets:host-not-found ...)
- ))
-
-(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)))
- (if usock-error
- (error usock-error :socket socket)
- (error 'unknown-error
- :socket socket
- :real-error condition))))
- (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)
- (signal 'unknown-condition
- :real-condition condition))))))
-
-
-(defun socket-connect (host port &key (element-type 'character))
- (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 (<= 0 count)
- ;; process the result...
- (remove-if
- #'(lambda (x)
- (not (sb-unix:fd-isset
- (sb-bsd-sockets:socket-file-descriptor (socket x))
- rfds)))
- sockets)
- (progn
- (unless (= err sb-unix:EINTR)
- (error (map-errno-error err))))
- ;;###FIXME generate an error, except for EINTR
- ))))))
-
- #+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)))
- (result-fds (read-select sock-fds (when timeout secs) usecs)))
- (remove-if #'(lambda (s)
- (not
- (member
- (sb-bsd-sockets:socket-file-descriptor (socket s))
- result-fds)))
- sockets)))))
- )
+;;;; $Id$
+;;;; $URL$
+
+;;;; 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 <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) 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(cur_fd->cons.car);
+ max_fd = (max_fd > fd) ? max_fd : fd;
+ FD_SET(fd, &rfds);
+ cur_fd = cur_fd->cons.cdr;
+ }
+
+ 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) = Cnil;
+ else if (count < 0)
+ /*###FIXME: We should be raising an error here...
+
+ except, ofcourse in case of EINTR or EAGAIN */
+
+ @(return) = Cnil;
+ 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(cur_fd->cons.car);
+ if (FD_ISSET(fd, &rfds))
+ rv = CONS(MAKE_INTEGER(fd), rv);
+
+ cur_fd = cur_fd->cons.cdr;
+ }
+ @(return) = rv;
+ }
+}"))
+
+)
+
+(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)
+ (sb-bsd-sockets:protocol-unknown
+ . 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
+;; (sb-bsd-sockets:no-recovery-error . network-reset-error)
+;; (sb-bsd-sockets:try-again-condition ...)
+;; (sb-bsd-sockets:host-not-found ...)
+ ))
+
+(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)))
+ (if usock-error
+ (error usock-error :socket socket)
+ (error 'unknown-error
+ :socket socket
+ :real-error condition))))
+ (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)
+ (signal 'unknown-condition
+ :real-condition condition))))))
+
+
+(defun socket-connect (host port &key (element-type 'character))
+ (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 (<= 0 count)
+ ;; process the result...
+ (remove-if
+ #'(lambda (x)
+ (not (sb-unix:fd-isset
+ (sb-bsd-sockets:socket-file-descriptor (socket x))
+ rfds)))
+ sockets)
+ (progn
+ (unless (= err sb-unix:EINTR)
+ (error (map-errno-error err))))
+ ;;###FIXME generate an error, except for EINTR
+ ))))))
+
+ #+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)))
+ (result-fds (read-select sock-fds (when timeout secs) usecs)))
+ (remove-if #'(lambda (s)
+ (not
+ (member
+ (sb-bsd-sockets:socket-file-descriptor (socket s))
+ result-fds)))
+ sockets)))))
+ )
More information about the usocket-cvs
mailing list