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.
This commit is contained in:
Ludovic Courtès 2019-03-16 17:07:57 +01:00
parent 22f95e028f
commit f0cc5e7e1e
No known key found for this signature in database
GPG key ID: 090B11993D9AEBB5
3 changed files with 85 additions and 2 deletions

View file

@ -1,5 +1,6 @@
;;; GNU Guix --- Functional package management for GNU ;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com> ;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
;;; Copyright © 2019 Ludovic Courtès <ludo@gnu.org>
;;; ;;;
;;; This file is part of GNU Guix. ;;; This file is part of GNU Guix.
;;; ;;;
@ -17,8 +18,15 @@
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
(define-module (gnu build bootloader) (define-module (gnu build bootloader)
#:use-module (srfi srfi-34)
#:use-module (srfi srfi-35)
#:use-module (ice-9 binary-ports) #: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 @@ (define (write-file-on-device file size device offset)
(seek output offset SEEK_SET) (seek output offset SEEK_SET)
(put-bytevector output bv)) (put-bytevector output bv))
#:binary #t))))) #: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))))))

View file

@ -72,4 +72,6 @@ guix/channels.scm
guix/profiles.scm guix/profiles.scm
guix/git.scm guix/git.scm
guix/deprecation.scm guix/deprecation.scm
gnu/build/bootloader.scm
nix/nix-daemon/guix-daemon.cc nix/nix-daemon/guix-daemon.cc

View file

@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU ;;; 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. ;;; This file is part of GNU Guix.
;;; ;;;
@ -20,11 +20,14 @@
(define-module (test-build-utils) (define-module (test-build-utils)
#:use-module (guix tests) #:use-module (guix tests)
#:use-module (guix build utils) #:use-module (guix build utils)
#:use-module ((gnu build bootloader)
#:select (invoke/quiet))
#:use-module ((guix utils) #:use-module ((guix utils)
#:select (%current-system call-with-temporary-directory)) #:select (%current-system call-with-temporary-directory))
#:use-module (gnu packages) #:use-module (gnu packages)
#:use-module (gnu packages bootstrap) #:use-module (gnu packages bootstrap)
#:use-module (srfi srfi-34) #:use-module (srfi srfi-34)
#:use-module (srfi srfi-35)
#:use-module (srfi srfi-64) #:use-module (srfi srfi-64)
#:use-module (rnrs io ports) #:use-module (rnrs io ports)
#:use-module (ice-9 popen)) #:use-module (ice-9 popen))
@ -123,5 +126,22 @@ (define-module (test-build-utils)
(and (zero? (close-pipe pipe)) (and (zero? (close-pipe pipe))
str))))))) 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) (test-end)