utils: Add call-with-output-pipe.

* tissue/utils.scm (call-with-output-pipe): New function.

1 files changed, 15 insertions, 0 deletions

diff --git a/tissue/utils.scm b/tissue/utils.scm
index aed729b..2eccc4f 100644
--- a/tissue/utils.scm
+++ b/tissue/utils.scm
@@ -24,6 +24,7 @@
   #:export (string-remove-prefix
             human-date-string
             call-with-current-directory
+            call-with-output-pipe
             get-line-dos-or-unix
             memoize-thunk))
 
@@ -59,6 +60,20 @@ directory after THUNK returns."
                   thunk
                   (cut chdir original-current-directory))))
 
+(define (call-with-output-pipe proc program . args)
+  "Execute PROGRAM ARGS ... in a subprocess with a pipe to it. Call PROC
+with an output port to that pipe. Close the pipe once PROC exits, even
+if it exits non-locally. Return the value returned by PROC."
+  (let ((port #f))
+    (dynamic-wind
+      (cut set! port (apply open-pipe* OPEN_WRITE program args))
+      (cut proc port)
+      (lambda ()
+        (let ((return-value (status:exit-val (close-pipe port))))
+          (unless (and return-value
+                       (zero? return-value))
+            (error "Invocation of program failed" (cons program args))))))))
+
 (define (get-line-dos-or-unix port)
   "Read line from PORT. This differs from `get-line' in (rnrs io
 ports) in that it also supports DOS line endings."