Merge branch 'master' into core-updates

Conflicts:
	guix/packages.scm

8 files changed, 335 insertions, 126 deletions

diff --git a/guix/build-system/python.scm b/guix/build-system/python.scm
index 32b1f36a94..a97135fe0c 100644
--- a/guix/build-system/python.scm
+++ b/guix/build-system/python.scm
@@ -96,6 +96,7 @@ prepended to the name."
                        #:key
                        (python (default-python))
                        (tests? #t)
+                       (test-target "test")
                        (configure-flags ''())
                        (phases '(@ (guix build python-build-system)
                                    %standard-phases))
@@ -124,7 +125,7 @@ provides a 'setup.py' file as its build system."
                                    source)
                      #:configure-flags ,configure-flags
                      #:system ,system
-                     #:test-target "test"
+                     #:test-target ,test-target
                      #:tests? ,tests?
                      #:phases ,phases
                      #:outputs %outputs
diff --git a/guix/derivations.scm b/guix/derivations.scm
index 48e9d5ec05..63c1ba4f2b 100644
--- a/guix/derivations.scm
+++ b/guix/derivations.scm
@@ -25,6 +25,7 @@
   #:use-module (rnrs bytevectors)
   #:use-module (ice-9 match)
   #:use-module (ice-9 rdelim)
+  #:use-module (ice-9 vlist)
   #:use-module (guix store)
   #:use-module (guix utils)
   #:use-module (guix hash)
@@ -63,6 +64,7 @@
             derivation-path->output-path
             derivation-path->output-paths
             derivation
+            map-derivation
 
             %guile-for-build
             imported-modules
@@ -539,15 +541,6 @@ advance, such as a file download.
 When REFERENCES-GRAPHS is true, it must be a list of file name/store path
 pairs.  In that case, the reference graph of each store path is exported in
 the build environment in the corresponding file, in a simple text format."
-  (define direct-store-path?
-    (let ((len (+ 1 (string-length (%store-prefix)))))
-      (lambda (p)
-        ;; Return #t if P is a store path, and not a sub-directory of a
-        ;; store path.  This predicate is needed because files *under* a
-        ;; store path are not valid inputs.
-        (and (store-path? p)
-             (not (string-index (substring p len) #\/))))))
-
   (define (add-output-paths drv)
     ;; Return DRV with an actual store path for each of its output and the
     ;; corresponding environment variable.
@@ -655,6 +648,113 @@ the build environment in the corresponding file, in a simple text format."
                                         inputs))))
       (set-file-name drv file))))
 
