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