rekahsoft
/
guix
1
1
Fork 0
Code Issues Pull Requests Releases Wiki Activity

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.
This commit is contained in:
Ludovic Courtès 2015-05-04 21:44:52 +02:00
parent e89431bf01
commit 6568d2bd6e
4 changed files with 77 additions and 70 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

36
guix/scripts/package.scm
View File

@ -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

72
guix/search-paths.scm
View File

@ -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

28
guix/utils.scm
View File

@ -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)

11
tests/utils.scm
View File

@ -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"