1.0.48.15: fix null broadcast-streams as RUN-PROGRAM output streams

[sbcl.git] / tests / run-program.impure.lisp

diff --git a/tests/run-program.impure.lisp b/tests/run-program.impure.lisp
index b6b38cf..e62eb95 100644 (file)
--- a/tests/run-program.impure.lisp
+++ b/tests/run-program.impure.lisp
@@ -31,6 +31,98 @@
               (assert (= (read-byte in) i)))
       (process-close process))))
 
+#+sb-thread
+(with-test (:name :run-program-cat-2)
+  ;; Tests that reading from a FIFO is interruptible.
+  (let* ((process (sb-ext:run-program "/bin/cat" '()
+                                      :wait nil
+                                      :output :stream :input :stream))
+         (in (process-input process))
+         (out (process-output process))
+         (sem (sb-thread:make-semaphore))
+         (state :init)
+         (writer (sb-thread:make-thread (lambda ()
+                                          (sb-thread:wait-on-semaphore sem)
+                                          (setf state :sleep)
+                                          (sleep 2)
+                                          (setf state :write)
+                                          (write-line "OK" in)
+                                          (finish-output in))))
+         (timeout nil)
+         (got nil)
+         (unwind nil))
+    (sb-thread:signal-semaphore sem)
+    (handler-case
+        (with-timeout 0.1
+          (unwind-protect
+               (setf got (read-line out))
+            (setf unwind state)))
+      (timeout ()
+        (setf timeout t)))
+    (assert (not got))
+    (assert timeout)
+    (assert (eq unwind :sleep))
+    (sb-thread:join-thread writer)
+    (assert (equal "OK" (read-line out)))))
+
+(defclass buffer-stream (sb-gray:fundamental-binary-input-stream sb-gray:fundamental-binary-output-stream)
+  ((buffer :initform (make-array 128
+                                :element-type '(unsigned-byte 8)
+                                :adjustable t
+                                :fill-pointer 0))
+   (mark :initform 0)))
+
+(defmethod stream-element-type ((stream buffer-stream))
+  '(unsigned-byte 8))
+
+(defmethod sb-gray:stream-read-sequence ((stream buffer-stream) seq &optional (start 0) end)
+  (let* ((buffer (slot-value stream 'buffer))
+         (end (or end (length seq)))
+         (mark (slot-value stream 'mark))
+         (fill-pointer (fill-pointer buffer))
+         (new-mark (+ mark (min fill-pointer (- end start)))))
+    (setf (slot-value stream 'mark) new-mark)
+    (replace seq buffer
+             :start1 start :end1 end
+             :start2 mark :end2 fill-pointer)
+    (min end (+ start (- fill-pointer mark)))))
+
+(defmethod sb-gray:stream-write-sequence ((stream buffer-stream) seq &optional (start 0) end)
+  (let* ((buffer (slot-value stream 'buffer))
+         (end (or end (length seq)))
+         (fill-pointer (fill-pointer buffer))
+         (new-fill (min (array-total-size buffer) (+ fill-pointer (- end start)))))
+    (setf (fill-pointer buffer) new-fill)
+    (replace buffer seq
+             :start1 fill-pointer
+             :start2 start :end2 end)
+    seq))
+
+(with-test (:name :run-program-cat-3)
+  ;; User-defined binary input and output streams.
+  (let ((in (make-instance 'buffer-stream))
+        (out (make-instance 'buffer-stream))
+        (data #(0 1 2 3 4 5 6 7 8 9 10 11 12)))
+    (write-sequence data in)
+    (let ((process (sb-ext:run-program "/bin/cat" '() :wait t :output out :input in))
+          (buf (make-array (length data))))
+      (assert (= 13 (read-sequence buf out)))
+      (assert (= 0 (read-sequence (make-array 8) out)))
+      (assert (equalp buf data)))))
+
+(with-test (:name :run-program-cat-4)
+  ;; Null broadcast stream as output
+  (let* ((process (sb-ext:run-program "/bin/cat" '() :wait nil
+                                      :output (make-broadcast-stream)
+                                      :input :stream))
+         (in (process-input process)))
+    (unwind-protect
+         (progn
+           (write-string "foobar" in)
+           (close in)
+           (process-wait process))
+      (process-close process))))
+
 ;;; Test driving an external program (cat) through pipes wrapped in
 ;;; composite streams.
 
@@ -53,7 +145,7 @@
 (defparameter *cat-out-pipe* (make-pipe))
 (defparameter *cat-out* (make-synonym-stream '*cat-out-pipe*))
 
-(with-test (:name :run-program-cat-2)
+(with-test (:name :run-program-cat-5)
   (let ((cat (run-program "/bin/cat" nil :input *cat-in* :output *cat-out*
                           :wait nil)))
     (dolist (test '("This is a test!"
@@ -84,8 +176,10 @@
 (defun read-linish (stream)
   (with-output-to-string (s)
     (loop for c = (read-char stream)
-       while (and c (not (eq #\newline c)) (not (eq #\return c)))
-       do (write-char c s))))
+          while (and c (not (eq #\newline c)))
+             ;; Some eds like to send \r\n
+          do (unless (eq #\return c)
+               (write-char c s)))))
 
 (defun assert-ed (command response)
   (when command
@@ -100,7 +194,7 @@
 (unwind-protect
      (with-test (:name :run-program-ed)
        (assert-ed nil "4")
-       (assert-ed ".s/bar/baz/g" "")
+       (assert-ed ".s/bar/baz/g" nil)
        (assert-ed "w" "4")
        (assert-ed "q" nil)
        (process-wait *ed*)