Author: ehuelsmann
Date: Fri Jun 20 20:06:02 2008
New Revision: 353
Modified:
usocket/trunk/backend/allegro.lisp
usocket/trunk/backend/armedbear.lisp
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
Log:
Start supporting the timeout parameter for SOCKET-CONNECT.
>From a patch by Hans Huebner, with additional supported platforms from me.
Modified: usocket/trunk/backend/allegro.lisp
==============================================================================
--- usocket/trunk/backend/allegro.lisp (original)
+++ usocket/trunk/backend/allegro.lisp Fri Jun 20 20:06:02 2008
@@ -49,13 +49,18 @@
:text
:binary))
-(defun socket-connect (host port &key (element-type 'character))
+(defun socket-connect (host port &key (element-type 'character) timeout)
(let ((socket))
(setf socket
(with-mapped-conditions (socket)
- (socket:make-socket :remote-host (host-to-hostname host)
- :remote-port port
- :format (to-format element-type))))
+ (if timeout
+ (mp:with-timeout (timeout nil)
+ (socket:make-socket :remote-host (host-to-hostname host)
+ :remote-port port
+ :format (to-format element-type)))
+ (socket:make-socket :remote-host (host-to-hostname host)
+ :remote-port port
+ :format (to-format element-type)))))
(make-stream-socket :socket socket :stream socket)))
Modified: usocket/trunk/backend/armedbear.lisp
==============================================================================
--- usocket/trunk/backend/armedbear.lisp (original)
+++ usocket/trunk/backend/armedbear.lisp Fri Jun 20 20:06:02 2008
@@ -185,7 +185,9 @@
(typecase condition
(error (error 'unknown-error :socket socket :real-error condition))))
-(defun socket-connect (host port &key (element-type 'character))
+(defun socket-connect (host port &key (element-type 'character) timeout)
+ (when timeout
+ (warn "SOCKET-CONNECT timeout not supported in ABCL"))
(let ((usock))
(with-mapped-conditions (usock)
(let* ((sock-addr (jdi:jcoerce
Modified: usocket/trunk/backend/clisp.lisp
==============================================================================
--- usocket/trunk/backend/clisp.lisp (original)
+++ usocket/trunk/backend/clisp.lisp Fri Jun 20 20:06:02 2008
@@ -55,14 +55,19 @@
(error usock-err :socket socket)
(signal usock-err :socket socket)))))))
-(defun socket-connect (host port &key (element-type 'character))
+(defun socket-connect (host port &key (element-type 'character) timeout)
(let ((socket)
(hostname (host-to-hostname host)))
(with-mapped-conditions (socket)
- (setf socket
- (socket:socket-connect port hostname
- :element-type element-type
- :buffered t)))
+ (setf socket
+ (if timeout
+ (socket:socket-connect port hostname
+ :element-type element-type
+ :buffered t
+ :timeout timeout)
+ (socket:socket-connect port hostname
+ :element-type element-type
+ :buffered t))))
(make-stream-socket :socket socket
:stream socket))) ;; the socket is a stream too
Modified: usocket/trunk/backend/cmucl.lisp
==============================================================================
--- usocket/trunk/backend/cmucl.lisp (original)
+++ usocket/trunk/backend/cmucl.lisp Fri Jun 20 20:06:02 2008
@@ -50,7 +50,9 @@
:socket socket
:condition condition))))
-(defun socket-connect (host port &key (element-type 'character))
+(defun socket-connect (host port &key (element-type 'character) timeout)
+ (when timeout
+ (warn "SOCKET-CONNECT timeout not supported in CMUCL"))
(let* ((socket))
(setf socket
(with-mapped-conditions (socket)
Modified: usocket/trunk/backend/lispworks.lisp
==============================================================================
--- usocket/trunk/backend/lispworks.lisp (original)
+++ usocket/trunk/backend/lispworks.lisp Fri Jun 20 20:06:02 2008
@@ -73,7 +73,9 @@
(declare (ignore host port err-msg))
(raise-usock-err errno socket condition)))))
-(defun socket-connect (host port &key (element-type 'base-char))
+(defun socket-connect (host port &key (element-type 'base-char) timeout)
+ (when timeout
+ (warn "SOCKET-CONNECT timeout not supported in Lispworks"))
(let ((hostname (host-to-hostname host))
(stream))
(setf stream
Modified: usocket/trunk/backend/openmcl.lisp
==============================================================================
--- usocket/trunk/backend/openmcl.lisp (original)
+++ usocket/trunk/backend/openmcl.lisp Fri Jun 20 20:06:02 2008
@@ -57,25 +57,30 @@
(defun handle-condition (condition &optional socket)
(typecase condition
(openmcl-socket:socket-error
- (raise-error-from-id (openmcl-socket:socket-error-identifier condition)
- socket condition))
+ (raise-error-from-id (openmcl-socket:socket-error-identifier condition)
+ socket condition))
+ (ccl:communication-deadline-expired
+ (error 'timeout-error :socket socket :real-error condition))
(ccl::socket-creation-error #| ugh! |#
- (raise-error-from-id (ccl::socket-creation-error-identifier condition)
- socket condition))))
+ (raise-error-from-id (ccl::socket-creation-error-identifier condition)
+ socket condition))))
(defun to-format (element-type)
(if (subtypep element-type 'character)
:text
:binary))
-(defun socket-connect (host port &key (element-type 'character))
+(defun socket-connect (host port &key (element-type 'character) timeout deadline)
(with-mapped-conditions ()
- (let ((mcl-sock
- (openmcl-socket:make-socket :remote-host (host-to-hostname host)
- :remote-port port
- :format (to-format element-type))))
- (openmcl-socket:socket-connect mcl-sock)
- (make-stream-socket :stream mcl-sock :socket mcl-sock))))
+ (let ((mcl-sock
+ (openmcl-socket:make-socket :remote-host (host-to-hostname host)
+ :remote-port port
+ :format (to-format element-type)
+ :deadline deadline
+ :connect-timeout (and timeout
+ (* timeout internal-time-units-per-second)))))
+ (openmcl-socket:socket-connect mcl-sock)
+ (make-stream-socket :stream mcl-sock :socket mcl-sock))))
(defun socket-listen (host port
&key reuseaddress
Modified: usocket/trunk/backend/sbcl.lisp
==============================================================================
--- usocket/trunk/backend/sbcl.lisp (original)
+++ usocket/trunk/backend/sbcl.lisp Fri Jun 20 20:06:02 2008
@@ -184,7 +184,10 @@
(signal usock-cond :socket socket))))))
-(defun socket-connect (host port &key (element-type 'character))
+(defun socket-connect (host port &key (element-type 'character) timeout deadline)
+ (declare (ignore deadline))
+ (when timeout
+ (warn "SOCKET-CONNECT timeout not supported in SBCL"))
(let* ((socket (make-instance 'sb-bsd-sockets:inet-socket
:type :stream :protocol :tcp))
(stream (sb-bsd-sockets:socket-make-stream socket
Modified: usocket/trunk/backend/scl.lisp
==============================================================================
--- usocket/trunk/backend/scl.lisp (original)
+++ usocket/trunk/backend/scl.lisp Fri Jun 20 20:06:02 2008
@@ -28,7 +28,9 @@
:socket socket
:condition condition))))
-(defun socket-connect (host port &key (element-type 'character))
+(defun socket-connect (host port &key (element-type 'character) timeout)
+ (when timeout
+ (warn "SOCKET-CONNECT timeout not supported in SCL"))
(let* ((socket (with-mapped-conditions ()
(ext:connect-to-inet-socket (host-to-hbo host) port
:kind :stream)))