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 "cat" '() :wait nil
  24                                       :search t
  25                                       :output :stream :input :stream))
  26          (out (process-input process))
  27          (in (process-output process)))
  28     (unwind-protect
  29          (loop for i from 0 to 255 do
  30               (write-byte i out)
  31               (force-output out)
  32               (assert (= (read-byte in) i)))
  33       (process-close process))))
  34
  35 (with-test (:name :run-program-cat-2 :skipped-on '(or (not :sb-thread) :win32))
  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 "cat" '()
 108                                        :search t
 109                                        :wait t
 110                                        :output out :input in))
 111           (buf (make-array (length data))))
 112       (declare (ignore process))
 113       (assert (= 13 (read-sequence buf out)))
 114       (assert (= 0 (read-sequence (make-array 8) out)))
 115       (assert (equalp buf data)))))
 116
 117 (with-test (:name :run-program-cat-4)
 118   ;; Null broadcast stream as output
 119   (let* ((process (sb-ext:run-program "cat" '() :wait nil
 120                                       :search t
 121                                       :output (make-broadcast-stream)
 122                                       :input :stream))
 123          (in (process-input process)))
 124     (unwind-protect
 125          (progn
 126            (write-string "foobar" in)
 127            (close in)
 128            (process-wait process))
 129       (process-close process))))
 130
 131 ;;; Test driving an external program (cat) through pipes wrapped in
 132 ;;; composite streams.
 133
 134 (require :sb-posix)
 135
 136 #-win32
 137 (progn
 138   (defun make-pipe ()
 139     (multiple-value-bind (in out) (sb-posix:pipe)
 140       (let ((input (sb-sys:make-fd-stream in
 141                                           :input t
 142                                           :external-format :ascii
 143                                           :buffering :none :name "in"))
 144             (output (sb-sys:make-fd-stream out
 145                                            :output t
 146                                            :external-format :ascii
 147                                            :buffering :none :name "out")))
 148         (make-two-way-stream input output))))
 149
 150   (defparameter *cat-in-pipe* (make-pipe))
 151   (defparameter *cat-in* (make-synonym-stream '*cat-in-pipe*))
 152   (defparameter *cat-out-pipe* (make-pipe))
 153   (defparameter *cat-out* (make-synonym-stream '*cat-out-pipe*)))
 154
 155 (with-test (:name :run-program-cat-5 :fails-on :win32)
 156   (let ((cat (run-program "/bin/cat" nil :input *cat-in* :output *cat-out*
 157                           :wait nil)))
 158     (dolist (test '("This is a test!"
 159                     "This is another test!"
 160                     "This is the last test...."))
 161       (write-line test *cat-in*)
 162       (assert (equal test (read-line *cat-out*))))
 163     (process-close cat)))
 164
 165 ;;; The above test used to use ed, but there were buffering issues: on some platforms
 166 ;;; buffering of stdin and stdout depends on their TTYness, and ed isn't sufficiently
 167 ;;; agressive about flushing them. So, here's another test using :PTY.
 168
 169 #-win32
 170 (with-test (:name :is-/bin/ed-installed?)
 171   (assert (probe-file "/bin/ed")))
 172
 173 #-win32
 174 (progn
 175   (defparameter *tmpfile* "run-program-ed-test.tmp")
 176
 177   (with-test (:name :run-program-/bin/ed)
 178     (with-open-file (f *tmpfile*
 179                        :direction :output
 180                        :if-exists :supersede)
 181       (write-line "bar" f))
 182     (unwind-protect
 183          (let* ((ed (run-program "/bin/ed" (list *tmpfile*) :wait nil :pty t))
 184                 (ed-in (process-pty ed))
 185                 (ed-out (process-pty ed)))
 186            (labels ((read-linish (stream)
 187                       (with-output-to-string (s)
 188                         (loop for c = (read-char stream)
 189                               while (and c (not (eq #\newline c)))
 190                               ;; Some eds like to send \r\n
 191                               do (unless (eq #\return c)
 192                                    (write-char c s)))))
 193                     (assert-ed (command response)
 194                       (when command
 195                         (write-line command ed-in)
 196                         (force-output ed-in))
 197                       (when response
 198                         (let ((got (read-linish ed-out)))
 199                           (unless (equal response got)
 200                             (error "wanted '~A' from ed, got '~A'" response got))))
 201                       ed))
 202              (assert-ed nil "4")
 203              (assert-ed ".s/bar/baz/g" nil)
 204              (assert-ed "w" "4")
 205              (assert-ed "q" nil)
 206              (process-wait ed)
 207              (with-open-file (f *tmpfile*)
 208                (assert (equal "baz" (read-line f))))))
 209       (delete-file *tmpfile*)))) ;; #-win32
 210
 211 ;; Around 1.0.12 there was a regression when :INPUT or :OUTPUT was a
 212 ;; pathname designator.  Since these use the same code, it should
 213 ;; suffice to test just :INPUT.
 214 (let ((file))
 215   (unwind-protect
 216        (progn (with-open-file (f "run-program-test.tmp" :direction :output)
 217                 (setf file (truename f))
 218                 (write-line "Foo" f))
 219                   (assert (run-program "cat" ()
 220                                        :input file :output t
 221                                        :search t :wait t)))
 222     (when file
 223       (delete-file file))))
 224
 225 ;;; This used to crash on Darwin and trigger recursive lock errors on
 226 ;;; every platform.
 227 (with-test (:name (:run-program :stress))
 228   ;; Do it a hundred times in batches of 10 so that with a low limit
 229   ;; of the number of processes the test can have a chance to pass.
 230   (loop
 231    repeat 10 do
 232    (map nil
 233         #'sb-ext:process-wait
 234         (loop repeat 10
 235               collect
 236               (sb-ext:run-program "echo"
 237                                   '("It would be nice if this didn't crash.")
 238                                   :search t
 239                                   :wait nil :output nil)))))
 240
 241 (with-test (:name (:run-program :pty-stream) :fails-on :win32)
 242   (assert (equal "OK"
 243                  (handler-case
 244                   (with-timeout 1
 245                     (subseq
 246                      (with-output-to-string (s)
 247                        (assert (= 42 (process-exit-code
 248                                       (run-program "/bin/sh" '("-c" "echo OK; exit 42") :wait t
 249                                                                                         :pty s))))
 250                        s)
 251                      0
 252                      2))
 253                   (timeout () "timeout")))))
 254
 255 ;; Check whether RUN-PROGRAM puts its child process into the foreground
 256 ;; when stdin is inherited. If it fails to do so we will receive a SIGTTIN.
 257 ;;
 258 ;; We can't check for the signal itself since run-program.c resets the
 259 ;; forked process' signal mask to defaults. But the default is `stop'
 260 ;; of which we can be notified asynchronously by providing a status hook.
 261 (with-test (:name (:run-program :inherit-stdin) :fails-on :win32)
 262   (let (stopped)
 263     (flet ((status-hook (proc)
 264              (case (sb-ext:process-status proc)
 265                (:stopped (setf stopped t)))))
 266       (let ((proc (sb-ext:run-program "/bin/ed" nil :search nil :wait nil
 267                                       :input t :output t
 268                                       :status-hook #'status-hook)))
 269         ;; Give the program a generous time to generate the SIGTTIN.
 270         ;; If it hasn't done so after that time we can consider it
 271         ;; to be working (i.e. waiting for input without generating SIGTTIN).
 272         (sleep 0.5)
 273         ;; either way we have to signal it to terminate
 274         (process-kill proc sb-posix:sigterm)
 275         (process-close proc)
 276         (assert (not stopped))))))
 277
 278
 279 ;; Check that in when you do run-program with :wait t that causes
 280 ;; encoding error, it does not affect the following run-program
 281 (with-test (:name (:run-program :clean-exit-after-encoding-error)
 282                   :fails-on :win32)
 283   (let ((had-error-p nil))
 284     (flet ((barf (&optional (format :default))
 285              (with-output-to-string (stream)
 286                (run-program #-netbsd "/usr/bin/perl" #+netbsd "/usr/pkg/bin/perl"
 287                             '("-e" "print \"\\x20\\xfe\\xff\\x0a\"")
 288                             :output stream
 289                             :external-format format)))
 290            (no-barf ()
 291              (with-output-to-string (stream)
 292                (run-program "/bin/echo"
 293                             '("This is a test")
 294                             :output stream))))
 295       (handler-case
 296           (barf :utf-8)
 297         (error ()
 298           (setq had-error-p t)))
 299       (assert had-error-p)
 300       ;; now run the harmless program
 301       (setq had-error-p nil)
 302       (handler-case
 303           (no-barf)
 304         (error ()
 305           (setq had-error-p t)))
 306       (assert (not had-error-p)))))
 307
 308 (with-test (:name (:run-program :no-such-thing))
 309   (assert (search "Couldn't execute"
 310                   (handler-case
 311                       (progn (run-program "no-such-program-we-hope" '()) nil)
 312                     (error (e)
 313                       (princ-to-string e))))))
 314
 315 (with-test (:name (:run-program :not-executable))
 316   (assert (search "Couldn't execute"
 317                   (handler-case
 318                       (progn (run-program "run-program.impure.lisp" '()) nil)
 319                     (error (e)
 320                       (princ-to-string e))))))
 321
 322 #-win32
 323 (with-test (:name (:run-program :if-input-does-not-exist))
 324   (let ((file (pathname (sb-posix:mktemp "rpXXXXXX"))))
 325     (assert (null (sb-ext:run-program "/bin/cat" '() :input file)))
 326     (assert (null (sb-ext:run-program "/bin/cat" '() :output #.(or *compile-file-truename*
 327                                                                    *load-truename*)
 328                                       :if-output-exists nil)))))
 329
 330
 331 (with-test (:name (:run-program :set-directory))
 332   (let* ((directory #-win32 "/"
 333                     #+win32 "c:\\")
 334          (out (sb-ext:process-output
 335                (sb-ext:run-program #-win32 "/bin/sh"
 336                                    #-win32 '("-c" "pwd")
 337                                    #+win32 "cmd.exe"
 338                                    #+win32 '("/c" "cd")
 339                                    :output :stream
 340                                    :directory directory
 341                                    :search t))))
 342     (assert
 343      (equal directory
 344             (string-right-trim '(#\Return) (read-line out))))))
 345
 346 (with-test (:name (:run-program :directory-nil))
 347   (sb-ext:run-program #-win32 "/bin/sh"
 348                       #-win32 '("-c" "pwd")
 349                       #+win32 "cmd.exe"
 350                       #+win32 '("/c" "cd")
 351                       :directory nil
 352                       :search t))
 353
 354 (with-test (:name (:run-program :bad-options))
 355   (assert-error
 356    (sb-ext:run-program #-win32 "/bin/sh"
 357                        #-win32 '("-c" "pwd")
 358                        #+win32 "cmd.exe"
 359                        #+win32 '("/c" "cd")
 360                        :search t
 361                        :output :bad)))