tests/run-program.impure.lisp

   1 ;;;; various RUN-PROGRAM tests with side effects
   2
   3 ;;;; This software is part of the SBCL system. See the README file for
   4 ;;;; more information.
   5 ;;;;
   6 ;;;; While most of SBCL is derived from the CMU CL system, the test
   7 ;;;; files (like this one) were written from scratch after the fork
   8 ;;;; from CMU CL.
   9 ;;;;
  10 ;;;; This software is in the public domain and is provided with
  11 ;;;; absolutely no warranty. See the COPYING and CREDITS files for
  12 ;;;; more information.
  13
  14 (cl:in-package :cl-user)
  15
  16 ;; In addition to definitions lower down the impurity we're avoiding
  17 ;; is the sigchld handler that RUN-PROGRAM sets up, which interfers
  18 ;; with the manual unix process control done by the test framework
  19 ;; (sometimes the handler will manage to WAIT3 a process before
  20 ;; run-tests WAITPIDs it).
  21
  22 (with-test (:name :run-program-cat-1)
  23   (let* ((process (sb-ext:run-program "/bin/cat" '() :wait nil
  24                                       :output :stream :input :stream))
  25          (out (process-input process))
  26          (in (process-output process)))
  27     (unwind-protect
  28          (loop for i from 0 to 255 do
  29               (write-byte i out)
  30               (force-output out)
  31               (assert (= (read-byte in) i)))
  32       (process-close process))))
  33
  34 #+sb-thread
  35 (with-test (:name :run-program-cat-2)
  36   ;; Tests that reading from a FIFO is interruptible.
  37   (let* ((process (sb-ext:run-program "/bin/cat" '()
  38                                       :wait nil
  39                                       :output :stream :input :stream))
  40          (in (process-input process))
  41          (out (process-output process))
  42          (sem (sb-thread:make-semaphore))
  43          (state :init)
  44          (writer (sb-thread:make-thread (lambda ()
  45                                           (sb-thread:wait-on-semaphore sem)
  46                                           (setf state :sleep)
  47                                           (sleep 2)
  48                                           (setf state :write)
  49                                           (write-line "OK" in)
  50                                           (finish-output in))))
  51          (timeout nil)
  52          (got nil)
  53          (unwind nil))
  54     (sb-thread:signal-semaphore sem)
  55     (handler-case
  56         (with-timeout 0.1
  57           (unwind-protect
  58                (setf got (read-line out))
  59             (setf unwind state)))
  60       (timeout ()
  61         (setf timeout t)))
  62     (assert (not got))
  63     (assert timeout)
  64     (assert (eq unwind :sleep))
  65     (sb-thread:join-thread writer)
  66     (assert (equal "OK" (read-line out)))))
  67
  68 (defclass buffer-stream (sb-gray:fundamental-binary-input-stream sb-gray:fundamental-binary-output-stream)
  69   ((buffer :initform (make-array 128
  70                                 :element-type '(unsigned-byte 8)
  71                                 :adjustable t
  72                                 :fill-pointer 0))
  73    (mark :initform 0)))
  74
  75 (defmethod stream-element-type ((stream buffer-stream))
  76   '(unsigned-byte 8))
  77
  78 (defmethod sb-gray:stream-read-sequence ((stream buffer-stream) seq &optional (start 0) end)
  79   (let* ((buffer (slot-value stream 'buffer))
  80          (end (or end (length seq)))
  81          (mark (slot-value stream 'mark))
  82          (fill-pointer (fill-pointer buffer))
  83          (new-mark (+ mark (min fill-pointer (- end start)))))
  84     (setf (slot-value stream 'mark) new-mark)
  85     (replace seq buffer
  86              :start1 start :end1 end
  87              :start2 mark :end2 fill-pointer)
  88     (min end (+ start (- fill-pointer mark)))))
  89
  90 (defmethod sb-gray:stream-write-sequence ((stream buffer-stream) seq &optional (start 0) end)
  91   (let* ((buffer (slot-value stream 'buffer))
  92          (end (or end (length seq)))
  93          (fill-pointer (fill-pointer buffer))
  94          (new-fill (min (array-total-size buffer) (+ fill-pointer (- end start)))))
  95     (setf (fill-pointer buffer) new-fill)
  96     (replace buffer seq
  97              :start1 fill-pointer
  98              :start2 start :end2 end)
  99     seq))
 100
 101 (with-test (:name :run-program-cat-3)
 102   ;; User-defined binary input and output streams.
 103   (let ((in (make-instance 'buffer-stream))
 104         (out (make-instance 'buffer-stream))
 105         (data #(0 1 2 3 4 5 6 7 8 9 10 11 12)))
 106     (write-sequence data in)
 107     (let ((process (sb-ext:run-program "/bin/cat" '() :wait t :output out :input in))
 108           (buf (make-array (length data))))
 109       (assert (= 13 (read-sequence buf out)))
 110       (assert (= 0 (read-sequence (make-array 8) out)))
 111       (assert (equalp buf data)))))
 112
 113 ;;; Test driving an external program (cat) through pipes wrapped in
 114 ;;; composite streams.
 115
 116 (require :sb-posix)
 117
 118 (defun make-pipe ()
 119   (multiple-value-bind (in out) (sb-posix:pipe)
 120     (let ((input (sb-sys:make-fd-stream in
 121                                         :input t
 122                                         :external-format :ascii
 123                                         :buffering :none :name "in"))
 124           (output (sb-sys:make-fd-stream out
 125                                          :output t
 126                                          :external-format :ascii
 127                                          :buffering :none :name "out")))
 128       (make-two-way-stream input output))))
 129
 130 (defparameter *cat-in-pipe* (make-pipe))
 131 (defparameter *cat-in* (make-synonym-stream '*cat-in-pipe*))
 132 (defparameter *cat-out-pipe* (make-pipe))
 133 (defparameter *cat-out* (make-synonym-stream '*cat-out-pipe*))
 134
 135 (with-test (:name :run-program-cat-2)
 136   (let ((cat (run-program "/bin/cat" nil :input *cat-in* :output *cat-out*
 137                           :wait nil)))
 138     (dolist (test '("This is a test!"
 139                     "This is another test!"
 140                     "This is the last test...."))
 141       (write-line test *cat-in*)
 142       (assert (equal test (read-line *cat-out*))))
 143     (process-close cat)))
 144
 145 ;;; The above test used to use ed, but there were buffering issues: on some platforms
 146 ;;; buffering of stdin and stdout depends on their TTYness, and ed isn't sufficiently
 147 ;;; agressive about flushing them. So, here's another test using :PTY.
 148
 149 (defparameter *tmpfile* "run-program-ed-test.tmp")
 150
 151 (with-open-file (f *tmpfile*
 152                    :direction :output
 153                    :if-exists :supersede)
 154   (write-line "bar" f))
 155
 156 (defparameter *ed*
 157   (run-program "/bin/ed" (list *tmpfile*) :wait nil :pty t))
 158
 159 (defparameter *ed-pipe* (make-two-way-stream (process-pty *ed*) (process-pty *ed*)))
 160 (defparameter *ed-in* (make-synonym-stream '*ed-pipe*))
 161 (defparameter *ed-out* (make-synonym-stream '*ed-pipe*))
 162
 163 (defun read-linish (stream)
 164   (with-output-to-string (s)
 165     (loop for c = (read-char stream)
 166           while (and c (not (eq #\newline c)))
 167              ;; Some eds like to send \r\n
 168           do (unless (eq #\return c)
 169                (write-char c s)))))
 170
 171 (defun assert-ed (command response)
 172   (when command
 173     (write-line command *ed-in*)
 174     (force-output *ed-in*))
 175   (when response
 176     (let ((got (read-linish *ed-out*)))
 177       (unless (equal response got)
 178         (error "wanted '~A' from ed, got '~A'" response got))))
 179   *ed*)
 180
 181 (unwind-protect
 182      (with-test (:name :run-program-ed)
 183        (assert-ed nil "4")
 184        (assert-ed ".s/bar/baz/g" nil)
 185        (assert-ed "w" "4")
 186        (assert-ed "q" nil)
 187        (process-wait *ed*)
 188        (with-open-file (f *tmpfile*)
 189          (assert (equal "baz" (read-line f)))))
 190   (delete-file *tmpfile*))
 191
 192 ;; Around 1.0.12 there was a regression when :INPUT or :OUTPUT was a
 193 ;; pathname designator.  Since these use the same code, it should
 194 ;; suffice to test just :INPUT.
 195 (let ((file))
 196   (unwind-protect
 197        (progn (with-open-file (f "run-program-test.tmp" :direction :output)
 198                 (setf file (truename f))
 199                 (write-line "Foo" f))
 200                   (assert (run-program "cat" ()
 201                                        :input file :output t
 202                                        :search t :wait t)))
 203     (when file
 204       (delete-file file))))
 205
 206 ;;; This used to crash on Darwin and trigger recursive lock errors on
 207 ;;; every platform.
 208 (with-test (:name (:run-program :stress))
 209   ;; Do it a hundred times in batches of 10 so that with a low limit
 210   ;; of the number of processes the test can have a chance to pass.
 211   (loop
 212    repeat 10 do
 213    (map nil
 214         #'sb-ext:process-wait
 215         (loop repeat 10
 216               collect
 217               (sb-ext:run-program "/bin/echo" '
 218                                   ("It would be nice if this didn't crash.")
 219                                   :wait nil :output nil)))))
 220
 221 (with-test (:name (:run-program :pty-stream))
 222   (assert (equal "OK"
 223                  (subseq
 224                   (with-output-to-string (s)
 225                     (assert (= 42 (process-exit-code
 226                                    (run-program "/bin/sh" '("-c" "echo OK; exit 42") :wait t
 227                                                 :pty s))))
 228                     s)
 229                   0
 230                   2))))
 231
 232 ;; Check whether RUN-PROGRAM puts its child process into the foreground
 233 ;; when stdin is inherited. If it fails to do so we will receive a SIGTTIN.
 234 ;;
 235 ;; We can't check for the signal itself since run-program.c resets the
 236 ;; forked process' signal mask to defaults. But the default is `stop'
 237 ;; of which we can be notified asynchronously by providing a status hook.
 238 (with-test (:name (:run-program :inherit-stdin))
 239   (let (stopped)
 240     (flet ((status-hook (proc)
 241              (case (sb-ext:process-status proc)
 242                (:stopped (setf stopped t)))))
 243       (let ((proc (sb-ext:run-program "/bin/ed" nil :search nil :wait nil
 244                                       :input t :output t
 245                                       :status-hook #'status-hook)))
 246         ;; Give the program a generous time to generate the SIGTTIN.
 247         ;; If it hasn't done so after that time we can consider it
 248         ;; to be working (i.e. waiting for input without generating SIGTTIN).
 249         (sleep 0.5)
 250         ;; either way we have to signal it to terminate
 251         (process-kill proc sb-posix:sigterm)
 252         (process-close proc)
 253         (assert (not stopped))))))
 254