[usocket-cvs] r353 - usocket/trunk/backend

[ehuelsmann at common-lisp.net]

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