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 ;;; Test driving an external program (cat) through pipes wrapped in
  69 ;;; composite streams.
  70
  71 (require :sb-posix)
  72
  73 (defun make-pipe ()
  74   (multiple-value-bind (in out) (sb-posix:pipe)
  75     (let ((input (sb-sys:make-fd-stream in
  76                                         :input t
  77                                         :external-format :ascii
  78                                         :buffering :none :name "in"))
  79           (output (sb-sys:make-fd-stream out
  80                                          :output t
  81                                          :external-format :ascii
  82                                          :buffering :none :name "out")))
  83       (make-two-way-stream input output))))
  84
  85 (defparameter *cat-in-pipe* (make-pipe))
  86 (defparameter *cat-in* (make-synonym-stream '*cat-in-pipe*))
  87 (defparameter *cat-out-pipe* (make-pipe))
  88 (defparameter *cat-out* (make-synonym-stream '*cat-out-pipe*))
  89
  90 (with-test (:name :run-program-cat-2)
  91   (let ((cat (run-program "/bin/cat" nil :input *cat-in* :output *cat-out*
  92                           :wait nil)))
  93     (dolist (test '("This is a test!"
  94                     "This is another test!"
  95                     "This is the last test...."))
  96       (write-line test *cat-in*)
  97       (assert (equal test (read-line *cat-out*))))
  98     (process-close cat)))
  99
 100 ;;; The above test used to use ed, but there were buffering issues: on some platforms
 101 ;;; buffering of stdin and stdout depends on their TTYness, and ed isn't sufficiently
 102 ;;; agressive about flushing them. So, here's another test using :PTY.
 103
 104 (defparameter *tmpfile* "run-program-ed-test.tmp")
 105
 106 (with-open-file (f *tmpfile*
 107                    :direction :output
 108                    :if-exists :supersede)
 109   (write-line "bar" f))
 110
 111 (defparameter *ed*
 112   (run-program "/bin/ed" (list *tmpfile*) :wait nil :pty t))
 113
 114 (defparameter *ed-pipe* (make-two-way-stream (process-pty *ed*) (process-pty *ed*)))
 115 (defparameter *ed-in* (make-synonym-stream '*ed-pipe*))
 116 (defparameter *ed-out* (make-synonym-stream '*ed-pipe*))
 117
 118 (defun read-linish (stream)
 119   (with-output-to-string (s)
 120     (loop for c = (read-char stream)
 121           while (and c (not (eq #\newline c)))
 122              ;; Some eds like to send \r\n
 123           do (unless (eq #\return c)
 124                (write-char c s)))))
 125
 126 (defun assert-ed (command response)
 127   (when command
 128     (write-line command *ed-in*)
 129     (force-output *ed-in*))
 130   (when response
 131     (let ((got (read-linish *ed-out*)))
 132       (unless (equal response got)
 133         (error "wanted '~A' from ed, got '~A'" response got))))
 134   *ed*)
 135
 136 (unwind-protect
 137      (with-test (:name :run-program-ed)
 138        (assert-ed nil "4")
 139        (assert-ed ".s/bar/baz/g" nil)
 140        (assert-ed "w" "4")
 141        (assert-ed "q" nil)
 142        (process-wait *ed*)
 143        (with-open-file (f *tmpfile*)
 144          (assert (equal "baz" (read-line f)))))
 145   (delete-file *tmpfile*))
 146
 147 ;; Around 1.0.12 there was a regression when :INPUT or :OUTPUT was a
 148 ;; pathname designator.  Since these use the same code, it should
 149 ;; suffice to test just :INPUT.
 150 (let ((file))
 151   (unwind-protect
 152        (progn (with-open-file (f "run-program-test.tmp" :direction :output)
 153                 (setf file (truename f))
 154                 (write-line "Foo" f))
 155                   (assert (run-program "cat" ()
 156                                        :input file :output t
 157                                        :search t :wait t)))
 158     (when file
 159       (delete-file file))))
 160
 161 ;;; This used to crash on Darwin and trigger recursive lock errors on
 162 ;;; every platform.
 163 (with-test (:name (:run-program :stress))
 164   ;; Do it a hundred times in batches of 10 so that with a low limit
 165   ;; of the number of processes the test can have a chance to pass.
 166   (loop
 167    repeat 10 do
 168    (map nil
 169         #'sb-ext:process-wait
 170         (loop repeat 10
 171               collect
 172               (sb-ext:run-program "/bin/echo" '
 173                                   ("It would be nice if this didn't crash.")
 174                                   :wait nil :output nil)))))
 175
 176 (with-test (:name (:run-program :pty-stream))
 177   (assert (equal "OK"
 178                  (subseq
 179                   (with-output-to-string (s)
 180                     (assert (= 42 (process-exit-code
 181                                    (run-program "/bin/sh" '("-c" "echo OK; exit 42") :wait t
 182                                                 :pty s))))
 183                     s)
 184                   0
 185                   2))))
 186
 187 ;; Check whether RUN-PROGRAM puts its child process into the foreground
 188 ;; when stdin is inherited. If it fails to do so we will receive a SIGTTIN.
 189 ;;
 190 ;; We can't check for the signal itself since run-program.c resets the
 191 ;; forked process' signal mask to defaults. But the default is `stop'
 192 ;; of which we can be notified asynchronously by providing a status hook.
 193 (with-test (:name (:run-program :inherit-stdin))
 194   (let (stopped)
 195     (flet ((status-hook (proc)
 196              (case (sb-ext:process-status proc)
 197                (:stopped (setf stopped t)))))
 198       (let ((proc (sb-ext:run-program "/bin/ed" nil :search nil :wait nil
 199                                       :input t :output t
 200                                       :status-hook #'status-hook)))
 201         ;; Give the program a generous time to generate the SIGTTIN.
 202         ;; If it hasn't done so after that time we can consider it
 203         ;; to be working (i.e. waiting for input without generating SIGTTIN).
 204         (sleep 0.5)
 205         ;; either way we have to signal it to terminate
 206         (process-kill proc sb-posix:sigterm)
 207         (process-close proc)
 208         (assert (not stopped))))))
 209