diff options
| author | Ludovic Courtès <ludo@gnu.org> | 2017-01-22 22:42:57 +0100 |
|---|---|---|
| committer | Ludovic Courtès <ludo@gnu.org> | 2017-01-23 22:23:41 +0100 |
| commit | fcd75bdbfa99d14363b905afbf914eec20e69df8 (patch) | |
| tree | 38f9cfaf9c186fc6c9af54183efbd02fa1a13f70 | |
| parent | c5746f239964a72642ac56640b8ff490d5bfa673 (diff) | |
search-paths: Allow specs with #f as their separator.
This adds support for single-entry search paths.
Fixes <http://bugs.gnu.org/25422>.
Reported by Leo Famulari <leo@famulari.name>.
* guix/search-paths.scm (<search-path-specification>)[separator]:
Document as string or #f.
(evaluate-search-paths): Add case for SEPARATOR as #f.
(environment-variable-definition): Handle SEPARATOR being #f.
* guix/build/utils.scm (list->search-path-as-string): Add case for
SEPARATOR as #f.
(search-path-as-string->list): Likewise.
* guix/build/profiles.scm (abstract-profile): Likewise.
* tests/search-paths.scm: New file.
* Makefile.am (SCM_TESTS): Add it.
* tests/packages.scm ("--search-paths with single-item search path"):
New test.
* gnu/packages/version-control.scm (git)[native-search-paths](separator):
New field.
| -rw-r--r-- | Makefile.am | 3 | ||||
| -rw-r--r-- | gnu/packages/version-control.scm | 4 | ||||
| -rw-r--r-- | guix/build/profiles.scm | 24 | ||||
| -rw-r--r-- | guix/build/utils.scm | 13 | ||||
| -rw-r--r-- | guix/search-paths.scm | 28 | ||||
| -rw-r--r-- | tests/packages.scm | 49 | ||||
| -rw-r--r-- | tests/search-paths.scm | 48 |
7 files changed, 144 insertions, 25 deletions
diff --git a/Makefile.am b/Makefile.am index 3e147df2e03..dd9069ea768 100644 --- a/Makefile.am +++ b/Makefile.am | |||
| @@ -1,5 +1,5 @@ | |||
| 1 | # GNU Guix --- Functional package management for GNU | 1 | # GNU Guix --- Functional package management for GNU |
| 2 | # Copyright © 2012, 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org> | 2 | # Copyright © 2012, 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org> |
| 3 | # Copyright © 2013 Andreas Enge <andreas@enge.fr> | 3 | # Copyright © 2013 Andreas Enge <andreas@enge.fr> |
| 4 | # Copyright © 2015 Alex Kost <alezost@gmail.com> | 4 | # Copyright © 2015 Alex Kost <alezost@gmail.com> |
| 5 | # Copyright © 2016 Mathieu Lirzin <mthl@gnu.org> | 5 | # Copyright © 2016 Mathieu Lirzin <mthl@gnu.org> |
| @@ -272,6 +272,7 @@ SCM_TESTS = \ | |||
| 272 | tests/nar.scm \ | 272 | tests/nar.scm \ |
| 273 | tests/union.scm \ | 273 | tests/union.scm \ |
| 274 | tests/profiles.scm \ | 274 | tests/profiles.scm \ |
| 275 | tests/search-paths.scm \ | ||
| 275 | tests/syscalls.scm \ | 276 | tests/syscalls.scm \ |
| 276 | tests/gremlin.scm \ | 277 | tests/gremlin.scm \ |
| 277 | tests/bournish.scm \ | 278 | tests/bournish.scm \ |
diff --git a/gnu/packages/version-control.scm b/gnu/packages/version-control.scm index 7918b90ca6c..bf1842010f2 100644 --- a/gnu/packages/version-control.scm +++ b/gnu/packages/version-control.scm | |||
| @@ -1,7 +1,7 @@ | |||
| 1 | ;;; GNU Guix --- Functional package management for GNU | 1 | ;;; GNU Guix --- Functional package management for GNU |
| 2 | ;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org> | 2 | ;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org> |
| 3 | ;;; Copyright © 2013 Cyril Roelandt <tipecaml@gmail.com> | 3 | ;;; Copyright © 2013 Cyril Roelandt <tipecaml@gmail.com> |
| 4 | ;;; Copyright © 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org> | 4 | ;;; Copyright © 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org> |
| 5 | ;;; Copyright © 2013, 2014 Andreas Enge <andreas@enge.fr> | 5 | ;;; Copyright © 2013, 2014 Andreas Enge <andreas@enge.fr> |
| 6 | ;;; Copyright © 2015, 2016 Mathieu Lirzin <mthl@gnu.org> | 6 | ;;; Copyright © 2015, 2016 Mathieu Lirzin <mthl@gnu.org> |
| 7 | ;;; Copyright © 2014, 2015, 2016 Mark H Weaver <mhw@netris.org> | 7 | ;;; Copyright © 2014, 2015, 2016 Mark H Weaver <mhw@netris.org> |
| @@ -297,10 +297,10 @@ as well as the classic centralized workflow.") | |||
| 297 | (native-search-paths | 297 | (native-search-paths |
| 298 | ;; For HTTPS access, Git needs a single-file certificate bundle, specified | 298 | ;; For HTTPS access, Git needs a single-file certificate bundle, specified |
| 299 | ;; with $GIT_SSL_CAINFO. | 299 | ;; with $GIT_SSL_CAINFO. |
| 300 | ;; FIXME: This variable designates a single file; it is not a search path. | ||
| 301 | (list (search-path-specification | 300 | (list (search-path-specification |
| 302 | (variable "GIT_SSL_CAINFO") | 301 | (variable "GIT_SSL_CAINFO") |
| 303 | (file-type 'regular) | 302 | (file-type 'regular) |
| 303 | (separator #f) ;single entry | ||
| 304 | (files '("etc/ssl/certs/ca-certificates.crt"))))) | 304 | (files '("etc/ssl/certs/ca-certificates.crt"))))) |
| 305 | 305 | ||
| 306 | (synopsis "Distributed version control system") | 306 | (synopsis "Distributed version control system") |
diff --git a/guix/build/profiles.scm b/guix/build/profiles.scm index 6e316d5d2c4..42eabfaf19e 100644 --- a/guix/build/profiles.scm +++ b/guix/build/profiles.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, 2017 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 | ;;; |
| @@ -39,17 +39,21 @@ | |||
| 39 | 'GUIX_PROFILE' environment variable. This allows users to specify what the | 39 | 'GUIX_PROFILE' environment variable. This allows users to specify what the |
| 40 | user-friendly name of the profile is, for instance ~/.guix-profile rather than | 40 | user-friendly name of the profile is, for instance ~/.guix-profile rather than |
| 41 | /gnu/store/...-profile." | 41 | /gnu/store/...-profile." |
| 42 | (let ((replacement (string-append "${GUIX_PROFILE:-" profile "}"))) | 42 | (let ((replacement (string-append "${GUIX_PROFILE:-" profile "}")) |
| 43 | (crop (cute string-drop <> (string-length profile)))) | ||
| 43 | (match-lambda | 44 | (match-lambda |
| 44 | ((search-path . value) | 45 | ((search-path . value) |
| 45 | (let* ((separator (search-path-specification-separator search-path)) | 46 | (match (search-path-specification-separator search-path) |
| 46 | (items (string-tokenize* value separator)) | 47 | (#f |
| 47 | (crop (cute string-drop <> (string-length profile)))) | 48 | (cons search-path |
| 48 | (cons search-path | 49 | (string-append replacement (crop value)))) |
| 49 | (string-join (map (lambda (str) | 50 | ((? string? separator) |
| 50 | (string-append replacement (crop str))) | 51 | (let ((items (string-tokenize* value separator))) |
| 51 | items) | 52 | (cons search-path |
| 52 | separator))))))) | 53 | (string-join (map (lambda (str) |
| 54 | (string-append replacement (crop str))) | ||
| 55 | items) | ||
| 56 | separator))))))))) | ||
| 53 | 57 | ||
| 54 | (define (write-environment-variable-definition port) | 58 | (define (write-environment-variable-definition port) |
| 55 | "Write the given environment variable definition to PORT." | 59 | "Write the given environment variable definition to PORT." |
diff --git a/guix/build/utils.scm b/guix/build/utils.scm index bc6f114152e..cf093263936 100644 --- a/guix/build/utils.scm +++ b/guix/build/utils.scm | |||
| @@ -1,5 +1,5 @@ | |||
| 1 | ;;; GNU Guix --- Functional package management for GNU | 1 | ;;; GNU Guix --- Functional package management for GNU |
| 2 | ;;; Copyright © 2012, 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org> | 2 | ;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org> |
| 3 | ;;; Copyright © 2013 Andreas Enge <andreas@enge.fr> | 3 | ;;; Copyright © 2013 Andreas Enge <andreas@enge.fr> |
| 4 | ;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org> | 4 | ;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org> |
| 5 | ;;; Copyright © 2015 Mark H Weaver <mhw@netris.org> | 5 | ;;; Copyright © 2015 Mark H Weaver <mhw@netris.org> |
| @@ -400,10 +400,17 @@ for under the directories designated by FILES. For example: | |||
| 400 | (delete-duplicates input-dirs))) | 400 | (delete-duplicates input-dirs))) |
| 401 | 401 | ||
| 402 | (define (list->search-path-as-string lst separator) | 402 | (define (list->search-path-as-string lst separator) |
| 403 | (string-join lst separator)) | 403 | (if separator |
| 404 | (string-join lst separator) | ||
| 405 | (match lst | ||
| 406 | ((head rest ...) head) | ||
| 407 | (() "")))) | ||
| 404 | 408 | ||
| 405 | (define* (search-path-as-string->list path #:optional (separator #\:)) | 409 | (define* (search-path-as-string->list path #:optional (separator #\:)) |
| 406 | (string-tokenize path (char-set-complement (char-set separator)))) | 410 | (if separator |
| 411 | (string-tokenize path | ||
| 412 | (char-set-complement (char-set separator))) | ||
| 413 | (list path))) | ||
| 407 | 414 | ||
| 408 | (define* (set-path-environment-variable env-var files input-dirs | 415 | (define* (set-path-environment-variable env-var files input-dirs |
| 409 | #:key | 416 | #:key |
diff --git a/guix/search-paths.scm b/guix/search-paths.scm index 7a6fe679595..4bf0e443891 100644 --- a/guix/search-paths.scm +++ b/guix/search-paths.scm | |||
| @@ -1,5 +1,5 @@ | |||
| 1 | ;;; GNU Guix --- Functional package management for GNU | 1 | ;;; GNU Guix --- Functional package management for GNU |
| 2 | ;;; Copyright © 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org> | 2 | ;;; Copyright © 2013, 2014, 2015, 2017 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 | ;;; |
| @@ -55,7 +55,7 @@ | |||
| 55 | search-path-specification? | 55 | search-path-specification? |
| 56 | (variable search-path-specification-variable) ;string | 56 | (variable search-path-specification-variable) ;string |
| 57 | (files search-path-specification-files) ;list of strings | 57 | (files search-path-specification-files) ;list of strings |
| 58 | (separator search-path-specification-separator ;string | 58 | (separator search-path-specification-separator ;string | #f |
| 59 | (default ":")) | 59 | (default ":")) |
| 60 | (file-type search-path-specification-file-type ;symbol | 60 | (file-type search-path-specification-file-type ;symbol |
| 61 | (default 'directory)) | 61 | (default 'directory)) |
| @@ -131,11 +131,23 @@ like `string-tokenize', but SEPARATOR is a string." | |||
| 131 | DIRECTORIES, a list of directory names, and return a list of | 131 | DIRECTORIES, a list of directory names, and return a list of |
| 132 | specification/value pairs. Use GETENV to determine the current settings and | 132 | specification/value pairs. Use GETENV to determine the current settings and |
| 133 | report only settings not already effective." | 133 | report only settings not already effective." |
| 134 | (define search-path-definition | 134 | (define (search-path-definition spec) |
| 135 | (match-lambda | 135 | (match spec |
| 136 | ((and spec | 136 | (($ <search-path-specification> variable files #f type pattern) |
| 137 | ($ <search-path-specification> variable files separator | 137 | ;; Separator is #f so return the first match. |
| 138 | type pattern)) | 138 | (match (with-null-error-port |
| 139 | (search-path-as-list files directories | ||
| 140 | #:type type | ||
| 141 | #:pattern pattern)) | ||
| 142 | (() | ||
| 143 | #f) | ||
| 144 | ((head . _) | ||
| 145 | (let ((value (getenv variable))) | ||
| 146 | (if (and value (string=? value head)) | ||
| 147 | #f ;VARIABLE already set appropriately | ||
| 148 | (cons spec head)))))) | ||
| 149 | (($ <search-path-specification> variable files separator | ||
| 150 | type pattern) | ||
| 139 | (let* ((values (or (and=> (getenv variable) | 151 | (let* ((values (or (and=> (getenv variable) |
| 140 | (cut string-tokenize* <> separator)) | 152 | (cut string-tokenize* <> separator)) |
| 141 | '())) | 153 | '())) |
| @@ -164,7 +176,7 @@ current value), or 'suffix (return the definition where VALUE is added as a | |||
| 164 | suffix to VARIABLE's current value.) In the case of 'prefix and 'suffix, | 176 | suffix to VARIABLE's current value.) In the case of 'prefix and 'suffix, |
| 165 | SEPARATOR is used as the separator between VARIABLE's current value and its | 177 | SEPARATOR is used as the separator between VARIABLE's current value and its |
| 166 | prefix/suffix." | 178 | prefix/suffix." |
| 167 | (match kind | 179 | (match (if (not separator) 'exact kind) |
| 168 | ('exact | 180 | ('exact |
| 169 | (format #f "export ~a=\"~a\"" variable value)) | 181 | (format #f "export ~a=\"~a\"" variable value)) |
| 170 | ('prefix | 182 | ('prefix |
diff --git a/tests/packages.scm b/tests/packages.scm index 247f75cc435..962f120ea2c 100644 --- a/tests/packages.scm +++ b/tests/packages.scm | |||
| @@ -1,5 +1,5 @@ | |||
| 1 | ;;; GNU Guix --- Functional package management for GNU | 1 | ;;; GNU Guix --- Functional package management for GNU |
| 2 | ;;; Copyright © 2012, 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org> | 2 | ;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017 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 | ;;; |
| @@ -42,6 +42,7 @@ | |||
| 42 | #:use-module (gnu packages base) | 42 | #:use-module (gnu packages base) |
| 43 | #:use-module (gnu packages guile) | 43 | #:use-module (gnu packages guile) |
| 44 | #:use-module (gnu packages bootstrap) | 44 | #:use-module (gnu packages bootstrap) |
| 45 | #:use-module (gnu packages version-control) | ||
| 45 | #:use-module (gnu packages xml) | 46 | #:use-module (gnu packages xml) |
| 46 | #:use-module (srfi srfi-1) | 47 | #:use-module (srfi srfi-1) |
| 47 | #:use-module (srfi srfi-26) | 48 | #:use-module (srfi srfi-26) |
| @@ -979,6 +980,52 @@ | |||
| 979 | (guix-package "-p" (derivation->output-path prof) | 980 | (guix-package "-p" (derivation->output-path prof) |
| 980 | "--search-paths")))))) | 981 | "--search-paths")))))) |
| 981 | 982 | ||
| 983 | (test-assert "--search-paths with single-item search path" | ||
| 984 | ;; Make sure 'guix package --search-paths' correctly reports environment | ||
| 985 | ;; variables for things like 'GIT_SSL_CAINFO' that have #f as their | ||
| 986 | ;; separator, meaning that the first match wins. | ||
| 987 | (let* ((p1 (dummy-package "foo" | ||
| 988 | (build-system trivial-build-system) | ||
| 989 | (arguments | ||
| 990 | `(#:guile ,%bootstrap-guile | ||
| 991 | #:modules ((guix build utils)) | ||
| 992 | #:builder (begin | ||
| 993 | (use-modules (guix build utils)) | ||
| 994 | (let ((out (assoc-ref %outputs "out"))) | ||
| 995 | (mkdir-p (string-append out "/etc/ssl/certs")) | ||
| 996 | (call-with-output-file | ||
| 997 | (string-append | ||
| 998 | out "/etc/ssl/certs/ca-certificates.crt") | ||
| 999 | (const #t)))))))) | ||
| 1000 | (p2 (package (inherit p1) (name "bar"))) | ||
| 1001 | (p3 (dummy-package "git" | ||
| 1002 | ;; Provide a fake Git to avoid building the real one. | ||
| 1003 | (build-system trivial-build-system) | ||
| 1004 | (arguments | ||
| 1005 | `(#:guile ,%bootstrap-guile | ||
| 1006 | #:builder (mkdir (assoc-ref %outputs "out")))) | ||
| 1007 | (native-search-paths (package-native-search-paths git)))) | ||
| 1008 | (prof1 (run-with-store %store | ||
| 1009 | (profile-derivation | ||
| 1010 | (packages->manifest (list p1 p3)) | ||
| 1011 | #:hooks '() | ||
| 1012 | #:locales? #f) | ||
| 1013 | #:guile-for-build (%guile-for-build))) | ||
| 1014 | (prof2 (run-with-store %store | ||
| 1015 | (profile-derivation | ||
| 1016 | (packages->manifest (list p2 p3)) | ||
| 1017 | #:hooks '() | ||
| 1018 | #:locales? #f) | ||
| 1019 | #:guile-for-build (%guile-for-build)))) | ||
| 1020 | (build-derivations %store (list prof1 prof2)) | ||
| 1021 | (string-match (format #f "^export GIT_SSL_CAINFO=\"~a/etc/ssl/certs/ca-certificates.crt" | ||
| 1022 | (regexp-quote (derivation->output-path prof1))) | ||
| 1023 | (with-output-to-string | ||
| 1024 | (lambda () | ||
| 1025 | (guix-package "-p" (derivation->output-path prof1) | ||
| 1026 | "-p" (derivation->output-path prof2) | ||
| 1027 | "--search-paths")))))) | ||
| 1028 | |||
| 982 | (test-equal "specification->package when not found" | 1029 | (test-equal "specification->package when not found" |
| 983 | 'quit | 1030 | 'quit |
| 984 | (catch 'quit | 1031 | (catch 'quit |
diff --git a/tests/search-paths.scm b/tests/search-paths.scm new file mode 100644 index 00000000000..2a4c18dd768 --- /dev/null +++ b/tests/search-paths.scm | |||
| @@ -0,0 +1,48 @@ | |||
| 1 | ;;; GNU Guix --- Functional package management for GNU | ||
| 2 | ;;; Copyright © 2017 Ludovic Courtès <ludo@gnu.org> | ||
| 3 | ;;; | ||
| 4 | ;;; This file is part of GNU Guix. | ||
| 5 | ;;; | ||
| 6 | ;;; GNU Guix is free software; you can redistribute it and/or modify it | ||
| 7 | ;;; under the terms of the GNU General Public License as published by | ||
| 8 | ;;; the Free Software Foundation; either version 3 of the License, or (at | ||
| 9 | ;;; your option) any later version. | ||
| 10 | ;;; | ||
| 11 | ;;; GNU Guix is distributed in the hope that it will be useful, but | ||
| 12 | ;;; WITHOUT ANY WARRANTY; without even the implied warranty of | ||
| 13 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | ||
| 14 | ;;; GNU General Public License for more details. | ||
| 15 | ;;; | ||
| 16 | ;;; You should have received a copy of the GNU General Public License | ||
| 17 | ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. | ||
| 18 | |||
| 19 | (define-module (test-search-paths) | ||
| 20 | #:use-module (guix search-paths) | ||
| 21 | #:use-module (ice-9 match) | ||
| 22 | #:use-module (srfi srfi-64)) | ||
| 23 | |||
| 24 | (define %top-srcdir | ||
| 25 | (dirname (search-path %load-path "guix.scm"))) | ||
| 26 | |||
| 27 | |||
| 28 | (test-begin "search-paths") | ||
| 29 | |||
| 30 | (test-equal "evaluate-search-paths, separator is #f" | ||
| 31 | (string-append %top-srcdir | ||
| 32 | "/gnu/packages/bootstrap/armhf-linux") | ||
| 33 | |||
| 34 | ;; The following search path spec should evaluate to a single item: the | ||
| 35 | ;; first directory that matches the "-linux$" pattern in | ||
| 36 | ;; gnu/packages/bootstrap. | ||
| 37 | (let ((spec (search-path-specification | ||
| 38 | (variable "CHBOUIB") | ||
| 39 | (files '("gnu/packages/bootstrap")) | ||
| 40 | (file-type 'directory) | ||
| 41 | (separator #f) | ||
| 42 | (file-pattern "-linux$")))) | ||
| 43 | (match (evaluate-search-paths (list spec) | ||
| 44 | (list %top-srcdir)) | ||
| 45 | (((spec* . value)) | ||
| 46 | (and (eq? spec* spec) value))))) | ||
| 47 | |||
| 48 | (test-end "search-paths") | ||
