ryan77627/guix
1
0
Fork 0
mirror of https://git.in.rschanz.org/ryan77627/guix.git synced 2025-01-11 21:59:08 -05:00
Code Issues Projects Releases Packages Wiki Activity Actions

guix package: Gracefully deal with EPIPE on stdout for --list-*.

Browse source 
* 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.
This commit is contained in:
Ludovic Courtès 2014-01-04 22:42:42 +01:00
parent aebaeaee33
commit 1a43e4dc57
2 changed files with 51 additions and 24 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

30
guix/scripts/package.scm
View file

@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU ;;; 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 Nikita Karetnikov <nikita@karetnikov.org>
;;; Copyright © 2013 Mark H Weaver <mhw@netris.org> ;;; Copyright © 2013 Mark H Weaver <mhw@netris.org>
;;; ;;;
@ -293,6 +293,22 @@ (define-syntax-rule (waiting exp fmt rest ...)
(format (current-error-port) " interrupted by signal ~a~%" SIGINT) (format (current-error-port) " interrupted by signal ~a~%" SIGINT)
#f)))) #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")) (define* (specification->package+output spec #:optional (output "out"))
"Return the package and output specified by SPEC, or #f and #f; SPEC may "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: optionally contain a version number and an output name, as in these examples:
@ -958,15 +974,17 @@ (define (list-generation number)
profile)) profile))
((string-null? pattern) ((string-null? pattern)
(let ((numbers (generation-numbers profile))) (let ((numbers (generation-numbers profile)))
(leave-on-EPIPE
(if (equal? numbers '(0)) (if (equal? numbers '(0))
(exit 0) (exit 0)
(for-each list-generation numbers)))) (for-each list-generation numbers)))))
((matching-generations pattern profile) ((matching-generations pattern profile)
=> =>
(lambda (numbers) (lambda (numbers)
(if (null-list? numbers) (if (null-list? numbers)
(exit 1) (exit 1)
(for-each list-generation numbers)))) (leave-on-EPIPE
(for-each list-generation numbers)))))
(else (else
(leave (_ "invalid syntax: ~a~%") (leave (_ "invalid syntax: ~a~%")
pattern))) pattern)))
@ -976,6 +994,7 @@ (define (list-generation number)
(let* ((regexp (and regexp (make-regexp regexp))) (let* ((regexp (and regexp (make-regexp regexp)))
(manifest (profile-manifest profile)) (manifest (profile-manifest profile))
(installed (manifest-entries manifest))) (installed (manifest-entries manifest)))
(leave-on-EPIPE
(for-each (match-lambda (for-each (match-lambda
(($ <manifest-entry> name version output path _) (($ <manifest-entry> name version output path _)
(when (or (not regexp) (when (or (not regexp)
@ -984,7 +1003,7 @@ (define (list-generation number)
name (or version "?") output path)))) name (or version "?") output path))))
;; Show most recently installed packages last. ;; Show most recently installed packages last.
(reverse installed)) (reverse installed)))
#t)) #t))
(('list-available regexp) (('list-available regexp)
@ -998,6 +1017,7 @@ (define (list-generation number)
r) r)
(cons p r)))) (cons p r))))
'()))) '())))
(leave-on-EPIPE
(for-each (lambda (p) (for-each (lambda (p)
(format #t "~a\t~a\t~a\t~a~%" (format #t "~a\t~a\t~a\t~a~%"
(package-name p) (package-name p)
@ -1007,7 +1027,7 @@ (define (list-generation number)
(sort available (sort available
(lambda (p1 p2) (lambda (p1 p2)
(string<? (package-name p1) (string<? (package-name p1)
(package-name p2))))) (package-name p2))))))
#t)) #t))
(('search regexp) (('search regexp)

9
tests/guix-package.sh
View file

@ -1,5 +1,5 @@
# GNU Guix --- Functional package management for GNU # 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 Nikita Karetnikov <nikita@karetnikov.org>
# #
# This file is part of GNU Guix. # This file is part of GNU Guix.
@ -218,3 +218,10 @@ done
# Extraneous argument. # Extraneous argument.
if guix package install foo-bar; if guix package install foo-bar;
then false; else true; fi 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"`" = ""