41/80: install: Define new procedure pipe-cmd and use it to implement window-pipe.

[John Darrington]

jmd pushed a commit to branch wip-installer
in repository guix.

commit e5ce40657b4dfae60bbe301edb1df3e4a0ec9624
Author: John Darrington <address@hidden>
Date:   Mon Dec 26 15:22:12 2016 +0100

    install: Define new procedure pipe-cmd and use it to implement window-pipe.
    
    * gnu/system/installer/utils.scm (pipe-cmd): New procedure. (window-pipe)
    reimplement.
---
 gnu/system/installer/utils.scm |   20 +++++++++++++-------
 1 file changed, 13 insertions(+), 7 deletions(-)

diff --git a/gnu/system/installer/utils.scm b/gnu/system/installer/utils.scm
index 5ea4964..b8e257d 100644
--- a/gnu/system/installer/utils.scm
+++ b/gnu/system/installer/utils.scm
@@ -39,6 +39,7 @@
            find-mount-device
 
            window-pipe
+            pipe-cmd
 
            N_
            
@@ -68,11 +69,17 @@
 
 (define* (window-pipe win cmd #:rest args)
   "Run CMD ARGS ... sending stdout and stderr to WIN.  Returns the exit status 
of CMD."
-  (let* ((windowp (make-window-port win))
+  (let* ((windowp (make-window-port win)))
+    (clear win)
+    (apply pipe-cmd windowp cmd args)
+    (close-port windowp)))
+
+(define* (pipe-cmd ipipe cmd #:rest args)
+  "Run CMD ARGS ... sending stdout and stderr to IPIPE.  Returns the exit 
status of CMD."
+  (let* (
         (pipep (pipe))
         (pid (primitive-fork)))
 
-    (clear win)
     (if (zero? pid)
        (begin
          (redirect-port (cdr pipep) (current-output-port))
@@ -81,11 +88,10 @@
        (begin
          (close (cdr pipep))
          (let loop ((c (read-char (car pipep))))
-           (if (not (eof-object? c))
-               (begin
-                 (display c windowp)
-                 (force-output windowp)
-                 (loop (read-char (car pipep))))))))
+           (unless (eof-object? c)
+              (display c ipipe)
+              (force-output ipipe)
+              (loop (read-char (car pipep)))))))
     
     (cdr (waitpid pid))))