From cbdfa50d9fb19704caa60818d7635047a6a26d71 Mon Sep 17 00:00:00 2001 From: Mark H Weaver Date: Fri, 16 Mar 2018 18:29:31 -0400 Subject: utils: invoke: Raise exceptions using SRFI-34 and SRFI-35. * guix/build/utils.scm (&invoke-error): New condition type. (invoke-error?, invoke-error-program, invoke-error-arguments) (invoke-error-exit-status, invoke-error-term-signal) (invoke-error-stop-signal): New exported procedures. (invoke): Raise exceptions using SRFI-34 and SRFI-35. * guix/ui.scm (call-with-error-handling): Add a guard clause for &invoke-error conditions. --- guix/build/utils.scm | 35 ++++++++++++++++++++++++++++------- guix/ui.scm | 18 +++++++++++++++++- 2 files changed, 45 insertions(+), 8 deletions(-) diff --git a/guix/build/utils.scm b/guix/build/utils.scm index ab309aa0df..c58a1afd1c 100644 --- a/guix/build/utils.scm +++ b/guix/build/utils.scm @@ -2,7 +2,7 @@ ;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès ;;; Copyright © 2013 Andreas Enge ;;; Copyright © 2013 Nikita Karetnikov -;;; Copyright © 2015 Mark H Weaver +;;; Copyright © 2015, 2018 Mark H Weaver ;;; ;;; This file is part of GNU Guix. ;;; @@ -23,6 +23,8 @@ #:use-module (srfi srfi-1) #:use-module (srfi srfi-11) #:use-module (srfi srfi-26) + #:use-module (srfi srfi-34) + #:use-module (srfi srfi-35) #:use-module (srfi srfi-60) #:use-module (ice-9 ftw) #:use-module (ice-9 match) @@ -86,7 +88,14 @@ fold-port-matches remove-store-references wrap-program + invoke + invoke-error? + invoke-error-program + invoke-error-arguments + invoke-error-exit-status + invoke-error-term-signal + invoke-error-stop-signal locale-category->string)) @@ -591,13 +600,25 @@ Where every <*-phase-name> is an expression evaluating to a symbol, and ((_ phases (add-after old-phase-name new-phase-name new-phase)) (alist-cons-after old-phase-name new-phase-name new-phase phases)))) +(define-condition-type &invoke-error &error + invoke-error? + (program invoke-error-program) + (arguments invoke-error-arguments) + (exit-status invoke-error-exit-status) + (term-signal invoke-error-term-signal) + (stop-signal invoke-error-stop-signal)) + (define (invoke program . args) - "Invoke PROGRAM with the given ARGS. Raise an error if the exit -code is non-zero; otherwise return #t." - (let ((status (apply system* program args))) - (unless (zero? status) - (error (format #f "program ~s exited with non-zero code" program) - status)) + "Invoke PROGRAM with the given ARGS. Raise an exception +if the exit code is non-zero; otherwise return #t." + (let ((code (apply system* program args))) + (unless (zero? code) + (raise (condition (&invoke-error + (program program) + (arguments args) + (exit-status (status:exit-val code)) + (term-signal (status:term-sig code)) + (stop-signal (status:stop-sig code)))))) #t)) diff --git a/guix/ui.scm b/guix/ui.scm index cb49a15c4d..c6d0704cfa 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -1,6 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès -;;; Copyright © 2013 Mark H Weaver +;;; Copyright © 2013, 2018 Mark H Weaver ;;; Copyright © 2013 Nikita Karetnikov ;;; Copyright © 2014 Cyril Roelandt ;;; Copyright © 2014 Cyrill Schenkel @@ -41,6 +41,12 @@ #:use-module ((guix licenses) #:select (license? license-name)) #:use-module ((guix build syscalls) #:select (free-disk-space terminal-columns)) + #:use-module ((guix build utils) + #:select (invoke-error? invoke-error-program + invoke-error-arguments + invoke-error-exit-status + invoke-error-term-signal + invoke-error-stop-signal)) #:use-module (srfi srfi-1) #:use-module (srfi srfi-11) #:use-module (srfi srfi-19) @@ -636,6 +642,16 @@ or remove one of them from the profile.") directories:~{ ~a~}~%") (file-search-error-file-name c) (file-search-error-search-path c))) + ((invoke-error? c) + (leave (G_ "program exited\ +~@[ with non-zero exit status ~a~]\ +~@[ terminated by signal ~a~]\ +~@[ stopped by signal ~a~]: ~s~%") + (invoke-error-exit-status c) + (invoke-error-term-signal c) + (invoke-error-stop-signal c) + (cons (invoke-error-program c) + (invoke-error-arguments c)))) ((and (error-location? c) (message-condition? c)) (format (current-error-port) (G_ "~a: error: ~a~%") -- cgit 1.4.1