From f0cc5e7e1e4c03af29c5d4855dc5962502c49147 Mon Sep 17 00:00:00 2001
From: Ludovic Courtès <ludo@gnu.org>
Date: Sat, 16 Mar 2019 17:07:57 +0100
Subject: booloader: Add 'invoke/quiet'.

* gnu/build/bootloader.scm (G_): New macro.
(open-pipe-with-stderr, invoke/quiet): New procedures.
* tests/build-utils.scm ("invoke/quiet, success")
("invoke/quiet, failure")
("invoke/quiet, failure, message on stderr"): New tests.
* po/guix/POTFILES.in: Add bootloader.scm.
---
 gnu/build/bootloader.scm | 63 +++++++++++++++++++++++++++++++++++++++++++++++-
 1 file changed, 62 insertions(+), 1 deletion(-)

(limited to 'gnu/build')

diff --git a/gnu/build/bootloader.scm b/gnu/build/bootloader.scm
index d00674dd40..c5febcde1e 100644
--- a/gnu/build/bootloader.scm
+++ b/gnu/build/bootloader.scm
@@ -1,5 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
+;;; Copyright © 2019 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -17,8 +18,15 @@
 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
 
 (define-module (gnu build bootloader)
+  #:use-module (srfi srfi-34)
+  #:use-module (srfi srfi-35)
   #:use-module (ice-9 binary-ports)
-  #:export (write-file-on-device))
+  #:use-module (ice-9 popen)
+  #:use-module (ice-9 match)
+  #:use-module (ice-9 rdelim)
+  #:use-module (ice-9 format)
+  #:export (write-file-on-device
+            invoke/quiet))
 
 
 ;;;
@@ -35,3 +43,56 @@
             (seek output offset SEEK_SET)
             (put-bytevector output bv))
           #:binary #t)))))
+
+(define-syntax-rule (G_ str) str)                 ;for xgettext
+
+(define (open-pipe-with-stderr program . args)
+  "Run PROGRAM with ARGS in an input pipe, but, unlike 'open-pipe*', redirect
+both its standard output and standard error to the pipe.  Return two value:
+the pipe to read PROGRAM's data from, and the PID of the child process running
+PROGRAM."
+  ;; 'open-pipe*' doesn't attempt to capture stderr in any way, which is why
+  ;; we need to roll our own.
+  (match (pipe)
+    ((input .  output)
+     (match (primitive-fork)
+       (0
+        (dynamic-wind
+          (const #t)
+          (lambda ()
+            (close-port input)
+            (dup2 (fileno output) 1)
+            (dup2 (fileno output) 2)
+            (apply execlp program program args))
+          (lambda ()
+            (primitive-exit 127))))
+       (pid
+        (close-port output)
+        (values input pid))))))
+
+;; TODO: Move to (guix build utils) on the next rebuild cycle.
+(define (invoke/quiet program . args)
+  "Invoke PROGRAM with ARGS and capture PROGRAM's standard output and standard
+error.  If PROGRAM succeeds, print nothing and return the unspecified value;
+otherwise, raise a '&message' error condition that includes the status code
+and the output of PROGRAM."
+  (define-values (pipe pid)
+    (apply open-pipe-with-stderr program args))
+
+  (let loop ((lines '()))
+    (match (read-line pipe)
+      ((? eof-object?)
+       (close-port pipe)
+       (match (waitpid pid)
+         ((_ . status)
+          (unless (zero? status)
+            (raise (condition
+                    (&message
+                     (message (format #f (G_ "'~a~{ ~a~}' exited with status ~a; \
+output follows:~%~%~{  ~a~%~}")
+                                      program args
+                                      (or (status:exit-val status)
+                                          status)
+                                      (reverse lines))))))))))
+      (line
+       (loop (cons line lines))))))
-- 
cgit v1.2.3