mirror of
git://git.code.sf.net/p/sbcl/sbcl
synced 2026-09-10 07:26:40 -04:00
530 lines
22 KiB
Common Lisp
530 lines
22 KiB
Common Lisp
;;;; various RUN-PROGRAM tests with side effects
|
|
|
|
;;;; This software is part of the SBCL system. See the README file for
|
|
;;;; more information.
|
|
;;;;
|
|
;;;; While most of SBCL is derived from the CMU CL system, the test
|
|
;;;; files (like this one) were written from scratch after the fork
|
|
;;;; from CMU CL.
|
|
;;;;
|
|
;;;; This software is in the public domain and is provided with
|
|
;;;; absolutely no warranty. See the COPYING and CREDITS files for
|
|
;;;; more information.
|
|
|
|
(cl:in-package :cl-user)
|
|
|
|
(defun bin-pwd-ignoring-result ()
|
|
(let ((initially-open-fds (directory "/proc/self/fd/*" :resolve-symlinks nil)))
|
|
(sb-ext:run-program "pwd" nil :search t :input :stream :output :stream :wait nil)
|
|
(length initially-open-fds)))
|
|
|
|
(with-test (:name (run-program :autoclose-streams)
|
|
:broken-on :sbcl ;; not reliable enough
|
|
:skipped-on (not :linux))
|
|
(let ((n-initially-open-fds (bin-pwd-ignoring-result)))
|
|
(gc)
|
|
(sb-sys:scrub-control-stack) ; Make sure we're not referencing the #<process>
|
|
(gc) ; now nothing should reference the streams
|
|
(assert (= (length (directory "/proc/self/fd/*" :resolve-symlinks nil))
|
|
n-initially-open-fds))))
|
|
|
|
;; In addition to definitions lower down the impurity we're avoiding
|
|
;; is the sigchld handler that RUN-PROGRAM sets up, which interfers
|
|
;; with the manual unix process control done by the test framework
|
|
;; (sometimes the handler will manage to WAIT3 a process before
|
|
;; run-tests WAITPIDs it).
|
|
|
|
(with-test (:name (run-program :cat 1))
|
|
(let* ((process (run-program "cat" '() :wait nil
|
|
:search t :output :stream :input :stream))
|
|
(out (process-input process))
|
|
(in (process-output process)))
|
|
(unwind-protect
|
|
(loop for i from 0 to 255 do
|
|
(write-byte i out)
|
|
(force-output out)
|
|
(assert (= (read-byte in) i)))
|
|
(process-close process))))
|
|
|
|
(with-test (:name (run-program :cat 2)
|
|
:skipped-on (not :sb-thread))
|
|
;; Tests that reading from a FIFO is interruptible.
|
|
(let* ((process (run-program "cat" '() :search t
|
|
: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 (run-program "cat" '()
|
|
:search t
|
|
:wait t
|
|
:output out :input in))
|
|
(buf (make-array (length data))))
|
|
(declare (ignore process))
|
|
(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 (run-program "cat" '() :wait nil
|
|
:search t
|
|
: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.
|
|
|
|
(require :sb-posix)
|
|
|
|
#-win32
|
|
(progn
|
|
(defun make-pipe ()
|
|
(multiple-value-bind (in out) (sb-posix:pipe)
|
|
(let ((input (sb-sys:make-fd-stream in
|
|
:input t
|
|
:external-format :ascii
|
|
:buffering :none :name "in"))
|
|
(output (sb-sys:make-fd-stream out
|
|
:output t
|
|
:external-format :ascii
|
|
:buffering :none :name "out")))
|
|
(make-two-way-stream input output))))
|
|
|
|
(defparameter *cat-in-pipe* (make-pipe))
|
|
(defparameter *cat-in* (make-synonym-stream '*cat-in-pipe*))
|
|
(defparameter *cat-out-pipe* (make-pipe))
|
|
(defparameter *cat-out* (make-synonym-stream '*cat-out-pipe*)))
|
|
|
|
(with-test (:name (run-program :cat 5) :skipped-on :win32)
|
|
(let ((cat (run-program "cat" nil :search t :input *cat-in* :output *cat-out*
|
|
:wait nil)))
|
|
(dolist (test '("This is a test!"
|
|
"This is another test!"
|
|
"This is the last test...."))
|
|
(write-line test *cat-in*)
|
|
(assert (equal test (read-line *cat-out*))))
|
|
(process-close cat)))
|
|
|
|
;;; The above test used to use ed, but there were buffering issues: on some platforms
|
|
;;; buffering of stdin and stdout depends on their TTYness, and ed isn't sufficiently
|
|
;;; agressive about flushing them. So, here's another test using :PTY.
|
|
|
|
#-win32
|
|
(unless (probe-file "/bin/ed") (push :no-bin-ed-installed *features*))
|
|
|
|
#-win32
|
|
(progn
|
|
(defparameter *tmpfile* (scratch-file-name))
|
|
|
|
(with-test (:name (run-program :/bin/ed) :skipped-on :no-bin-ed-installed)
|
|
(with-open-file (f *tmpfile*
|
|
:direction :output
|
|
:if-exists :supersede)
|
|
(write-line "bar" f))
|
|
(unwind-protect
|
|
(let* ((ed (run-program "/bin/ed" (list *tmpfile*) :wait nil :pty t))
|
|
(ed-in (process-pty ed))
|
|
(ed-out (process-pty ed)))
|
|
(labels ((read-linish (stream)
|
|
(with-output-to-string (s)
|
|
(loop for c = (read-char stream)
|
|
while (and c (not (eq #\newline c)))
|
|
;; Some eds like to send \r\n
|
|
do (unless (eq #\return c)
|
|
(write-char c s)))))
|
|
(assert-ed (command response)
|
|
(when command
|
|
(write-line command ed-in)
|
|
(force-output ed-in))
|
|
(when response
|
|
(let ((got (read-linish ed-out)))
|
|
(unless (equal response got)
|
|
(error "wanted '~A' from ed, got '~A'" response got))))
|
|
ed))
|
|
(assert-ed nil "4")
|
|
(assert-ed ".s/bar/baz/g" nil)
|
|
(assert-ed "w" "4")
|
|
(assert-ed "q" nil)
|
|
(process-wait ed)
|
|
(with-open-file (f *tmpfile*)
|
|
(assert (equal "baz" (read-line f))))))
|
|
(delete-file *tmpfile*)))) ;; #-win32
|
|
|
|
;; Around 1.0.12 there was a regression when :INPUT or :OUTPUT was a
|
|
;; pathname designator. Since these use the same code, it should
|
|
;; suffice to test just :INPUT.
|
|
(with-test (:name (run-program :input :output pathname))
|
|
(with-scratch-file (file)
|
|
(with-open-file (f file :direction :output)
|
|
(setf file (truename file))
|
|
(write-line "Foo" f))
|
|
(assert (run-program "cat" ()
|
|
:input file :output t
|
|
:search t :wait t))))
|
|
|
|
;;; This used to crash on Darwin and trigger recursive lock errors on
|
|
;;; every platform.
|
|
;;; ...and now it triggers recursive lock errors on safepoint + linux.
|
|
(with-test (:name (run-program :stress) :skipped-on (:and :sb-safepoint :linux))
|
|
;; Do it a hundred times in batches of 10 so that with a low limit
|
|
;; of the number of processes the test can have a chance to pass.
|
|
;;
|
|
;; If #+sb-thread, then make this test even more brutal by calling
|
|
;; RUN-PROGRAM in new threads. This is neither good nor bad as far as
|
|
;; total run time, but good in that it excercises RUN-PROGRAM
|
|
;; from other than the main thread.
|
|
(flet ((start-run ()
|
|
(run-program "echo"
|
|
'("It would be nice if this didn't crash.")
|
|
:search t :wait nil :output nil)))
|
|
(dotimes (i 10)
|
|
(mapc #'process-wait
|
|
#+sb-thread (mapcar #'sb-thread:join-thread
|
|
(loop repeat 10
|
|
collect (sb-thread:make-thread #'start-run)))
|
|
#-sb-thread (loop repeat 10 collect (start-run))))))
|
|
|
|
(with-test (:name (run-program :pty-stream)
|
|
:skipped-on :win32
|
|
:broken-on :darwin)
|
|
(let (process
|
|
stream)
|
|
(assert (search "OK"
|
|
(handler-bind
|
|
((timeout (lambda (c)
|
|
c
|
|
(format t "~a ~a~%" process
|
|
(when stream
|
|
(get-output-stream-string stream))))))
|
|
(with-timeout 60
|
|
(with-output-to-string (s)
|
|
(setf stream s)
|
|
(setf process
|
|
(run-program "/bin/sh" '("-c" "echo OK; exit 42") :pty s
|
|
:wait nil))
|
|
(process-wait process)
|
|
(assert (= (process-exit-code process) 42))
|
|
s)))))))
|
|
|
|
;; Check whether RUN-PROGRAM puts its child process into the foreground
|
|
;; when stdin is inherited. If it fails to do so we will receive a SIGTTIN.
|
|
;;
|
|
;; We can't check for the signal itself since run-program.c resets the
|
|
;; forked process' signal mask to defaults. But the default is `stop'
|
|
;; of which we can be notified asynchronously by providing a status hook.
|
|
(with-test (:name (run-program :inherit-stdin) :fails-on :win32
|
|
:skipped-on :no-bin-ed-installed)
|
|
(let (stopped)
|
|
(flet ((status-hook (proc)
|
|
(case (process-status proc)
|
|
(:stopped (setf stopped t)))))
|
|
(let ((proc (run-program "/bin/ed" nil :search nil :wait nil
|
|
:input t :output t
|
|
:status-hook #'status-hook)))
|
|
;; Give the program a generous time to generate the SIGTTIN.
|
|
;; If it hasn't done so after that time we can consider it
|
|
;; to be working (i.e. waiting for input without generating SIGTTIN).
|
|
(sleep 0.5)
|
|
;; either way we have to signal it to terminate
|
|
(process-kill proc sb-posix:sigterm)
|
|
(process-close proc)
|
|
(assert (not stopped))))))
|
|
|
|
|
|
;; Check that in when you do run-program with :wait t that causes
|
|
;; encoding error, it does not affect the following run-program
|
|
(with-test (:name (run-program :clean-exit-after-encoding-error))
|
|
(let ((had-error-p nil))
|
|
(flet ((barf (&optional (format :default))
|
|
(with-output-to-string (stream)
|
|
(run-program (sb-ext:posix-getenv "SBCL_RUNTIME")
|
|
'("--core"
|
|
(sb-ext:posix-getenv "SBCL_CORE")
|
|
"--disable-ldb" "--noinform" "--no-sysinit" "--no-userinit" "--noprint" "--disable-debugger"
|
|
"--eval"
|
|
"(mapc (lambda (b) (write-byte b *standard-output*)) '(#x20 #xfe #xff #x0))"
|
|
"--quit" )
|
|
:output stream
|
|
:external-format format)))
|
|
(no-barf ()
|
|
(with-output-to-string (stream)
|
|
(run-program "echo"
|
|
'("This is a test")
|
|
:search t
|
|
:output stream))))
|
|
(handler-case
|
|
(barf :utf-8)
|
|
(error ()
|
|
(setq had-error-p t)))
|
|
(assert had-error-p)
|
|
;; now run the harmless program
|
|
(setq had-error-p nil)
|
|
(handler-case
|
|
(no-barf)
|
|
(error ()
|
|
(setq had-error-p t)))
|
|
(assert (not had-error-p)))))
|
|
|
|
(with-test (:name (run-program :no-such-thing))
|
|
(assert (search "Couldn't execute"
|
|
(handler-case
|
|
(progn (run-program "no-such-program-we-hope" '()) nil)
|
|
(error (e)
|
|
(princ-to-string e))))))
|
|
|
|
(with-test (:name (run-program :not-executable))
|
|
(assert (search "Couldn't execute"
|
|
(handler-case
|
|
(progn (run-program "run-program.impure.lisp" '()) nil)
|
|
(error (e)
|
|
(princ-to-string e))))))
|
|
|
|
#-win32
|
|
(with-test (:name (run-program :if-input-does-not-exist))
|
|
(let ((file (pathname (sb-posix:mktemp "rpXXXXXX"))))
|
|
(when (and (boundp 'run-tests::*allowed-inputs*)
|
|
;; If the permitted inputs are :ANY then leave it be
|
|
(listp (symbol-value 'run-tests::*allowed-inputs*)))
|
|
(push (namestring file) (symbol-value 'run-tests::*allowed-inputs*)))
|
|
(assert (null (run-program "cat" '() :search t :input file)))
|
|
(assert (null (run-program "cat" '() :search t :output #.(or *compile-file-truename*
|
|
*load-truename*)
|
|
:if-output-exists nil)))))
|
|
|
|
|
|
(with-test (:name (run-program :set-directory))
|
|
(let* ((directory #-win32 "/"
|
|
#+win32 "c:\\")
|
|
(out (process-output
|
|
(run-program #-win32 "/bin/sh"
|
|
#-win32 '("-c" "pwd")
|
|
#+win32 "cmd.exe"
|
|
#+win32 '("/c" "cd")
|
|
:output :stream
|
|
:directory directory
|
|
:search t))))
|
|
(assert
|
|
(equal directory
|
|
(string-right-trim '(#\Return) (read-line out))))))
|
|
|
|
(with-test (:name (run-program :directory-nil))
|
|
(run-program #-win32 "/bin/sh"
|
|
#-win32 '("-c" "pwd")
|
|
#+win32 "cmd.exe"
|
|
#+win32 '("/c" "cd")
|
|
:directory nil
|
|
:search t))
|
|
|
|
(with-test (:name (run-program :bad-options))
|
|
(assert-error
|
|
(run-program #-win32 "/bin/sh"
|
|
#-win32 '("-c" "pwd")
|
|
#+win32 "cmd.exe"
|
|
#+win32 '("/c" "cd")
|
|
:search t
|
|
:output :bad)))
|
|
|
|
(with-test (:name (run-program :stop+continue) :skipped-on :win32)
|
|
(let ((process (run-program "cat" '() :search t :input :stream :wait nil)))
|
|
(flet ((kill-and-check-status (signal expected-status)
|
|
(process-kill process signal)
|
|
(loop :repeat 2000
|
|
:when (eq (process-status process) expected-status)
|
|
:do (return)
|
|
:do (sleep 1/100)
|
|
:finally (error "~@<Process ~A did not change its ~
|
|
status to ~S within 20 seconds.~@:>"
|
|
process expected-status))))
|
|
(kill-and-check-status sb-posix:sigstop :stopped)
|
|
(kill-and-check-status sb-posix:sigcont :running)
|
|
(kill-and-check-status sb-posix:sigkill :signaled)
|
|
(process-wait process)
|
|
(assert (not (process-alive-p process))))))
|
|
|
|
#-win32
|
|
(with-test (:name (run-program :stop+continue :posix-kill))
|
|
(let ((process (run-program "cat" '() :search t :input :stream :wait nil)))
|
|
(flet ((kill-and-check-status (signal expected-status)
|
|
(sb-posix:kill (process-pid process) signal)
|
|
(loop :repeat 2000
|
|
:when (eq (process-status process) expected-status)
|
|
:do (return)
|
|
:do (sleep 1/100)
|
|
:finally (error "~@<Process ~A did not change its ~
|
|
status to ~S within 20 seconds.~@:>"
|
|
process expected-status))))
|
|
(kill-and-check-status sb-posix:sigstop :stopped)
|
|
(kill-and-check-status sb-posix:sigcont :running)
|
|
(kill-and-check-status sb-posix:sigkill :signaled)
|
|
(process-wait process)
|
|
(assert (not (process-alive-p process))))))
|
|
|
|
(defun malloc ()
|
|
(let ((x (sb-alien:make-alien int 10000)))
|
|
(sb-alien:free-alien x)
|
|
1))
|
|
|
|
(with-test (:name (run-program :malloc-deadlock)
|
|
:broken-on :sb-safepoint
|
|
:skipped-on (or :ubsan (not :sb-thread) :win32 :android))
|
|
(let* (stop
|
|
(delay-between-gc
|
|
(or #+freebsd
|
|
(let* ((p (run-program "sysctl" '("hw.model") :search t :output :stream))
|
|
(output (process-output p))
|
|
(result (read-line output)))
|
|
(close output)
|
|
;; With the default delay of 0 using FreeBSD on QEMU this test never
|
|
;; finished because the RUN-PROGRAM thread would never get scheduled
|
|
;; after its first entry into the loop.
|
|
;; It wasn't hung, it just wasn't getting CPU time. For me anyway.
|
|
(when (search "QEMU" result)
|
|
.00000001)) ; 10 nanoseconds
|
|
#+(and darwin arm64)
|
|
0.01
|
|
0))
|
|
(threads (list*
|
|
(sb-thread:make-thread (lambda ()
|
|
(loop until (progn (sb-thread:barrier (:read))
|
|
stop)
|
|
do
|
|
(sleep delay-between-gc)
|
|
(gc :full t))))
|
|
(loop repeat 3
|
|
collect
|
|
(sb-thread:make-thread
|
|
(lambda ()
|
|
(loop until (progn (sb-thread:barrier (:read))
|
|
stop)
|
|
do (malloc))))))))
|
|
(loop with dot = (get-internal-real-time)
|
|
with end = (+ dot (* internal-time-units-per-second 4))
|
|
for time = (get-internal-real-time)
|
|
while (> end time)
|
|
do
|
|
(when (> (- time dot)
|
|
(/ internal-time-units-per-second 10))
|
|
(setf dot time)
|
|
(write-char #\.)
|
|
(finish-output))
|
|
(with-output-to-string (str)
|
|
(run-program "uname" ()
|
|
:output str
|
|
:search t
|
|
:wait t)))
|
|
(setf stop t)
|
|
(sb-thread:barrier (:write))
|
|
(mapc #'sb-thread:join-thread threads)))
|
|
|
|
(with-test (:name (run-program :child-fd-leak)
|
|
:skipped-on (or :openbsd :win32))
|
|
(when (probe-file "/dev/fd")
|
|
(with-open-file (stream "/dev/null")
|
|
(let* ((fd (sb-sys:fd-stream-fd stream))
|
|
(process (run-program "test" (list "-e" (format nil "/dev/fd/~a" fd))
|
|
:search t)))
|
|
(assert (not (zerop (process-exit-code process))))))))
|
|
|
|
;; PROCESS-CLOSE's contract is "close the streams and stop updating
|
|
;; the process", but SBCL should still internally watch the process:
|
|
;; to do otherwise will cause an accumulation of zombies.
|
|
(with-test (:name (run-program :minimizes-zombies)
|
|
;; 1. IDK whether Windows has the zombies, &
|
|
;; 2. this test runs ps(1) to look for them,
|
|
;; so skip on Windows.
|
|
:skipped-on :win32)
|
|
(flet ((gather-process-output (&rest argv)
|
|
(with-output-to-string (s)
|
|
(run-program (first argv) (rest argv) :output s :search t)))
|
|
(make-zombies (count &rest argv)
|
|
(loop repeat count
|
|
for proc = (run-program (first argv) (rest argv)
|
|
:wait nil :search t)
|
|
collect (process-pid proc)
|
|
do (process-close proc)
|
|
(process-kill proc #+unix sb-unix:sigterm #+win32 :ignore))))
|
|
(let ((pids (make-zombies 3 "sleep" "300")))
|
|
;; Give a little time for signal delivery (to kids, and to SBCL).
|
|
(sleep 1/100)
|
|
(let ((ps-output
|
|
(gather-process-output
|
|
;; Test written in 2024; these ps(1) flags are specified
|
|
;; as early as 2008, so hopefully everybody has 'em.
|
|
;; https://pubs.opengroup.org/onlinepubs/9699919799.2008edition/
|
|
"ps" "-opid" "-oppid" "-oargs" (format nil "-p~{~D~^,~}" pids))))
|
|
;; Should be just a header line.
|
|
(assert (= 1 (count #\newline ps-output)) ()
|
|
"Zombies found in ps(1) output (SBCL pid ~D):~%~A"
|
|
(sb-unix:unix-getpid) ps-output)))))
|