From ehuelsmann at common-lisp.net Sun Feb 10 20:16:43 2008 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Sun, 10 Feb 2008 15:16:43 -0500 (EST) Subject: [usocket-cvs] r302 - usocket/trunk/backend Message-ID: <20080210201643.4A7E12D07C@common-lisp.net> Author: ehuelsmann Date: Sun Feb 10 15:16:42 2008 New Revision: 302 Modified: usocket/trunk/backend/sbcl.lisp Log: Fix sb-bsd-sockets:unknown-protocol leaking through to the usocket user. Modified: usocket/trunk/backend/sbcl.lisp ============================================================================== --- usocket/trunk/backend/sbcl.lisp (original) +++ usocket/trunk/backend/sbcl.lisp Sun Feb 10 15:16:42 2008 @@ -1,322 +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 ") - #+:wsock - (ffi:clines - "#ifndef FD_SETSIZE" - "#define FD_SETSIZE 1024" - "#endif" - "#include ") - - (ffi:clines - "#include ") - - #+: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: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 ") + #+:wsock + (ffi:clines + "#ifndef FD_SETSIZE" + "#define FD_SETSIZE 1024" + "#endif" + "#include ") + + (ffi:clines + "#include ") + + #+: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))))) + ) From ehuelsmann at common-lisp.net Sun Feb 10 20:18:59 2008 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Sun, 10 Feb 2008 15:18:59 -0500 (EST) Subject: [usocket-cvs] r303 - in usocket/trunk: . backend test Message-ID: <20080210201859.2A8872D07C@common-lisp.net> Author: ehuelsmann Date: Sun Feb 10 15:18:58 2008 New Revision: 303 Modified: usocket/trunk/ (props changed) usocket/trunk/backend/ (props changed) usocket/trunk/test/ (props changed) Log: Ignore clisp generated fasl files. From ehuelsmann at common-lisp.net Sun Feb 10 20:19:49 2008 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Sun, 10 Feb 2008 15:19:49 -0500 (EST) Subject: [usocket-cvs] r304 - usocket/trunk/test Message-ID: <20080210201949.D93994908D@common-lisp.net> Author: ehuelsmann Date: Sun Feb 10 15:19:49 2008 New Revision: 304 Removed: usocket/trunk/test/usocket.asd Log: Remove spurious file. From ehuelsmann at common-lisp.net Sun Feb 10 20:29:25 2008 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Sun, 10 Feb 2008 15:29:25 -0500 (EST) Subject: [usocket-cvs] r305 - in usocket/trunk: . backend Message-ID: <20080210202925.C02434D042@common-lisp.net> 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 ") - #+:wsock - (ffi:clines - "#ifndef FD_SETSIZE" - "#define FD_SETSIZE 1024" - "#endif" - "#include ") - - (ffi:clines - "#include ") - - #+: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 ") + #+:wsock + (ffi:clines + "#ifndef FD_SETSIZE" + "#define FD_SETSIZE 1024" + "#endif" + "#include ") + + (ffi:clines + "#include ") + + #+: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))))) + ) From ehuelsmann at common-lisp.net Sun Feb 10 20:31:42 2008 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Sun, 10 Feb 2008 15:31:42 -0500 (EST) Subject: [usocket-cvs] r305 - svn:log Message-ID: <20080210203142.6482B601A8@common-lisp.net> Author: ehuelsmann Revision: 305 Property Name: svn:log New Property Value: Add native eol-style property for better cooperation between Windows and Unix. NOTE: Unintentionally, a lot of LispWorks code got included in this revision. I'll leave it in, as I was meaning to commit it some time anyway (but not exactly now). From ehuelsmann at common-lisp.net Fri Feb 15 10:20:19 2008 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Fri, 15 Feb 2008 05:20:19 -0500 (EST) Subject: [usocket-cvs] r306 - usocket/trunk/backend Message-ID: <20080215102019.EB85C15022@common-lisp.net> Author: ehuelsmann Date: Fri Feb 15 05:20:17 2008 New Revision: 306 Modified: usocket/trunk/backend/sbcl.lisp Log: Fix r302. Modified: usocket/trunk/backend/sbcl.lisp ============================================================================== --- usocket/trunk/backend/sbcl.lisp (original) +++ usocket/trunk/backend/sbcl.lisp Fri Feb 15 05:20:17 2008 @@ -148,7 +148,7 @@ . operation-not-permitted-error) (sb-bsd-sockets:protocol-not-supported-error . protocol-not-supported-error) - (sb-bsd-sockets:protocol-unknown + (sb-bsd-sockets:unknown-protocol . protocol-not-supported-error) (sb-bsd-sockets:socket-type-not-supported-error . socket-type-not-supported-error) From ehuelsmann at common-lisp.net Fri Feb 15 16:07:03 2008 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Fri, 15 Feb 2008 11:07:03 -0500 (EST) Subject: [usocket-cvs] r307 - usocket/trunk/backend Message-ID: <20080215160703.BC4D25D17A@common-lisp.net> Author: ehuelsmann Date: Fri Feb 15 11:07:02 2008 New Revision: 307 Modified: usocket/trunk/backend/sbcl.lisp Log: sb-unix:fast-unix-select doesn't return multiple values; check 'get-errno' ourselves. Modified: usocket/trunk/backend/sbcl.lisp ============================================================================== --- usocket/trunk/backend/sbcl.lisp (original) +++ usocket/trunk/backend/sbcl.lisp Fri Feb 15 11:07:02 2008 @@ -280,14 +280,13 @@ (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) + (let ((count + (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 (=> count 0) ;; process the result... (remove-if #'(lambda (x) @@ -295,7 +294,7 @@ (sb-bsd-sockets:socket-file-descriptor (socket x)) rfds))) sockets) - (progn + (let ((err (sb-alien:get-errno))) (unless (= err sb-unix:EINTR) (error (map-errno-error err)))) ;;###FIXME generate an error, except for EINTR From ehuelsmann at common-lisp.net Sat Feb 16 10:16:53 2008 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Sat, 16 Feb 2008 05:16:53 -0500 (EST) Subject: [usocket-cvs] r308 - in usocket/trunk: . backend Message-ID: <20080216101653.421CC340DF@common-lisp.net> Author: ehuelsmann Date: Sat Feb 16 05:16:50 2008 New Revision: 308 Modified: usocket/trunk/backend/sbcl.lisp usocket/trunk/usocket.lisp Log: Don't loop over the sockets if we timed out... Modified: usocket/trunk/backend/sbcl.lisp ============================================================================== --- usocket/trunk/backend/sbcl.lisp (original) +++ usocket/trunk/backend/sbcl.lisp Sat Feb 16 05:16:50 2008 @@ -286,19 +286,19 @@ :key #'sb-bsd-sockets:socket-file-descriptor)) (sb-alien:addr rfds) nil nil (when timeout secs) musecs))) - (if (=> count 0) - ;; process the result... - (remove-if - #'(lambda (x) - (not (sb-unix:fd-isset - (sb-bsd-sockets:socket-file-descriptor (socket x)) - rfds))) - sockets) - (let ((err (sb-alien:get-errno))) - (unless (= err sb-unix:EINTR) - (error (map-errno-error err)))) - ;;###FIXME generate an error, except for EINTR - )))))) + (unless (= 0 count) ;; 0 means timeout + (if (=> count 0) + ;; process the result... + (remove-if + #'(lambda (x) + (not + (sb-unix:fd-isset + (sb-bsd-sockets:socket-file-descriptor (socket x)) + rfds))) + sockets) + (let ((err (sb-alien:get-errno))) + (unless (= err sb-unix:EINTR) + (error (map-errno-error err))))))))))) #+win32 (warn "wait-for-input not (yet!) supported...") Modified: usocket/trunk/usocket.lisp ============================================================================== --- usocket/trunk/usocket.lisp (original) +++ usocket/trunk/usocket.lisp Sat Feb 16 05:16:50 2008 @@ -198,15 +198,23 @@ (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 - (if (listp socket-or-sockets) socket-or-sockets - (list socket-or-sockets)) - :timeout timeout))) - (values result + 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))) From ehuelsmann at common-lisp.net Sat Feb 16 22:53:09 2008 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Sat, 16 Feb 2008 17:53:09 -0500 (EST) Subject: [usocket-cvs] r308 - svn:log Message-ID: <20080216225309.71CEF15028@common-lisp.net> Author: ehuelsmann Revision: 308 Property Name: svn:log New Property Value: Don't loop over the sockets if we timed out... [NOTE] Kill me, but I accidentally also committed a fix to wait-for-input, which used to wait, even if a socket's stream would return T on CL:LISTEN. From ehuelsmann at common-lisp.net Sat Feb 16 23:44:55 2008 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Sat, 16 Feb 2008 18:44:55 -0500 (EST) Subject: [usocket-cvs] r309 - usocket/trunk/backend Message-ID: <20080216234455.F1CFC15030@common-lisp.net> Author: ehuelsmann Date: Sat Feb 16 18:44:54 2008 New Revision: 309 Modified: usocket/trunk/backend/sbcl.lisp Log: Generate a mapped error on ECL when select() returns one. Modified: usocket/trunk/backend/sbcl.lisp ============================================================================== --- usocket/trunk/backend/sbcl.lisp (original) +++ usocket/trunk/backend/sbcl.lisp Sat Feb 16 18:44:54 2008 @@ -39,6 +39,7 @@ (progn #-:wsock (ffi:clines + "#include " "#include ") #+:wsock (ffi:clines @@ -99,13 +100,15 @@ (#1 != Cnil) ? &tv : NULL); if (count == 0) - @(return) = Cnil; + @(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) = Cnil; + @(return 0) = Cnil; + @(return 1) = MAKE_INTEGER(errno); else { cl_object rv = Cnil; @@ -123,7 +126,8 @@ cur_fd = cur_fd->cons.cdr; } - @(return) = rv; + @(return 0) = rv; + @(return 1) = Cnil; } }")) @@ -312,12 +316,17 @@ (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))))) + (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) + (map-socket-error err))))))) ) From ehuelsmann at common-lisp.net Sat Feb 16 23:48:32 2008 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Sat, 16 Feb 2008 18:48:32 -0500 (EST) Subject: [usocket-cvs] r310 - in usocket/trunk: . backend Message-ID: <20080216234832.2DFCA6A005@common-lisp.net> Author: ehuelsmann Date: Sat Feb 16 18:48:31 2008 New Revision: 310 Modified: usocket/trunk/backend/clisp.lisp usocket/trunk/backend/cmucl.lisp usocket/trunk/backend/lispworks.lisp usocket/trunk/backend/openmcl.lisp usocket/trunk/backend/sbcl.lisp usocket/trunk/backend/scl.lisp usocket/trunk/condition.lisp Log: Adapt backends to my newly gained understanding of the CL condition system: make handle-condition less gready grabbing errors, now that with-mapped-conditions is adapted to use handler-bind instead of handler-case. Modified: usocket/trunk/backend/clisp.lisp ============================================================================== --- usocket/trunk/backend/clisp.lisp (original) +++ usocket/trunk/backend/clisp.lisp Sat Feb 16 18:48:31 2008 @@ -49,13 +49,11 @@ (let ((usock-err (cdr (assoc (car (simple-condition-format-arguments condition)) +clisp-error-map+ :test #'member)))) - (if usock-err + (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)) - (error 'unknown-error - :socket socket - :real-error condition)))))) + (signal usock-err :socket socket))))))) (defun socket-connect (host port &key (element-type 'character)) (let ((socket) Modified: usocket/trunk/backend/cmucl.lisp ============================================================================== --- usocket/trunk/backend/cmucl.lisp (original) +++ usocket/trunk/backend/cmucl.lisp Sat Feb 16 18:48:31 2008 @@ -48,11 +48,7 @@ (typecase condition (ext::socket-error (cmucl-map-socket-error (ext::socket-errno condition) :socket socket - :condition condition)) - (simple-error (error 'unknown-error - :real-condition condition - :socket socket)) - (condition (error condition)))) + :condition condition)))) (defun socket-connect (host port &key (element-type 'character)) (let* ((socket)) Modified: usocket/trunk/backend/lispworks.lisp ============================================================================== --- usocket/trunk/backend/lispworks.lisp (original) +++ usocket/trunk/backend/lispworks.lisp Sat Feb 16 18:48:31 2008 @@ -45,13 +45,11 @@ (defun raise-or-signal-socket-error (errno socket) (let ((usock-err (cdr (assoc errno +lispworks-error-map+ :test #'member)))) - (if usock-err + (when usock-err ;; don't claim the error when we're not sure + ;; it's actually sockets related (if (subtypep usock-err 'error) (error usock-err :socket socket) - (signal usock-err :socket)) - (error 'unknown-error - :socket socket - :real-condition nil)))) + (signal usock-err :socket))))) (defun raise-usock-err (errno socket &optional condition) (let* ((usock-err Modified: usocket/trunk/backend/openmcl.lisp ============================================================================== --- usocket/trunk/backend/openmcl.lisp (original) +++ usocket/trunk/backend/openmcl.lisp Sat Feb 16 18:48:31 2008 @@ -69,10 +69,8 @@ (raise-error-from-id (openmcl-socket:socket-error-identifier condition) socket condition)) (ccl::socket-creation-error #| ugh! |# - (raise-error-from-id (ccl::socket-creationg-error-identifier condition) - socket condition)) - (error (error 'unknown-error :socket socket :real-error condition)) - (condition (signal 'unknown-condition :real-condition condition)))) + (raise-error-from-id (ccl::socket-creation-error-identifier condition) + socket condition)))) (defun to-format (element-type) (if (subtypep element-type 'character) Modified: usocket/trunk/backend/sbcl.lisp ============================================================================== --- usocket/trunk/backend/sbcl.lisp (original) +++ usocket/trunk/backend/sbcl.lisp Sat Feb 16 18:48:31 2008 @@ -173,20 +173,15 @@ (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)))) + (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) - (signal 'unknown-condition - :real-condition condition)))))) + (signal usock-cond :socket socket)))))) (defun socket-connect (host port &key (element-type 'character)) Modified: usocket/trunk/backend/scl.lisp ============================================================================== --- usocket/trunk/backend/scl.lisp (original) +++ usocket/trunk/backend/scl.lisp Sat Feb 16 18:48:31 2008 @@ -26,11 +26,7 @@ (ext::socket-error (scl-map-socket-error (ext::socket-errno condition) :socket socket - :condition condition)) - (error - (error 'unknown-error - :real-condition condition - :socket socket)))) + :condition condition)))) (defun socket-connect (host port &key (element-type 'character)) (let* ((socket (with-mapped-conditions () Modified: usocket/trunk/condition.lisp ============================================================================== --- usocket/trunk/condition.lisp (original) +++ usocket/trunk/condition.lisp Sat Feb 16 18:48:31 2008 @@ -115,9 +115,8 @@ error available.")) (defmacro with-mapped-conditions ((&optional socket) &body body) - `(handler-case - (progn , at body) - (condition (condition) (handle-condition condition ,socket)))) + `(handler-bind ((condition #'(lambda (c) (handle-condition c ,socket)))) + , at body)) (defparameter +unix-errno-condition-map+ `(((11) . retry-condition) ;; EAGAIN From ehuelsmann at common-lisp.net Sat Feb 16 23:51:10 2008 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Sat, 16 Feb 2008 18:51:10 -0500 (EST) Subject: [usocket-cvs] r311 - usocket/trunk/backend Message-ID: <20080216235110.C80A36A005@common-lisp.net> Author: ehuelsmann Date: Sat Feb 16 18:51:09 2008 New Revision: 311 Modified: usocket/trunk/backend/sbcl.lisp Log: Nameservice condition/error mapping to usocket conditions/errors. Modified: usocket/trunk/backend/sbcl.lisp ============================================================================== --- usocket/trunk/backend/sbcl.lisp (original) +++ usocket/trunk/backend/sbcl.lisp Sat Feb 16 18:51:09 2008 @@ -159,11 +159,11 @@ (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 ...) - )) + (sb-bsd-sockets:no-recovery-error . ns-no-recovery-error) + (sb-bsd-sockets:try-again-condition . ns-try-again-condition) + (sb-bsd-sockets:host-not-found . ns-host-not-found-error))) (defun handle-condition (condition &optional (socket nil)) "Dispatch correct usocket condition." From ehuelsmann at common-lisp.net Sun Feb 17 09:29:37 2008 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Sun, 17 Feb 2008 04:29:37 -0500 (EST) Subject: [usocket-cvs] r312 - usocket/trunk/backend Message-ID: <20080217092937.CFD154610B@common-lisp.net> Author: ehuelsmann Date: Sun Feb 17 04:29:37 2008 New Revision: 312 Modified: usocket/trunk/backend/sbcl.lisp Log: Fix ECL error reporting: we need to map an errno-error, not a socket-error. Modified: usocket/trunk/backend/sbcl.lisp ============================================================================== --- usocket/trunk/backend/sbcl.lisp (original) +++ usocket/trunk/backend/sbcl.lisp Sun Feb 17 04:29:37 2008 @@ -323,5 +323,5 @@ (socket s)) result-fds))) sockets) - (map-socket-error err))))))) + (error (map-errno-error err)))))))) ) From ehuelsmann at common-lisp.net Sun Feb 17 09:38:05 2008 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Sun, 17 Feb 2008 04:38:05 -0500 (EST) Subject: [usocket-cvs] r313 - usocket/trunk/backend Message-ID: <20080217093805.0A4DF25115@common-lisp.net> Author: ehuelsmann Date: Sun Feb 17 04:37:57 2008 New Revision: 313 Modified: usocket/trunk/backend/lispworks.lisp Log: Adapt LW backend WAIT-FOR-INPUT-INTERNAL to new general behaviour in caller, which already adjusts TIMEOUT. Modified: usocket/trunk/backend/lispworks.lisp ============================================================================== --- usocket/trunk/backend/lispworks.lisp (original) +++ usocket/trunk/backend/lispworks.lisp Sun Feb 17 04:37:57 2008 @@ -326,14 +326,7 @@ 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) + (wait-for-sockets sockets timeout) (sockets-ready sockets)) );; end of WIN32-block From ehuelsmann at common-lisp.net Sun Feb 17 12:44:48 2008 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Sun, 17 Feb 2008 07:44:48 -0500 (EST) Subject: [usocket-cvs] r314 - usocket/trunk/backend Message-ID: <20080217124448.07BDD5E006@common-lisp.net> Author: ehuelsmann Date: Sun Feb 17 07:44:47 2008 New Revision: 314 Modified: usocket/trunk/backend/lispworks.lisp Log: Clean up LW backend for socket waiting: - rename MAP-NETWORK-ERRORS to MAP-NETWORK-EVENTS - reimplement more lispy HAS-NETWORK-ERRORS-P (record for posterity, as it's now unused) - change implementation of SOCKETS-READY to use MAP-NETWORK-EVENTS Modified: usocket/trunk/backend/lispworks.lisp ============================================================================== --- usocket/trunk/backend/lispworks.lisp (original) +++ usocket/trunk/backend/lispworks.lisp Sun Feb 17 07:44:47 2008 @@ -292,38 +292,50 @@ nil)))) - (defun map-network-errors (func network-events) + (defun map-network-events (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)))))) + (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 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)))) + (map-network-events #'(lambda (err-code) + (unless (zerop err-code) + (return-from has-network-errors-p t))) + network-events) + nil) + + (defun has-non-error-state-p (network-events) + (map-network-events #'(lambda (err-code) + (when (zerop err-code) + (return-from has-non-error-state-p t))) + network-errors) + nil) (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)) + (remove-if-not + #'(lambda (socket) + (multiple-value-bind + (rv network-events) + (wsa-enum-network-events (os-socket-handle socket) 0) + (if (zerop rv) + (let ((non-error-state-p nil)) + ;; raise any errors we find + (map-network-events + #'(lambda (err-code) + (if (zerop err-code) + (setf non-error-statep t) + (let ((err-class (map-errno-error err-code))) + (if (subtypep err-class 'socket-error) + (error err-class :socket socket) + (error err-class))))) + network-events) + ;; return whether we found non-error state + non-error-state-p) + (maybe-wsa-error rv socket)))) + sockets)) (defun wait-for-input-internal (sockets &key timeout) (wait-for-sockets sockets timeout) From ehuelsmann at common-lisp.net Sun Feb 17 12:46:10 2008 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Sun, 17 Feb 2008 07:46:10 -0500 (EST) Subject: [usocket-cvs] r315 - usocket/trunk/backend Message-ID: <20080217124610.D31096D07A@common-lisp.net> Author: ehuelsmann Date: Sun Feb 17 07:46:10 2008 New Revision: 315 Modified: usocket/trunk/backend/lispworks.lisp Log: Remove obsolete HAS-NON-ERROR-STATE-P and HAS-NETWORK-ERRORS-P. Modified: usocket/trunk/backend/lispworks.lisp ============================================================================== --- usocket/trunk/backend/lispworks.lisp (original) +++ usocket/trunk/backend/lispworks.lisp Sun Feb 17 07:46:10 2008 @@ -300,20 +300,6 @@ (unless (zerop (ldb (byte 1 i) event-map)) (funcall func (fli:foreign-aref error-array i))))))) - (defun has-network-errors-p (network-events) - (map-network-events #'(lambda (err-code) - (unless (zerop err-code) - (return-from has-network-errors-p t))) - network-events) - nil) - - (defun has-non-error-state-p (network-events) - (map-network-events #'(lambda (err-code) - (when (zerop err-code) - (return-from has-non-error-state-p t))) - network-errors) - nil) - (defun sockets-ready (sockets) (remove-if-not #'(lambda (socket) From ehuelsmann at common-lisp.net Sun Feb 17 19:29:17 2008 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Sun, 17 Feb 2008 14:29:17 -0500 (EST) Subject: [usocket-cvs] r316 - in usocket/trunk: . backend Message-ID: <20080217192917.5762956222@common-lisp.net> Author: ehuelsmann Date: Sun Feb 17 14:29:16 2008 New Revision: 316 Modified: usocket/trunk/backend/lispworks.lisp usocket/trunk/usocket.lisp Log: Take alternate approach on LW: We don't know whether the internals depend on WSAEnumNetworkEvents(), but if we use that function, the internals can't work correctly anymore: it clears the socket state. So, for the stream socket (the one type supported by LispWorks), resort to trickery to establish whether there are octets to be read from the network buffer. Modified: usocket/trunk/backend/lispworks.lisp ============================================================================== --- usocket/trunk/backend/lispworks.lisp (original) +++ usocket/trunk/backend/lispworks.lisp Sun Feb 17 14:29:16 2008 @@ -45,11 +45,13 @@ (defun raise-or-signal-socket-error (errno socket) (let ((usock-err (cdr (assoc errno +lispworks-error-map+ :test #'member)))) - (when usock-err ;; don't claim the error when we're not sure - ;; it's actually sockets related + (if usock-err (if (subtypep usock-err 'error) (error usock-err :socket socket) - (signal usock-err :socket))))) + (signal usock-err :socket)) + (error 'unknown-error + :socket socket + :real-condition nil)))) (defun raise-usock-err (errno socket &optional condition) (let* ((usock-err @@ -105,6 +107,9 @@ :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 @@ -148,9 +153,7 @@ (comm:get-host-entry name :fields '(:addresses))))) (defun os-socket-handle (usocket) - (if (stream-usocket-p usocket) - (comm:socket-stream-socket (socket usocket)) - (socket usocket))) + (socket usocket)) (defun usocket-listen (usocket) (if (stream-usocket-p usocket) @@ -223,6 +226,8 @@ (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) @@ -234,7 +239,7 @@ :result-type :int :module "ws2_32") (fli:define-foreign-function (wsa-event-close "WSACloseEvent" :source) - (event-object win32-handle) + ((event-object win32-handle)) :result-type :int :module "ws2_32") (fli:define-foreign-function (wsa-enum-network-events "WSAEnumNetworkEvents" :source) @@ -256,6 +261,15 @@ :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 @@ -271,6 +285,13 @@ (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)) @@ -279,52 +300,51 @@ (wsa-event-select (os-socket-handle socket) event-object events) socket))) - (defun wait-for-sockets (sockets timeout) + (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 - (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)))) - + (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-value network-events 'error-code))) + (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))))))) + (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 - #'(lambda (socket) - (multiple-value-bind - (rv network-events) - (wsa-enum-network-events (os-socket-handle socket) 0) - (if (zerop rv) - (let ((non-error-state-p nil)) - ;; raise any errors we find - (map-network-events - #'(lambda (err-code) - (if (zerop err-code) - (setf non-error-statep t) - (let ((err-class (map-errno-error err-code))) - (if (subtypep err-class 'socket-error) - (error err-class :socket socket) - (error err-class))))) - network-events) - ;; return whether we found non-error state - non-error-state-p) - (maybe-wsa-error rv socket)))) - sockets)) - - (defun wait-for-input-internal (sockets &key timeout) - (wait-for-sockets sockets timeout) - (sockets-ready sockets)) - + (remove-if-not #'socket-ready-p sockets)) + );; end of WIN32-block Modified: usocket/trunk/usocket.lisp ============================================================================== --- usocket/trunk/usocket.lisp (original) +++ usocket/trunk/usocket.lisp Sun Feb 17 14:29:16 2008 @@ -45,7 +45,21 @@ #+lispworks 'base-char :reader element-type :documentation "Default element type for streams created by -`socket-accept'.")) +`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.")) From ehuelsmann at common-lisp.net Sun Feb 17 21:40:31 2008 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Sun, 17 Feb 2008 16:40:31 -0500 (EST) Subject: [usocket-cvs] r317 - usocket/trunk/backend Message-ID: <20080217214031.D3E7624121@common-lisp.net> Author: ehuelsmann Date: Sun Feb 17 16:40:31 2008 New Revision: 317 Modified: usocket/trunk/backend/sbcl.lisp Log: Fix nameservice condition/error names; also revert some of r307: fast-unix-select *does* return errno, but change the code a bit to prevent the compiler from issueing warnings. Modified: usocket/trunk/backend/sbcl.lisp ============================================================================== --- usocket/trunk/backend/sbcl.lisp (original) +++ usocket/trunk/backend/sbcl.lisp Sun Feb 17 16:40:31 2008 @@ -162,8 +162,8 @@ ;; Nameservice errors: mapped to unknown-error (sb-bsd-sockets:no-recovery-error . ns-no-recovery-error) - (sb-bsd-sockets:try-again-condition . ns-try-again-condition) - (sb-bsd-sockets:host-not-found . ns-host-not-found-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." @@ -279,25 +279,24 @@ (multiple-value-bind (secs musecs) (split-timeout (or timeout 1)) - (let ((count - (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))) - (unless (= 0 count) ;; 0 means timeout - (if (=> count 0) + (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) - (let ((err (sb-alien:get-errno))) - (unless (= err sb-unix:EINTR) - (error (map-errno-error err))))))))))) + (not (sb-unix:fd-isset + (sb-bsd-sockets:socket-file-descriptor (socket x)) + rfds))) + sockets)))))))) #+win32 (warn "wait-for-input not (yet!) supported...") From ehuelsmann at common-lisp.net Wed Feb 20 21:38:47 2008 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Wed, 20 Feb 2008 16:38:47 -0500 (EST) Subject: [usocket-cvs] r318 - usocket/branches/0.4.x Message-ID: <20080220213847.E20B6392D4@common-lisp.net> Author: ehuelsmann Date: Wed Feb 20 16:38:47 2008 New Revision: 318 Added: usocket/branches/0.4.x/ - copied from r317, usocket/trunk/ Log: Make way on trunk for development of UDP sockets interfaces by creating a WAIT-FOR-INPUT branch (0.4.x). From ehuelsmann at common-lisp.net Wed Feb 20 21:47:47 2008 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Wed, 20 Feb 2008 16:47:47 -0500 (EST) Subject: [usocket-cvs] r319 - usocket/trunk Message-ID: <20080220214747.43DAB3917E@common-lisp.net> Author: ehuelsmann Date: Wed Feb 20 16:47:46 2008 New Revision: 319 Modified: usocket/trunk/package.lisp usocket/trunk/usocket.lisp Log: Introduce datagram socket and several utility functions. Modified: usocket/trunk/package.lisp ============================================================================== --- usocket/trunk/package.lisp (original) +++ usocket/trunk/package.lisp Wed Feb 20 16:47:46 2008 @@ -33,6 +33,7 @@ #:stream-server-usocket #:socket #:socket-stream + #:datagram-usocket #:host-byte-order ; IP(v4) utility functions #:hbo-to-dotted-quad @@ -42,6 +43,13 @@ #: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 + #:socket-condition ; conditions #:ns-condition #:socket-error ; errors Modified: usocket/trunk/usocket.lisp ============================================================================== --- usocket/trunk/usocket.lisp (original) +++ usocket/trunk/usocket.lisp Wed Feb 20 16:47:46 2008 @@ -73,13 +73,11 @@ (typep socket 'stream-server-usocket)) (defun datagram-usocket-p (socket) - (declare (ignore socket)) - nil) + (typep socket 'datagram-usocket)) -;;Not in use yet: -;;(defclass datagram-usocket (usocket) -;; () -;; (:documentation "")) +(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." @@ -235,6 +233,42 @@ (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 ;; From ehuelsmann at common-lisp.net Thu Feb 21 20:29:19 2008 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Thu, 21 Feb 2008 15:29:19 -0500 (EST) Subject: [usocket-cvs] r320 - usocket/trunk Message-ID: <20080221202919.C011B340CC@common-lisp.net> Author: ehuelsmann Date: Thu Feb 21 15:29:19 2008 New Revision: 320 Modified: usocket/trunk/usocket.asd Log: Update version identifier, as 0.4.x has branched now, we're working toward 0.5.0. Modified: usocket/trunk/usocket.asd ============================================================================== --- usocket/trunk/usocket.asd (original) +++ usocket/trunk/usocket.asd Thu Feb 21 15:29:19 2008 @@ -14,7 +14,7 @@ (defsystem usocket :name "usocket" :author "Erik Enge & Erik Huelsmann" - :version "0.4.0-dev" + :version "0.5.0-dev" :licence "MIT" :description "Universal socket library for Common Lisp" :depends-on (:split-sequence From ehuelsmann at common-lisp.net Thu Feb 28 07:30:05 2008 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Thu, 28 Feb 2008 02:30:05 -0500 (EST) Subject: [usocket-cvs] r321 - usocket/trunk/backend Message-ID: <20080228073005.26EED111CE@common-lisp.net> Author: ehuelsmann Date: Thu Feb 28 02:30:01 2008 New Revision: 321 Modified: usocket/trunk/backend/clisp.lisp Log: Preliminary implementation of datagram sockets send(to)/recv(from) functions. TODO: - Adjust WAIT-FOR-INPUT - Think of a name to instantiate datagram sockets - Make sure the functions which retrieve local and remote socket names work with datagram sockets Modified: usocket/trunk/backend/clisp.lisp ============================================================================== --- usocket/trunk/backend/clisp.lisp (original) +++ usocket/trunk/backend/clisp.lisp Thu Feb 28 02:30:01 2008 @@ -145,3 +145,69 @@ (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-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:socket-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.") + + ) \ No newline at end of file