From 739380542da7e434c581ec620edeb4348d6ece89 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 12 Feb 2019 22:17:11 +0100 Subject: inferior: Add 'inferior-available-packages'. * guix/inferior.scm (inferior-available-packages): New procedure. * tests/inferior.scm ("inferior-available-packages"): New test. --- tests/inferior.scm | 22 +++++++++++++++++++++- 1 file changed, 21 insertions(+), 1 deletion(-) (limited to 'tests') diff --git a/tests/inferior.scm b/tests/inferior.scm index d5a894ca8f..71ebf8f59b 100644 --- a/tests/inferior.scm +++ b/tests/inferior.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2018 Ludovic Courtès +;;; Copyright © 2018, 2019 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -89,6 +89,26 @@ (close-inferior inferior) result)))) +(test-equal "inferior-available-packages" + (take (sort (fold-available-packages + (lambda* (name version result + #:key supported? deprecated? + #:allow-other-keys) + (if (and supported? (not deprecated?)) + (alist-cons name version result) + result)) + '()) + (lambda (x y) + (stringlist (lambda (package) (list (package-name package) -- cgit v1.2.3 From e6e599fa0106f57b9de15f90dcab3795ff1575b6 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 15 Feb 2019 08:45:57 +0100 Subject: environment: Add '--inherit'. * guix/scripts/environment.scm (purify-environment): Add 'white-list' parameter and honor it. (create-environment): Add #:white-list parameter and honor it. (launch-environment): Likewise. (launch-environment/fork): Likewise. (show-help, %options): Add '--inherit'. (guix-environment): Define 'white-list' and pass it to 'launch-environment/fork'. * tests/guix-environment.sh: Test '--inherit'. * doc/guix.texi (Invoking guix environment): Document it. --- doc/guix.texi | 21 +++++++++++++++--- guix/scripts/environment.scm | 53 +++++++++++++++++++++++++++++++------------- tests/guix-environment.sh | 15 ++++++++++++- 3 files changed, 69 insertions(+), 20 deletions(-) (limited to 'tests') diff --git a/doc/guix.texi b/doc/guix.texi index 1ac077d98a..68d39ed02f 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -4454,9 +4454,24 @@ default behavior. Packages appearing after are interpreted as packages that will be added to the environment directly. @item --pure -Unset existing environment variables when building the new environment. -This has the effect of creating an environment in which search paths -only contain package inputs. +Unset existing environment variables when building the new environment, except +those specified with @option{--inherit} (see below.) This has the effect of +creating an environment in which search paths only contain package inputs. + +@item --inherit=@var{regexp} +When used alongside @option{--pure}, inherit all the environment variables +matching @var{regexp}---in other words, put them on a ``white list'' of +environment variables that must be preserved. + +@example +guix environment --pure --inherit=^SLURM --ad-hoc openmpi @dots{} \ + -- mpirun @dots{} +@end example + +This example runs @command{mpirun} in a context where the only environment +variables defined are @code{PATH}, environment variables whose name starts +with @code{SLURM}, as well as the usual ``precious'' variables (@code{HOME}, +@code{USER}, etc.) @item --search-paths Display the environment variable definitions that make up the diff --git a/guix/scripts/environment.scm b/guix/scripts/environment.scm index 3143ea9281..3966531efa 100644 --- a/guix/scripts/environment.scm +++ b/guix/scripts/environment.scm @@ -57,20 +57,27 @@ (define %default-shell (or (getenv "SHELL") "/bin/sh")) -(define (purify-environment) - "Unset almost all environment variables. A small number of variables such -as 'HOME' and 'USER' are left untouched." +(define (purify-environment white-list) + "Unset all environment variables except those that match the regexps in +WHITE-LIST and those listed in %PRECIOUS-VARIABLES. A small number of +variables such as 'HOME' and 'USER' are left untouched." (for-each unsetenv - (remove (cut member <> %precious-variables) + (remove (lambda (variable) + (or (member variable %precious-variables) + (find (cut regexp-exec <> variable) + white-list))) (match (get-environment-variables) (((names . _) ...) names))))) -(define* (create-environment profile manifest #:key pure?) - "Set the environment variables specified by MANIFEST for PROFILE. When PURE? -is #t, unset the variables in the current environment. Otherwise, augment -existing environment variables with additional search paths." - (when pure? (purify-environment)) +(define* (create-environment profile manifest + #:key pure? (white-list '())) + "Set the environment variables specified by MANIFEST for PROFILE. When +PURE? is #t, unset the variables in the current environment except those that +match the regexps in WHITE-LIST. Otherwise, augment existing environment +variables with additional search paths." + (when pure? + (purify-environment white-list)) (for-each (match-lambda ((($ variable _ separator) . value) (let ((current (getenv variable))) @@ -133,6 +140,8 @@ COMMAND or an interactive shell in that environment.\n")) of only their inputs")) (display (G_ " --pure unset existing environment variables")) + (display (G_ " + --inherit=REGEXP inherit environment variables that match REGEXP")) (display (G_ " --search-paths display needed environment variable definitions")) (display (G_ " @@ -206,6 +215,11 @@ COMMAND or an interactive shell in that environment.\n")) (option '("pure") #f #f (lambda (opt name arg result) (alist-cons 'pure #t result))) + (option '("inherit") #t #f + (lambda (opt name arg result) + (alist-cons 'inherit-regexp + (make-regexp* arg) + result))) (option '(#\E "exec") #t #f ; deprecated (lambda (opt name arg result) (alist-cons 'exec (list %default-shell "-c" arg) result))) @@ -397,25 +411,30 @@ and suitable for 'exit'." (define primitive-exit/status (compose primitive-exit status->exit-code)) (define* (launch-environment command profile manifest - #:key pure?) + #:key pure? (white-list '())) "Run COMMAND in a new environment containing INPUTS, using the native search paths defined by the list PATHS. When PURE?, pre-existing environment -variables are cleared before setting the new ones." +variables are cleared before setting the new ones, except those matching the +regexps in WHITE-LIST." ;; Properly handle SIGINT, so pressing C-c in an interactive terminal ;; application works. (sigaction SIGINT SIG_DFL) - (create-environment profile manifest #:pure? pure?) + (create-environment profile manifest + #:pure? pure? #:white-list white-list) (match command ((program . args) (apply execlp program program args)))) -(define* (launch-environment/fork command profile manifest #:key pure?) +(define* (launch-environment/fork command profile manifest + #:key pure? (white-list '())) "Run COMMAND in a new process with an environment containing PROFILE, with the search paths specified by MANIFEST. When PURE?, pre-existing environment -variables are cleared before setting the new ones." +variables are cleared before setting the new ones, except those matching the +regexps in WHITE-LIST." (match (primitive-fork) (0 (launch-environment command profile manifest - #:pure? pure?)) + #:pure? pure? + #:white-list white-list)) (pid (match (waitpid pid) ((_ . status) status))))) @@ -672,7 +691,8 @@ message if any test fails." ;; within the container. '("/bin/sh") (list %default-shell)))) - (mappings (pick-all opts 'file-system-mapping))) + (mappings (pick-all opts 'file-system-mapping)) + (white-list (pick-all opts 'inherit-regexp))) (when container? (assert-container-features)) @@ -741,4 +761,5 @@ message if any test fails." (return (exit/status (launch-environment/fork command profile manifest + #:white-list white-list #:pure? pure?)))))))))))))) diff --git a/tests/guix-environment.sh b/tests/guix-environment.sh index 30b21028aa..ccbe027c7b 100644 --- a/tests/guix-environment.sh +++ b/tests/guix-environment.sh @@ -1,5 +1,5 @@ # GNU Guix --- Functional package management for GNU -# Copyright © 2015, 2016, 2017, 2018 Ludovic Courtès +# Copyright © 2015, 2016, 2017, 2018, 2019 Ludovic Courtès # # This file is part of GNU Guix. # @@ -49,6 +49,19 @@ test -x `sed -r 's/^export PATH="(.*)"/\1/' "$tmpdir/a"`/guile cmp "$tmpdir/a" "$tmpdir/b" +# Check '--inherit'. +GUIX_TEST_ABC=1 +GUIX_TEST_DEF=2 +GUIX_TEST_XYZ=3 +export GUIX_TEST_ABC GUIX_TEST_DEF GUIX_TEST_XYZ +guix environment --bootstrap --ad-hoc guile-bootstrap --pure \ + --inherit='^GUIX_TEST_A' --inherit='^GUIX_TEST_D' \ + -- "$SHELL" -c set > "$tmpdir/a" +grep '^PATH=' "$tmpdir/a" +grep '^GUIX_TEST_ABC=' "$tmpdir/a" +grep '^GUIX_TEST_DEF=' "$tmpdir/a" +if grep '^GUIX_TEST_XYZ=' "$tmpdir/a"; then false; else true; fi + # Make sure the exit value is preserved. if guix environment --bootstrap --ad-hoc guile-bootstrap --pure \ -- guile -c '(exit 42)' -- cgit v1.2.3 From 36754eee28187b41e9a6ef15cd3c9911449a4e8d Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 15 Feb 2019 22:58:29 +0100 Subject: packages: Remove duplicates from package cache. Previously the same package could appear several times if several variables were bound to it, as is notably the case for "python" currently. This, in turn, would lead to obnoxious "ambiguous package specification" messages. * gnu/packages.scm (generate-package-cache)[expand-cache]: Change RESULT to RESULT+SEEN and adjust accordingly. Call 'first' on the result of 'fold-module-public-variables*'. * tests/packages.scm ("fold-available-packages with/without cache"): Check for lack of duplicates in FROM-CACHE. --- gnu/packages.scm | 53 ++++++++++++++++++++++++++++++----------------------- tests/packages.scm | 3 ++- 2 files changed, 32 insertions(+), 24 deletions(-) (limited to 'tests') diff --git a/gnu/packages.scm b/gnu/packages.scm index a1814205f9..7b17e70c53 100644 --- a/gnu/packages.scm +++ b/gnu/packages.scm @@ -371,34 +371,41 @@ reducing the memory footprint." (define cache-file (string-append directory %package-cache-file)) - (define (expand-cache module symbol variable result) + (define (expand-cache module symbol variable result+seen) (match (false-if-exception (variable-ref variable)) ((? package? package) - (if (hidden-package? package) - result - (cons `#(,(package-name package) - ,(package-version package) - ,(module-name module) - ,symbol - ,(package-outputs package) - ,(->bool (member (%current-system) - (package-supported-systems package))) - ,(->bool (package-superseded package)) - ,@(let ((loc (package-location package))) - (if loc - `(,(location-file loc) - ,(location-line loc) - ,(location-column loc)) - '(#f #f #f)))) - result))) + (match result+seen + ((result . seen) + (if (or (vhash-assq package seen) + (hidden-package? package)) + (cons result seen) + (cons (cons `#(,(package-name package) + ,(package-version package) + ,(module-name module) + ,symbol + ,(package-outputs package) + ,(->bool + (member (%current-system) + (package-supported-systems package))) + ,(->bool (package-superseded package)) + ,@(let ((loc (package-location package))) + (if loc + `(,(location-file loc) + ,(location-line loc) + ,(location-column loc)) + '(#f #f #f)))) + result) + (vhash-consq package #t seen)))))) (_ - result))) + result+seen))) (define exp - (fold-module-public-variables* expand-cache '() - (all-modules (%package-module-path) - #:warn - warn-about-load-error))) + (first + (fold-module-public-variables* expand-cache + (cons '() vlist-null) + (all-modules (%package-module-path) + #:warn + warn-about-load-error)))) (mkdir-p (dirname cache-file)) (call-with-output-file cache-file diff --git a/tests/packages.scm b/tests/packages.scm index e5704ae4b9..4e4bffc48c 100644 --- a/tests/packages.scm +++ b/tests/packages.scm @@ -1037,7 +1037,8 @@ result)) '())))))) - (lset= equal? no-cache from-cache))) + (and (equal? (delete-duplicates from-cache) from-cache) + (lset= equal? no-cache from-cache)))) (test-assert "find-packages-by-name" (match (find-packages-by-name "hello") -- cgit v1.2.3