diff options
| -rw-r--r-- | guix/scripts/package.scm | 36 | ||||
| -rw-r--r-- | guix/search-paths.scm | 72 | ||||
| -rw-r--r-- | guix/utils.scm | 28 | ||||
| -rw-r--r-- | tests/utils.scm | 11 |
4 files changed, 77 insertions, 70 deletions
diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index 44cacdca8b..933f7d8ee5 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -375,42 +375,6 @@ an output path different than CURRENT-PATH." ;;; Search paths. ;;; -(define-syntax-rule (with-null-error-port exp) - "Evaluate EXP with the error port pointing to the bit bucket." - (with-error-to-port (%make-void-port "w") - (lambda () exp))) - -(define* (evaluate-search-paths search-paths directory - #:optional (getenv (const #f))) - "Evaluate SEARCH-PATHS, a list of search-path specifications, for DIRECTORY, -and return a list of variable/value pairs. Use GETENV to determine the -current settings and report only settings not already effective." - (define search-path-definition - (match-lambda - (($ <search-path-specification> variable files separator - type pattern) - (let* ((values (or (and=> (getenv variable) - (cut string-tokenize* <> separator)) - '())) - ;; Add a trailing slash to force symlinks to be treated as - ;; directories when 'find-files' traverses them. - (files (if pattern - (map (cut string-append <> "/") files) - files)) - - ;; XXX: Silence 'find-files' when it stumbles upon non-existent - ;; directories (see - ;; <http://lists.gnu.org/archive/html/guix-devel/2015-01/msg00269.html>.) - (path (with-null-error-port - (search-path-as-list files (list directory) - #:type type - #:pattern pattern)))) - (if (every (cut member <> values) path) - #f ;VARIABLE is already set appropriately - (cons variable (string-join path separator))))))) - - (filter-map search-path-definition search-paths)) - (define* (search-path-environment-variables entries profile #:optional (getenv getenv)) "Return environment variable definitions that may be needed for the use of diff --git a/guix/search-paths.scm b/guix/search-paths.scm index 147bfcae8c..b17f5acd5d 100644 --- a/guix/search-paths.scm +++ b/guix/search-paths.scm @@ -18,6 +18,9 @@ (define-module (guix search-paths) #:use-module (guix records) + #:use-module (guix build utils) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-26) #:use-module (ice-9 match) #:export (<search-path-specification> search-path-specification @@ -29,7 +32,8 @@ search-path-specification-file-pattern search-path-specification->sexp - sexp->search-path-specification)) + sexp->search-path-specification + evaluate-search-paths)) ;;; Commentary: ;;; @@ -74,4 +78,70 @@ a <search-path-specification> object." (file-type type) (file-pattern pattern))))) +(define-syntax-rule (with-null-error-port exp) + "Evaluate EXP with the error port pointing to the bit bucket." + (with-error-to-port (%make-void-port "w") + (lambda () exp))) + +;; XXX: This procedure used to be in (guix utils) but since we want to be able +;; to use (guix search-paths) on the build side, we want to avoid the +;; dependency on (guix utils), and so this procedure is back here for now. +(define (string-tokenize* string separator) + "Return the list of substrings of STRING separated by SEPARATOR. This is +like `string-tokenize', but SEPARATOR is a string." + (define (index string what) + (let loop ((string string) + (offset 0)) + (cond ((string-null? string) + #f) + ((string-prefix? what string) + offset) + (else + (loop (string-drop string 1) (+ 1 offset)))))) + + (define len + (string-length separator)) + + (let loop ((string string) + (result '())) + (cond ((index string separator) + => + (lambda (offset) + (loop (string-drop string (+ offset len)) + (cons (substring string 0 offset) + result)))) + (else + (reverse (cons string result)))))) + +(define* (evaluate-search-paths search-paths directory + #:optional (getenv (const #f))) + "Evaluate SEARCH-PATHS, a list of search-path specifications, for DIRECTORY, +and return a list of variable/value pairs. Use GETENV to determine the +current settings and report only settings not already effective." + (define search-path-definition + (match-lambda + (($ <search-path-specification> variable files separator + type pattern) + (let* ((values (or (and=> (getenv variable) + (cut string-tokenize* <> separator)) + '())) + ;; Add a trailing slash to force symlinks to be treated as + ;; directories when 'find-files' traverses them. + (files (if pattern + (map (cut string-append <> "/") files) + files)) + + ;; XXX: Silence 'find-files' when it stumbles upon non-existent + ;; directories (see + ;; <http://lists.gnu.org/archive/html/guix-devel/2015-01/msg00269.html>.) + (path (with-null-error-port + (search-path-as-list files (list directory) + #:type type + #:pattern pattern)))) + (if (every (cut member <> values) path) + #f ;VARIABLE is already set appropriately + (cons variable (string-join path separator))))))) + + (filter-map search-path-definition search-paths)) + ;;; search-paths.scm ends here diff --git a/guix/utils.scm b/guix/utils.scm index 3d38ba1223..a2ade2bf97 100644 --- a/guix/utils.scm +++ b/guix/utils.scm @@ -72,7 +72,6 @@ version-major+minor guile-version>? package-name->name+version - string-tokenize* string-replace-substring arguments-from-environment-variable file-extension @@ -606,33 +605,6 @@ introduce the version part." (substring file 0 dot) file))) -(define (string-tokenize* string separator) - "Return the list of substrings of STRING separated by SEPARATOR. This is -like `string-tokenize', but SEPARATOR is a string." - (define (index string what) - (let loop ((string string) - (offset 0)) - (cond ((string-null? string) - #f) - ((string-prefix? what string) - offset) - (else - (loop (string-drop string 1) (+ 1 offset)))))) - - (define len - (string-length separator)) - - (let loop ((string string) - (result '())) - (cond ((index string separator) - => - (lambda (offset) - (loop (string-drop string (+ offset len)) - (cons (substring string 0 offset) - result)))) - (else - (reverse (cons string result)))))) - (define* (string-replace-substring str substr replacement #:optional (start 0) diff --git a/tests/utils.scm b/tests/utils.scm index a662c9a8d3..e03a07b2f5 100644 --- a/tests/utils.scm +++ b/tests/utils.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013, 2014 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2012, 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2014 Eric Bavier <bavier@member.fsf.org> ;;; ;;; This file is part of GNU Guix. @@ -82,10 +82,11 @@ ("foo" "bar" "baz") ("foo" "bar" "") ("foo" "bar" "baz")) - (list (string-tokenize* "foo" ":") - (string-tokenize* "foo;bar;baz" ";") - (string-tokenize* "foo!bar!" "!") - (string-tokenize* "foo+-+bar+-+baz" "+-+"))) + (let ((string-tokenize* (@@ (guix search-paths) string-tokenize*))) + (list (string-tokenize* "foo" ":") + (string-tokenize* "foo;bar;baz" ";") + (string-tokenize* "foo!bar!" "!") + (string-tokenize* "foo+-+bar+-+baz" "+-+")))) (test-equal "string-replace-substring" '("foo BAR! baz" |