Hi Erik,
since I last posted my patch, I have made some more changes to usocket
to support connect timeouts. I also removed the need for platform
specific syscalls files - Gary Byers suggested that we use #_select
instead of the direct syscall interface, which I think is the right
thing to do.
Let me know if that suits.
-Hans
2008/4/9, Erik Huelsmann <[EMAIL PROTECTED]>:
> On 3/25/08, Hans Hübner <[EMAIL PROTECTED]> wrote:
> > Hi,
> >
> > please consider this patch:
> >
> > http://bknr.net/trac/changeset/2795?format=diff&new=2795
> >
> > It fixes loading of system calls for Linux and FreeBSD. I have opened
> > a bug with Clozure to make them move to a unified system call loading
> > interface so that applications do not need to dispatch on an
> > architecture symbol, but until that went into CCL, the fix should be
> > fine.
>
>
> I missed this patch. I'll commit it tonight and backport it to the
> release branches it applies to.
>
> Bye,
>
>
> Erik.
>
Index: package.lisp
===================================================================
--- package.lisp (.../vendor/lisp/current/usocket-svn) (revision 175669)
+++ package.lisp (.../trunk/qres/lisp/libs/usocket) (working copy)
@@ -50,6 +50,7 @@
#:ip-to-octet-buffer
#:ip-from-octet-buffer
+ #:with-mapped-conditions
#:socket-condition ; conditions
#:ns-condition
#:socket-error ; errors
Index: usocket.lisp
===================================================================
--- usocket.lisp (.../vendor/lisp/current/usocket-svn) (revision 175669)
+++ usocket.lisp (.../trunk/qres/lisp/libs/usocket) (working copy)
@@ -167,7 +167,8 @@
`(let ((,var ,socket))
(unwind-protect
(when ,var
- ,@body)
+ (with-mapped-conditions (,var)
+ ,@body))
(when ,var
(socket-close ,var)))))
Index: backend/clisp.lisp
===================================================================
--- backend/clisp.lisp (.../vendor/lisp/current/usocket-svn) (revision 175669)
+++ backend/clisp.lisp (.../trunk/qres/lisp/libs/usocket) (working copy)
@@ -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)
Index: backend/lispworks.lisp
===================================================================
--- backend/lispworks.lisp (.../vendor/lisp/current/usocket-svn) (revision 175669)
+++ backend/lispworks.lisp (.../trunk/qres/lisp/libs/usocket) (working copy)
@@ -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
Index: backend/openmcl.lisp
===================================================================
--- backend/openmcl.lisp (.../vendor/lisp/current/usocket-svn) (revision 175669)
+++ backend/openmcl.lisp (.../trunk/qres/lisp/libs/usocket) (working copy)
@@ -5,15 +5,6 @@
(in-package :usocket)
-(eval-when (:compile-toplevel :load-toplevel :execute)
- ;; also present in OpenMCL l1-sockets.lisp
- #+linuxppc-target
- (require "LINUX-SYSCALLS")
- #+darwinppc-target
- (require "DARWIN-SYSCALLS")
- #+darwinx86-target
- (require "DARWINX8664-SYSCALLS"))
-
(defun get-host-name ()
(ccl::%stack-block ((resultbuf 256))
(when (zerop (#_gethostname resultbuf 256))
@@ -48,9 +39,9 @@
(let ((fd (openmcl-socket:socket-os-fd sock)))
(setf max-fd (max max-fd fd))
(ccl::fd-set fd infds)))
- (let* ((res (ccl::syscall syscalls::select (1+ max-fd)
- infds (ccl::%null-ptr) (ccl::%null-ptr)
- (if ticks-to-wait tv (ccl::%null-ptr)))))
+ (let* ((res (#_select (1+ max-fd)
+ infds (ccl::%null-ptr) (ccl::%null-ptr)
+ (if ticks-to-wait tv (ccl::%null-ptr)))))
(when (> res 0)
(remove-if #'(lambda (x)
(not (ccl::fd-is-set (openmcl-socket:socket-os-fd x)
@@ -66,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
Index: backend/scl.lisp
===================================================================
--- backend/scl.lisp (.../vendor/lisp/current/usocket-svn) (revision 175669)
+++ backend/scl.lisp (.../trunk/qres/lisp/libs/usocket) (working copy)
@@ -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)))
Index: backend/armedbear.lisp
===================================================================
--- backend/armedbear.lisp (.../vendor/lisp/current/usocket-svn) (revision 175669)
+++ backend/armedbear.lisp (.../trunk/qres/lisp/libs/usocket) (working copy)
@@ -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
Index: backend/cmucl.lisp
===================================================================
--- backend/cmucl.lisp (.../vendor/lisp/current/usocket-svn) (revision 175669)
+++ backend/cmucl.lisp (.../trunk/qres/lisp/libs/usocket) (working copy)
@@ -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)
Index: backend/sbcl.lisp
===================================================================
--- backend/sbcl.lisp (.../vendor/lisp/current/usocket-svn) (revision 175669)
+++ backend/sbcl.lisp (.../trunk/qres/lisp/libs/usocket) (working copy)
@@ -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
Index: backend/allegro.lisp
===================================================================
--- backend/allegro.lisp (.../vendor/lisp/current/usocket-svn) (revision 175669)
+++ backend/allegro.lisp (.../trunk/qres/lisp/libs/usocket) (working copy)
@@ -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)
Property changes on: backend
___________________________________________________________________
Name: svn:ignore
+ *.x86f
*.fasl
*.lx64fsl
Index: condition.lisp
===================================================================
--- condition.lisp (.../vendor/lisp/current/usocket-svn) (revision 175669)
+++ condition.lisp (.../trunk/qres/lisp/libs/usocket) (working copy)
@@ -148,7 +148,7 @@
((50 100) . network-down-error)
((52 102) . network-reset-error)
((58 108) . already-shutdown-error)
- ((60 110) . connection-timeout-error)
+ ((60 110) . timeout-error)
((64 112) . host-down-error)
((65 113) . host-unreachable-error)))
Property changes on: .
___________________________________________________________________
Name: svn:ignore
+ *.x86f
*.fasl
*.lx64fsl
_______________________________________________
usocket-devel mailing list
usocket-devel@common-lisp.net
http://common-lisp.net/cgi-bin/mailman/listinfo/usocket-devel
