Merge branch 'core-updates'

Conflicts:
	guix/build/union.scm

6 files changed, 326 insertions, 79 deletions

diff --git a/guix/build-system/gnu.scm b/guix/build-system/gnu.scm
index 4d247b04e1..a3a770f631 100644
--- a/guix/build-system/gnu.scm
+++ b/guix/build-system/gnu.scm
@@ -21,6 +21,7 @@
   #:use-module (guix utils)
   #:use-module (guix derivations)
   #:use-module (guix build-system)
+  #:use-module (guix build-system gnu)
   #:use-module (guix packages)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-39)
@@ -29,7 +30,8 @@
             gnu-build-system
             package-with-explicit-inputs
             package-with-extra-configure-variable
-            static-libgcc-package))
+            static-libgcc-package
+            static-package))
 
 ;; Commentary:
 ;;
@@ -117,6 +119,28 @@ configure flags for VARIABLE, the associated value is augmented."
   "A version of P linked with `-static-gcc'."
   (package-with-extra-configure-variable p "LDFLAGS" "-static-libgcc"))
 
+(define* (static-package p #:optional (loc (current-source-location)))
+  "Return a statically-linked version of package P."
+  (let ((args (package-arguments p)))
+    (package (inherit p)
+      (location (source-properties->location loc))
+      (arguments
+       (let ((augment (lambda (args)
+                        (let ((a (default-keyword-arguments args
+                                   '(#:configure-flags '()
+                                     #:strip-flags #f))))
+                          (substitute-keyword-arguments a
+                            ((#:configure-flags flags)
+                             `(cons* "--disable-shared"
+                                     "LDFLAGS=-static"
+                                     ,flags))
+                            ((#:strip-flags _)
+                             ''("--strip-all")))))))
+         (if (procedure? args)
+             (lambda x
+               (augment (apply args x)))
+             (augment args)))))))
+
 
 (define %store
   ;; Store passed to STANDARD-INPUTS.
@@ -152,6 +176,7 @@ System: GCC, GNU Make, Bash, Coreutils, etc."
                     (out-of-source? #f)
                     (path-exclusions ''())
                     (tests? #t)
+                    (test-target "check")
                     (parallel-build? #t) (parallel-tests? #t)
                     (patch-shebangs? #t)
                     (strip-binaries? #t)
@@ -193,6 +218,7 @@ which could lead to gratuitous input divergence."
                   #:out-of-source? ,out-of-source?
                   #:path-exclusions ,path-exclusions
                   #:tests? ,tests?
+                  #:test-target ,test-target
                   #:parallel-build? ,parallel-build?
                   #:parallel-tests? ,parallel-tests?
                   #:patch-shebangs? ,patch-shebangs?
diff --git a/guix/build/download.scm b/guix/build/download.scm
index 074315cc9f..09c62541de 100644
--- a/guix/build/download.scm
+++ b/guix/build/download.scm
@@ -1,20 +1,20 @@
-;;; Guix --- Nix package management from Guile.         -*- coding: utf-8 -*-
-;;; Copyright (C) 2012 Ludovic Courtès <ludo@gnu.org>
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2012, 2013 Ludovic Courtès <ludo@gnu.org>
 ;;;
-;;; This file is part of Guix.
+;;; This file is part of GNU Guix.
 ;;;
-;;; Guix is free software; you can redistribute it and/or modify it
+;;; GNU Guix is free software; you can redistribute it and/or modify it
 ;;; under the terms of the GNU General Public License as published by
 ;;; the Free Software Foundation; either version 3 of the License, or (at
 ;;; your option) any later version.
 ;;;
-;;; Guix is distributed in the hope that it will be useful, but
+;;; GNU Guix is distributed in the hope that it will be useful, but
 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 ;;; GNU General Public License for more details.
 ;;;
 ;;; You should have received a copy of the GNU General Public License
-;;; along with Guix.  If not, see <http://www.gnu.org/licenses/>.
+;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
 
 (define-module (guix build download)
   #:use-module (web uri)
@@ -27,6 +27,7 @@
   #:use-module (srfi srfi-11)
   #:use-module (srfi srfi-26)
   #:use-module (ice-9 match)
+  #:use-module (ice-9 format)
   #:export (url-fetch))
 
 ;;; Commentary:
@@ -35,17 +36,58 @@
 ;;;
 ;;; Code:
 
+(define* (progress-proc file size #:optional (log-port (current-output-port)))
+  "Return a procedure to show the progress of FILE's download, which is
+SIZE byte long.  The returned procedure is suitable for use as an
+argument to `dump-port'.  The progress report is written to LOG-PORT."
+  (if (number? size)
+      (lambda (transferred cont)
+        (let ((% (* 100.0 (/ transferred size))))
+          (display #\cr log-port)
+          (format log-port "~a\t~5,1f% of ~,1f KiB"
+                  file % (/ size 1024.0))
+          (flush-output-port log-port)
+          (cont)))
+      (lambda (transferred cont)
+        (display #\cr log-port)
+        (format log-port "~a\t~6,1f KiB transferred"
+                file (/ transferred 1024.0))
+        (flush-output-port log-port)
+        (cont))))
+
+(define* (uri-abbreviation uri #:optional (max-length 42))
+  "If URI's string representation is larger than MAX-LENGTH, return an
+abbreviation of URI showing the scheme, host, and basename of the file."
+  (define uri-as-string
+    (uri->string uri))
+
+  (define (elide-path)
+    (let ((path (uri-path uri)))
+      (string-append (symbol->string (uri-scheme uri))
+                     "://" (uri-host uri)
+                     (string-append "/.../" (basename path)))))
+
+  (if (> (string-length uri-as-string) max-length)
+      (let ((short (elide-path)))
+        (if (< (string-length short) (string-length uri-as-string))
+            short
+            uri-as-string))
+      uri-as-string))
+
 (define (ftp-fetch uri file)
   "Fetch data from URI and write it to FILE.  Return FILE on success."
   (let* ((conn (ftp-open (uri-host uri)))
+         (size (false-if-exception (ftp-size conn (uri-path uri))))
          (in   (ftp-retr conn (basename (uri-path uri))
                          (dirname (uri-path uri)))))
     (call-with-output-file file
       (lambda (out)
-        ;; TODO: Show a progress bar.
-        (dump-port in out)))
+        (dump-port in out
+                   #:buffer-size 65536            ; don't flood the log
+                   #:progress (progress-proc (uri-abbreviation uri) size))))
 
     (ftp-close conn))
+    (newline)
   file)
 
 (define (open-connection-for-uri uri)
@@ -103,20 +145,34 @@ which is not available during bootstrap."
 (define (http-fetch uri file)
   "Fetch data from URI and write it to FILE.  Return FILE on success."
 
-  ;; FIXME: Use a variant of `http-get' that returns a port instead of
-  ;; loading everything in memory.
   (let*-values (((connection)
                  (open-connection-for-uri uri))
-                ((resp bv)
-                 (http-get uri #:port connection #:decode-body? #f))
+                ((resp bv-or-port)
+                 ;; XXX: `http-get*' was introduced in 2.0.7.  We know
+                 ;; we're using it within the chroot, but
+                 ;; `guix-download' might be using a different version.
+                 ;; So keep this compatibility hack for now.
+                 (if (module-defined? (resolve-interface '(web client))
+                                      'http-get*)
+                     (http-get* uri #:port connection #:decode-body? #f)
+                     (http-get uri #:port connection #:decode-body? #f)))
                 ((code)
-                 (response-code resp)))
+                 (response-code resp))
+                ((size)
+                 (response-content-length resp)))
     (case code
       ((200)                                      ; OK
        (begin
          (call-with-output-file file
            (lambda (p)
-             (put-bytevector p bv)))
+             (if (port? bv-or-port)
+                 (begin
+                   (dump-port bv-or-port p
+                              #:buffer-size 65536  ; don't flood the log
+                              #:progress (progress-proc (uri-abbreviation uri)
+                                                        size))
+                   (newline))
+                 (put-bytevector p bv-or-port))))
          file))
       ((302)                                      ; found (redirection)
        (let ((uri (response-location resp)))
diff --git a/guix/build/gnu-build-system.scm b/guix/build/gnu-build-system.scm
index 2b7d1c180e..b7b9fdac95 100644
--- a/guix/build/gnu-build-system.scm
+++ b/guix/build/gnu-build-system.scm
@@ -1,25 +1,26 @@
-;;; Guix --- Nix package management from Guile.         -*- coding: utf-8 -*-
-;;; Copyright (C) 2012 Ludovic Courtès <ludo@gnu.org>
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2012, 2013 Ludovic Courtès <ludo@gnu.org>
 ;;;
-;;; This file is part of Guix.
+;;; This file is part of GNU Guix.
 ;;;
-;;; Guix is free software; you can redistribute it and/or modify it
+;;; GNU Guix is free software; you can redistribute it and/or modify it
 ;;; under the terms of the GNU General Public License as published by
 ;;; the Free Software Foundation; either version 3 of the License, or (at
 ;;; your option) any later version.
 ;;;
-;;; Guix is distributed in the hope that it will be useful, but
+;;; GNU Guix is distributed in the hope that it will be useful, but
 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 ;;; GNU General Public License for more details.
 ;;;
 ;;; You should have received a copy of the GNU General Public License
-;;; along with Guix.  If not, see <http://www.gnu.org/licenses/>.
+;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
 
 (define-module (guix build gnu-build-system)
   #:use-module (guix build utils)
   #:use-module (ice-9 ftw)
   #:use-module (ice-9 match)
+  #:use-module (ice-9 format)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-26)
   #:export (%standard-phases
@@ -82,6 +83,28 @@
   (and (zero? (system* "tar" "xvf" source))
        (chdir (first-subdirectory "."))))
 
+(define* (patch-source-shebangs #:key source #:allow-other-keys)
+  "Patch shebangs in all source files; this includes non-executable
+files such as `.in' templates.  Most scripts honor $SHELL and
+$CONFIG_SHELL, but some don't, such as `mkinstalldirs' or Automake's
+`missing' script."
+  (for-each patch-shebang
+            (remove file-is-directory? (find-files "." ".*"))))
+
+(define (patch-generated-file-shebangs . rest)
+  "Patch shebangs in generated files, including `SHELL' variables in
+makefiles."
+  ;; Patch executable files, some of which might have been generated by
+  ;; `configure'.
+  (for-each patch-shebang
+            (filter (lambda (file)
+                      (and (executable-file? file)
+                           (not (file-is-directory? file))))
+                    (find-files "." ".*")))
+
+  ;; Patch `SHELL' in generated makefiles.
+  (for-each patch-makefile-SHELL (find-files "." "^(GNU)?[mM]akefile$")))
+
 (define* (patch #:key (patches '()) (patch-flags '("--batch" "-p1"))
                 #:allow-other-keys)
   (every (lambda (p)
@@ -90,23 +113,51 @@
                          (append patch-flags (list "--input" p)))))
          patches))
 
-(define* (configure #:key outputs (configure-flags '()) out-of-source?
+(define* (configure #:key inputs outputs (configure-flags '()) out-of-source?
                     #:allow-other-keys)
+  (define (package-name)
+    (let* ((out  (assoc-ref outputs "out"))
+           (base (basename out))
+           (dash (string-rindex base #\-)))
+      ;; XXX: We'd rather use `package-name->name+version' or similar.
+      (if dash
+          (substring base 0 dash)
+          base)))
+
   (let* ((prefix     (assoc-ref outputs "out"))
+         (bindir     (assoc-ref outputs "bin"))
          (libdir     (assoc-ref outputs "lib"))
          (includedir (assoc-ref outputs "include"))
-         (flags      `(,(string-append "--prefix=" prefix)
+         (docdir     (assoc-ref outputs "doc"))
+         (bash       (or (and=> (assoc-ref inputs "bash")
+                                (cut string-append <> "/bin/bash"))
+                         "/bin/sh"))
+         (flags      `(,(string-append "CONFIG_SHELL=" bash)
+                       ,(string-append "SHELL=" bash)
+                       ,(string-append "--prefix=" prefix)
                        "--enable-fast-install"    ; when using Libtool
 
                        ;; Produce multiple outputs when specific output names
                        ;; are recognized.
+                       ,@(if bindir
+                              (list (string-append "--bindir=" bindir "/bin"))
+                              '())
                        ,@(if libdir
-                              (list (string-append "--libdir=" libdir "/lib"))
+                              (cons (string-append "--libdir=" libdir "/lib")
+                                    (if includedir
+                                        '()
+                                        (list
+                                         (string-append "--includedir="
+                                                        libdir "/include"))))
                               '())
                        ,@(if includedir
                              (list (string-append "--includedir="
                                                   includedir "/include"))
                              '())
+                       ,@(if docdir
+                             (list (string-append "--docdir=" docdir
+                                                  "/doc/" (package-name)))
+                             '())
                        ,@configure-flags))
          (abs-srcdir (getcwd))
          (srcdir     (if out-of-source?
@@ -121,10 +172,15 @@
     (format #t "build directory: ~s~%" (getcwd))
     (format #t "configure flags: ~s~%" flags)
 
+    ;; Use BASH to reduce reliance on /bin/sh since it may not always be
+    ;; reliable (see
+    ;; <http://thread.gmane.org/gmane.linux.distributions.nixos/9748>
+    ;; for a summary of the situation.)
+    ;;
     ;; Call `configure' with a relative path.  Otherwise, GCC's build system
     ;; (for instance) records absolute source file names, which typically
     ;; contain the hash part of the `.drv' file, leading to a reference leak.
-    (zero? (apply system*
+    (zero? (apply system* bash
                   (string-append srcdir "/configure")
                   flags))))
 
@@ -221,7 +277,9 @@
   ;; Standard build phases, as a list of symbol/procedure pairs.
   (let-syntax ((phases (syntax-rules ()
                          ((_ p ...) `((p . ,p) ...)))))
-    (phases set-paths unpack patch configure build check install
+    (phases set-paths unpack patch
+            patch-source-shebangs configure patch-generated-file-shebangs
+            build check install
             patch-shebangs strip)))
 
 
@@ -232,11 +290,17 @@
   "Build from SOURCE to OUTPUTS, using INPUTS, and by running all of PHASES
 in order.  Return #t if all the PHASES succeeded, #f otherwise."
   (setvbuf (current-output-port) _IOLBF)
+  (setvbuf (current-error-port) _IOLBF)
 
   ;; The trick is to #:allow-other-keys everywhere, so that each procedure in
   ;; PHASES can pick the keyword arguments it's interested in.
   (every (match-lambda
           ((name . proc)
-           (format #t "starting phase `~a'~%" name)
-           (apply proc args)))
+           (let ((start (gettimeofday)))
+            (format #t "starting phase `~a'~%" name)
+            (let ((result (apply proc args))
+                  (end    (gettimeofday)))
+              (format #t "phase `~a' ~:[failed~;succeeded~] after ~a seconds~%"
+                      name result (- (car end) (car start)))
+              result))))
          phases))
diff --git a/guix/build/union.scm b/guix/build/union.scm
index d1578a6ef5..234964dba5 100644
--- a/guix/build/union.scm
+++ b/guix/build/union.scm
@@ -1,20 +1,20 @@
-;;; Guix --- Nix package management from Guile.         -*- coding: utf-8 -*-
-;;; Copyright (C) 2012, 2013 Ludovic Courtès <ludo@gnu.org>
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2012, 2013 Ludovic Courtès <ludo@gnu.org>
 ;;;
-;;; This file is part of Guix.
+;;; This file is part of GNU Guix.
 ;;;
-;;; Guix is free software; you can redistribute it and/or modify it
+;;; GNU Guix is free software; you can redistribute it and/or modify it
 ;;; under the terms of the GNU General Public License as published by
 ;;; the Free Software Foundation; either version 3 of the License, or (at
 ;;; your option) any later version.
 ;;;
-;;; Guix is distributed in the hope that it will be useful, but
+;;; GNU Guix is distributed in the hope that it will be useful, but
 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 ;;; GNU General Public License for more details.
 ;;;
 ;;; You should have received a copy of the GNU General Public License
-;;; along with Guix.  If not, see <http://www.gnu.org/licenses/>.
+;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
 
 (define-module (guix build union)
   #:use-module (ice-9 ftw)
diff --git a/guix/build/utils.scm b/guix/build/utils.scm
index 8ae190f656..6921e31bdd 100644
--- a/guix/build/utils.scm
+++ b/guix/build/utils.scm
@@ -1,20 +1,20 @@
-;;; Guix --- Nix package management from Guile.         -*- coding: utf-8 -*-
-;;; Copyright (C) 2012 Ludovic Courtès <ludo@gnu.org>
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2012, 2013 Ludovic Courtès <ludo@gnu.org>
 ;;;
-;;; This file is part of Guix.
+;;; This file is part of GNU Guix.
 ;;;
-;;; Guix is free software; you can redistribute it and/or modify it
+;;; GNU Guix is free software; you can redistribute it and/or modify it
 ;;; under the terms of the GNU General Public License as published by
 ;;; the Free Software Foundation; either version 3 of the License, or (at
 ;;; your option) any later version.
 ;;;
-;;; Guix is distributed in the hope that it will be useful, but
+;;; GNU Guix is distributed in the hope that it will be useful, but
 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 ;;; GNU General Public License for more details.
 ;;;
 ;;; You should have received a copy of the GNU General Public License
-;;; along with Guix.  If not, see <http://www.gnu.org/licenses/>.
+;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
 
 (define-module (guix build utils)
   #:use-module (srfi srfi-1)
@@ -26,6 +26,8 @@
   #:use-module (rnrs bytevectors)
   #:use-module (rnrs io ports)
   #:export (directory-exists?
+            executable-file?
+            call-with-ascii-input-file
             with-directory-excursion
             mkdir-p
             copy-recursively
@@ -34,6 +36,8 @@
             set-path-environment-variable
             search-path-as-string->list
             list->search-path-as-string
+            which
+
             alist-cons-before
             alist-cons-after
             alist-replace
@@ -41,7 +45,9 @@
             substitute
             substitute*
             dump-port
+            set-file-time
             patch-shebang
+            patch-makefile-SHELL
             fold-port-matches
             remove-store-references))
 
@@ -56,6 +62,27 @@
     (and s
          (eq? 'directory (stat:type s)))))
 
+(define (executable-file? file)
+  "Return #t if FILE exists and is executable."
+  (let ((s (stat file #f)))
+    (and s
+         (not (zero? (logand (stat:mode s) #o100))))))
+
+(define (call-with-ascii-input-file file proc)
+  "Open FILE as an ASCII or binary file, and pass the resulting port to
+PROC.  FILE is closed when PROC's dynamic extent is left.  Return the
+return values of applying PROC to the port."
+  (let ((port (with-fluids ((%default-port-encoding #f))
+                ;; Use "b" so that `open-file' ignores `coding:' cookies.
+                (open-file file "rb"))))
+    (dynamic-wind
+      (lambda ()
+        #t)
+      (lambda ()
+        (proc port))
+      (lambda ()
+        (close-input-port port)))))
+
 (define-syntax-rule (with-directory-excursion dir body ...)
   "Run BODY with DIR as the process's current directory."
   (let ((init (getcwd)))
@@ -189,6 +216,12 @@ SEPARATOR-separated path accordingly.  Example:
    (format #t "environment variable `~a' set to `~a'~%"
            env-var value)))
 
+(define (which program)
+  "Return the complete file name for PROGRAM as found in $PATH, or #f if
+PROGRAM could not be found."
+  (search-path (search-path-as-string->list (getenv "PATH"))
+               program))
+
 
 ;;;
 ;;; Phases.
@@ -364,29 +397,49 @@ all subject to the substitutions."
 ;;; Patching shebangs---e.g., /bin/sh -> /nix/store/xyz...-bash/bin/sh.
 ;;;
 
-(define (dump-port in out)
-  "Read as much data as possible from IN and write it to OUT."
-  (define buffer-size 4096)
+(define* (dump-port in out
+                    #:key (buffer-size 16384)
+                    (progress (lambda (t k) (k))))
+  "Read as much data as possible from IN and write it to OUT, using
+chunks of BUFFER-SIZE bytes.  Call PROGRESS after each successful
+transfer of BUFFER-SIZE bytes or less, passing it the total number of
+bytes transferred and the continuation of the transfer as a thunk."
   (define buffer
     (make-bytevector buffer-size))
 
-  (let loop ((bytes (get-bytevector-n! in buffer 0 buffer-size)))
+  (let loop ((total 0)
+             (bytes (get-bytevector-n! in buffer 0 buffer-size)))
     (or (eof-object? bytes)
-        (begin
+        (let ((total (+ total bytes)))
           (put-bytevector out buffer 0 bytes)
-          (loop (get-bytevector-n! in buffer 0 buffer-size))))))
+          (progress total
+                    (lambda ()
+                      (loop total
+                            (get-bytevector-n! in buffer 0 buffer-size))))))))
+
+(define (set-file-time file stat)
+  "Set the atime/mtime of FILE to that specified by STAT."
+  (utime file
+         (stat:atime stat)
+         (stat:mtime stat)
+         (stat:atimensec stat)
+         (stat:mtimensec stat)))
 
 (define patch-shebang
   (let ((shebang-rx (make-regexp "^[[:blank:]]*([[:graph:]]+)(.*)$")))
     (lambda* (file
-              #:optional (path (search-path-as-string->list (getenv "PATH"))))
+              #:optional
+              (path (search-path-as-string->list (getenv "PATH")))
+              #:key (keep-mtime? #t))
       "Replace the #! interpreter file name in FILE by a valid one found in
 PATH, when FILE actually starts with a shebang.  Return #t when FILE was
-patched, #f otherwise."
+patched, #f otherwise.  When KEEP-MTIME? is true, the atime/mtime of
+FILE are kept unchanged."
       (define (patch p interpreter rest-of-line)
         (let* ((template (string-append file ".XXXXXX"))
                (out      (mkstemp! template))
-               (mode     (stat:mode (stat file))))
+               (st       (stat file))
+               (mode     (stat:mode st)))
           (with-throw-handler #t
             (lambda ()
               (format out "#!~a~a~%"
@@ -395,6 +448,8 @@ patched, #f otherwise."
               (close out)
               (chmod template mode)
               (rename-file template file)
+              (when keep-mtime?
+                (set-file-time file st))
               #t)
             (lambda (key . args)
               (format (current-error-port)
@@ -403,30 +458,60 @@ patched, #f otherwise."
               (false-if-exception (delete-file template))
               #f))))
 
-      (with-fluids ((%default-port-encoding #f))  ; ASCII
-        (call-with-input-file file
-          (lambda (p)
-            (and (eq? #\# (read-char p))
-                 (eq? #\! (read-char p))
-                 (let ((line (false-if-exception (read-line p))))
-                   (and=> (and line (regexp-exec shebang-rx line))
-                          (lambda (m)
-                            (let* ((cmd (match:substring m 1))
-                                   (bin (search-path path
-                                                     (basename cmd))))
-                              (if bin
-                                  (if (string=? bin cmd)
-                                      #f          ; nothing to do
-                                      (begin
-                                        (format (current-error-port)
-                                                "patch-shebang: ~a: changing `~a' to `~a'~%"
-                                                file cmd bin)
-                                        (patch p bin (match:substring m 2))))
-                                  (begin
-                                    (format (current-error-port)
-                                            "patch-shebang: ~a: warning: no binary for interpreter `~a' found in $PATH~%"
-                                            file (basename cmd))
-                                    #f)))))))))))))
+      (call-with-ascii-input-file file
+        (lambda (p)
+          (and (eq? #\# (read-char p))
+               (eq? #\! (read-char p))
+               (let ((line (false-if-exception (read-line p))))
+                 (and=> (and line (regexp-exec shebang-rx line))
+                        (lambda (m)
+                          (let* ((cmd (match:substring m 1))
+                                 (bin (search-path path (basename cmd))))
+                            (if bin
+                                (if (string=? bin cmd)
+                                    #f            ; nothing to do
+                                    (begin
+                                      (format (current-error-port)
+                                              "patch-shebang: ~a: changing `~a' to `~a'~%"
+                                              file cmd bin)
+                                      (patch p bin (match:substring m 2))))
+                                (begin
+                                  (format (current-error-port)
+                                          "patch-shebang: ~a: warning: no binary for interpreter `~a' found in $PATH~%"
+                                          file (basename cmd))
+                                  #f))))))))))))
+
+(define* (patch-makefile-SHELL file #:key (keep-mtime? #t))
+  "Patch the `SHELL' variable in FILE, which is supposedly a makefile.
+When KEEP-MTIME? is true, the atime/mtime of FILE are kept unchanged."
+
+  ;; For instance, Gettext-generated po/Makefile.in.in do not honor $SHELL.
+
+  ;; XXX: Unlike with `patch-shebang', FILE is always touched.
+
+  (define (find-shell name)
+    (let ((shell
+           (search-path (search-path-as-string->list (getenv "PATH"))
+                        name)))
+      (unless shell
+        (format (current-error-port)
+                "patch-makefile-SHELL: warning: no binary for shell `~a' found in $PATH~%"
+                name))
+      shell))
+
+  (let ((st (stat file)))
+   (substitute* file
+     (("^ *SHELL[[:blank:]]*=[[:blank:]]*([[:graph:]]*/)([[:graph:]]+)[[:blank:]]*" _ dir shell)
+      (let* ((old (string-append dir shell))
+             (new (or (find-shell shell) old)))
+        (unless (string=? new old)
+          (format (current-error-port)
+                  "patch-makefile-SHELL: ~a: changing `SHELL' from `~a' to `~a'~%"
+                  file old new))
+        (string-append "SHELL = " new "\n"))))
+
+   (when keep-mtime?
+     (set-file-time file st))))
 
 (define* (fold-port-matches proc init pattern port
                             #:optional (unmatched (lambda (_ r) r)))
@@ -440,6 +525,14 @@ for each unmatched character."
         (map char-set (string->list pattern))
         pattern))
 
+  (define (get-char p)
+    ;; We call it `get-char', but that's really a binary version
+    ;; thereof.  (The real `get-char' cannot be used here because our
+    ;; bootstrap Guile is hacked to always use UTF-8.)
+    (match (get-u8 p)
+      ((? integer? x) (integer->char x))
+      (x x)))
+
   ;; Note: we're not really striving for performance here...
   (let loop ((chars   '())
              (pattern initial-pattern)
@@ -499,16 +592,17 @@ known as `nuke-refs' in Nixpkgs."
         (setvbuf in _IOFBF 65536)
         (setvbuf out _IOFBF 65536)
         (fold-port-matches (lambda (match result)
-                             (put-string out store)
-                             (put-char out #\/)
-                             (put-string out
-                              "eeeeeeeeeeeeeeeeeeeeeeeeeeeeeeee-")
+                             (put-bytevector out (string->utf8 store))
+                             (put-u8 out (char->integer #\/))
+                             (put-bytevector out
+                                             (string->utf8
+                                              "eeeeeeeeeeeeeeeeeeeeeeeeeeeeeeee-"))
                              #t)
                            #f
                            pattern
                            in
                            (lambda (char result)
-                             (put-char out char)
+                             (put-u8 out (char->integer char))
                              result))))))
 
 ;;; Local Variables:
diff --git a/guix/ftp-client.scm b/guix/ftp-client.scm
index 7e241f37b2..e3bacc3720 100644
--- a/guix/ftp-client.scm
+++ b/guix/ftp-client.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2010, 2011, 2012 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2010, 2011, 2012, 2013 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -33,6 +33,7 @@
             ftp-open
             ftp-close
             ftp-chdir
+            ftp-size
             ftp-list
             ftp-retr))
 
@@ -133,6 +134,12 @@ or a TCP port number), and return it."
   (%ftp-command (string-append "CWD " dir) 250
                 (ftp-connection-socket conn)))
 
+(define (ftp-size conn file)
+  "Return the size in bytes of FILE."
+  (let ((message (%ftp-command (string-append "SIZE " file) 213
+                               (ftp-connection-socket conn))))
+    (string->number (string-trim-both message))))
+
 (define (ftp-pasv conn)
   (define %pasv-rx
     (make-regexp "([0-9]+),([0-9]+),([0-9]+),([0-9]+),([0-9]+),([0-9]+)"))