From 6a55e39bd39283f56e197cc8719035a9bdd93987 Mon Sep 17 00:00:00 2001 From: David Lichteblau Date: Fri, 23 Nov 2012 18:15:31 +0100 Subject: [PATCH] sb-bsd-sockets: Implement NON-BLOCKING-MODE on Windows Thanks to Anton Kovalenko. --- contrib/sb-bsd-sockets/misc.lisp | 19 +++++++++++++------ contrib/sb-bsd-sockets/name-service.lisp | 3 +-- contrib/sb-bsd-sockets/sockets.lisp | 8 ++++++-- contrib/sb-bsd-sockets/sockopt.lisp | 3 ++- contrib/sb-bsd-sockets/tests.lisp | 8 ++++---- contrib/sb-bsd-sockets/win32-constants.lisp | 1 + 6 files changed, 27 insertions(+), 15 deletions(-) diff --git a/contrib/sb-bsd-sockets/misc.lisp b/contrib/sb-bsd-sockets/misc.lisp index 2c0246b..e38a613 100644 --- a/contrib/sb-bsd-sockets/misc.lisp +++ b/contrib/sb-bsd-sockets/misc.lisp @@ -22,7 +22,8 @@ 0)))) #+win32 -(defmethod non-blocking-mode ((socket socket)) 0) +(defmethod non-blocking-mode ((socket socket)) + (slot-value socket 'non-blocking-p)) (defgeneric (setf non-blocking-mode) (non-blocking-p socket) (:documentation "Put SOCKET in non-blocking mode - or not, according to NON-BLOCKING-P")) @@ -43,8 +44,14 @@ non-blocking-p)) #+win32 -(defmethod (setf non-blocking-mode) (non-blocking-p (socket socket)) 0) -;; (sb-alien:with-alien ((mode (unsigned 32))) -;; (if non-blocking-p (setf mode 1)) -;; (ioctlsocket socket FIONBIO mode))) - +(defmethod (setf non-blocking-mode) + (non-blocking-p (socket socket)) + (declare (optimize (speed 3))) + (setf (slot-value socket 'non-blocking-p) + (when non-blocking-p t)) + (let ((fd (socket-file-descriptor socket))) + (when (= (the (signed-byte 32) -1) + (the (signed-byte 32) + (sockint::ioctl fd sockint::FIONBIO (if non-blocking-p 1 0)))) + (socket-error "ioctl(FIONBIO)")) + (when non-blocking-p t))) diff --git a/contrib/sb-bsd-sockets/name-service.lisp b/contrib/sb-bsd-sockets/name-service.lisp index 0b731db..d148373 100644 --- a/contrib/sb-bsd-sockets/name-service.lisp +++ b/contrib/sb-bsd-sockets/name-service.lisp @@ -164,8 +164,7 @@ GET-NAME-SERVICE-ERRNO") (let ((*name-service-errno* (get-name-service-errno errno))) ;; Comment next to NETDB_INTERNAL in netdb.h says "See errno.". ;; This special case treatment hasn't actually been tested yet. - #-win32 - (if (= *name-service-errno* sockint::NETDB-INTERNAL) + (if (and #-win32 (= *name-service-errno* sockint::NETDB-INTERNAL)) (socket-error where) (let ((condition (condition-for-name-service-errno *name-service-errno*))) diff --git a/contrib/sb-bsd-sockets/sockets.lisp b/contrib/sb-bsd-sockets/sockets.lisp index 5d09d65..146d32b 100644 --- a/contrib/sb-bsd-sockets/sockets.lisp +++ b/contrib/sb-bsd-sockets/sockets.lisp @@ -26,6 +26,8 @@ protocol. Other values are used as-is.") (type :initarg :type :reader socket-type :documentation "Type of the socket: :STREAM or :DATAGRAM.") + #+win32 + (non-blocking-p :type (member t nil) :initform nil) (stream)) (:documentation "Common base class of all sockets, not meant to be directly instantiated."))) @@ -433,7 +435,7 @@ request an input stream and get an output stream in response\)." :external-format external-format :timeout timeout :auto-close auto-close - :serve-events serve-events)) + :serve-events (and serve-events #+win32 nil))) (setf (slot-value socket 'stream) stream)) (sb-ext:cancel-finalization socket) stream)) @@ -454,7 +456,9 @@ request an input stream and get an output stream in response\)." (socket-error-syscall c) (or (socket-error-symbol c) (socket-error-errno c)) #+cmu (sb-unix:get-unix-error-msg num) - #+sbcl (sb-int:strerror num))))) + #+sbcl + #+win32 (sb-win32::get-last-error-message num) + #-win32 (sb-int:strerror num))))) (:documentation "Common base class of socket related conditions.")) ;;; watch out for slightly hacky symbol punning: we use both the value diff --git a/contrib/sb-bsd-sockets/sockopt.lisp b/contrib/sb-bsd-sockets/sockopt.lisp index fb438f1..343fd18 100644 --- a/contrib/sb-bsd-sockets/sockopt.lisp +++ b/contrib/sb-bsd-sockets/sockopt.lisp @@ -55,7 +55,8 @@ Code for options that not every system has should be conditionalised: (if (= -1 (sockint::getsockopt (socket-file-descriptor socket) ,find-level ,number (sb-alien:addr buffer) - (sb-alien:addr size))) + #+win32 size + #-win32 (sb-alien:addr size))) (socket-error "getsockopt") (,mangle-return buffer size))) `(error 'unsupported-operator diff --git a/contrib/sb-bsd-sockets/tests.lisp b/contrib/sb-bsd-sockets/tests.lisp index 1ddb408..776878c 100644 --- a/contrib/sb-bsd-sockets/tests.lisp +++ b/contrib/sb-bsd-sockets/tests.lisp @@ -50,7 +50,7 @@ (and (> (socket-file-descriptor s) 1) t)) t) -(deftest* (make-inet-socket-wrong :fails-on :win32) +(deftest* (make-inet-socket-wrong) ;; fail to make a socket: check correct error return. There's no nice ;; way to check the condition stuff on its own, which is a shame (handler-case @@ -66,7 +66,7 @@ (:no-error nil)) t) -(deftest* (make-inet-socket-keyword-wrong :fails-on :win32) +(deftest* (make-inet-socket-keyword-wrong) ;; same again with keywords (handler-case (make-instance 'inet-socket :type :stream :protocol :udp) @@ -83,7 +83,7 @@ t) -(deftest* (non-block-socket :fails-on :win32) +(deftest* (non-block-socket) (let ((s (make-instance 'inet-socket :type :stream :protocol :tcp))) (setf (non-blocking-mode s) t) (non-blocking-mode s)) @@ -112,7 +112,7 @@ (address-in-use-error () t))) t) -(deftest* (simple-sockopt-test :fails-on :win32) +(deftest* (simple-sockopt-test) ;; test we can set SO_REUSEADDR on a socket and retrieve it, and in ;; the process that all the weird macros in sockopt happened right. (let ((s (make-instance 'inet-socket :type :stream :protocol (get-protocol-by-name "tcp")))) diff --git a/contrib/sb-bsd-sockets/win32-constants.lisp b/contrib/sb-bsd-sockets/win32-constants.lisp index 4bf52d2..7b8e719 100644 --- a/contrib/sb-bsd-sockets/win32-constants.lisp +++ b/contrib/sb-bsd-sockets/win32-constants.lisp @@ -73,6 +73,7 @@ (:integer ENETUNREACH "WSAENETUNREACH") (:integer ENOTCONN "WSAENOTCONN") (:integer inaddr-any "INADDR_ANY") + (:integer FIONBIO "FIONBIO") ;; for socket-receive -- 1.7.10.4