From: Nikodemus S. <de...@us...> - 2010-09-30 07:38:16
|
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 |