1.0.43.29: fix OVERAGER-CHARACTER-BUFFERING test-case

[sbcl.git] / tests / stream.impure.lisp

diff --git a/tests/stream.impure.lisp b/tests/stream.impure.lisp
index adf3986..60c00c5 100644 (file)
--- a/tests/stream.impure.lisp
+++ b/tests/stream.impure.lisp
@@ -607,4 +607,72 @@
       (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))))))
+
+#-win32
+(require :sb-posix)
+#-win32
+(with-test (:name :overeager-character-buffering)
+  (let ((fifo nil)
+        (proc nil))
+    (maphash
+     (lambda (format _)
+       (declare (ignore _))
+       (format t "trying ~A~%" format)
+       (finish-output t)
+       (unwind-protect
+            (progn
+              (setf fifo (sb-posix:mktemp "SBCL-fifo-XXXXXXX"))
+              (sb-posix:mkfifo fifo (logior sb-posix:s-iwusr sb-posix:s-irusr))
+              ;; KLUDGE: because we have both ends in the same process, we would
+              ;; need to use O_NONBLOCK, but this works too.
+              (setf proc
+                    (run-program "/bin/sh"
+                                 (list "-c"
+                                       (format nil "cat > ~A" (native-namestring fifo)))
+                                 :input :stream
+                                 :wait nil
+                                 :external-format format))
+              (write-line "foobar" (process-input proc))
+              (finish-output (process-input proc))
+              (with-open-file (f fifo :direction :input :external-format format)
+                (assert (equal "foobar" (read-line f)))))
+         (when proc
+           (ignore-errors (process-close proc))
+           (setf proc nil))
+         (when fifo
+           (ignore-errors (delete-file fifo))
+           (setf fifo nil))))
+     sb-impl::*external-formats*)))
+
 ;;; success