diff --git a/module/ice-9/popen.scm b/module/ice-9/popen.scm index 5ab93f275..a0ef0dc71 100644 --- a/module/ice-9/popen.scm +++ b/module/ice-9/popen.scm @@ -99,13 +99,28 @@ process (based on pipes) is created and returned. @var{mode} specifies whether an input, an output or an input-output port to the process is created: it should be the value of @code{OPEN_READ}, @code{OPEN_WRITE} or @code{OPEN_BOTH}." + (define (unbuffered port) + (setvbuf port 'none) + port) + + (define (fdes-pair ports) + (and ports + (cons (port->fdes (car ports)) (port->fdes (cdr ports))))) + (let* ((from (and (or (string=? mode OPEN_READ) - (string=? mode OPEN_BOTH)) (pipe->fdes))) + (string=? mode OPEN_BOTH)) + (pipe))) (to (and (or (string=? mode OPEN_WRITE) - (string=? mode OPEN_BOTH)) (pipe->fdes))) - (pid (piped-process command args from to))) - (values (and from (fdes->inport (car from))) - (and to (fdes->outport (cdr to))) pid))) + (string=? mode OPEN_BOTH)) + (pipe))) + (pid (piped-process command args + (fdes-pair from) + (fdes-pair to)))) + ;; The original 'open-process' procedure would return unbuffered + ;; ports; do the same here. + (values (and from (unbuffered (car from))) + (and to (unbuffered (cdr to))) + pid))) (define (open-pipe* mode command . args) "Executes the program @var{command} with optional arguments diff --git a/test-suite/tests/popen.test b/test-suite/tests/popen.test index 86e388923..692156a34 100644 --- a/test-suite/tests/popen.test +++ b/test-suite/tests/popen.test @@ -196,6 +196,29 @@ exec 2>~a; read REPLY" (close-pipe port) 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)))))) + ;; ;; close-pipe ;;