[usocket-cvs] r335 - in usocket/branches/hans: . backend
hhubner at common-lisp.net
hhubner at common-lisp.net
Wed Apr 23 21:29:52 UTC 2008
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)
More information about the usocket-cvs
mailing list