Author: hhubner Date: Wed Apr 23 17:29:50 2008 New Revision: 335 Modified: usocket/branches/hans/backend/allegro.lisp usocket/branches/hans/backend/armedbear.lisp usocket/branches/hans/backend/clisp.lisp usocket/branches/hans/backend/cmucl.lisp usocket/branches/hans/backend/lispworks.lisp usocket/branches/hans/backend/openmcl.lisp usocket/branches/hans/backend/sbcl.lisp usocket/branches/hans/backend/scl.lisp usocket/branches/hans/usocket.lisp Log: Merging from ITA branch: CCL fixes, timeout argument to SOCKET-CONNECT. Modified: usocket/branches/hans/backend/allegro.lisp ============================================================================== --- usocket/branches/hans/backend/allegro.lisp (original) +++ usocket/branches/hans/backend/allegro.lisp Wed Apr 23 17:29:50 2008 @@ -49,7 +49,9 @@ :text :binary)) -(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 Allegro CL")) (let ((socket)) (setf socket (with-mapped-conditions (socket) Modified: usocket/branches/hans/backend/armedbear.lisp ============================================================================== --- usocket/branches/hans/backend/armedbear.lisp (original) +++ usocket/branches/hans/backend/armedbear.lisp Wed Apr 23 17:29:50 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/branches/hans/backend/clisp.lisp ============================================================================== --- usocket/branches/hans/backend/clisp.lisp (original) +++ usocket/branches/hans/backend/clisp.lisp Wed Apr 23 17:29:50 2008 @@ -55,7 +55,9 @@ (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) + (when timeout + (warn "SOCKET-CONNECT timeout not supported in CLISP")) (let ((socket) (hostname (host-to-hostname host))) (with-mapped-conditions (socket) @@ -217,7 +219,7 @@ (defmethod socket-close ((usocket datagram-usocket)) (rawsock:sock-close (socket usocket))) - + ) #-rawsock @@ -226,4 +228,4 @@ 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 + ) Modified: usocket/branches/hans/backend/cmucl.lisp ============================================================================== --- usocket/branches/hans/backend/cmucl.lisp (original) +++ usocket/branches/hans/backend/cmucl.lisp Wed Apr 23 17:29:50 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/branches/hans/backend/lispworks.lisp ============================================================================== --- usocket/branches/hans/backend/lispworks.lisp (original) +++ usocket/branches/hans/backend/lispworks.lisp Wed Apr 23 17:29:50 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/branches/hans/backend/openmcl.lisp ============================================================================== --- usocket/branches/hans/backend/openmcl.lisp (original) +++ usocket/branches/hans/backend/openmcl.lisp Wed Apr 23 17:29:50 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/branches/hans/backend/sbcl.lisp ============================================================================== --- usocket/branches/hans/backend/sbcl.lisp (original) +++ usocket/branches/hans/backend/sbcl.lisp Wed Apr 23 17:29:50 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/branches/hans/backend/scl.lisp ============================================================================== --- usocket/branches/hans/backend/scl.lisp (original) +++ usocket/branches/hans/backend/scl.lisp Wed Apr 23 17:29:50 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))) Modified: usocket/branches/hans/usocket.lisp ============================================================================== --- usocket/branches/hans/usocket.lisp (original) +++ usocket/branches/hans/usocket.lisp Wed Apr 23 17:29:50 2008 @@ -77,7 +77,6 @@ (defclass datagram-usocket (usocket) ((connected-p :initarg :connected-p :accessor connected-p)) -;; ###FIXME: documentation to be added. (:documentation "")) (defun make-socket (&key socket)