utils: Add 'invoke/quiet'.
* gnu/build/bootloader.scm (G_): Remove. (open-pipe-with-stderr, invoke/quiet): Move to... * guix/build/utils.scm: ... here. Use 'let-values' instead of 'define-values' because Guile 2.0 (the bootstrap Guile) doesn't know about 'define-values'. * po/guix/POTFILES.in: Remove gnu/build/bootloader.scm, and add guix/build/utils.scm. * tests/build-utils.scm: Remove import of (gnu build bootloader).
This commit is contained in:
parent
25c639e2a3
commit
45d46223f9
|
@ -18,15 +18,8 @@
|
||||||
;;; 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)
|
||||||
#:use-module (ice-9 popen)
|
#:export (write-file-on-device))
|
||||||
#:use-module (ice-9 match)
|
|
||||||
#:use-module (ice-9 rdelim)
|
|
||||||
#:use-module (ice-9 format)
|
|
||||||
#:export (write-file-on-device
|
|
||||||
invoke/quiet))
|
|
||||||
|
|
||||||
|
|
||||||
;;;
|
;;;
|
||||||
|
@ -43,56 +36,3 @@
|
||||||
(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))))))
|
|
||||||
|
|
|
@ -106,6 +106,8 @@
|
||||||
invoke-error-stop-signal
|
invoke-error-stop-signal
|
||||||
report-invoke-error
|
report-invoke-error
|
||||||
|
|
||||||
|
invoke/quiet
|
||||||
|
|
||||||
locale-category->string))
|
locale-category->string))
|
||||||
|
|
||||||
|
|
||||||
|
@ -666,6 +668,57 @@ way."
|
||||||
(invoke-error-term-signal c)
|
(invoke-error-term-signal c)
|
||||||
(invoke-error-stop-signal c))))
|
(invoke-error-stop-signal c))))
|
||||||
|
|
||||||
|
(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))))))
|
||||||
|
|
||||||
|
(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."
|
||||||
|
(let-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)
|
||||||
|
(let-syntax ((G_ (syntax-rules () ;for xgettext
|
||||||
|
((_ str) str))))
|
||||||
|
(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)))))))
|
||||||
|
|
||||||
|
|
||||||
;;;
|
;;;
|
||||||
;;; Text substitution (aka. sed).
|
;;; Text substitution (aka. sed).
|
||||||
|
|
|
@ -37,6 +37,7 @@ gnu/installer/timezone.scm
|
||||||
gnu/installer/user.scm
|
gnu/installer/user.scm
|
||||||
gnu/installer/utils.scm
|
gnu/installer/utils.scm
|
||||||
gnu/packages/bootstrap.scm
|
gnu/packages/bootstrap.scm
|
||||||
|
guix/build/utils.scm
|
||||||
guix/scripts.scm
|
guix/scripts.scm
|
||||||
guix/scripts/build.scm
|
guix/scripts/build.scm
|
||||||
guix/discovery.scm
|
guix/discovery.scm
|
||||||
|
@ -79,6 +80,4 @@ 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
|
||||||
|
|
||||||
|
|
|
@ -21,8 +21,6 @@
|
||||||
(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)
|
||||||
|
|
Loading…
Reference in New Issue