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