Steel Bank Common Lisp

Update of /cvsroot/sbcl/sbcl/tests
In directory sfp-cvsdas-3.v30.ch3.sourceforge.com:/tmp/cvs-serv4858/tests

Modified Files:
	stream.impure.lisp 
Log Message:
1.0.43.4: deal with interrupted open(2) calls

 Particularly if the other end is a FIFO, it isn't all that
 hard to get interrupted before open() completes.


Index: stream.impure.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/tests/stream.impure.lisp,v
retrieving revision 1.34
retrieving revision 1.35
diff -u -d -r1.34 -r1.35
--- stream.impure.lisp	12 Nov 2009 11:29:24 -0000	1.34
+++ stream.impure.lisp	30 Sep 2010 07:38:07 -0000	1.35
@@ -607,4 +607,36 @@
       (read-char-no-hang stream)
       (assert (< (- (get-universal-time) time) 2)))))
 
+#-win32
+(require :sb-posix)
+
+#-win32
+(with-test (:name :interrupt-open)
+  (let ((fifo nil)
+        (to 0))
+    (unwind-protect
+         (progn
+           ;; Make a FIFO
+           (setf fifo (sb-posix:mktemp "SBCL-fifo.XXXXXXX"))
+           (sb-posix:mkfifo fifo (logior sb-posix:s-iwusr sb-posix:s-irusr))
+           ;; Try to open it (which hangs), and interrupt ourselves with a timer,
+           ;; continue (this used to result in an error due to open(2) returning with
+           ;; EINTR, then interupt again and unwind.
+           (handler-case
+               (with-timeout 2
+                 (handler-bind ((timeout (lambda (c)
+                                           (when (eql 1 (incf to))
+                                             (continue c)))))
+                   (with-timeout 1
+                     (with-open-file (f fifo :direction :input)
+                       :open))))
+             (timeout ()
+               (if (eql 2 to)
+                   :timeout
+                   :wtf))
+             (error (e)
+               e)))
+      (when fifo
+        (ignore-errors (delete-file fifo))))))
+
 ;;; success