diff options
Diffstat (limited to 'guix/scripts/package.scm')
| -rw-r--r-- | guix/scripts/package.scm | 88 |
1 files changed, 48 insertions, 40 deletions
diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index 49fa457a9c..04393abc9a 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> ;;; @@ -41,7 +41,8 @@ #:use-module ((gnu packages base) #:select (guile-final)) #:use-module ((gnu packages bootstrap) #:select (%bootstrap-guile)) #:use-module (guix gnu-maintenance) - #:export (guix-package)) + #:export (specification->package+output + guix-package)) (define %store (make-parameter #f)) @@ -56,7 +57,7 @@ (cut string-append <> "/.guix-profile"))) (define %profile-directory - (string-append (or (getenv "NIX_STATE_DIR") %state-directory) "/profiles/" + (string-append %state-directory "/profiles/" (or (and=> (getenv "USER") (cut string-append "per-user/" <>)) "default"))) @@ -292,21 +293,24 @@ return its return value." (format (current-error-port) " interrupted by signal ~a~%" SIGINT) #f)))) -(define newest-available-packages - (memoize find-newest-available-packages)) - -(define (find-best-packages-by-name name version) - "If version is #f, return the list of packages named NAME with the highest -version numbers; otherwise, return the list of packages named NAME and at -VERSION." - (if version - (find-packages-by-name name version) - (match (vhash-assoc name (newest-available-packages)) - ((_ version pkgs ...) pkgs) - (#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")) - "Find 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: guile @@ -342,7 +346,7 @@ version; if SPEC does not specify an output, return OUTPUT." "Return #t if there's a version of package NAME newer than CURRENT-VERSION, or if the newest available version is equal to CURRENT-VERSION but would have an output path different than CURRENT-PATH." - (match (vhash-assoc name (newest-available-packages)) + (match (vhash-assoc name (find-newest-available-packages)) ((_ candidate-version pkg . rest) (case (version-compare candidate-version current-version) ((>) #t) @@ -970,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))) @@ -988,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) @@ -1010,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) |