From 868c923f13e6ed95e1e5ad2bd32d4166842254ea Mon Sep 17 00:00:00 2001 From: Mark H Weaver Date: Thu, 14 Feb 2013 04:15:25 -0500 Subject: Replace individual scripts with master 'guix' script. * scripts/guix.in: New script. * Makefile.am (bin_SCRIPTS): Add 'scripts/guix'. Remove 'guix-build', 'guix-download', 'guix-import', 'guix-package', and 'guix-gc'. (MODULES): Add 'guix/scripts/build.scm', 'guix/scripts/download.scm', 'guix/scripts/import.scm', 'guix/scripts/package.scm', and 'guix/scripts/gc.scm'. * configure.ac (AC_CONFIG_FILES): Add 'scripts/guix'. Remove 'guix-build', 'guix-download', 'guix-import', 'guix-package', and 'guix-gc'. * guix-build.in, guix-download.in, guix-gc.in, guix-import.in, guix-package.in: Remove shell script boilerplate. Move to guix-COMMAND.in to guix/scripts/COMMAND.scm. Rename module from (guix-COMMAND) to (guix scripts COMMAND). Change "guix-COMMAND" to "guix COMMAND" in usage help string. * pre-inst-env.in: Add "@abs_top_builddir@/scripts" to the front of $PATH. Export $GUIX_UNINSTALLED. * tests/guix-build.sh, tests/guix-daemon.sh, tests/guix-download.sh, tests/guix-gc.sh, tests/guix-package.sh: Use "guix COMMAND" instead of "guix-COMMAND". * doc/guix.texi: Replace all occurrences of "guix-COMMAND" with "guix COMMAND". * po/POTFILES.in: Update. --- guix/scripts/package.scm | 693 +++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 693 insertions(+) create mode 100644 guix/scripts/package.scm (limited to 'guix/scripts/package.scm') diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm new file mode 100644 index 0000000000..4935837d33 --- /dev/null +++ b/guix/scripts/package.scm @@ -0,0 +1,693 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2012, 2013 Ludovic Courtès +;;; Copyright © 2013 Nikita Karetnikov +;;; Copyright © 2013 Mark H Weaver +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see . + +(define-module (guix scripts package) + #:use-module (guix ui) + #:use-module (guix store) + #:use-module (guix derivations) + #:use-module (guix packages) + #:use-module (guix utils) + #:use-module (guix config) + #:use-module ((guix build utils) #:select (directory-exists? mkdir-p)) + #:use-module (ice-9 ftw) + #:use-module (ice-9 format) + #:use-module (ice-9 match) + #:use-module (ice-9 regex) + #:use-module (ice-9 vlist) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-11) + #:use-module (srfi srfi-26) + #:use-module (srfi srfi-34) + #:use-module (srfi srfi-37) + #:use-module (gnu packages) + #:use-module ((gnu packages base) #:select (guile-final)) + #:use-module ((gnu packages bootstrap) #:select (%bootstrap-guile)) + #:export (guix-package)) + +(define %store + (make-parameter #f)) + + +;;; +;;; User environment. +;;; + +(define %user-environment-directory + (and=> (getenv "HOME") + (cut string-append <> "/.guix-profile"))) + +(define %profile-directory + (string-append (or (getenv "NIX_STATE_DIR") %state-directory) "/profiles/" + (or (and=> (getenv "USER") + (cut string-append "per-user/" <>)) + "default"))) + +(define %current-profile + ;; Call it `guix-profile', not `profile', to allow Guix profiles to + ;; coexist with Nix profiles. + (string-append %profile-directory "/guix-profile")) + +(define (profile-manifest profile) + "Return the PROFILE's manifest." + (let ((manifest (string-append profile "/manifest"))) + (if (file-exists? manifest) + (call-with-input-file manifest read) + '(manifest (version 1) (packages ()))))) + +(define (manifest-packages manifest) + "Return the packages listed in MANIFEST." + (match manifest + (('manifest ('version 0) + ('packages ((name version output path) ...))) + (zip name version output path + (make-list (length name) '()))) + + ;; Version 1 adds a list of propagated inputs to the + ;; name/version/output/path tuples. + (('manifest ('version 1) + ('packages (packages ...))) + packages) + + (_ + (error "unsupported manifest format" manifest)))) + +(define (profile-regexp profile) + "Return a regular expression that matches PROFILE's name and number." + (make-regexp (string-append "^" (regexp-quote (basename profile)) + "-([0-9]+)"))) + +(define (profile-numbers profile) + "Return the list of generation numbers of PROFILE, or '(0) if no +former profiles were found." + (define* (scandir name #:optional (select? (const #t)) + (entry (file-system-fold enter? leaf down up skip error #f name lstat) + (lambda (files) + (sort files entry)) + (#f ; no profile directory + '(0)) + (() ; no profiles + '(0)) + ((profiles ...) ; former profiles around + (map (compose string->number + (cut match:substring <> 1) + (cute regexp-exec (profile-regexp profile) <>)) + profiles)))) + +(define (previous-profile-number profile number) + "Return the number of the generation before generation NUMBER of +PROFILE, or 0 if none exists. It could be NUMBER - 1, but it's not the +case when generations have been deleted (there are \"holes\")." + (fold (lambda (candidate highest) + (if (and (< candidate number) (> candidate highest)) + candidate + highest)) + 0 + (profile-numbers profile))) + +(define (profile-derivation store packages) + "Return a derivation that builds a profile (a user environment) with +all of PACKAGES, a list of name/version/output/path/deps tuples." + (define builder + `(begin + (use-modules (ice-9 pretty-print) + (guix build union)) + + (setvbuf (current-output-port) _IOLBF) + (setvbuf (current-error-port) _IOLBF) + + (let ((output (assoc-ref %outputs "out")) + (inputs (map cdr %build-inputs))) + (format #t "building user environment `~a' with ~a packages...~%" + output (length inputs)) + (union-build output inputs) + (call-with-output-file (string-append output "/manifest") + (lambda (p) + (pretty-print '(manifest (version 1) + (packages ,packages)) + p)))))) + + (build-expression->derivation store "user-environment" + (%current-system) + builder + (append-map (match-lambda + ((name version output path deps) + `((,name ,path) + ,@deps))) + packages) + #:modules '((guix build union)))) + +(define (profile-number profile) + "Return PROFILE's number or 0. An absolute file name must be used." + (or (and=> (false-if-exception (regexp-exec (profile-regexp profile) + (basename (readlink profile)))) + (compose string->number (cut match:substring <> 1))) + 0)) + +(define (switch-symlinks link target) + "Atomically switch LINK, a symbolic link, to point to TARGET. Works +both when LINK already exists and when it does not." + (let ((pivot (string-append link ".new"))) + (symlink target pivot) + (rename-file pivot link))) + +(define (roll-back profile) + "Roll back to the previous generation of PROFILE." + (let* ((number (profile-number profile)) + (previous-number (previous-profile-number profile number)) + (previous-profile (format #f "~a-~a-link" + profile previous-number)) + (manifest (string-append previous-profile "/manifest"))) + + (define (switch-link) + ;; Atomically switch PROFILE to the previous profile. + (format #t (_ "switching from generation ~a to ~a~%") + number previous-number) + (switch-symlinks profile previous-profile)) + + (cond ((not (file-exists? profile)) ; invalid profile + (format (current-error-port) + (_ "error: profile `~a' does not exist~%") + profile)) + ((zero? number) ; empty profile + (format (current-error-port) + (_ "nothing to do: already at the empty profile~%"))) + ((or (zero? previous-number) ; going to emptiness + (not (file-exists? previous-profile))) + (let*-values (((drv-path drv) + (profile-derivation (%store) '())) + ((prof) + (derivation-output-path + (assoc-ref (derivation-outputs drv) "out")))) + (when (not (build-derivations (%store) (list drv-path))) + (leave (_ "failed to build the empty profile~%"))) + + (switch-symlinks previous-profile prof) + (switch-link))) + (else (switch-link))))) ; anything else + +(define (find-packages-by-description rx) + "Search in SYNOPSIS and DESCRIPTION using RX. Return a list of +matching packages." + (define (same-location? p1 p2) + ;; Compare locations of two packages. + (equal? (package-location p1) (package-location p2))) + + (delete-duplicates + (sort + (fold-packages (lambda (package result) + (define matches? + (cut regexp-exec rx <>)) + + (if (or (and=> (package-synopsis package) + (compose matches? gettext)) + (and=> (package-description package) + (compose matches? gettext))) + (cons package result) + result)) + '()) + (lambda (p1 p2) + (stringname+path input) + "Convert the name/package/sub-drv tuple INPUT to a name/store-path tuple." + (let loop ((input input)) + (match input + ((name package) + (loop `(,name ,package "out"))) + ((name package sub-drv) + (let*-values (((_ drv) + (package-derivation (%store) package)) + ((out) + (derivation-output-path + (assoc-ref (derivation-outputs drv) sub-drv)))) + `(,name ,out)))))) + + +;;; +;;; Command-line options. +;;; + +(define %default-options + ;; Alist of default option values. + `((profile . ,%current-profile))) + +(define (show-help) + (display (_ "Usage: guix package [OPTION]... PACKAGES... +Install, remove, or upgrade PACKAGES in a single transaction.\n")) + (display (_ " + -i, --install=PACKAGE install PACKAGE")) + (display (_ " + -r, --remove=PACKAGE remove PACKAGE")) + (display (_ " + -u, --upgrade=REGEXP upgrade all the installed packages matching REGEXP")) + (display (_ " + --roll-back roll back to the previous generation")) + (newline) + (display (_ " + -p, --profile=PROFILE use PROFILE instead of the user's default profile")) + (display (_ " + -n, --dry-run show what would be done without actually doing it")) + (display (_ " + --bootstrap use the bootstrap Guile to build the profile")) + (display (_ " + --verbose produce verbose output")) + (newline) + (display (_ " + -s, --search=REGEXP search in synopsis and description using REGEXP")) + (display (_ " + -I, --list-installed[=REGEXP] + list installed packages matching REGEXP")) + (display (_ " + -A, --list-available[=REGEXP] + list available packages matching REGEXP")) + (newline) + (display (_ " + -h, --help display this help and exit")) + (display (_ " + -V, --version display version information and exit")) + (newline) + (show-bug-report-information)) + +(define %options + ;; Specification of the command-line options. + (list (option '(#\h "help") #f #f + (lambda args + (show-help) + (exit 0))) + (option '(#\V "version") #f #f + (lambda args + (show-version-and-exit "guix-package"))) + + (option '(#\i "install") #t #f + (lambda (opt name arg result) + (alist-cons 'install arg result))) + (option '(#\r "remove") #t #f + (lambda (opt name arg result) + (alist-cons 'remove arg result))) + (option '(#\u "upgrade") #t #f + (lambda (opt name arg result) + (alist-cons 'upgrade arg result))) + (option '("roll-back") #f #f + (lambda (opt name arg result) + (alist-cons 'roll-back? #t result))) + (option '(#\p "profile") #t #f + (lambda (opt name arg result) + (alist-cons 'profile arg + (alist-delete 'profile result)))) + (option '(#\n "dry-run") #f #f + (lambda (opt name arg result) + (alist-cons 'dry-run? #t result))) + (option '("bootstrap") #f #f + (lambda (opt name arg result) + (alist-cons 'bootstrap? #t result))) + (option '("verbose") #f #f + (lambda (opt name arg result) + (alist-cons 'verbose? #t result))) + (option '(#\s "search") #t #f + (lambda (opt name arg result) + (cons `(query search ,(or arg "")) + result))) + (option '(#\I "list-installed") #f #t + (lambda (opt name arg result) + (cons `(query list-installed ,(or arg "")) + result))) + (option '(#\A "list-available") #f #t + (lambda (opt name arg result) + (cons `(query list-available ,(or arg "")) + result))))) + + +;;; +;;; Entry point. +;;; + +(define (guix-package . args) + (define (parse-options) + ;; Return the alist of option values. + (args-fold args %options + (lambda (opt name arg result) + (leave (_ "~A: unrecognized option~%") name)) + (lambda (arg result) + (leave (_ "~A: extraneous argument~%") arg)) + %default-options)) + + (define (guile-missing?) + ;; Return #t if %GUILE-FOR-BUILD is not available yet. + (let ((out (derivation-path->output-path (%guile-for-build)))) + (not (valid-path? (%store) out)))) + + (define (show-what-to-build drv dry-run?) + ;; Show what will/would be built in realizing the derivations listed + ;; in DRV. + (let* ((req (append-map (lambda (drv-path) + (let ((d (call-with-input-file drv-path + read-derivation))) + (derivation-prerequisites-to-build + (%store) d))) + drv)) + (req* (delete-duplicates + (append (remove (compose (cute valid-path? (%store) <>) + derivation-path->output-path) + drv) + (map derivation-input-path req))))) + (if dry-run? + (format (current-error-port) + (N_ "~:[the following derivation would be built:~%~{ ~a~%~}~;~]" + "~:[the following derivations would be built:~%~{ ~a~%~}~;~]" + (length req*)) + (null? req*) req*) + (format (current-error-port) + (N_ "~:[the following derivation will be built:~%~{ ~a~%~}~;~]" + "~:[the following derivations will be built:~%~{ ~a~%~}~;~]" + (length req*)) + (null? req*) req*)))) + + (define newest-available-packages + (memoize find-newest-available-packages)) + + (define (find-best-packages-by-name name version) + (if version + (find-packages-by-name name version) + (match (vhash-assoc name (newest-available-packages)) + ((_ version pkgs ...) pkgs) + (#f '())))) + + (define (find-package name) + ;; Find the package NAME; NAME may contain a version number and a + ;; sub-derivation name. If the version number is not present, + ;; return the preferred newest version. + (define request name) + + (define (ensure-output p sub-drv) + (if (member sub-drv (package-outputs p)) + p + (leave (_ "~a: error: package `~a' lacks output `~a'~%") + (location->string (package-location p)) + (package-full-name p) + sub-drv))) + + (let*-values (((name sub-drv) + (match (string-rindex name #\:) + (#f (values name "out")) + (colon (values (substring name 0 colon) + (substring name (+ 1 colon)))))) + ((name version) + (package-name->name+version name))) + (match (find-best-packages-by-name name version) + ((p) + (list name (package-version p) sub-drv (ensure-output p sub-drv) + (package-transitive-propagated-inputs p))) + ((p p* ...) + (format (current-error-port) + (_ "warning: ambiguous package specification `~a'~%") + request) + (format (current-error-port) + (_ "warning: choosing ~a from ~a~%") + (package-full-name p) + (location->string (package-location p))) + (list name (package-version p) sub-drv (ensure-output p sub-drv) + (package-transitive-propagated-inputs p))) + (() + (leave (_ "~a: package not found~%") request))))) + + (define (upgradeable? name current-version current-path) + ;; 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)) + ((_ candidate-version pkg . rest) + (case (version-compare candidate-version current-version) + ((>) #t) + ((<) #f) + ((=) (let ((candidate-path (derivation-path->output-path + (package-derivation (%store) pkg)))) + (not (string=? current-path candidate-path)))))) + (#f #f))) + + (define (ensure-default-profile) + ;; Ensure the default profile symlink and directory exist. + + ;; Create ~/.guix-profile if it doesn't exist yet. + (when (and %user-environment-directory + %current-profile + (not (false-if-exception + (lstat %user-environment-directory)))) + (symlink %current-profile %user-environment-directory)) + + ;; Attempt to create /…/profiles/per-user/$USER if needed. + (unless (directory-exists? %profile-directory) + (catch 'system-error + (lambda () + (mkdir-p %profile-directory)) + (lambda args + ;; Often, we cannot create %PROFILE-DIRECTORY because its + ;; parent directory is root-owned and we're running + ;; unprivileged. + (format (current-error-port) + (_ "error: while creating directory `~a': ~a~%") + %profile-directory + (strerror (system-error-errno args))) + (format (current-error-port) + (_ "Please create the `~a' directory, with you as the owner.~%") + %profile-directory) + (exit 1))))) + + (define (process-actions opts) + ;; Process any install/remove/upgrade action from OPTS. + + (define dry-run? (assoc-ref opts 'dry-run?)) + (define verbose? (assoc-ref opts 'verbose?)) + (define profile (assoc-ref opts 'profile)) + + (define (canonicalize-deps deps) + ;; Remove duplicate entries from DEPS, a list of propagated inputs, + ;; where each input is a name/path tuple. + (define (same? d1 d2) + (match d1 + ((_ path1) + (match d2 + ((_ path2) + (string=? path1 path2)))))) + + (delete-duplicates (map input->name+path deps) same?)) + + ;; First roll back if asked to. + (if (and (assoc-ref opts 'roll-back?) (not dry-run?)) + (begin + (roll-back profile) + (process-actions (alist-delete 'roll-back? opts))) + (let* ((installed (manifest-packages (profile-manifest profile))) + (upgrade-regexps (filter-map (match-lambda + (('upgrade . regexp) + (make-regexp regexp)) + (_ #f)) + opts)) + (upgrade (if (null? upgrade-regexps) + '() + (let ((newest (find-newest-available-packages))) + (filter-map (match-lambda + ((name version output path _) + (and (any (cut regexp-exec <> name) + upgrade-regexps) + (upgradeable? name version path) + (find-package name))) + (_ #f)) + installed)))) + (install (append + upgrade + (filter-map (match-lambda + (('install . (? store-path?)) + #f) + (('install . package) + (find-package package)) + (_ #f)) + opts))) + (drv (filter-map (match-lambda + ((name version sub-drv + (? package? package) + (deps ...)) + (package-derivation (%store) package)) + (_ #f)) + install)) + (install* (append + (filter-map (match-lambda + (('install . (? store-path? path)) + (let-values (((name version) + (package-name->name+version + (store-path-package-name + path)))) + `(,name ,version #f ,path ()))) + (_ #f)) + opts) + (map (lambda (tuple drv) + (match tuple + ((name version sub-drv _ (deps ...)) + (let ((output-path + (derivation-path->output-path + drv sub-drv))) + `(,name ,version ,sub-drv ,output-path + ,(canonicalize-deps deps)))))) + install drv))) + (remove (filter-map (match-lambda + (('remove . package) + package) + (_ #f)) + opts)) + (packages (append install* + (fold (lambda (package result) + (match package + ((name _ ...) + (alist-delete name result)))) + (fold alist-delete installed remove) + install*)))) + + (when (equal? profile %current-profile) + (ensure-default-profile)) + + (show-what-to-build drv dry-run?) + + (or dry-run? + (and (build-derivations (%store) drv) + (let* ((prof-drv (profile-derivation (%store) packages)) + (prof (derivation-path->output-path prof-drv)) + (old-drv (profile-derivation + (%store) (manifest-packages + (profile-manifest profile)))) + (old-prof (derivation-path->output-path old-drv)) + (number (profile-number profile)) + + ;; Always use NUMBER + 1 for the new profile, + ;; possibly overwriting a "previous future + ;; generation". + (name (format #f "~a-~a-link" + profile (+ 1 number)))) + (if (string=? old-prof prof) + (when (or (pair? install) (pair? remove)) + (format (current-error-port) + (_ "nothing to be done~%"))) + (and (parameterize ((current-build-output-port + ;; Output something when Guile + ;; needs to be built. + (if (or verbose? (guile-missing?)) + (current-error-port) + (%make-void-port "w")))) + (build-derivations (%store) (list prof-drv))) + (begin + (switch-symlinks name prof) + (switch-symlinks profile name)))))))))) + + (define (process-query opts) + ;; Process any query specified by OPTS. Return #t when a query was + ;; actually processed, #f otherwise. + (let ((profile (assoc-ref opts 'profile))) + (match (assoc-ref opts 'query) + (('list-installed regexp) + (let* ((regexp (and regexp (make-regexp regexp))) + (manifest (profile-manifest profile)) + (installed (manifest-packages manifest))) + (for-each (match-lambda + ((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)))) + installed) + #t)) + + (('list-available regexp) + (let* ((regexp (and regexp (make-regexp regexp))) + (available (fold-packages + (lambda (p r) + (let ((n (package-name p))) + (if regexp + (if (regexp-exec regexp n) + (cons p r) + 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) + (stringrecutils <> (current-output-port)) + (find-packages-by-description regexp)) + #t)) + (_ #f)))) + + (install-locale) + (textdomain "guix") + (setvbuf (current-output-port) _IOLBF) + (setvbuf (current-error-port) _IOLBF) + + (let ((opts (parse-options))) + (or (process-query opts) + (parameterize ((%store (open-connection))) + (with-error-handling + (parameterize ((%guile-for-build + (package-derivation (%store) + (if (assoc-ref opts 'bootstrap?) + %bootstrap-guile + guile-final)))) + (process-actions opts))))))) -- cgit v1.2.3 From c07512179ef50cc50067844ec7ab15a228c70ac9 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 17 Feb 2013 15:38:02 +0100 Subject: scripts: Remove initialization now redundant with `initialize-guix'. * guix/scripts/build.scm (guix-build): Remove calls to `install-locale', `textdomain', etc., now redundant with `initialize-guix'. * guix/scripts/download.scm (guix-download): Likewise. * guix/scripts/import.scm (guix-import): Likewise. * guix/scripts/package.scm (guix-package): Likewise. * guix/ui.scm: Remove export of `install-locale' and `initialize-guix'. (initialize-guix): Add docstring. --- guix/scripts/build.scm | 5 ----- guix/scripts/download.scm | 5 ----- guix/scripts/import.scm | 5 ----- guix/scripts/package.scm | 5 ----- guix/ui.scm | 3 +-- 5 files changed, 1 insertion(+), 22 deletions(-) (limited to 'guix/scripts/package.scm') diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm index bad04418f1..3e241ca9da 100644 --- a/guix/scripts/build.scm +++ b/guix/scripts/build.scm @@ -221,11 +221,6 @@ Build the given PACKAGE-OR-DERIVATION and return their output paths.\n")) name version) (leave (_ "~A: unknown package~%") name)))))) - (install-locale) - (textdomain "guix") - (setvbuf (current-output-port) _IOLBF) - (setvbuf (current-error-port) _IOLBF) - (with-error-handling (let ((opts (parse-options))) (parameterize ((%store (open-connection))) diff --git a/guix/scripts/download.scm b/guix/scripts/download.scm index 1098e6714b..790cf9fc2f 100644 --- a/guix/scripts/download.scm +++ b/guix/scripts/download.scm @@ -121,11 +121,6 @@ and the hash of its contents.\n")) (alist-cons 'argument arg result)) %default-options)) - (install-locale) - (textdomain "guix") - (setvbuf (current-output-port) _IOLBF) - (setvbuf (current-error-port) _IOLBF) - (let* ((opts (parse-options)) (store (open-connection)) (arg (assq-ref opts 'argument)) diff --git a/guix/scripts/import.scm b/guix/scripts/import.scm index 0bc6926c66..f0aaa80aa0 100644 --- a/guix/scripts/import.scm +++ b/guix/scripts/import.scm @@ -102,11 +102,6 @@ Import and convert the Nix expression ATTRIBUTE of NIXPKGS.\n")) (alist-cons 'argument arg result)) %default-options)) - (install-locale) - (textdomain "guix") - (setvbuf (current-output-port) _IOLBF) - (setvbuf (current-error-port) _IOLBF) - (let* ((opts (parse-options)) (args (filter-map (match-lambda (('argument . value) diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index 4935837d33..559be50824 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -676,11 +676,6 @@ Install, remove, or upgrade PACKAGES in a single transaction.\n")) #t)) (_ #f)))) - (install-locale) - (textdomain "guix") - (setvbuf (current-output-port) _IOLBF) - (setvbuf (current-error-port) _IOLBF) - (let ((opts (parse-options))) (or (process-query opts) (parameterize ((%store (open-connection))) diff --git a/guix/ui.scm b/guix/ui.scm index 644a3070f6..af8b238ce1 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -30,8 +30,6 @@ #:use-module (ice-9 match) #:export (_ N_ - install-locale - initialize-guix leave show-version-and-exit show-bug-report-information @@ -67,6 +65,7 @@ (strerror (system-error-errno args)))))) (define (initialize-guix) + "Perform the usual initialization for stand-alone Guix commands." (install-locale) (textdomain "guix") (setvbuf (current-output-port) _IOLBF) -- cgit v1.2.3 From dc3f1809cf4637fcf30d9c1789fa0eb96aefd0f5 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 17 Feb 2013 16:25:30 +0100 Subject: scripts: Remove hyphen in the command name shown by `--version'. * guix/scripts/build.scm (%options): Remove hyphen from the name passed to `show-version-and-exit'. * guix/scripts/download.scm (%options): Likewise. * guix/scripts/gc.scm (%options): Likewise. * guix/scripts/import.scm (%options): Likewise. * guix/scripts/package.scm (%options): Likewise. --- guix/scripts/build.scm | 2 +- guix/scripts/download.scm | 2 +- guix/scripts/gc.scm | 2 +- guix/scripts/import.scm | 2 +- guix/scripts/package.scm | 2 +- 5 files changed, 5 insertions(+), 5 deletions(-) (limited to 'guix/scripts/package.scm') diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm index 3e241ca9da..7863fb881b 100644 --- a/guix/scripts/build.scm +++ b/guix/scripts/build.scm @@ -105,7 +105,7 @@ Build the given PACKAGE-OR-DERIVATION and return their output paths.\n")) (exit 0))) (option '(#\V "version") #f #f (lambda args - (show-version-and-exit "guix-build"))) + (show-version-and-exit "guix build"))) (option '(#\S "source") #f #f (lambda (opt name arg result) diff --git a/guix/scripts/download.scm b/guix/scripts/download.scm index 790cf9fc2f..10370e59af 100644 --- a/guix/scripts/download.scm +++ b/guix/scripts/download.scm @@ -104,7 +104,7 @@ and the hash of its contents.\n")) (exit 0))) (option '(#\V "version") #f #f (lambda args - (show-version-and-exit "guix-download"))))) + (show-version-and-exit "guix download"))))) ;;; diff --git a/guix/scripts/gc.scm b/guix/scripts/gc.scm index 8e2587186e..f2d2e17d4b 100644 --- a/guix/scripts/gc.scm +++ b/guix/scripts/gc.scm @@ -97,7 +97,7 @@ interpreted." (exit 0))) (option '(#\V "version") #f #f (lambda args - (show-version-and-exit "guix-gc"))) + (show-version-and-exit "guix gc"))) (option '(#\C "collect-garbage") #f #t (lambda (opt name arg result) diff --git a/guix/scripts/import.scm b/guix/scripts/import.scm index f0aaa80aa0..0b95afced1 100644 --- a/guix/scripts/import.scm +++ b/guix/scripts/import.scm @@ -85,7 +85,7 @@ Import and convert the Nix expression ATTRIBUTE of NIXPKGS.\n")) (exit 0))) (option '(#\V "version") #f #f (lambda args - (show-version-and-exit "guix-import"))))) + (show-version-and-exit "guix import"))))) ;;; diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index 559be50824..23786fb7d8 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -327,7 +327,7 @@ Install, remove, or upgrade PACKAGES in a single transaction.\n")) (exit 0))) (option '(#\V "version") #f #f (lambda args - (show-version-and-exit "guix-package"))) + (show-version-and-exit "guix package"))) (option '(#\i "install") #t #f (lambda (opt name arg result) -- cgit v1.2.3 From bdeee95a214eedfde979958f62cee466c28e638f Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 20 Feb 2013 23:03:24 +0100 Subject: ui: Add temporary file handling and atomic symlink switch. * guix/scripts/download.scm (call-with-temporary-output-file): Move to ui.scm. * guix/scripts/package.scm (switch-symlinks): Likewise. * guix/ui.scm (call-with-temporary-output-file, switch-symlinks): New procedures. --- guix/scripts/download.scm | 11 ----------- guix/scripts/package.scm | 7 ------- guix/ui.scm | 24 ++++++++++++++++++++++++ 3 files changed, 24 insertions(+), 18 deletions(-) (limited to 'guix/scripts/package.scm') diff --git a/guix/scripts/download.scm b/guix/scripts/download.scm index 10370e59af..3dc227fdcd 100644 --- a/guix/scripts/download.scm +++ b/guix/scripts/download.scm @@ -33,17 +33,6 @@ #:use-module (rnrs io ports) #:export (guix-download)) -(define (call-with-temporary-output-file proc) - (let* ((template (string-copy "guix-download.XXXXXX")) - (out (mkstemp! template))) - (dynamic-wind - (lambda () - #t) - (lambda () - (proc template out)) - (lambda () - (false-if-exception (delete-file template)))))) - (define (fetch-and-store store fetch name) "Call FETCH for URI, and pass it the name of a file to write to; eventually, copy data from that port to STORE, under NAME. Return the resulting diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index 23786fb7d8..38e8ae1150 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -192,13 +192,6 @@ all of PACKAGES, a list of name/version/output/path/deps tuples." (compose string->number (cut match:substring <> 1))) 0)) -(define (switch-symlinks link target) - "Atomically switch LINK, a symbolic link, to point to TARGET. Works -both when LINK already exists and when it does not." - (let ((pivot (string-append link ".new"))) - (symlink target pivot) - (rename-file pivot link))) - (define (roll-back profile) "Roll back to the previous generation of PROFILE." (let* ((number (profile-number profile)) diff --git a/guix/ui.scm b/guix/ui.scm index af8b238ce1..9c27dd8b3a 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -36,6 +36,8 @@ call-with-error-handling with-error-handling location->string + call-with-temporary-output-file + switch-symlinks fill-paragraph string->recutils package->recutils @@ -125,6 +127,28 @@ General help using GNU software: ")) (($ file line column) (format #f "~a:~a:~a" file line column)))) +(define (call-with-temporary-output-file proc) + "Call PROC with a name of a temporary file and open output port to that +file; close the file and delete it when leaving the dynamic extent of this +call." + (let* ((template (string-copy "guix-file.XXXXXX")) + (out (mkstemp! template))) + (dynamic-wind + (lambda () + #t) + (lambda () + (proc template out)) + (lambda () + (false-if-exception (close out)) + (false-if-exception (delete-file template)))))) + +(define (switch-symlinks link target) + "Atomically switch LINK, a symbolic link, to point to TARGET. Works +both when LINK already exists and when it does not." + (let ((pivot (string-append link ".new"))) + (symlink target pivot) + (rename-file pivot link))) + (define* (fill-paragraph str width #:optional (column 0)) "Fill STR such that each line contains at most WIDTH characters, assuming that the first character is at COLUMN. -- cgit v1.2.3 From 7650e148f69832e6b89b93c549278b1bbf89946a Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 20 Feb 2013 23:41:24 +0100 Subject: ui: Factorize `show-what-to-build'. * guix/scripts/package.scm (guix-package)[show-what-to-build]: Move to.. * guix/ui.scm (show-what-to-build): ... here. Add a `store' parameter'. Adjust callers. * guix/scripts/build.scm (guix-build): Use it. Remove `req' and `req*' variables. --- guix/scripts/build.scm | 23 ++--------------------- guix/scripts/package.scm | 28 +--------------------------- guix/ui.scm | 29 +++++++++++++++++++++++++++++ 3 files changed, 32 insertions(+), 48 deletions(-) (limited to 'guix/scripts/package.scm') diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm index 7863fb881b..fbd22a9e29 100644 --- a/guix/scripts/build.scm +++ b/guix/scripts/build.scm @@ -241,31 +241,12 @@ Build the given PACKAGE-OR-DERIVATION and return their output paths.\n")) (package-derivation (%store) p sys)))) (_ #f)) opts)) - (req (append-map (lambda (drv-path) - (let ((d (call-with-input-file drv-path - read-derivation))) - (derivation-prerequisites-to-build (%store) d))) - drv)) - (req* (delete-duplicates - (append (remove (compose (cut valid-path? (%store) <>) - derivation-path->output-path) - drv) - (map derivation-input-path req)))) (roots (filter-map (match-lambda (('gc-root . root) root) (_ #f)) opts))) - (if (assoc-ref opts 'dry-run?) - (format (current-error-port) - (N_ "~:[the following derivation would be built:~%~{ ~a~%~}~;~]" - "~:[the following derivations would be built:~%~{ ~a~%~}~;~]" - (length req*)) - (null? req*) req*) - (format (current-error-port) - (N_ "~:[the following derivation will be built:~%~{ ~a~%~}~;~]" - "~:[the following derivations will be built:~%~{ ~a~%~}~;~]" - (length req*)) - (null? req*) req*)) + + (show-what-to-build (%store) drv (assoc-ref opts 'dry-run?)) ;; TODO: Add more options. (set-build-options (%store) diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index 38e8ae1150..1f9355ff22 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -380,32 +380,6 @@ Install, remove, or upgrade PACKAGES in a single transaction.\n")) (let ((out (derivation-path->output-path (%guile-for-build)))) (not (valid-path? (%store) out)))) - (define (show-what-to-build drv dry-run?) - ;; Show what will/would be built in realizing the derivations listed - ;; in DRV. - (let* ((req (append-map (lambda (drv-path) - (let ((d (call-with-input-file drv-path - read-derivation))) - (derivation-prerequisites-to-build - (%store) d))) - drv)) - (req* (delete-duplicates - (append (remove (compose (cute valid-path? (%store) <>) - derivation-path->output-path) - drv) - (map derivation-input-path req))))) - (if dry-run? - (format (current-error-port) - (N_ "~:[the following derivation would be built:~%~{ ~a~%~}~;~]" - "~:[the following derivations would be built:~%~{ ~a~%~}~;~]" - (length req*)) - (null? req*) req*) - (format (current-error-port) - (N_ "~:[the following derivation will be built:~%~{ ~a~%~}~;~]" - "~:[the following derivations will be built:~%~{ ~a~%~}~;~]" - (length req*)) - (null? req*) req*)))) - (define newest-available-packages (memoize find-newest-available-packages)) @@ -589,7 +563,7 @@ Install, remove, or upgrade PACKAGES in a single transaction.\n")) (when (equal? profile %current-profile) (ensure-default-profile)) - (show-what-to-build drv dry-run?) + (show-what-to-build (%store) drv dry-run?) (or dry-run? (and (build-derivations (%store) drv) diff --git a/guix/ui.scm b/guix/ui.scm index 9c27dd8b3a..2b75504573 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -22,17 +22,20 @@ #:use-module (guix store) #:use-module (guix config) #:use-module (guix packages) + #:use-module (guix derivations) #:use-module ((guix licenses) #:select (license? license-name)) #:use-module (srfi srfi-1) #:use-module (srfi srfi-11) #:use-module (srfi srfi-26) #:use-module (srfi srfi-34) #:use-module (ice-9 match) + #:use-module (ice-9 format) #:export (_ N_ leave show-version-and-exit show-bug-report-information + show-what-to-build call-with-error-handling with-error-handling location->string @@ -112,6 +115,32 @@ General help using GNU software: ")) (nix-protocol-error-message c)))) (thunk))) +(define* (show-what-to-build store drv #:optional dry-run?) + "Show what will or would (depending on DRY-RUN?) be built in realizing the +derivations listed in DRV." + (let* ((req (append-map (lambda (drv-path) + (let ((d (call-with-input-file drv-path + read-derivation))) + (derivation-prerequisites-to-build + store d))) + drv)) + (req* (delete-duplicates + (append (remove (compose (cute valid-path? store <>) + derivation-path->output-path) + drv) + (map derivation-input-path req))))) + (if dry-run? + (format (current-error-port) + (N_ "~:[the following derivation would be built:~%~{ ~a~%~}~;~]" + "~:[the following derivations would be built:~%~{ ~a~%~}~;~]" + (length req*)) + (null? req*) req*) + (format (current-error-port) + (N_ "~:[the following derivation will be built:~%~{ ~a~%~}~;~]" + "~:[the following derivations will be built:~%~{ ~a~%~}~;~]" + (length req*)) + (null? req*) req*)))) + (define-syntax with-error-handling (syntax-rules () "Run BODY within a user-friendly error condition handler." -- cgit v1.2.3 From 6f80c9d8f387f5b881a73cefdbbba91a40d8eec6 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 11 Apr 2013 22:30:06 +0200 Subject: ui: Add a `warning' macro. * guix/ui.scm (program-name, guix-warning-port): New variables. (warning): New macro. (guix-main): Parametrize PROGRAM-NAME. * guix/scripts/build.scm, guix/scripts/download.scm, guix/scripts/gc.scm, guix/scripts/package.scm: Adjust to use `leave' and `warning' consistently. --- guix/scripts/build.scm | 16 ++++++---------- guix/scripts/download.scm | 3 +-- guix/scripts/gc.scm | 15 ++++----------- guix/scripts/package.scm | 20 ++++++++----------- guix/ui.scm | 49 +++++++++++++++++++++++++++++++++++++++++++---- 5 files changed, 64 insertions(+), 39 deletions(-) (limited to 'guix/scripts/package.scm') diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm index a49bfdbeb8..339ad0d06f 100644 --- a/guix/scripts/build.scm +++ b/guix/scripts/build.scm @@ -176,9 +176,8 @@ Build the given PACKAGE-OR-DERIVATION and return their output paths.\n")) 0 paths)))) (lambda args - (format (current-error-port) - (_ "failed to create GC root `~a': ~a~%") - root (strerror (system-error-errno args))) + (leave (_ "failed to create GC root `~a': ~a~%") + root (strerror (system-error-errno args))) (exit 1))))) (define newest-available-packages @@ -202,13 +201,10 @@ Build the given PACKAGE-OR-DERIVATION and return their output paths.\n")) ((p) ; one match p) ((p x ...) ; several matches - (format (current-error-port) - (_ "warning: ambiguous package specification `~a'~%") - request) - (format (current-error-port) - (_ "warning: choosing ~a from ~a~%") - (package-full-name p) - (location->string (package-location p))) + (warning (_ "ambiguous package specification `~a'~%") request) + (warning (_ "choosing ~a from ~a~%") + (package-full-name p) + (location->string (package-location p))) p) (_ ; no matches (if version diff --git a/guix/scripts/download.scm b/guix/scripts/download.scm index 3f989a3494..7c00312c74 100644 --- a/guix/scripts/download.scm +++ b/guix/scripts/download.scm @@ -81,8 +81,7 @@ and the hash of its contents.\n")) ((or "base16" "hex" "hexadecimal") bytevector->base16-string) (x - (format (current-error-port) - "unsupported hash format: ~a~%" arg)))) + (leave (_ "unsupported hash format: ~a~%") arg)))) (alist-cons 'format fmt-proc (alist-delete 'format result)))) diff --git a/guix/scripts/gc.scm b/guix/scripts/gc.scm index 12d80fd171..3d918923f8 100644 --- a/guix/scripts/gc.scm +++ b/guix/scripts/gc.scm @@ -87,13 +87,9 @@ interpreted." ("TB" (expt 10 12)) ("" 1) (_ - (format (current-error-port) (_ "error: unknown unit: ~a~%") - unit) + (leave (_ "error: unknown unit: ~a~%") unit) (exit 1)))) - (begin - (format (current-error-port) - (_ "error: invalid number: ~a") numstr) - (exit 1))))) + (leave (_ "error: invalid number: ~a") numstr)))) (define %options ;; Specification of the command-line options. @@ -114,11 +110,8 @@ interpreted." (let ((amount (size->number arg))) (if arg (alist-cons 'min-freed amount result) - (begin - (format (current-error-port) - (_ "error: invalid amount of storage: ~a~%") - arg) - (exit 1))))) + (leave (_ "error: invalid amount of storage: ~a~%") + arg)))) (#f result))))) (option '(#\d "delete") #f #f (lambda (opt name arg result) diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index 6de2f1beb6..89708ccc49 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -208,12 +208,10 @@ all of PACKAGES, a list of name/version/output/path/deps tuples." (switch-symlinks profile previous-profile)) (cond ((not (file-exists? profile)) ; invalid profile - (format (current-error-port) - (_ "error: profile `~a' does not exist~%") - profile)) + (leave (_ "error: profile `~a' does not exist~%") + profile)) ((zero? number) ; empty profile - (format (current-error-port) - (_ "nothing to do: already at the empty profile~%"))) + (leave (_ "nothing to do: already at the empty profile~%"))) ((or (zero? previous-number) ; going to emptiness (not (file-exists? previous-profile))) (let*-values (((drv-path drv) @@ -465,13 +463,11 @@ Install, remove, or upgrade PACKAGES in a single transaction.\n")) (list name (package-version p) sub-drv (ensure-output p sub-drv) (package-transitive-propagated-inputs p))) ((p p* ...) - (format (current-error-port) - (_ "warning: ambiguous package specification `~a'~%") - request) - (format (current-error-port) - (_ "warning: choosing ~a from ~a~%") - (package-full-name p) - (location->string (package-location p))) + (warning (_ "ambiguous package specification `~a'~%") + request) + (warning (_ "choosing ~a from ~a~%") + (package-full-name p) + (location->string (package-location p))) (list name (package-version p) sub-drv (ensure-output p sub-drv) (package-transitive-propagated-inputs p))) (() diff --git a/guix/ui.scm b/guix/ui.scm index 94f0825a0a..dfb6418a10 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -47,6 +47,9 @@ string->recutils package->recutils run-guix-command + program-name + guix-warning-port + warning guix-main)) ;;; Commentary: @@ -332,6 +335,43 @@ WIDTH columns." (symbol-append 'guix- command)))) (apply command-main args))) +(define program-name + ;; Name of the command-line program currently executing, or #f. + (make-parameter #f)) + +(define guix-warning-port + (make-parameter (current-warning-port))) + +(define-syntax warning + (lambda (s) + "Emit a warming. The macro assumes that `_' is bound to `gettext'." + ;; All this just to preserve `-Wformat' warnings. Too much? + + (define (augmented-format-string fmt) + (string-append "~:[~;guix ~a: ~]~a" (syntax->datum fmt))) + + (define prefix + #'(_ "warning: ")) + + (syntax-case s (N_ _) ; these are literals, yeah... + ((warning (_ fmt) args ...) + (string? (syntax->datum #'fmt)) + (with-syntax ((fmt* (augmented-format-string #'fmt)) + (prefix prefix)) + #'(format (guix-warning-port) (gettext fmt*) + (program-name) (program-name) prefix + args ...))) + ((warning (N_ singular plural n) args ...) + (and (string? (syntax->datum #'singular)) + (string? (syntax->datum #'plural))) + (with-syntax ((s (augmented-format-string #'singular)) + (p (augmented-format-string #'plural)) + (b prefix)) + #'(format (guix-warning-port) + (ngettext s p n %gettext-domain) + (program-name) (program-name) b + args ...)))))) + (define (guix-main arg0 . args) (initialize-guix) (let () @@ -340,10 +380,11 @@ WIDTH columns." (() (show-guix-usage) (exit 1)) (("--help") (show-guix-usage)) (("--version") (show-version-and-exit "guix")) - (((? option? arg1) args ...) (show-guix-usage) (exit 1)) + (((? option?) args ...) (show-guix-usage) (exit 1)) ((command args ...) - (apply run-guix-command - (string->symbol command) - args))))) + (parameterize ((program-name command)) + (apply run-guix-command + (string->symbol command) + args)))))) ;;; ui.scm ends here -- cgit v1.2.3 From 581f9eb84532b5682f48926e868456e2457fe54c Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 12 Apr 2013 15:43:55 +0200 Subject: guix package: Add `--no-substitutes'. * guix/scripts/package.scm (%default-options): Add `substitutes?'. (show-help, %options): Add and document `--no-substitutes'. (guix-package): Call `set-build-options' to honor `substitutes?'. --- doc/guix.texi | 3 +++ guix/scripts/package.scm | 13 ++++++++++++- 2 files changed, 15 insertions(+), 1 deletion(-) (limited to 'guix/scripts/package.scm') diff --git a/doc/guix.texi b/doc/guix.texi index 1be172c3f6..c91bc2021d 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -570,6 +570,9 @@ Use @var{profile} instead of the user's default profile. @itemx -n Show what would be done without actually doing it. +@item --no-substitutes +Build instead of resorting to pre-built substitutes. + @item --verbose Produce verbose output. In particular, emit the environment's build log on the standard error port. diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index 89708ccc49..ba75cd778c 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -313,7 +313,8 @@ but ~a is available upstream~%") (define %default-options ;; Alist of default option values. - `((profile . ,%current-profile))) + `((profile . ,%current-profile) + (substitutes? . #t))) (define (show-help) (display (_ "Usage: guix package [OPTION]... PACKAGES... @@ -334,6 +335,8 @@ Install, remove, or upgrade PACKAGES in a single transaction.\n")) -p, --profile=PROFILE use PROFILE instead of the user's default profile")) (display (_ " -n, --dry-run show what would be done without actually doing it")) + (display (_ " + --no-substitutes build instead of resorting to pre-built substitutes")) (display (_ " --bootstrap use the bootstrap Guile to build the profile")) (display (_ " @@ -388,6 +391,10 @@ Install, remove, or upgrade PACKAGES in a single transaction.\n")) (option '(#\n "dry-run") #f #f (lambda (opt name arg result) (alist-cons 'dry-run? #t result))) + (option '("no-substitutes") #f #f + (lambda (opt name arg result) + (alist-cons 'substitutes? #f + (alist-delete 'substitutes? result)))) (option '("bootstrap") #f #f (lambda (opt name arg result) (alist-cons 'bootstrap? #t result))) @@ -750,6 +757,10 @@ Install, remove, or upgrade PACKAGES in a single transaction.\n")) (or (process-query opts) (with-error-handling (parameterize ((%store (open-connection))) + (set-build-options (%store) + #:use-substitutes? + (assoc-ref opts 'substitutes?)) + (parameterize ((%guile-for-build (package-derivation (%store) (if (assoc-ref opts 'bootstrap?) -- cgit v1.2.3 From d5d6db8918fb8cd66132f5ad5d4c03d6ed2db815 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 12 Apr 2013 18:07:17 +0200 Subject: package: Being at the empty profile is not an error. * guix/scripts/package.scm (roll-back): Use `format', not `leave' when indicating "already at the empty profile". Fixes a regression introduced in a2011be5dfaf2b94a1d0e3dfbcf4b512389b4711. Reported by Nikita Karetnikov . --- guix/scripts/package.scm | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) (limited to 'guix/scripts/package.scm') diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index ba75cd778c..ac99d16497 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -211,7 +211,8 @@ all of PACKAGES, a list of name/version/output/path/deps tuples." (leave (_ "error: profile `~a' does not exist~%") profile)) ((zero? number) ; empty profile - (leave (_ "nothing to do: already at the empty profile~%"))) + (format (current-error-port) + (_ "nothing to do: already at the empty profile~%"))) ((or (zero? previous-number) ; going to emptiness (not (file-exists? previous-profile))) (let*-values (((drv-path drv) -- cgit v1.2.3 From 5924080dccae93fa725bf77df5f7a1e9a8756101 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 28 Apr 2013 23:05:57 +0200 Subject: guix package: Add `--search-paths' & co. * guix/scripts/package.scm (search-path-environment-variables, display-search-paths): New procedures. (show-help, %options): Add `--search-paths'. (guix-package)[process-actions]: Call `display-search-paths' once the profile is ready. [process-query]: Honor `search-paths'. --- doc/guix.texi | 22 +++++++++++++++- guix/scripts/package.scm | 66 +++++++++++++++++++++++++++++++++++++++++++++++- tests/guix-package.sh | 8 ++++++ 3 files changed, 94 insertions(+), 2 deletions(-) (limited to 'guix/scripts/package.scm') diff --git a/doc/guix.texi b/doc/guix.texi index e23eab0f81..d571de95a0 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -517,8 +517,13 @@ Thus, when installing MPC, the MPFR and GMP libraries also get installed in the profile; removing MPC also removes MPFR and GMP---unless they had also been explicitly installed independently. +Besides, packages sometime rely on the definition of environment +variables for their search paths (see explanation of +@code{--search-paths} below.) Any missing or possibly incorrect +environment variable definitions are reported here. + @c XXX: keep me up-to-date -Besides, when installing a GNU package, the tool reports the +Finally, when installing a GNU package, the tool reports the availability of a newer upstream version. In the future, it may provide the option of installing directly from the upstream version, even if that version is not yet in the distribution. @@ -566,6 +571,21 @@ Installing, removing, or upgrading packages from a generation that has been rolled back to overwrites previous future generations. Thus, the history of a profile's generations is always linear. +@item --search-paths +@cindex search paths +Report environment variable definitions, in Bash syntax, that may be +needed in order to use the set of installed packages. These environment +variables are used to specify @dfn{search paths} for files used by some +of the installed packages. + +For example, GCC needs the @code{CPATH} and @code{LIBRARY_PATH} +environment variables to be defined so it can look for headers and +libraries in the user's profile (@pxref{Environment Variables,,, gcc, +Using the GNU Compiler Collection (GCC)}). If GCC and, say, the C +library are installed in the profile, then @code{--search-paths} will +suggest setting these variables to @code{@var{profile}/include} and +@code{@var{profile}/lib}, respectively. + @item --profile=@var{profile} @itemx -p @var{profile} Use @var{profile} instead of the user's default profile. diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index c5656efc14..560b673618 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -330,6 +330,53 @@ but ~a is available upstream~%") ((getaddrinfo-error ftp-error) #f) (else (apply throw key args)))))) +(define* (search-path-environment-variables packages profile + #:optional (getenv getenv)) + "Return environment variable definitions that may be needed for the use of +PACKAGES in PROFILE. Use GETENV to determine the current settings and report +only settings not already effective." + + ;; The search path info is not stored in the manifest. Thus, we infer the + ;; search paths from same-named packages found in the distro. + + (define package-in-manifest->package + (match-lambda + ((name version _ ...) + (match (append (find-packages-by-name name version) + (find-packages-by-name name)) + ((p _ ...) p) + (_ #f))))) + + (define search-path-definition + (match-lambda + (($ variable directories separator) + (let ((values (or (and=> (getenv variable) + (cut string-tokenize* <> separator)) + '())) + (directories (filter file-exists? + (map (cut string-append profile + "/" <>) + directories)))) + (if (every (cut member <> values) directories) + #f + (format #f "export ~a=\"~a\"" + variable + (string-join directories separator))))))) + + (let* ((packages (filter-map package-in-manifest->package packages)) + (search-paths (delete-duplicates + (append-map package-native-search-paths + packages)))) + (filter-map search-path-definition search-paths))) + +(define (display-search-paths packages profile) + "Display the search path environment variables that may need to be set for +PACKAGES, in the context of PROFILE." + (let ((settings (search-path-environment-variables packages profile))) + (unless (null? settings) + (format #t (_ "The following environment variable definitions may be needed:~%")) + (format #t "~{ ~a~%~}" settings)))) + ;;; ;;; Command-line options. @@ -354,6 +401,8 @@ Install, remove, or upgrade PACKAGES in a single transaction.\n")) -u, --upgrade[=REGEXP] upgrade all the installed packages matching REGEXP")) (display (_ " --roll-back roll back to the previous generation")) + (display (_ " + --search-paths display needed environment variable definitions")) (newline) (display (_ " -p, --profile=PROFILE use PROFILE instead of the user's default profile")) @@ -408,6 +457,9 @@ Install, remove, or upgrade PACKAGES in a single transaction.\n")) (option '("roll-back") #f #f (lambda (opt name arg result) (alist-cons 'roll-back? #t result))) + (option '("search-paths") #f #f + (lambda (opt name arg result) + (cons `(query search-paths) result))) (option '(#\p "profile") #t #f (lambda (opt name arg result) (alist-cons 'profile arg @@ -728,7 +780,9 @@ Install, remove, or upgrade PACKAGES in a single transaction.\n")) (build-derivations (%store) (list prof-drv))) (begin (switch-symlinks name prof) - (switch-symlinks profile name)))))))))) + (switch-symlinks profile name) + (display-search-paths packages + profile)))))))))) (define (process-query opts) ;; Process any query specified by OPTS. Return #t when a query was @@ -776,6 +830,16 @@ Install, remove, or upgrade PACKAGES in a single transaction.\n")) (for-each (cute package->recutils <> (current-output-port)) (find-packages-by-description regexp)) #t)) + + (('search-paths) + (let* ((manifest (profile-manifest profile)) + (packages (manifest-packages manifest)) + (settings (search-path-environment-variables packages + profile + (const #f)))) + (format #t "~{~a~%~}" settings) + #t)) + (_ #f)))) (let ((opts (parse-options))) diff --git a/tests/guix-package.sh b/tests/guix-package.sh index 7b101aa501..5a514a0dc0 100644 --- a/tests/guix-package.sh +++ b/tests/guix-package.sh @@ -47,6 +47,10 @@ test -L "$profile" && test -L "$profile-1-link" ! test -f "$profile-2-link" test -f "$profile/bin/guile" +# No search path env. var. here. +guix package --search-paths -p "$profile" +test "`guix package --search-paths -p "$profile" | wc -l`" = 0 + # Check whether we have network access. if guile -c '(getaddrinfo "www.gnu.org" "80" AI_NUMERICSERV)' 2> /dev/null then @@ -119,6 +123,10 @@ then rm "$profile-1-link" guix package --bootstrap -p "$profile" --roll-back test "`readlink_base "$profile"`" = "$profile-0-link" + + # Make sure LIBRARY_PATH gets listed by `--search-paths'. + guix package --bootstrap -p "$profile" -i guile-bootstrap -i gcc-bootstrap + guix package --search-paths -p "$profile" | grep LIBRARY_PATH fi # Make sure the `:' syntax works. -- cgit v1.2.3