bug#43364: with-output-to-port works with file ports

[Ricardo Wurmus]

Felix Lechner via "Bug reports for GUILE, GNU's Ubiquitous Extension Language" 
<bug-guile@gnu.org> writes:

> Hi,
>
> In an interesting (or perhaps maddening) inconsistency,
> 'with-output-to-port' captures stdout from system* here
>
> (call-with-output-file "/tmp/test.log"
>   (lambda (port)
>     (with-output-to-port
>       port
>       (lambda ()
>         (system* "mktemp" "-d")))))
>
> but 'with-output-to-string' does not do so here
>
> (with-output-to-string
>   (lambda ()
>     (system* "mktemp" "-d")))
>
> According to lloda on #guile, system* handles the redirection only
> when the current ports are file ports. Thanks for that pointer!

That’s correct.  I’ve been using the following monstrosity to capture
and process output.  Perhaps someone finds a prettier way?

--8<---------------cut here---------------start------------->8---
(define* (call-with-output-processor command proc #:optional capture-stderr?)
  "Silently execute COMMAND, a list of strings representing an
executable with its arguments, and apply PROC to every line printed to
standard output and, optionally when CAPTURE-STDERR? is #T, standard
error.  Return the exit status of COMMAND."
  ;; We can only capture a program's standard error by parameterizing
  ;; current-error-port to a *file* port before using system* or
  ;; open-pipe*.  The process will write its standard error stream to
  ;; the provided file descriptor.  Meanwhile we read from the file
  ;; descriptor (blocking) for new lines until the process exits.
  (match (socketpair PF_UNIX SOCK_STREAM 0)
    ((in . out)
     (let ((err (if capture-stderr?
                    (dup out)
                    (%make-void-port "w"))))
       (catch #true
         (lambda ()
           (let ((thread
                  (parameterize ((current-error-port err)
                                 (current-output-port out))
                    (call-with-new-thread
                     (lambda ()
                       (let ((status
                              (status:exit-val
                               (apply system* command))))
                         (close-port err)
                         (close-port out)
                         status))))))
             (let loop ()
               (match (read-line in 'concat)
                 ((? eof-object?)
                  (for-each
                   (lambda (port)
                     (false-if-exception (close-port port)))
                   (list err out in))
                  (join-thread thread))
                 (line
                  (proc line)
                  (loop))))))
         (lambda (key . args)
           (for-each
            (lambda (port)
              (false-if-exception (close-port port)))
            (list err out in))
           (apply throw key args)))))))
--8<---------------cut here---------------end--------------->8---


-- 
Ricardo