aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2014-01-04 22:42:42 +0100
committerLudovic Courtès <ludo@gnu.org>2014-01-04 22:45:33 +0100
commit1a43e4dc572c49e01380c86cdf09934aa0560917 (patch)
tree1d4835b5b60273f00060503823579857198d069b
parentaebaeaee33231d5027dc26c05ac510e8324af3dd (diff)
downloadguix-1a43e4dc572c49e01380c86cdf09934aa0560917.tar
guix-1a43e4dc572c49e01380c86cdf09934aa0560917.tar.gz
guix package: Gracefully deal with EPIPE on stdout for --list-*.
* guix/scripts/package.scm (leave-on-EPIPE): New macro. (guix-package): Use it for 'list-installed', 'list-available', and '--list-generations'. * tests/guix-package.sh: Add test.
-rw-r--r--guix/scripts/package.scm68
-rw-r--r--tests/guix-package.sh9
2 files changed, 52 insertions, 25 deletions
diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm
index 7cebf6b4d4..c12ddcd8c9 100644
--- a/guix/scripts/package.scm
+++ b/guix/scripts/package.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012, 2013, 2014 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org>
;;; Copyright © 2013 Mark H Weaver <mhw@netris.org>
;;;
@@ -293,6 +293,22 @@ return its return value."
(format (current-error-port) " interrupted by signal ~a~%" SIGINT)
#f))))
+(define-syntax-rule (leave-on-EPIPE exp ...)
+ "Run EXP... in a context when EPIPE errors are caught and lead to 'exit'
+with successful exit code. This is useful when writing to the standard output
+may lead to EPIPE, because the standard output is piped through 'head' or
+similar."
+ (catch 'system-error
+ (lambda ()
+ exp ...)
+ (lambda args
+ ;; We really have to exit this brutally, otherwise Guile eventually
+ ;; attempts to flush all the ports, leading to an uncaught EPIPE down
+ ;; the path.
+ (if (= EPIPE (system-error-errno args))
+ (primitive-_exit 0)
+ (apply throw args)))))
+
(define* (specification->package+output spec #:optional (output "out"))
"Return the package and output specified by SPEC, or #f and #f; SPEC may
optionally contain a version number and an output name, as in these examples:
@@ -958,15 +974,17 @@ more information.~%"))
profile))
((string-null? pattern)
(let ((numbers (generation-numbers profile)))
- (if (equal? numbers '(0))
- (exit 0)
- (for-each list-generation numbers))))
+ (leave-on-EPIPE
+ (if (equal? numbers '(0))
+ (exit 0)
+ (for-each list-generation numbers)))))
((matching-generations pattern profile)
=>
(lambda (numbers)
(if (null-list? numbers)
(exit 1)
- (for-each list-generation numbers))))
+ (leave-on-EPIPE
+ (for-each list-generation numbers)))))
(else
(leave (_ "invalid syntax: ~a~%")
pattern)))
@@ -976,15 +994,16 @@ more information.~%"))
(let* ((regexp (and regexp (make-regexp regexp)))
(manifest (profile-manifest profile))
(installed (manifest-entries manifest)))
- (for-each (match-lambda
- (($ <manifest-entry> name version output path _)
- (when (or (not regexp)
- (regexp-exec regexp name))
- (format #t "~a\t~a\t~a\t~a~%"
- name (or version "?") output path))))
-
- ;; Show most recently installed packages last.
- (reverse installed))
+ (leave-on-EPIPE
+ (for-each (match-lambda
+ (($ <manifest-entry> name version output path _)
+ (when (or (not regexp)
+ (regexp-exec regexp name))
+ (format #t "~a\t~a\t~a\t~a~%"
+ name (or version "?") output path))))
+
+ ;; Show most recently installed packages last.
+ (reverse installed)))
#t))
(('list-available regexp)
@@ -998,16 +1017,17 @@ more information.~%"))
r)
(cons p r))))
'())))
- (for-each (lambda (p)
- (format #t "~a\t~a\t~a\t~a~%"
- (package-name p)
- (package-version p)
- (string-join (package-outputs p) ",")
- (location->string (package-location p))))
- (sort available
- (lambda (p1 p2)
- (string<? (package-name p1)
- (package-name p2)))))
+ (leave-on-EPIPE
+ (for-each (lambda (p)
+ (format #t "~a\t~a\t~a\t~a~%"
+ (package-name p)
+ (package-version p)
+ (string-join (package-outputs p) ",")
+ (location->string (package-location p))))
+ (sort available
+ (lambda (p1 p2)
+ (string<? (package-name p1)
+ (package-name p2))))))
#t))
(('search regexp)
diff --git a/tests/guix-package.sh b/tests/guix-package.sh
index 47a2d06cb3..b79c4951d8 100644
--- a/tests/guix-package.sh
+++ b/tests/guix-package.sh
@@ -1,5 +1,5 @@
# GNU Guix --- Functional package management for GNU
-# Copyright © 2012, 2013 Ludovic Courtès <ludo@gnu.org>
+# Copyright © 2012, 2013, 2014 Ludovic Courtès <ludo@gnu.org>
# Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org>
#
# This file is part of GNU Guix.
@@ -218,3 +218,10 @@ done
# Extraneous argument.
if guix package install foo-bar;
then false; else true; fi
+
+# Make sure the "broken pipe" doesn't yield an error.
+# Note: 'pipefail' is a Bash-specific option.
+set -o pipefail || true
+guix package -A g | head -1 2> "$HOME/err1"
+guix package -I | head -1 2> "$HOME/err2"
+test "`cat "$HOME/err1" "$HOME/err2"`" = ""