diff options
| -rw-r--r-- | gnu/build/bootloader.scm | 63 | ||||
| -rw-r--r-- | po/guix/POTFILES.in | 2 | ||||
| -rw-r--r-- | 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 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) |