On Sat, Dec 29, 2007, Erik Huelsmann wrote:
> That's why I rather use
> select()/LISTEN/READ-CHAR/READ-CHAR-NO-HANG/etc. to implement time-out
> behaviour which can be used on all lisps on all OSes. I hope you don't
> mind (and that you - as I do - think that the result is what counts).
I have implemented timeouts for non-LispWorks lisps. Latest usocket
trunk and working usocket:wait-for-input required.
Patch attached.
--
/\
/ Jabber ID :: [EMAIL PROTECTED]
\ \/ Unix stuff :: http://tehran.lain.pl
\/\ Yet Another RBL :: http://rbl.lain.pl
diff -urN /tmp/drakma-0.11.1/drakma.asd drakma-0.11.1/drakma.asd
--- /tmp/drakma-0.11.1/drakma.asd 2007-10-11 10:45:47.000000000 +0200
+++ drakma-0.11.1/drakma.asd 2007-12-29 14:01:24.000000000 +0100
@@ -48,9 +48,11 @@
(:file "util")
(:file "read")
(:file "cookies")
- (:file "request"))
+ (:file "request")
+ #-lispworks (:file "gray-streams"))
:depends-on (:puri
:cl-base64
:chunga
#-:lispworks :usocket
- #-(or :lispworks :allegro) :cl+ssl))
+ #-(or :lispworks :allegro) :cl+ssl
+ #-lispworks #:trivial-gray-streams))
diff -urN /tmp/drakma-0.11.1/gray-streams.lisp drakma-0.11.1/gray-streams.lisp
--- /tmp/drakma-0.11.1/gray-streams.lisp 1970-01-01 01:00:00.000000000 +0100
+++ drakma-0.11.1/gray-streams.lisp 2007-12-29 14:48:36.000000000 +0100
@@ -0,0 +1,46 @@
+(in-package #:drakma)
+
+(defclass timeout-stream (trivial-gray-stream-mixin
+ fundamental-binary-input-stream
+ fundamental-binary-output-stream)
+ ((socket :initarg :socket :accessor timeout-stream-socket)
+ (stream :initarg :stream :accessor timeout-stream-stream)
+ (timeout :initarg :timeout :accessor timeout-stream-timeout)))
+
+(defmethod stream-force-output ((stream timeout-stream))
+ (force-output (timeout-stream-stream stream)))
+
+(defmethod stream-finish-output ((stream timeout-stream))
+ (finish-output (timeout-stream-stream stream)))
+
+(defun timeout-stream-do-timeout (stream)
+ (with-slots (socket timeout stream) stream
+ (unless (or (listen stream)
+ (usocket:wait-for-input socket :timeout timeout))
+ (usocket:socket-close socket)
+ (error 'usocket:timeout-error :socket socket))))
+
+(defmethod stream-read-byte ((stream timeout-stream))
+ (timeout-stream-do-timeout stream)
+ (read-byte (timeout-stream-stream stream) nil nil))
+
+(defmethod stream-write-byte ((stream timeout-stream) integer)
+ (write-byte integer (timeout-stream-stream stream)))
+
+(defmethod stream-read-sequence ((stream timeout-stream)
+ sequence start end &key)
+ (loop
+ with s = (timeout-stream-stream stream)
+ with ret = 0
+ for i from start below end
+ do (timeout-stream-do-timeout stream)
+ do (setf (aref sequence i)
+ (or (read-byte s nil nil)
+ (return ret)))
+ do (incf i)
+ finally (return ret)))
+
+(defmethod stream-write-sequence ((stream timeout-stream)
+ sequence start end &key)
+ (write-sequence sequence (timeout-stream-stream stream)
+ :start start :end end))
diff -urN /tmp/drakma-0.11.1/request.lisp drakma-0.11.1/request.lisp
--- /tmp/drakma-0.11.1/request.lisp 2007-10-11 10:45:47.000000000 +0200
+++ drakma-0.11.1/request.lisp 2007-12-29 14:12:34.000000000 +0100
@@ -194,7 +194,7 @@
want-stream
stream
#+:lispworks (connection-timeout 20)
- #+:lispworks (read-timeout 20)
+ (read-timeout 20)
#+:lispworks5.0 (write-timeout 20))
"Sends an HTTP request to a web server and returns its reply. URI
is where the request is sent to, and it is either a string denoting a
@@ -428,9 +428,17 @@
:write-timeout write-timeout
:errorp t)
#-:lispworks
- (usocket:socket-stream
- (usocket:socket-connect host port
- :element-type 'octet)))))
+ (if (null read-timeout)
+ (usocket:socket-stream
+ (usocket:socket-connect host port
+ :element-type 'octet))
+ (let* ((socket (usocket:socket-connect host port
+ :element-type 'octet))
+ (stream (usocket:socket-stream socket)))
+ (make-instance 'timeout-stream
+ :socket socket
+ :stream stream
+ :timeout read-timeout))))))
(when (and (or force-ssl
(eq (uri-scheme uri) :https))
;; don't attach SSL to existing streams
_______________________________________________
drakma-devel mailing list
drakma-devel@common-lisp.net
http://common-lisp.net/cgi-bin/mailman/listinfo/drakma-devel
