~ruther/guix-local

6568d2bd6e4e047dd95b00a7a6e7501a16491eb5 — Ludovic Courtès 11 years ago e89431b
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.
4 files changed, 77 insertions(+), 70 deletions(-)

M guix/scripts/package.scm
M guix/search-paths.scm
M guix/utils.scm
M tests/utils.scm
M guix/scripts/package.scm => guix/scripts/package.scm +0 -36
@@ 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

M guix/search-paths.scm => guix/search-paths.scm +71 -1
@@ 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

M guix/utils.scm => guix/utils.scm +0 -28
@@ 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)

M tests/utils.scm => tests/utils.scm +6 -5
@@ 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"