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))))) + )