From: David L. <lic...@us...> - 2012-10-19 16:57:29
|
The branch "master" has been updated in SBCL: via 7f9bcccc3463d69272fb98d7418a973e41a013c9 (commit) from 7572e0506af331534e6f97b027d56e8bea09410c (commit) - Log ----------------------------------------------------------------- commit 7f9bcccc3463d69272fb98d7418a973e41a013c9 Author: David Lichteblau <da...@li...> Date: Mon Sep 24 18:48:34 2012 +0200 sb-bsd-sockets: Add a test for interruptible I/O Test TCP sockets even without :internet-available, albeit only on threaded builds. Check that INTERRUPT-THREAD works in a timely fashion on threads currently blocked in I/O on a socket. --- contrib/sb-bsd-sockets/tests.lisp | 55 ++++++++++++++++++++++++++++++++++++- 1 files changed, 54 insertions(+), 1 deletions(-) diff --git a/contrib/sb-bsd-sockets/tests.lisp b/contrib/sb-bsd-sockets/tests.lisp index f624297..1ddb408 100644 --- a/contrib/sb-bsd-sockets/tests.lisp +++ b/contrib/sb-bsd-sockets/tests.lisp @@ -311,4 +311,57 @@ (format t "Received ~A bytes from ~A:~A - ~A ~%" len address port (subseq buf 0 (min 10 len))))))) - +#+sb-thread +(deftest interrupt-io + (let (result) + (labels + ((client (port) + (setf result + (let ((s (make-instance 'inet-socket + :type :stream + :protocol :tcp))) + (socket-connect s #(127 0 0 1) port) + (let ((stream (socket-make-stream s + :input t + :output t + :buffering :none))) + (handler-case + (prog1 + (catch 'stop + (progn + (read-char stream) + (sleep 0.1) + (sleep 0.1) + (sleep 0.1))) + (close stream)) + (error (c) + c)))))) + (server () + (let ((s (make-instance 'inet-socket + :type :stream + :protocol :tcp))) + (setf (sockopt-reuse-address s) t) + (socket-bind s (make-inet-address "127.0.0.1") 0) + (socket-listen s 5) + (multiple-value-bind (* port) + (socket-name s) + (let* ((client (sb-thread:make-thread + (lambda () (client port)))) + (r (socket-accept s)) + (stream (socket-make-stream r + :input t + :output t + :buffering :none)) + (ok :ok)) + (socket-close s) + (sleep 5) + (sb-thread:interrupt-thread client + (lambda () (throw 'stop ok))) + (sleep 5) + (setf ok :not-ok) + (write-char #\x stream) + (close stream) + (socket-close r)))))) + (server)) + result) + :ok) ----------------------------------------------------------------------- hooks/post-receive -- SBCL |