04/08: search-paths: Add 'evaluate-search-paths', from (guix scripts package).

[Ludovic Courtès]

civodul pushed a commit to branch master
in repository guix.

commit 6568d2bd6e4e047dd95b00a7a6e7501a16491eb5
Author: Ludovic Courtès <address@hidden>
Date:   Mon May 4 21:44:52 2015 +0200

    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.
---
 guix/scripts/package.scm |   36 -----------------------
 guix/search-paths.scm    |   72 +++++++++++++++++++++++++++++++++++++++++++++-
 guix/utils.scm           |   28 ------------------
 tests/utils.scm          |   11 ++++---
 4 files changed, 77 insertions(+), 70 deletions(-)

diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm
index 44cacdc..933f7d8 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 147bfca..b17f5ac 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 3d38ba1..a2ade2b 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 a662c9a..e03a07b 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 <address@hidden>
+;;; Copyright © 2012, 2013, 2014, 2015 Ludovic Courtès <address@hidden>
 ;;; Copyright © 2014 Eric Bavier <address@hidden>
 ;;;
 ;;; 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"