mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-16 18:50:23 +02:00
Code Activity

(open-input-pipe, open-output-pipe): In the "no

Browse source 
duplicate" tests, close parent side of signalling pipe, to hopefully
generate an error instead of a hang if something bad in the child
means it doesn't write anything.
This commit is contained in:
Kevin Ryde 2006-08-25 01:28:58 +00:00
parent 596a92c43a
commit 830388a115
1 changed files with 9 additions and 7 deletions
Download patch file Download diff file Expand all files Collapse all files

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

@ -107,9 +107,10 @@
(port (with-error-to-port (cdr pair)
(lambda ()
(open-input-pipe
"exec 1>/dev/null; echo closed 1>&2; sleep 999")))))
(read-char (car pair)) ;; wait for child to do its thing
(and (char-ready? port)
"exec 1>/dev/null; echo closed 1>&2; exec 2>/dev/null; sleep 999")))))
(close-port (cdr pair)) ;; write side
(and (char? (read-char (car pair))) ;; wait for child to do its thing
(char-ready? port)
(eof-object? (read-char port))))))
;;
@ -156,15 +157,16 @@
(port (with-error-to-port (cdr pair)
(lambda ()
(open-output-pipe
"exec 0</dev/null; echo closed 1>&2; sleep 999")))))
(read-char (car pair)) ;; wait for child to do its thing
(catch 'system-error
"exec 0</dev/null; echo closed 1>&2; exec 2>/dev/null; sleep 999")))))
(close-port (cdr pair)) ;; write side
(and (char? (read-char (car pair))) ;; wait for child to do its thing
(catch 'system-error
(lambda ()
(write-char #\x port)
(force-output port)
#f)
(lambda (key name fmt args errno-list)
(= (car errno-list) EPIPE))))))))
(= (car errno-list) EPIPE)))))))))
;;
;; close-pipe