mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-29 19:30:36 +02:00
Code Activity

MinGW: don't hand on unsupported popen tests

Browse source
This commit is contained in:
Michael Gran 2025-03-30 20:54:06 -07:00
parent 59f3e1a881
commit 2b5528847d
1 changed files with 26 additions and 22 deletions
Download patch file Download diff file Expand all files Collapse all files

48
test-suite/tests/popen.test
View file

@ -115,11 +115,11 @@
(open-input-pipe "read line && echo $line")))))
(display "hello\n" (cdr p2c))
(force-output (cdr p2c))
(let ((result (eq? (read port) 'hello)))
(let ((result (eq? (read port)) 'hello))
(close-port (cdr p2c))
(close-pipe port)
result)))
;; After the child closes stdout (which it indicates here by writing
;; "closed" to stderr), the parent should see eof. In Guile 1.6.4
;; and earlier a duplicate of stdout existed in the child, meaning
@ -132,7 +132,10 @@
;; sure that we are testing what the parent sees at a point where
;; the child has closed stdout but is still alive.
(pass-if "no duplicate"
(when mingw? (throw 'unresolved))
(when mingw?
;; MinGW has no SIGPIPE, so closing the pipe doesn't
;; terminate the process.
(throw 'unresolved))
(let* ((c2p (pipe))
(p2c (pipe))
(port (with-error-to-port (cdr c2p)
@ -200,8 +203,8 @@ exec 2>~a; read REPLY"
;; the child process; we rely on the child getting SIGPIPE, to
;; terminate it (and avoid leaving a zombie).
(pass-if "no duplicate"
(unless (defined? 'SIGPIPE)
;; MinGW has no SIGPIPE, so closing the pipe doesn't
(when mingw?
;; MinGW has no working SIGPIPE, so closing the pipe doesn't
;; terminate the process.
(throw 'unsupported))
(let* ((c2p (pipe))
@ -230,26 +233,27 @@ exec 2>~a; read REPLY"
result))))))
(with-test-prefix "open-pipe*"
(pass-if-equal "OPEN_BOTH"
'(0 (good!))
;; This test ensures that the ports that underlie the read/write
;; port are unbuffered. If they were buffered, the child process
;; would wait in 'read' forever.
(let ((pipe (open-pipe* OPEN_BOTH "guile" "-c"
(object->string
'(begin
(setvbuf (current-output-port) 'line)
(write '(hello!))
(newline)
(let ((greeting (read)))
(write '(good!))))))))
(setvbuf pipe 'line)
(let ((return (read pipe)))
(write '(hi!) pipe)
(newline pipe)
(let ((last (read pipe)))
(list (close-pipe pipe) last))))))
(if mingw?
(throw 'unresolved) ; FIXME: why does this hang?
(let ((pipe (open-pipe* OPEN_BOTH "guile" "-c"
(object->string
'(begin
(setvbuf (current-output-port) 'line)
(write '(hello!))
(newline)
(let ((greeting (read)))
(write '(good!))))))))
(setvbuf pipe 'line)
(let ((return (read pipe)))
(write '(hi!) pipe)
(newline pipe)
(let ((last (read pipe)))
(list (close-pipe pipe) last)))))))
;;
;; close-pipe
@ -277,8 +281,8 @@ exec 2>~a; read REPLY"
(pass-if-equal "open-process"
'("HELLO WORLD" 0)
(unless (defined? 'SIGPIPE)
;; MinGW has no SIGPIPE, so 'tr' doesn't exit when input is
(when mingw?
;; MinGW has a broken SIGPIPE, so 'tr' doesn't exit when input is
;; exhausted.
(throw 'unsupported))
(receive (from to pid)