02/03: booloader: Add 'invoke/quiet'.

[guix-commits]

civodul pushed a commit to branch master
in repository guix.

commit f0cc5e7e1e4c03af29c5d4855dc5962502c49147
Author: Ludovic Courtès <address@hidden>
Date:   Sat Mar 16 17:07:57 2019 +0100

    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 +++++++++++++++++++++++++++++++++++++++++++++++-
 po/guix/POTFILES.in      |  2 ++
 tests/build-utils.scm    | 22 ++++++++++++++++-
 3 files changed, 85 insertions(+), 2 deletions(-)

diff --git a/gnu/build/bootloader.scm b/gnu/build/bootloader.scm
index d00674d..c5febcd 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 <address@hidden>
+;;; Copyright © 2019 Ludovic Courtès <address@hidden>
 ;;;
 ;;; 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))))))
diff --git a/po/guix/POTFILES.in b/po/guix/POTFILES.in
index 07b73a7..debff5a 100644
--- a/po/guix/POTFILES.in
+++ b/po/guix/POTFILES.in
@@ -72,4 +72,6 @@ guix/channels.scm
 guix/profiles.scm
 guix/git.scm
 guix/deprecation.scm
+gnu/build/bootloader.scm
 nix/nix-daemon/guix-daemon.cc
+
diff --git a/tests/build-utils.scm b/tests/build-utils.scm
index 03216f9..46fe8ea 100644
--- a/tests/build-utils.scm
+++ b/tests/build-utils.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2015, 2016 Ludovic Courtès <address@hidden>
+;;; Copyright © 2012, 2015, 2016, 2019 Ludovic Courtès <address@hidden>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -20,11 +20,14 @@
 (define-module (test-build-utils)
   #:use-module (guix tests)
   #:use-module (guix build utils)
+  #:use-module ((gnu build bootloader)
+                #:select (invoke/quiet))
   #:use-module ((guix utils)
                 #:select (%current-system call-with-temporary-directory))
   #:use-module (gnu packages)
   #:use-module (gnu packages bootstrap)
   #:use-module (srfi srfi-34)
+  #:use-module (srfi srfi-35)
   #:use-module (srfi srfi-64)
   #:use-module (rnrs io ports)
   #:use-module (ice-9 popen))
@@ -123,5 +126,22 @@
            (and (zero? (close-pipe pipe))
                 str)))))))
 
+(test-assert "invoke/quiet, success"
+  (begin
+    (invoke/quiet "true")
+    #t))
+
+(test-assert "invoke/quiet, failure"
+  (guard (c ((message-condition? c)
+             (string-contains (condition-message c) "This is an error.")))
+    (invoke/quiet "sh" "-c" "echo This is an error. ; false")
+    #f))
+
+(test-assert "invoke/quiet, failure, message on stderr"
+  (guard (c ((message-condition? c)
+             (string-contains (condition-message c)
+                              "This is another error.")))
+    (invoke/quiet "sh" "-c" "echo This is another error. >&2 ; false")
+    #f))
 
 (test-end)