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