+(define* (map-derivation store drv mapping
+                         #:key (system (%current-system)))
+  "Given MAPPING, a list of pairs of derivations, return a derivation based on
+DRV where all the 'car's of MAPPING have been replaced by its 'cdr's,
+recursively."
+  (define (substitute str initial replacements)
+    (fold (lambda (path replacement result)
+            (string-replace-substring result path
+                                      replacement))
+          str
+          initial replacements))
+
+  (define (substitute-file file initial replacements)
+    (define contents
+      (with-fluids ((%default-port-encoding #f))
+        (call-with-input-file file get-string-all)))
+
+    (let ((updated (substitute contents initial replacements)))
+      (if (string=? updated contents)
+          file
+          ;; XXX: permissions aren't preserved.
+          (add-text-to-store store (store-path-package-name file)
+                             updated))))
+
+  (define input->output-paths
+    (match-lambda
+     (((? derivation? drv))
+      (list (derivation->output-path drv)))
+     (((? derivation? drv) sub-drvs ...)
+      (map (cut derivation->output-path drv <>)
+           sub-drvs))
+     ((file)
+      (list file))))
+
+  (let ((mapping (fold (lambda (pair result)
+                         (match pair
+                           (((? derivation? orig) . replacement)
+                            (vhash-cons (derivation-file-name orig)
+                                        replacement result))
+                           ((file . replacement)
+                            (vhash-cons file replacement result))))
+                       vlist-null
+                       mapping)))
+    (define rewritten-input
+      ;; Rewrite the given input according to MAPPING, and return an input
+      ;; in the format used in 'derivation' calls.
+      (memoize
+       (lambda (input loop)
+         (match input
+           (($ <derivation-input> path (sub-drvs ...))
+            (match (vhash-assoc path mapping)
+              ((_ . (? derivation? replacement))
+               (cons replacement sub-drvs))
+              ((_ . replacement)
+               (list replacement))
+              (#f
+               (let* ((drv (loop (call-with-input-file path read-derivation))))
+                 (cons drv sub-drvs)))))))))
+
+    (let loop ((drv drv))
+      (let* ((inputs       (map (cut rewritten-input <> loop)
+                                (derivation-inputs drv)))
+             (initial      (append-map derivation-input-output-paths
+                                       (derivation-inputs drv)))
+             (replacements (append-map input->output-paths inputs))
+
+             ;; Sources typically refer to the output directories of the
+             ;; original inputs, INITIAL.  Rewrite them by substituting
+             ;; REPLACEMENTS.
+             (sources      (map (lambda (source)
+                                  (match (vhash-assoc source mapping)
+                                    ((_ . replacement)
+                                     replacement)
+                                    (#f
+                                     (substitute-file source
+                                                      initial replacements))))
+                                (derivation-sources drv)))
+
+             ;; Now augment the lists of initials and replacements.
+             (initial      (append (derivation-sources drv) initial))
+             (replacements (append sources replacements))
+             (name         (store-path-package-name
+                            (string-drop-right (derivation-file-name drv)
+                                               4))))
+        (derivation store name
+                    (substitute (derivation-builder drv)
+                                initial replacements)
+                    (map (cut substitute <> initial replacements)
+                         (derivation-builder-arguments drv))
+                    #:system system
+                    #:env-vars (map (match-lambda
+                                     ((var . value)
+                                      `(,var
+                                        . ,(substitute value initial
+                                                       replacements))))
+                                    (derivation-builder-environment-vars drv))
+                    #:inputs (append (map list sources) inputs)
+                    #:outputs (map car (derivation-outputs drv))
+                    #:hash (match (derivation-outputs drv)
+                             ((($ <derivation-output> _ algo hash))
+                              hash)
+                             (_ #f))
+                    #:hash-algo (match (derivation-outputs drv)
+                                  ((($ <derivation-output> _ algo hash))
+                                   algo)
+                                  (_ #f)))))))
+
 
 ;;;
 ;;; Store compatibility layer.
diff --git a/guix/packages.scm b/guix/packages.scm
index 9a2f08d862..c1247b71ac 100644
--- a/guix/packages.scm
+++ b/guix/packages.scm
@@ -224,24 +224,26 @@ corresponds to the arguments expected by `set-path-environment-variable'."
     (($ <location> file line column)
      (catch 'system
        (lambda ()
-         (call-with-input-file (search-path %load-path file)
-           (lambda (port)
-             (goto port line column)
-             (match (read port)
-               (('package inits ...)
-                (let ((field (assoc field inits)))
-                  (match field
-                    ((_ value)
-                     ;; Put the `or' here, and not in the first argument of
-                     ;; `and=>', to work around a compiler bug in 2.0.5.
-                     (or (and=> (source-properties value)
-                                source-properties->location)
-                         (and=> (source-properties field)
-                                source-properties->location)))
-                    (_
-                     #f))))
-               (_
-                #f)))))
+         ;; In general we want to keep relative file names for modules.
+         (with-fluids ((%file-port-name-canonicalization 'relative))
+           (call-with-input-file (search-path %load-path file)
+             (lambda (port)
+               (goto port line column)
+               (match (read port)
+                 (('package inits ...)
+                  (let ((field (assoc field inits)))
+                    (match field
+                      ((_ value)
+                       ;; Put the `or' here, and not in the first argument of
+                       ;; `and=>', to work around a compiler bug in 2.0.5.
+                       (or (and=> (source-properties value)
+                                  source-properties->location)
+                           (and=> (source-properties field)
+                                  source-properties->location)))
+                      (_
+                       #f))))
+                 (_
+                  #f))))))
        (lambda _
          #f)))
     (_ #f)))
@@ -419,7 +421,7 @@ IMPORTED-MODULES specify modules to use/import for use by SNIPPET."
                          #:modules modules
                          #:imported-modules modules
                          #:guile-for-build guile)))
-    ((and (? string?) (? store-path?) file)
+    ((and (? string?) (? direct-store-path?) file)
      file)
     ((? string? file)
      (add-to-store store (basename file) #t "sha256" file))))
diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm
index a06755dc7a..dd9a9b8127 100644
--- a/guix/scripts/build.scm
+++ b/guix/scripts/build.scm
@@ -23,6 +23,7 @@
   #:use-module (guix derivations)
   #:use-module (guix packages)
   #:use-module (guix utils)
+  #:use-module (guix monads)
   #:use-module (ice-9 format)
   #:use-module (ice-9 match)
   #:use-module (ice-9 vlist)
@@ -38,19 +39,23 @@
 (define %store
   (make-parameter #f))
 
-(define (derivations-from-package-expressions str package-derivation
-                                              system source?)
+(define (derivation-from-expression str package-derivation
+                                    system source?)
   "Read/eval STR and return the corresponding derivation path for SYSTEM.
-When SOURCE? is true, return the derivations of the package sources;
-otherwise, use PACKAGE-DERIVATION to compute the derivation of a package."
-  (let ((p (read/eval-package-expression str)))
-    (if source?
-        (let ((source (package-source p)))
-          (if source
-              (package-source-derivation (%store) source)
-              (leave (_ "package `~a' has no source~%")
-                     (package-name p))))
-        (package-derivation (%store) p system))))
+When SOURCE? is true and STR evaluates to a package, return the derivation of
+the package source; otherwise, use PACKAGE-DERIVATION to compute the
+derivation of a package."
+  (match (read/eval str)
+    ((? package? p)
+     (if source?
+         (let ((source (package-source p)))
+           (if source
+               (package-source-derivation (%store) source)
+               (leave (_ "package `~a' has no source~%")
+                      (package-name p))))
+         (package-derivation (%store) p system)))
+    ((? procedure? proc)
+     (run-with-store (%store) (proc) #:system system))))
 
 
 ;;;
@@ -68,7 +73,7 @@ otherwise, use PACKAGE-DERIVATION to compute the derivation of a package."
   (display (_ "Usage: guix build [OPTION]... PACKAGE-OR-DERIVATION...
 Build the given PACKAGE-OR-DERIVATION and return their output paths.\n"))
   (display (_ "
-  -e, --expression=EXPR  build the package EXPR evaluates to"))
+  -e, --expression=EXPR  build the package or derivation EXPR evaluates to"))
   (display (_ "
   -S, --source           build the packages' source derivations"))
   (display (_ "
@@ -95,6 +100,8 @@ Build the given PACKAGE-OR-DERIVATION and return their output paths.\n"))
                          as a garbage collector root"))
   (display (_ "
       --verbosity=LEVEL  use the given verbosity LEVEL"))
+  (display (_ "
+      --log-file         return the log file names for the given derivations"))
   (newline)
   (display (_ "
   -h, --help             display this help and exit"))
@@ -161,7 +168,10 @@ Build the given PACKAGE-OR-DERIVATION and return their output paths.\n"))
                 (lambda (opt name arg result)
                   (let ((level (string->number arg)))
                     (alist-cons 'verbosity level
-                                (alist-delete 'verbosity result)))))))
+                                (alist-delete 'verbosity result)))))
+        (option '("log-file") #f #f
+                (lambda (opt name arg result)
+                  (alist-cons 'log-file? #t result)))))
 
 
 ;;;
@@ -235,68 +245,89 @@ Build the given PACKAGE-OR-DERIVATION and return their output paths.\n"))
              (leave (_ "~A: unknown package~%") name))))))
 
   (with-error-handling
-    (let ((opts (parse-options)))
-      (define package->derivation
-        (match (assoc-ref opts 'target)
-          (#f package-derivation)
-          (triplet
-           (cut package-cross-derivation <> <> triplet <>))))
+    ;; Ask for absolute file names so that .drv file names passed from the
+    ;; user to 'read-derivation' are absolute when it returns.
+    (with-fluids ((%file-port-name-canonicalization 'absolute))
+      (let ((opts (parse-options)))
+        (define package->derivation
+          (match (assoc-ref opts 'target)
+            (#f package-derivation)
+            (triplet
+             (cut package-cross-derivation <> <> triplet <>))))
 
-      (parameterize ((%store (open-connection)))
-        (let* ((src? (assoc-ref opts 'source?))
-               (sys  (assoc-ref opts 'system))
-               (drv  (filter-map (match-lambda
-                                  (('expression . str)
-                                   (derivations-from-package-expressions
-                                    str package->derivation sys src?))
-                                  (('argument . (? derivation-path? drv))
-                                   (call-with-input-file drv read-derivation))
-                                  (('argument . (? string? x))
-                                   (let ((p (find-package x)))
-                                     (if src?
-                                         (let ((s (package-source p)))
-                                           (package-source-derivation
-                                            (%store) s))
-                                         (package->derivation (%store) p sys))))
-                                  (_ #f))
-                                 opts))
-               (roots (filter-map (match-lambda
-                                   (('gc-root . root) root)
-                                   (_ #f))
-                                  opts)))
+        (parameterize ((%store (open-connection)))
+          (let* ((src? (assoc-ref opts 'source?))
+                 (sys  (assoc-ref opts 'system))
+                 (drv  (filter-map (match-lambda
+                                    (('expression . str)
+                                     (derivation-from-expression
+                                      str package->derivation sys src?))
+                                    (('argument . (? derivation-path? drv))
+                                     (call-with-input-file drv read-derivation))
+                                    (('argument . (? store-path?))
+                                     ;; Nothing to do; maybe for --log-file.
+                                     #f)
+                                    (('argument . (? string? x))
+                                     (let ((p (find-package x)))
+                                       (if src?
+                                           (let ((s (package-source p)))
+                                             (package-source-derivation
+                                              (%store) s))
+                                           (package->derivation (%store) p sys))))
+                                    (_ #f))
+                                   opts))
+                 (roots (filter-map (match-lambda
+                                     (('gc-root . root) root)
+                                     (_ #f))
+                                    opts)))
 
-          (show-what-to-build (%store) drv
-                              #:use-substitutes? (assoc-ref opts 'substitutes?)
-                              #:dry-run? (assoc-ref opts 'dry-run?))
+            (unless (assoc-ref opts 'log-file?)
+              (show-what-to-build (%store) drv
+                                  #:use-substitutes? (assoc-ref opts 'substitutes?)
+                                  #:dry-run? (assoc-ref opts 'dry-run?)))
 
-          ;; TODO: Add more options.
-          (set-build-options (%store)
-                             #:keep-failed? (assoc-ref opts 'keep-failed?)
-                             #:build-cores (or (assoc-ref opts 'cores) 0)
-                             #:fallback? (assoc-ref opts 'fallback?)
-                             #:use-substitutes? (assoc-ref opts 'substitutes?)
-                             #:max-silent-time (assoc-ref opts 'max-silent-time)
-                             #:verbosity (assoc-ref opts 'verbosity))
+            ;; TODO: Add more options.
+            (set-build-options (%store)
+                               #:keep-failed? (assoc-ref opts 'keep-failed?)
+                               #:build-cores (or (assoc-ref opts 'cores) 0)
+                               #:fallback? (assoc-ref opts 'fallback?)
+                               #:use-substitutes? (assoc-ref opts 'substitutes?)
+                               #:max-silent-time (assoc-ref opts 'max-silent-time)
+                               #:verbosity (assoc-ref opts 'verbosity))
 
-          (if (assoc-ref opts 'derivations-only?)
-              (begin
-                (format #t "~{~a~%~}" (map derivation-file-name drv))
-                (for-each (cut register-root <> <>)
-                          (map (compose list derivation-file-name) drv)
-                          roots))
-              (or (assoc-ref opts 'dry-run?)
-                  (and (build-derivations (%store) drv)
-                       (for-each (lambda (d)
-                                   (format #t "~{~a~%~}"
-                                           (map (match-lambda
-                                                 ((out-name . out)
-                                                  (derivation->output-path
-                                                   d out-name)))
-                                                (derivation-outputs d))))
-                                 drv)
-                       (for-each (cut register-root <> <>)
-                                 (map (lambda (drv)
-                                        (map cdr
-                                             (derivation->output-paths drv)))
-                                      drv)
-                                 roots)))))))))
+            (cond ((assoc-ref opts 'log-file?)
+                   (for-each (lambda (file)
+                               (let ((log (log-file (%store) file)))
+                                 (if log
+                                     (format #t "~a~%" log)
+                                     (leave (_ "no build log for '~a'~%")
+                                            file))))
+                             (delete-duplicates
+                              (append (map derivation-file-name drv)
+                                      (filter-map (match-lambda
+                                                   (('argument
+                                                     . (? store-path? file))
+                                                    file)
+                                                   (_ #f))
+                                                  opts)))))
+                  ((assoc-ref opts 'derivations-only?)
+                   (format #t "~{~a~%~}" (map derivation-file-name drv))
+                   (for-each (cut register-root <> <>)
+                             (map (compose list derivation-file-name) drv)
+                             roots))
+                  ((not (assoc-ref opts 'dry-run?))
+                   (and (build-derivations (%store) drv)
+                        (for-each (lambda (d)
+                                    (format #t "~{~a~%~}"
+                                            (map (match-lambda
+                                                  ((out-name . out)
+                                                   (derivation->output-path
+                                                    d out-name)))
+                                                 (derivation-outputs d))))
+                                  drv)
+                        (for-each (cut register-root <> <>)
+                                  (map (lambda (drv)
+                                         (map cdr
+                                              (derivation->output-paths drv)))
+                                       drv)
+                                  roots))))))))))
diff --git a/guix/scripts/substitute-binary.scm b/guix/scripts/substitute-binary.scm
index 1afc93bbc9..83e3d25dba 100755
--- a/guix/scripts/substitute-binary.scm
+++ b/guix/scripts/substitute-binary.scm
@@ -123,7 +123,8 @@ again."
               (lambda ()
                 body ...)
               (lambda args
-                ;; The SIGALRM triggers EINTR, because of the bug at
+                ;; Before Guile v2.0.9-39-gfe51c7b, the SIGALRM triggers EINTR
+                ;; because of the bug at
                 ;; <http://lists.gnu.org/archive/html/guile-devel/2013-06/msg00050.html>.
                 ;; When that happens, try again.  Note: SA_RESTART cannot be
                 ;; used because of <http://bugs.gnu.org/14640>.
@@ -162,10 +163,17 @@ provide."
            (warning (_ "while fetching ~a: server is unresponsive~%")
                     (uri->string uri))
            (warning (_ "try `--no-substitutes' if the problem persists~%"))
-           (when port
-             (close-port port)))
+
+           ;; Before Guile v2.0.9-39-gfe51c7b, EINTR was reported to the user,
+           ;; and thus PORT had to be closed and re-opened.  This is not the
+           ;; case afterward.
+           (unless (or (guile-version>? "2.0.9")
+                       (version>? (version) "2.0.9.39"))
+             (when port
+               (close-port port))))
          (begin
-           (set! port (open-socket-for-uri uri #:buffered? buffered?))
+           (when (or (not port) (port-closed? port))
+             (set! port (open-socket-for-uri uri #:buffered? buffered?)))
            (http-fetch uri #:text? #f #:port port)))))))
 
 (define-record-type <cache>
@@ -290,6 +298,12 @@ reading PORT."
   (time>? (subtract-duration now (make-time time-duration 0 ttl))
           (make-time time-monotonic 0 date)))
 
+(define %lookup-threads
+  ;; Number of threads spawned to perform lookup operations.  This means we
+  ;; can have this many simultaneous HTTP GET requests to the server, which
+  ;; limits the impact of connection latency.
+  20)
+
 (define (lookup-narinfo cache path)
   "Check locally if we have valid info about PATH, otherwise go to CACHE and
 check what it has."
@@ -489,8 +503,9 @@ Internal tool to substitute a pre-built binary to a local build.\n"))
                    ;; Return the subset of PATHS available in CACHE.
                    (let ((substitutable
                           (if cache
-                              (par-map (cut lookup-narinfo cache <>)
-                                       paths)
+                              (n-par-map %lookup-threads
+                                         (cut lookup-narinfo cache <>)
+                                         paths)
                               '())))
                      (for-each (lambda (narinfo)
                                  (when narinfo
@@ -501,8 +516,9 @@ Internal tool to substitute a pre-built binary to a local build.\n"))
                    ;; Reply info about PATHS if it's in CACHE.
                    (let ((substitutable
                           (if cache
-                              (par-map (cut lookup-narinfo cache <>)
-                                       paths)
+                              (n-par-map %lookup-threads
+                                         (cut lookup-narinfo cache <>)
+                                         paths)
                               '())))
                      (for-each (lambda (narinfo)
                                  (format #t "~a\n~a\n~a\n"
diff --git a/guix/store.scm b/guix/store.scm
index 0f1e2f9466..2821cacdcc 100644
--- a/guix/store.scm
+++ b/guix/store.scm
@@ -85,9 +85,11 @@
 
             %store-prefix
             store-path?
+            direct-store-path?
             derivation-path?
             store-path-package-name
-            store-path-hash-part))
+            store-path-hash-part
+            log-file))
 
 (define %protocol-version #x10c)
 
@@ -639,6 +641,14 @@ collected, and the number of bytes freed."
   ;; `isStorePath' in Nix does something similar.
   (string-prefix? (%store-prefix) path))
 
+(define (direct-store-path? path)
+  "Return #t if PATH is a store path, and not a sub-directory of a store path.
+This predicate is sometimes needed because files *under* a store path are not
+valid inputs."
+  (and (store-path? path)
+       (let ((len (+ 1 (string-length (%store-prefix)))))
+         (not (string-index (substring path len) #\/)))))
+
 (define (derivation-path? path)
   "Return #t if PATH is a derivation path."
   (and (store-path? path) (string-suffix? ".drv" path)))
@@ -660,3 +670,23 @@ syntactically valid store path."
                                 "/([0-9a-df-np-sv-z]{32})-[^/]+$"))))
     (and=> (regexp-exec path-rx path)
            (cut match:substring <> 1))))
+
+(define (log-file store file)
+  "Return the build log file for FILE, or #f if none could be found.  FILE
+must be an absolute store file name, or a derivation file name."
+  (define state-dir                               ; XXX: factorize
+    (or (getenv "NIX_STATE_DIR") %state-directory))
+
+  (cond ((derivation-path? file)
+         (let* ((base (basename file))
+                (log  (string-append (dirname state-dir) ; XXX: ditto
+                                     "/log/nix/drvs/"
+                                     (string-take base 2) "/"
+                                     (string-drop base 2) ".bz2")))
+           (and (file-exists? log) log)))
+        (else
+         (match (valid-derivers store file)
+           ((derivers ...)
+            ;; Return the first that works.
+            (any (cut log-file store <>) derivers))
+           (_ #f)))))
diff --git a/guix/ui.scm b/guix/ui.scm
index 8a28574c3c..f15419f7a8 100644
--- a/guix/ui.scm
+++ b/guix/ui.scm
@@ -45,6 +45,7 @@
             show-what-to-build
             call-with-error-handling
             with-error-handling
+            read/eval
             read/eval-package-expression
             location->string
             switch-symlinks
@@ -193,25 +194,29 @@ General help using GNU software: <http://www.gnu.org/gethelp/>"))
         (leave (_ "~a~%")
                (strerror (system-error-errno args)))))))
 
-(define (read/eval-package-expression str)
-  "Read and evaluate STR and return the package it refers to, or exit an
-error."
+(define (read/eval str)
+  "Read and evaluate STR, raising an error if something goes wrong."
   (let ((exp (catch #t
                (lambda ()
                  (call-with-input-string str read))
                (lambda args
                  (leave (_ "failed to read expression ~s: ~s~%")
                         str args)))))
-    (let ((p (catch #t
-               (lambda ()
-                 (eval exp the-scm-module))
-               (lambda args
-                 (leave (_ "failed to evaluate expression `~a': ~s~%")
-                        exp args)))))
-      (if (package? p)
-          p
-          (leave (_ "expression `~s' does not evaluate to a package~%")
-                 exp)))))
+    (catch #t
+      (lambda ()
+        (eval exp the-scm-module))
+      (lambda args
+        (leave (_ "failed to evaluate expression `~a': ~s~%")
+               exp args)))))
+
+(define (read/eval-package-expression str)
+  "Read and evaluate STR and return the package it refers to, or exit an
+error."
+  (match (read/eval str)
+    ((? package? p) p)
+    (_
+     (leave (_ "expression ~s does not evaluate to a package~%")
+            str))))
 
 (define* (show-what-to-build store drv
                              #:key dry-run? (use-substitutes? #t))
diff --git a/guix/utils.scm b/guix/utils.scm
index 1f3c0c8ad6..b730340eda 100644
--- a/guix/utils.scm
+++ b/guix/utils.scm
@@ -1,5 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2012, 2013 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2013 Mark H Weaver <mhw@netris.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -62,6 +63,7 @@
             guile-version>?
             package-name->name+version
             string-tokenize*
+            string-replace-substring
             file-extension
             file-sans-extension
             call-with-temporary-output-file
@@ -387,6 +389,28 @@ like `string-tokenize', but SEPARATOR is a string."
           (else
            (reverse (cons string result))))))
 
+(define* (string-replace-substring str substr replacement
+                                   #:optional
+                                   (start 0)
+                                   (end (string-length str)))
+  "Replace all occurrences of SUBSTR in the START--END range of STR by
+REPLACEMENT."
+  (match (string-length substr)
+    (0
+     (error "string-replace-substring: empty substring"))
+    (substr-length
+     (let loop ((start  start)
+                (pieces (list (substring str 0 start))))
+       (match (string-contains str substr start end)
+         (#f
+          (string-concatenate-reverse
+           (cons (substring str start) pieces)))
+         (index
+          (loop (+ index substr-length)
+                (cons* replacement
+                       (substring str start index)
+                       pieces))))))))
+
 (define (call-with-temporary-output-file proc)
   "Call PROC with a name of a temporary file and open output port to that
 file; close the file and delete it when leaving the dynamic extent of this