aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2015-05-04 21:44:52 +0200
committerLudovic Courtès <ludo@gnu.org>2015-05-04 23:30:51 +0200
commit6568d2bd6e4e047dd95b00a7a6e7501a16491eb5 (patch)
treef5f16ed73cbb0486fd00a8147707ce75b2132df4
parente89431bf016830a919ec2430889f6c2679aab408 (diff)
downloadguix-6568d2bd6e4e047dd95b00a7a6e7501a16491eb5.tar
guix-6568d2bd6e4e047dd95b00a7a6e7501a16491eb5.tar.gz
search-paths: Add 'evaluate-search-paths', from (guix scripts package).
* guix/scripts/package.scm (with-null-error-port, evaluate-search-paths): Move to... * guix/search-paths.scm: ... here. * guix/utils.scm (string-tokenize*): Move to... * guix/search-paths.scm: ... here. * tests/utils.scm ("string-tokenize*"): Adjust accordingly.
-rw-r--r--guix/scripts/package.scm36
-rw-r--r--guix/search-paths.scm72
-rw-r--r--guix/utils.scm28
-rw-r--r--tests/utils.scm11
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"