Merge branch 'master' into core-updates

5 files changed, 200 insertions, 33 deletions

diff --git a/guix/build/download.scm b/guix/build/download.scm
index ae59b0109c..6e85174bc9 100644
--- a/guix/build/download.scm
+++ b/guix/build/download.scm
@@ -1,6 +1,7 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2012, 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2015 Mark H Weaver <mhw@netris.org>
+;;; Copyright © 2015 Steve Sprang <scs@stevesprang.com>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -54,17 +55,46 @@ object, as an inexact number."
   (+ (time-second duration)
      (/ (time-nanosecond duration) 1e9)))
 
-(define (throughput->string throughput)
-  "Given THROUGHPUT, measured in bytes per second, return a string
-representing it in a human-readable way."
-  (if (> throughput 3e6)
-      (format #f "~,2f MiB/s" (/ throughput (expt 2. 20)))
-      (format #f "~,0f KiB/s" (/ throughput 1024.0))))
+(define (seconds->string duration)
+  "Given DURATION in seconds, return a string representing it in 'hh:mm:ss'
+format."
+  (if (not (number? duration))
+      "00:00:00"
+      (let* ((total-seconds (inexact->exact (round duration)))
+             (extra-seconds (modulo total-seconds 3600))
+             (hours         (quotient total-seconds 3600))
+             (mins          (quotient extra-seconds 60))
+             (secs          (modulo extra-seconds 60)))
+        (format #f "~2,'0d:~2,'0d:~2,'0d" hours mins secs))))
+
+(define (byte-count->string size)
+  "Given SIZE in bytes, return a string representing it in a human-readable
+way."
+  (let ((KiB 1024.)
+        (MiB (expt 1024. 2))
+        (GiB (expt 1024. 3))
+        (TiB (expt 1024. 4)))
+    (cond
+     ((< size KiB) (format #f "~dB" (inexact->exact size)))
+     ((< size MiB) (format #f "~dKiB" (inexact->exact (round (/ size KiB)))))
+     ((< size GiB) (format #f "~,1fMiB" (/ size MiB)))
+     ((< size TiB) (format #f "~,2fGiB" (/ size GiB)))
+     (else         (format #f "~,3fTiB" (/ size TiB))))))
+
+(define* (progress-bar % #:optional (bar-width 20))
+  "Return % as a string representing an ASCII-art progress bar.  The total
+width of the bar is BAR-WIDTH."
+  (let* ((fraction (/ % 100))
+         (filled   (inexact->exact (floor (* fraction bar-width))))
+         (empty    (- bar-width filled)))
+    (format #f "[~a~a]"
+            (make-string filled #\#)
+            (make-string empty #\space))))
 
 (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."
+  "Return a procedure to show the progress of FILE's download, which is SIZE
+bytes long.  The returned procedure is suitable for use as an argument to
+`dump-port'.  The progress report is written to LOG-PORT."
   ;; XXX: Because of <http://bugs.gnu.org/19939> this procedure is often not
   ;; called as frequently as we'd like too; this is especially bad with Nginx
   ;; on hydra.gnu.org, which returns whole nars as a single chunk.
@@ -83,14 +113,24 @@ argument to `dump-port'.  The progress report is written to LOG-PORT."
       (if (number? size)
           (lambda (transferred cont)
             (with-elapsed-time elapsed
-              (let ((%          (* 100.0 (/ transferred size)))
-                    (throughput (if elapsed
-                                    (/ transferred elapsed)
-                                    0)))
+              (let* ((%          (* 100.0 (/ transferred size)))
+                     (throughput (if elapsed
+                                     (/ transferred elapsed)
+                                     0))
+                     (left       (format #f " ~a  ~a"
+                                         (basename file)
+                                         (byte-count->string size)))
+                     (right      (format #f "~a/s ~a ~a~6,1f%"
+                                         (byte-count->string throughput)
+                                         (seconds->string elapsed)
+                                         (progress-bar %) %))
+                     ;; TODO: Make this adapt to the actual terminal width.
+                     (cols       80)
+                     (num-spaces (max 1 (- cols (+ (string-length left)
+                                                   (string-length right)))))
+                     (gap        (make-string num-spaces #\space)))
+                (format log-port "~a~a~a" left gap right)
                 (display #\cr log-port)
-                (format log-port "~a\t~5,1f% of ~,1f KiB (~a)"
-                        file % (/ size 1024.0)
-                        (throughput->string throughput))
                 (flush-output-port log-port)
                 (cont))))
           (lambda (transferred cont)
@@ -99,9 +139,10 @@ argument to `dump-port'.  The progress report is written to LOG-PORT."
                                     (/ transferred elapsed)
                                     0)))
                 (display #\cr log-port)
-                (format log-port "~a\t~6,1f KiB transferred (~a)"
-                        file (/ transferred 1024.0)
-                        (throughput->string throughput))
+                (format log-port "~a\t~a transferred (~a/s)"
+                        file
+                        (byte-count->string transferred)
+                        (byte-count->string throughput))
                 (flush-output-port log-port)
                 (cont))))))))
 
diff --git a/guix/build/emacs-build-system.scm b/guix/build/emacs-build-system.scm
index aacb5a4186..cb5bde3191 100644
--- a/guix/build/emacs-build-system.scm
+++ b/guix/build/emacs-build-system.scm
@@ -84,7 +84,7 @@ store in '.el' files."
          (elpa-name-ver (store-directory->elpa-name-version out))
          (el-dir (string-append out %install-suffix "/" elpa-name-ver))
          (name-ver (strip-store-file-name out))
-         (info-dir (string-append out "/share/info/" name-ver))
+         (info-dir (string-append out "/share/info/"))
          (info-files (find-files el-dir "\\.info$")))
     (unless (null? info-files)
       (mkdir-p info-dir)
diff --git a/guix/build/r-build-system.scm b/guix/build/r-build-system.scm
new file mode 100644
index 0000000000..3fc13eb835
--- /dev/null
+++ b/guix/build/r-build-system.scm
@@ -0,0 +1,112 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2015 Ricardo Wurmus <rekado@elephly.net>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; 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.
+;;;
+;;; 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 GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (guix build r-build-system)
+  #:use-module ((guix build gnu-build-system) #:prefix gnu:)
+  #:use-module (guix build utils)
+  #:use-module (ice-9 match)
+  #:use-module (ice-9 ftw)
+  #:use-module (ice-9 popen)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-26)
+  #:export (%standard-phases
+            r-build))
+
+;; Commentary:
+;;
+;; Builder-side code of the standard build procedure for R packages.
+;;
+;; Code:
+
+(define (invoke-r command params)
+  (zero? (apply system* "R" "CMD" command params)))
+
+(define (pipe-to-r command params)
+  (let ((port (apply open-pipe* OPEN_WRITE "R" params)))
+    (display command port)
+    (zero? (status:exit-val (close-pipe port)))))
+
+(define (generate-site-path inputs)
+  (string-join (map (match-lambda
+                      ((_ . path)
+                       (string-append path "/site-library")))
+                    ;; Restrict to inputs beginning with "r-".
+                    (filter (match-lambda
+                              ((name . _)
+                               (string-prefix? "r-" name)))
+                            inputs))
+               ":"))
+
+(define* (check #:key test-target inputs outputs tests? #:allow-other-keys)
+  "Run the test suite of a given R package."
+  (let* ((libdir    (string-append (assoc-ref outputs "out") "/site-library/"))
+
+         ;; R package names are case-sensitive and cannot be derived from the
+         ;; Guix package name.  The exact package name is required as an
+         ;; argument to ‘tools::testInstalledPackage’, which runs the tests
+         ;; for a package given its name and the path to the “library” (a
+         ;; location for a collection of R packages) containing it.
+
+         ;; Since there can only be one R package in any collection (=
+         ;; “library”), the name of the only directory in the collection path
+         ;; is the original name of the R package.
+         (pkg-name  (car (scandir libdir (negate (cut member <> '("." ".."))))))
+         (testdir   (string-append libdir pkg-name "/" test-target))
+         (site-path (string-append libdir ":" (generate-site-path inputs))))
+    (if (and tests? (file-exists? testdir))
+        (begin
+          (setenv "R_LIBS_SITE" site-path)
+          (pipe-to-r (string-append "tools::testInstalledPackage(\"" pkg-name "\", "
+                                    "lib.loc = \"" libdir "\")")
+                     '("--no-save" "--slave")))
+        #t)))
+
+(define* (install #:key outputs inputs (configure-flags '())
+                  #:allow-other-keys)
+  "Install a given R package."
+  (let* ((out          (assoc-ref outputs "out"))
+         (site-library (string-append out "/site-library/"))
+         (params       (append configure-flags
+                               (list "--install-tests"
+                                     (string-append "--library=" site-library)
+                                     ".")))
+         (site-path    (string-append site-library ":"
+                                      (generate-site-path inputs))))
+    ;; If dependencies cannot be found at install time, R will refuse to
+    ;; install the package.
+    (setenv "R_LIBS_SITE" site-path)
+    ;; Some R packages contain a configure script for which the CONFIG_SHELL
+    ;; variable should be set.
+    (setenv "CONFIG_SHELL" (which "bash"))
+    (mkdir-p site-library)
+    (invoke-r "INSTALL" params)))
+
+(define %standard-phases
+  (modify-phases gnu:%standard-phases
+    (delete 'configure)
+    (delete 'build)
+    (delete 'check) ; tests must be run after installation
+    (replace 'install install)
+    (add-after 'install 'check check)))
+
+(define* (r-build #:key inputs (phases %standard-phases)
+                       #:allow-other-keys #:rest args)
+  "Build the given R package, applying all of PHASES in order."
+  (apply gnu:gnu-build #:inputs inputs #:phases phases args))
+
+;;; r-build-system.scm ends here
diff --git a/guix/build/ruby-build-system.scm b/guix/build/ruby-build-system.scm
index 90fab92f6a..4184ccc9ac 100644
--- a/guix/build/ruby-build-system.scm
+++ b/guix/build/ruby-build-system.scm
@@ -44,12 +44,16 @@ directory."
 (define* (unpack #:key source #:allow-other-keys)
   "Unpack the gem SOURCE and enter the resulting directory."
   (and (zero? (system* "gem" "unpack" source))
-       (begin
-         ;; The unpacked gem directory is named the same as the archive, sans
-         ;; the ".gem" extension.
-         (chdir (match:substring (string-match "^(.*)\\.gem$"
-                                               (basename source))
-                                 1))
+       ;; The unpacked gem directory is named the same as the archive, sans
+       ;; the ".gem" extension.  It is renamed to simply "gem" in an effort to
+       ;; keep file names shorter to avoid UNIX-domain socket file names and
+       ;; shebangs that exceed the system's fixed maximum length when running
+       ;; test suites.
+       (let ((dir (match:substring (string-match "^(.*)\\.gem$"
+                                                 (basename source))
+                                   1)))
+         (rename-file dir "gem")
+         (chdir "gem")
          #t)))
 
 (define* (build #:key source #:allow-other-keys)
diff --git a/guix/build/syscalls.scm b/guix/build/syscalls.scm
index fc801a5e9d..2c2fbde0a3 100644
--- a/guix/build/syscalls.scm
+++ b/guix/build/syscalls.scm
@@ -50,6 +50,8 @@
             mkdtemp!
             pivot-root
 
+            CLONE_CHILD_CLEARTID
+            CLONE_CHILD_SETTID
             CLONE_NEWNS
             CLONE_NEWUTS
             CLONE_NEWIPC
@@ -303,12 +305,14 @@ string TMPL and return its file name.  TMPL must end with 'XXXXXX'."
         (pointer->string result)))))
 
 ;; Linux clone flags, from linux/sched.h
-(define CLONE_NEWNS   #x00020000)
-(define CLONE_NEWUTS  #x04000000)
-(define CLONE_NEWIPC  #x08000000)
-(define CLONE_NEWUSER #x10000000)
-(define CLONE_NEWPID  #x20000000)
-(define CLONE_NEWNET  #x40000000)
+(define CLONE_CHILD_CLEARTID #x00200000)
+(define CLONE_CHILD_SETTID   #x01000000)
+(define CLONE_NEWNS          #x00020000)
+(define CLONE_NEWUTS         #x04000000)
+(define CLONE_NEWIPC         #x08000000)
+(define CLONE_NEWUSER        #x10000000)
+(define CLONE_NEWPID         #x20000000)
+(define CLONE_NEWNET         #x40000000)
 
 ;; The libc interface to sys_clone is not useful for Scheme programs, so the
 ;; low-level system call is wrapped instead.
@@ -325,7 +329,13 @@ string TMPL and return its file name.  TMPL must end with 'XXXXXX'."
       "Create a new child process by duplicating the current parent process.
 Unlike the fork system call, clone accepts FLAGS that specify which resources
 are shared between the parent and child processes."
-      (proc syscall-id flags %null-pointer))))
+      (let ((ret (proc syscall-id flags %null-pointer))
+            (err (errno)))
+        (if (= ret -1)
+            (throw 'system-error "clone" "~d: ~A"
+                   (list flags (strerror err))
+                   (list err))
+            ret)))))
 
 (define setns
   ;; Some systems may be using an old (pre-2.14) version of glibc where there