summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2019-03-16 17:07:57 +0100
committerLudovic Courtès <ludo@gnu.org>2019-03-16 18:15:13 +0100
commitf0cc5e7e1e4c03af29c5d4855dc5962502c49147 (patch)
tree8ed975abe2ac957b165a7f32900c739949f01cf5
parent22f95e028f038cee342f455dfc55bd32b804907c (diff)
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.
-rw-r--r--gnu/build/bootloader.scm63
-rw-r--r--po/guix/POTFILES.in2
-rw-r--r--tests/build-utils.scm22
3 files changed, 85 insertions, 2 deletions
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))))))
diff --git a/po/guix/POTFILES.in b/po/guix/POTFILES.in
index 07b73a770a..debff5ae8e 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 03216f9a35..46fe8ea2c0 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 <ludo@gnu.org>
+;;; Copyright © 2012, 2015, 2016, 2019 Ludovic Courtès <ludo@gnu.org>
;;;
;;; 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)