diff options
| author | Ludovic Courtès <ludo@gnu.org> | 2019-03-16 15:11:29 +0100 |
|---|---|---|
| committer | Ludovic Courtès <ludo@gnu.org> | 2019-03-16 18:15:09 +0100 |
| commit | 22f95e028f038cee342f455dfc55bd32b804907c (patch) | |
| tree | dade133425c4c41f26ffad0ecad315923db94dee | |
| parent | 0848615300ec0693b2849e80103a13063fa4b190 (diff) | |
tests: Add 'with-environment-variable'.
* tests/scripts.scm (with-environment-variable): Move to...
* guix/tests.scm (with-environment-variable): ... here.
* tests/build-utils.scm ("wrap-program, one input, multiple calls"):
Use it instead of 'setenv'.
| -rw-r--r-- | guix/tests.scm | 15 | ||||
| -rw-r--r-- | tests/build-utils.scm | 30 | ||||
| -rw-r--r-- | tests/scripts.scm | 15 |
3 files changed, 32 insertions, 28 deletions
diff --git a/guix/tests.scm b/guix/tests.scm index 749a4edd7ab..35ebf8464d6 100644 --- a/guix/tests.scm +++ b/guix/tests.scm | |||
| @@ -39,6 +39,8 @@ | |||
| 39 | canonical-file? | 39 | canonical-file? |
| 40 | network-reachable? | 40 | network-reachable? |
| 41 | shebang-too-long? | 41 | shebang-too-long? |
| 42 | with-environment-variable | ||
| 43 | |||
| 42 | mock | 44 | mock |
| 43 | %test-substitute-urls | 45 | %test-substitute-urls |
| 44 | test-assertm | 46 | test-assertm |
| @@ -195,6 +197,19 @@ store is opened." | |||
| 195 | (run-with-store store exp | 197 | (run-with-store store exp |
| 196 | #:guile-for-build (%guile-for-build))))) | 198 | #:guile-for-build (%guile-for-build))))) |
| 197 | 199 | ||
| 200 | (define-syntax-rule (with-environment-variable variable value body ...) | ||
| 201 | "Run BODY with VARIABLE set to VALUE." | ||
| 202 | (let ((orig (getenv variable))) | ||
| 203 | (dynamic-wind | ||
| 204 | (lambda () | ||
| 205 | (setenv variable value)) | ||
| 206 | (lambda () | ||
| 207 | body ...) | ||
| 208 | (lambda () | ||
| 209 | (if orig | ||
| 210 | (setenv variable orig) | ||
| 211 | (unsetenv variable)))))) | ||
| 212 | |||
| 198 | 213 | ||
| 199 | ;;; | 214 | ;;; |
| 200 | ;;; Narinfo files, as used by the substituter. | 215 | ;;; Narinfo files, as used by the substituter. |
diff --git a/tests/build-utils.scm b/tests/build-utils.scm index 7d49446f666..03216f9a35d 100644 --- a/tests/build-utils.scm +++ b/tests/build-utils.scm | |||
| @@ -107,19 +107,21 @@ | |||
| 107 | ;; it can't know about the bootstrap bash in the store, since it's not | 107 | ;; it can't know about the bootstrap bash in the store, since it's not |
| 108 | ;; named "bash". Help it out a bit by providing a symlink it this | 108 | ;; named "bash". Help it out a bit by providing a symlink it this |
| 109 | ;; package's output. | 109 | ;; package's output. |
| 110 | (setenv "PATH" (dirname bash)) | 110 | (with-environment-variable "PATH" (dirname bash) |
| 111 | (wrap-program foo `("GUIX_FOO" prefix ("hello"))) | 111 | (wrap-program foo `("GUIX_FOO" prefix ("hello"))) |
| 112 | (wrap-program foo `("GUIX_BAR" prefix ("world"))) | 112 | (wrap-program foo `("GUIX_BAR" prefix ("world"))) |
| 113 | 113 | ||
| 114 | ;; The bootstrap Bash is linked against an old libc and would abort with | 114 | ;; The bootstrap Bash is linked against an old libc and would abort |
| 115 | ;; an assertion failure when trying to load incompatible locale data. | 115 | ;; with an assertion failure when trying to load incompatible locale |
| 116 | (unsetenv "LOCPATH") | 116 | ;; data. |
| 117 | 117 | (unsetenv "LOCPATH") | |
| 118 | (let* ((pipe (open-input-pipe foo)) | 118 | |
| 119 | (str (get-string-all pipe))) | 119 | (let* ((pipe (open-input-pipe foo)) |
| 120 | (with-directory-excursion directory | 120 | (str (get-string-all pipe))) |
| 121 | (for-each delete-file '("foo" ".foo-real"))) | 121 | (with-directory-excursion directory |
| 122 | (and (zero? (close-pipe pipe)) | 122 | (for-each delete-file '("foo" ".foo-real"))) |
| 123 | str)))))) | 123 | (and (zero? (close-pipe pipe)) |
| 124 | str))))))) | ||
| 125 | |||
| 124 | 126 | ||
| 125 | (test-end) | 127 | (test-end) |
diff --git a/tests/scripts.scm b/tests/scripts.scm index 39017109533..efee271197f 100644 --- a/tests/scripts.scm +++ b/tests/scripts.scm | |||
| @@ -1,5 +1,5 @@ | |||
| 1 | ;;; GNU Guix --- Functional package management for GNU | 1 | ;;; GNU Guix --- Functional package management for GNU |
| 2 | ;;; Copyright © 2015 Ludovic Courtès <ludo@gnu.org> | 2 | ;;; Copyright © 2015, 2019 Ludovic Courtès <ludo@gnu.org> |
| 3 | ;;; | 3 | ;;; |
| 4 | ;;; This file is part of GNU Guix. | 4 | ;;; This file is part of GNU Guix. |
| 5 | ;;; | 5 | ;;; |
| @@ -25,19 +25,6 @@ | |||
| 25 | 25 | ||
| 26 | ;; Test the (guix scripts) module. | 26 | ;; Test the (guix scripts) module. |
| 27 | 27 | ||
| 28 | (define-syntax-rule (with-environment-variable variable value body ...) | ||
| 29 | "Run BODY with VARIABLE set to VALUE." | ||
| 30 | (let ((orig (getenv variable))) | ||
| 31 | (dynamic-wind | ||
| 32 | (lambda () | ||
| 33 | (setenv variable value)) | ||
| 34 | (lambda () | ||
| 35 | body ...) | ||
| 36 | (lambda () | ||
| 37 | (if orig | ||
| 38 | (setenv variable orig) | ||
| 39 | (unsetenv variable)))))) | ||
| 40 | |||
| 41 | 28 | ||
| 42 | (test-begin "scripts") | 29 | (test-begin "scripts") |
| 43 | 30 | ||
