1 ;;;; various RUN-PROGRAM tests with side effects
3 ;;;; This software is part of the SBCL system. See the README file for
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
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.
14 (cl:in-package
:cl-user
)
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).
22 (with-test (:name
:run-program-cat-1
:skipped-on
:win32
)
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
)))
28 (loop for i from
0 to
255 do
31 (assert (= (read-byte in
) i
)))
32 (process-close process
))))
34 (with-test (:name
:run-program-cat-2
:skipped-on
'(or (not :sb-thread
) :win32
))
35 ;; Tests that reading from a FIFO is interruptible.
36 (let* ((process (sb-ext:run-program
"/bin/cat" '()
38 :output
:stream
:input
:stream
))
39 (in (process-input process
))
40 (out (process-output process
))
41 (sem (sb-thread:make-semaphore
))
43 (writer (sb-thread:make-thread
(lambda ()
44 (sb-thread:wait-on-semaphore sem
)
53 (sb-thread:signal-semaphore sem
)
57 (setf got
(read-line out
))
63 (assert (eq unwind
:sleep
))
64 (sb-thread:join-thread writer
)
65 (assert (equal "OK" (read-line out
)))))
67 (defclass buffer-stream
(sb-gray:fundamental-binary-input-stream sb-gray
:fundamental-binary-output-stream
)
68 ((buffer :initform
(make-array 128
69 :element-type
'(unsigned-byte 8)
74 (defmethod stream-element-type ((stream buffer-stream
))
77 (defmethod sb-gray:stream-read-sequence
((stream buffer-stream
) seq
&optional
(start 0) end
)
78 (let* ((buffer (slot-value stream
'buffer
))
79 (end (or end
(length seq
)))
80 (mark (slot-value stream
'mark
))
81 (fill-pointer (fill-pointer buffer
))
82 (new-mark (+ mark
(min fill-pointer
(- end start
)))))
83 (setf (slot-value stream
'mark
) new-mark
)
85 :start1 start
:end1 end
86 :start2 mark
:end2 fill-pointer
)
87 (min end
(+ start
(- fill-pointer mark
)))))
89 (defmethod sb-gray:stream-write-sequence
((stream buffer-stream
) seq
&optional
(start 0) end
)
90 (let* ((buffer (slot-value stream
'buffer
))
91 (end (or end
(length seq
)))
92 (fill-pointer (fill-pointer buffer
))
93 (new-fill (min (array-total-size buffer
) (+ fill-pointer
(- end start
)))))
94 (setf (fill-pointer buffer
) new-fill
)
97 :start2 start
:end2 end
)
100 (with-test (:name
:run-program-cat-3
:skipped-on
:win32
)
101 ;; User-defined binary input and output streams.
102 (let ((in (make-instance 'buffer-stream
))
103 (out (make-instance 'buffer-stream
))
104 (data #(0 1 2 3 4 5 6 7 8 9 10 11 12)))
105 (write-sequence data in
)
106 (let ((process (sb-ext:run-program
"/bin/cat" '() :wait t
:output out
:input in
))
107 (buf (make-array (length data
))))
108 (assert (= 13 (read-sequence buf out
)))
109 (assert (= 0 (read-sequence (make-array 8) out
)))
110 (assert (equalp buf data
)))))
112 (with-test (:name
:run-program-cat-4
:skipped-on
:win32
)
113 ;; Null broadcast stream as output
114 (let* ((process (sb-ext:run-program
"/bin/cat" '() :wait nil
115 :output
(make-broadcast-stream)
117 (in (process-input process
)))
120 (write-string "foobar" in
)
122 (process-wait process
))
123 (process-close process
))))
125 ;;; Test driving an external program (cat) through pipes wrapped in
126 ;;; composite streams.
133 (multiple-value-bind (in out
) (sb-posix:pipe
)
134 (let ((input (sb-sys:make-fd-stream in
136 :external-format
:ascii
137 :buffering
:none
:name
"in"))
138 (output (sb-sys:make-fd-stream out
140 :external-format
:ascii
141 :buffering
:none
:name
"out")))
142 (make-two-way-stream input output
))))
144 (defparameter *cat-in-pipe
* (make-pipe))
145 (defparameter *cat-in
* (make-synonym-stream '*cat-in-pipe
*))
146 (defparameter *cat-out-pipe
* (make-pipe))
147 (defparameter *cat-out
* (make-synonym-stream '*cat-out-pipe
*)))
149 (with-test (:name
:run-program-cat-5
:fails-on
:win32
)
150 (let ((cat (run-program "/bin/cat" nil
:input
*cat-in
* :output
*cat-out
*
152 (dolist (test '("This is a test!"
153 "This is another test!"
154 "This is the last test...."))
155 (write-line test
*cat-in
*)
156 (assert (equal test
(read-line *cat-out
*))))
157 (process-close cat
)))
159 ;;; The above test used to use ed, but there were buffering issues: on some platforms
160 ;;; buffering of stdin and stdout depends on their TTYness, and ed isn't sufficiently
161 ;;; agressive about flushing them. So, here's another test using :PTY.
163 #-win32
(progn ;; kludge: It would be nicer to disable individual test cases,
164 ;; but we are not using WITH-TEST yet here.
166 (defparameter *tmpfile
* "run-program-ed-test.tmp")
168 (with-open-file (f *tmpfile
*
170 :if-exists
:supersede
)
171 (write-line "bar" f
))
174 (run-program "/bin/ed" (list *tmpfile
*) :wait nil
:pty t
))
176 (defparameter *ed-pipe
* (make-two-way-stream (process-pty *ed
*) (process-pty *ed
*)))
177 (defparameter *ed-in
* (make-synonym-stream '*ed-pipe
*))
178 (defparameter *ed-out
* (make-synonym-stream '*ed-pipe
*))
180 (defun read-linish (stream)
181 (with-output-to-string (s)
182 (loop for c
= (read-char stream
)
183 while
(and c
(not (eq #\newline c
)))
184 ;; Some eds like to send \r\n
185 do
(unless (eq #\return c
)
188 (defun assert-ed (command response
)
190 (write-line command
*ed-in
*)
191 (force-output *ed-in
*))
193 (let ((got (read-linish *ed-out
*)))
194 (unless (equal response got
)
195 (error "wanted '~A' from ed, got '~A'" response got
))))
199 (with-test (:name
:run-program-ed
)
201 (assert-ed ".s/bar/baz/g" nil
)
205 (with-open-file (f *tmpfile
*)
206 (assert (equal "baz" (read-line f
)))))
207 (delete-file *tmpfile
*))
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.
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
223 (delete-file file
))))
225 ;;; This used to crash on Darwin and trigger recursive lock errors on
227 (with-test (:name
(:run-program
:stress
) :fails-on
:win32
)
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.
233 #'sb-ext
:process-wait
236 (sb-ext:run-program
"/bin/echo" '
237 ("It would be nice if this didn't crash.")
238 :wait nil
:output nil
)))))
240 (with-test (:name
(:run-program
:pty-stream
) :fails-on
:win32
)
243 (with-output-to-string (s)
244 (assert (= 42 (process-exit-code
245 (run-program "/bin/sh" '("-c" "echo OK; exit 42") :wait t
251 ;; Check whether RUN-PROGRAM puts its child process into the foreground
252 ;; when stdin is inherited. If it fails to do so we will receive a SIGTTIN.
254 ;; We can't check for the signal itself since run-program.c resets the
255 ;; forked process' signal mask to defaults. But the default is `stop'
256 ;; of which we can be notified asynchronously by providing a status hook.
257 (with-test (:name
(:run-program
:inherit-stdin
) :fails-on
:win32
)
259 (flet ((status-hook (proc)
260 (case (sb-ext:process-status proc
)
261 (:stopped
(setf stopped t
)))))
262 (let ((proc (sb-ext:run-program
"/bin/ed" nil
:search nil
:wait nil
264 :status-hook
#'status-hook
)))
265 ;; Give the program a generous time to generate the SIGTTIN.
266 ;; If it hasn't done so after that time we can consider it
267 ;; to be working (i.e. waiting for input without generating SIGTTIN).
269 ;; either way we have to signal it to terminate
270 (process-kill proc sb-posix
:sigterm
)
272 (assert (not stopped
))))))
275 ;; Check that in when you do run-program with :wait t that causes
276 ;; encoding error, it does not affect the following run-program
277 (with-test (:name
(:run-program
:clean-exit-after-encoding-error
)
279 (let ((had-error-p nil
))
280 (flet ((barf (&optional
(format :default
))
281 (with-output-to-string (stream)
282 (run-program #-netbsd
"/usr/bin/perl" #+netbsd
"/usr/pkg/bin/perl"
283 '("-e" "print \"\\x20\\xfe\\xff\\x0a\"")
285 :external-format format
)))
287 (with-output-to-string (stream)
288 (run-program "/bin/echo"
294 (setq had-error-p t
)))
296 ;; now run the harmless program
297 (setq had-error-p nil
)
301 (setq had-error-p t
)))
302 (assert (not had-error-p
)))))
304 (with-test (:name
(:run-program
:no-such-thing
))
305 (assert (search "Couldn't execute"
307 (progn (run-program "no-such-program-we-hope" '()) nil
)
309 (princ-to-string e
))))))
311 (with-test (:name
(:run-program
:not-executable
))
312 (assert (search "Couldn't execute"
314 (progn (run-program "run-program.impure.lisp" '()) nil
)
316 (princ-to-string e
))))))
319 (with-test (:name
(:run-program
:if-input-does-not-exist
))
320 (let ((file (pathname (sb-posix:mktemp
"rpXXXXXX"))))
321 (assert (null (sb-ext:run-program
"/bin/cat" '() :input file
)))
322 (assert (null (sb-ext:run-program
"/bin/cat" '() :output
#.
(or *compile-file-truename
*
324 :if-output-exists nil
)))))
327 (with-test (:name
(:run-program
:set-directory
))
328 (let* ((directory #-win32
"/"
330 (out (sb-ext:process-output
331 (sb-ext:run-program
#-win32
"/bin/sh"
332 #-win32
'("-c" "pwd")
340 (string-right-trim '(#\Return
) (read-line out
))))))