guix-bioinformatics
/
guix
mirror of http://git.savannah.gnu.org/git/guix.git
3
0
Fork 0
Code Issues Projects Releases Wiki Activity
Browse Source

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.
version-0.8.3
Ludovic Courtès 7 years ago
parent
e89431bf01
commit
6568d2bd6e
4 changed files with 77 additions and 70 deletions
Whitespace
Show all changes Ignore whitespace when comparing lines Ignore changes in amount of whitespace Ignore changes in whitespace at EOL
Split View
Diff Options
Show Stats Download Patch File Download Diff File
  1. 36
      guix/scripts/package.scm
  2. 72
      guix/search-paths.scm
  3. 28
      guix/utils.scm
  4. 11
      tests/utils.scm

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"

Write Preview
Loading…
Cancel
Save