mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-04-30 03:40:34 +02:00
Skip tests that require SIGPIPE when not supported
On MINGW, and probably native Windows, closing a pipe does not send SIGPIPE to a child process, so tests that need SIGPIPE to close the child process are skipped. * test-suite/tests/popen.test ("no duplicate", "open-process"): skip if SIGPIPE unsupported * test-suite/tests/ports.test ("pipe: write"): modify to use and awk script that terminates without SIGPIPE * test-suite/tests/posix.test ("wc with stdin and stdout redirects"): skip if SIGPIPE unsupported ("awk with stdin and stdout redirects"): new test that doesn't require SIGPIPE
This commit is contained in:
parent
83cf9fa5c4
commit
f187c46bd9
3 changed files with 35 additions and 1 deletions
|
@ -200,6 +200,10 @@ exec 2>~a; read REPLY"
|
||||||
;; the child process; we rely on the child getting SIGPIPE, to
|
;; the child process; we rely on the child getting SIGPIPE, to
|
||||||
;; terminate it (and avoid leaving a zombie).
|
;; terminate it (and avoid leaving a zombie).
|
||||||
(pass-if "no duplicate"
|
(pass-if "no duplicate"
|
||||||
|
(unless (defined? 'SIGPIPE)
|
||||||
|
;; MinGW has no SIGPIPE, so closing the pipe doesn't
|
||||||
|
;; terminate the process.
|
||||||
|
(throw 'unsupported))
|
||||||
(let* ((c2p (pipe))
|
(let* ((c2p (pipe))
|
||||||
(port (with-error-to-port (cdr c2p)
|
(port (with-error-to-port (cdr c2p)
|
||||||
(lambda ()
|
(lambda ()
|
||||||
|
@ -273,6 +277,10 @@ exec 2>~a; read REPLY"
|
||||||
|
|
||||||
(pass-if-equal "open-process"
|
(pass-if-equal "open-process"
|
||||||
'("HELLO WORLD" 0)
|
'("HELLO WORLD" 0)
|
||||||
|
(unless (defined? 'SIGPIPE)
|
||||||
|
;; MinGW has no SIGPIPE, so 'tr' doesn't exit when input is
|
||||||
|
;; exhausted.
|
||||||
|
(throw 'unsupported))
|
||||||
(receive (from to pid)
|
(receive (from to pid)
|
||||||
((@@ (ice-9 popen) open-process) OPEN_BOTH
|
((@@ (ice-9 popen) open-process) OPEN_BOTH
|
||||||
"tr" "[:lower:]" "[:upper:]")
|
"tr" "[:lower:]" "[:upper:]")
|
||||||
|
|
|
@ -752,9 +752,14 @@
|
||||||
|
|
||||||
|
|
||||||
;;; Run a command, send some output to it, and see if it worked.
|
;;; Run a command, send some output to it, and see if it worked.
|
||||||
|
|
||||||
|
;; We could have used grep for this test, but on systems without
|
||||||
|
;; SIGPIPE, grep never exits.
|
||||||
(pass-if "pipe: write"
|
(pass-if "pipe: write"
|
||||||
(let* ((filename (test-file))
|
(let* ((filename (test-file))
|
||||||
(pipe (open-pipe (string-append "grep Mommy > " filename) "w")))
|
(awkscript
|
||||||
|
"awk 'BEGIN{i=1} {if (match($0,\"Mommy\")) print $0; if (i==2) exit; i++;}'")
|
||||||
|
(pipe (open-pipe (string-append awkscript " > " filename) "w")))
|
||||||
(display "Now Jimmy lives on a mushroom cloud\n" pipe)
|
(display "Now Jimmy lives on a mushroom cloud\n" pipe)
|
||||||
(display "Mommy, why does everybody have a bomb?\n" pipe)
|
(display "Mommy, why does everybody have a bomb?\n" pipe)
|
||||||
(close-pipe pipe)
|
(close-pipe pipe)
|
||||||
|
|
|
@ -422,8 +422,29 @@
|
||||||
(close-port (car input+output))
|
(close-port (car input+output))
|
||||||
(list (cdr (waitpid pid)) str))))
|
(list (cdr (waitpid pid)) str))))
|
||||||
|
|
||||||
|
(pass-if-equal "awk with stdin and stdout redirects"
|
||||||
|
"world.\n"
|
||||||
|
(let* ((a+b (pipe))
|
||||||
|
(c+d (pipe))
|
||||||
|
(pid (spawn "awk" '("awk" "{print $2; exit 0;}")
|
||||||
|
#:input (car a+b)
|
||||||
|
#:output (cdr c+d))))
|
||||||
|
(close-port (car a+b))
|
||||||
|
(close-port (cdr c+d))
|
||||||
|
|
||||||
|
(display "Hello world.\n" (cdr a+b))
|
||||||
|
(close-port (cdr a+b))
|
||||||
|
|
||||||
|
(let ((str (get-string-all (car c+d))))
|
||||||
|
(close-port (car c+d))
|
||||||
|
(waitpid pid)
|
||||||
|
str)))
|
||||||
|
|
||||||
(pass-if-equal "wc with stdin and stdout redirects"
|
(pass-if-equal "wc with stdin and stdout redirects"
|
||||||
"2\n"
|
"2\n"
|
||||||
|
(unless (defined? 'SIGPIPE)
|
||||||
|
;; This test expects a closing pipe to kill the spawned process.
|
||||||
|
(throw 'unsupported))
|
||||||
(let* ((a+b (pipe))
|
(let* ((a+b (pipe))
|
||||||
(c+d (pipe))
|
(c+d (pipe))
|
||||||
(pid (spawn "wc" '("wc" "-w")
|
(pid (spawn "wc" '("wc" "-w")
|
||||||
|
|
Loading…
Add table
Add a link
Reference in a new issue