Merge branch 'staging' into core-updates

6 files changed, 237 insertions, 39 deletions

diff --git a/tests/build-utils.scm b/tests/build-utils.scm
index 1c9084514d..5678bb6a22 100644
--- a/tests/build-utils.scm
+++ b/tests/build-utils.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2015, 2016 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012, 2015, 2016, 2019 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2019 Ricardo Wurmus <rekado@elephly.net>
 ;;;
 ;;; This file is part of GNU Guix.
@@ -21,11 +21,14 @@
 (define-module (test-build-utils)
   #:use-module (guix tests)
   #:use-module (guix build utils)
+  #:use-module ((gnu build bootloader)
+                #:select (invoke/quiet))
   #:use-module ((guix utils)
                 #:select (%current-system call-with-temporary-directory))
   #:use-module (gnu packages)
   #:use-module (gnu packages bootstrap)
   #:use-module (srfi srfi-34)
+  #:use-module (srfi srfi-35)
   #:use-module (srfi srfi-64)
   #:use-module (rnrs io ports)
   #:use-module (ice-9 popen))
@@ -108,20 +111,39 @@
        ;; it can't know about the bootstrap bash in the store, since it's not
        ;; named "bash".  Help it out a bit by providing a symlink it this
        ;; package's output.
-       (setenv "PATH" (dirname bash))
-       (wrap-program foo `("GUIX_FOO" prefix ("hello")))
-       (wrap-program foo `("GUIX_BAR" prefix ("world")))
-
-       ;; The bootstrap Bash is linked against an old libc and would abort with
-       ;; an assertion failure when trying to load incompatible locale data.
-       (unsetenv "LOCPATH")
-
-       (let* ((pipe (open-input-pipe foo))
-              (str  (get-string-all pipe)))
-         (with-directory-excursion directory
-           (for-each delete-file '("foo" ".foo-real")))
-         (and (zero? (close-pipe pipe))
-              str))))))
+       (with-environment-variable "PATH" (dirname bash)
+         (wrap-program foo `("GUIX_FOO" prefix ("hello")))
+         (wrap-program foo `("GUIX_BAR" prefix ("world")))
+
+         ;; The bootstrap Bash is linked against an old libc and would abort
+         ;; with an assertion failure when trying to load incompatible locale
+         ;; data.
+         (unsetenv "LOCPATH")
+
+         (let* ((pipe (open-input-pipe foo))
+                (str  (get-string-all pipe)))
+           (with-directory-excursion directory
+             (for-each delete-file '("foo" ".foo-real")))
+           (and (zero? (close-pipe pipe))
+                str)))))))
+
+(test-assert "invoke/quiet, success"
+  (begin
+    (invoke/quiet "true")
+    #t))
+
+(test-assert "invoke/quiet, failure"
+  (guard (c ((message-condition? c)
+             (string-contains (condition-message c) "This is an error.")))
+    (invoke/quiet "sh" "-c" "echo This is an error. ; false")
+    #f))
+
+(test-assert "invoke/quiet, failure, message on stderr"
+  (guard (c ((message-condition? c)
+             (string-contains (condition-message c)
+                              "This is another error.")))
+    (invoke/quiet "sh" "-c" "echo This is another error. >&2 ; false")
+    #f))
 
 (let ((script-contents "\
 #!/anything/cabbage-bash-1.2.3/bin/sh
diff --git a/tests/graph.scm b/tests/graph.scm
index 2a0f675717..b7732ec709 100644
--- a/tests/graph.scm
+++ b/tests/graph.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -191,6 +191,32 @@ edges."
                                 (string=? target (derivation-file-name g)))))
                         edges)))))))))
 
+(test-assert "reverse bag DAG"
+  (let-values (((dune bap ocaml-base)
+                (values (specification->package "dune")
+                        (specification->package "bap")
+                        (specification->package "ocaml-base")))
+               ((backend nodes+edges) (make-recording-backend)))
+    (run-with-store %store
+      (export-graph (list dune) 'port
+                    #:node-type %reverse-bag-node-type
+                    #:backend backend))
+
+    (run-with-store %store
+      (mlet %store-monad ((dune-drv       (package->derivation dune))
+                          (bap-drv        (package->derivation bap))
+                          (ocaml-base-drv (package->derivation ocaml-base)))
+        ;; OCAML-BASE uses 'dune-build-system' so DUNE is a direct dependency.
+        ;; BAP is much higher in the stack but it should be there.
+        (let-values (((nodes edges) (nodes+edges)))
+          (return
+           (and (member `(,(derivation-file-name bap-drv)
+                          ,(package-full-name bap))
+                        nodes)
+                (->bool (member (map derivation-file-name
+                                     (list dune-drv ocaml-base-drv))
+                                edges)))))))))
+
 (test-assert "derivation DAG"
   (let-values (((backend nodes+edges) (make-recording-backend)))
     (run-with-store %store
diff --git a/tests/guix-pack-relocatable.sh b/tests/guix-pack-relocatable.sh
index 554416627b..38dcf1e485 100644
--- a/tests/guix-pack-relocatable.sh
+++ b/tests/guix-pack-relocatable.sh
@@ -1,5 +1,5 @@
 # GNU Guix --- Functional package management for GNU
-# Copyright © 2018 Ludovic Courtès <ludo@gnu.org>
+# Copyright © 2018, 2019 Ludovic Courtès <ludo@gnu.org>
 #
 # This file is part of GNU Guix.
 #
@@ -41,17 +41,28 @@ STORE_PARENT="`dirname $NIX_STORE_DIR`"
 export STORE_PARENT
 if test "$STORE_PARENT" = "/"; then exit 77; fi
 
-# This test requires user namespaces and associated command-line tools.
-if ! unshare -mrf sh -c 'mount -t tmpfs none "$STORE_PARENT"'
+if unshare -mrf sh -c 'mount -t tmpfs none "$STORE_PARENT"'
 then
-    exit 77
+    # Test the wrapper that relies on user namespaces.
+    relocatable_option="-R"
+else
+    case "`uname -m`" in
+	x86_64|i?86)
+	    # Test the wrapper that falls back to PRoot.
+	    relocatable_option="-RR";;
+	*)
+	    # XXX: Our 'proot' package currently fails tests on non-Intel
+	    # architectures, so skip this by default.
+	    exit 77;;
+    esac
 fi
 
 test_directory="`mktemp -d`"
 export test_directory
 trap 'chmod -Rf +w "$test_directory"; rm -rf "$test_directory"' EXIT
 
-tarball="`guix pack -R -S /Bin=bin sed`"
+export relocatable_option
+tarball="`guix pack $relocatable_option -S /Bin=bin sed`"
 (cd "$test_directory"; tar xvf "$tarball")
 
 # Run that relocatable 'sed' in a user namespace where we "erase" the store by
diff --git a/tests/packages.scm b/tests/packages.scm
index ad972deb31..af1f76e36d 100644
--- a/tests/packages.scm
+++ b/tests/packages.scm
@@ -998,6 +998,57 @@
                    ((("x" dep))
                     (eq? dep findutils)))))))))
 
+(test-assert "package-input-rewriting/spec"
+  (let* ((dep     (dummy-package "chbouib"
+                    (native-inputs `(("x" ,grep)))))
+         (p0      (dummy-package "example"
+                    (inputs `(("foo" ,coreutils)
+                              ("bar" ,grep)
+                              ("baz" ,dep)))))
+         (rewrite (package-input-rewriting/spec
+                   `(("coreutils" . ,(const sed))
+                     ("grep" . ,(const findutils)))))
+         (p1      (rewrite p0))
+         (p2      (rewrite p0)))
+    (and (not (eq? p1 p0))
+         (eq? p1 p2)                              ;memoization
+         (string=? "example" (package-name p1))
+         (match (package-inputs p1)
+           ((("foo" dep1) ("bar" dep2) ("baz" dep3))
+            (and (string=? (package-full-name dep1)
+                           (package-full-name sed))
+                 (string=? (package-full-name dep2)
+                           (package-full-name findutils))
+                 (string=? (package-name dep3) "chbouib")
+                 (eq? dep3 (rewrite dep))         ;memoization
+                 (match (package-native-inputs dep3)
+                   ((("x" dep))
+                    (string=? (package-full-name dep)
+                              (package-full-name findutils))))))))))
+
+(test-assert "package-input-rewriting/spec, partial match"
+  (let* ((dep     (dummy-package "chbouib"
+                    (version "1")
+                    (native-inputs `(("x" ,grep)))))
+         (p0      (dummy-package "example"
+                    (inputs `(("foo" ,coreutils)
+                              ("bar" ,dep)))))
+         (rewrite (package-input-rewriting/spec
+                   `(("chbouib@123" . ,(const sed)) ;not matched
+                     ("grep" . ,(const findutils)))))
+         (p1      (rewrite p0)))
+    (and (not (eq? p1 p0))
+         (string=? "example" (package-name p1))
+         (match (package-inputs p1)
+           ((("foo" dep1) ("bar" dep2))
+            (and (string=? (package-full-name dep1)
+                           (package-full-name coreutils))
+                 (eq? dep2 (rewrite dep))         ;memoization
+                 (match (package-native-inputs dep2)
+                   ((("x" dep))
+                    (string=? (package-full-name dep)
+                              (package-full-name findutils))))))))))
+
 (test-equal "package-patched-vulnerabilities"
   '(("CVE-2015-1234")
     ("CVE-2016-1234" "CVE-2018-4567")
diff --git a/tests/scripts-build.scm b/tests/scripts-build.scm
index 190426ed06..32876e956a 100644
--- a/tests/scripts-build.scm
+++ b/tests/scripts-build.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2016, 2017 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2016, 2017, 2019 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -20,9 +20,11 @@
   #:use-module (guix tests)
   #:use-module (guix store)
   #:use-module (guix packages)
+  #:use-module (guix git-download)
   #:use-module (guix scripts build)
   #:use-module (guix ui)
   #:use-module (guix utils)
+  #:use-module (guix git)
   #:use-module (gnu packages)
   #:use-module (gnu packages base)
   #:use-module (gnu packages busybox)
@@ -138,12 +140,15 @@
         (and (not (eq? new p))
              (match (package-inputs new)
                ((("foo" dep1) ("bar" dep2) ("baz" dep3))
-                (and (eq? dep1 busybox)
-                     (eq? dep2 findutils)
+                (and (string=? (package-full-name dep1)
+                               (package-full-name busybox))
+                     (string=? (package-full-name dep2)
+                               (package-full-name findutils))
                      (string=? (package-name dep3) "chbouib")
                      (match (package-native-inputs dep3)
                        ((("x" dep))
-                        (eq? dep findutils)))))))))))
+                        (string=? (package-full-name dep)
+                                  (package-full-name findutils))))))))))))
 
 (test-assert "options->transformation, with-graft"
   (let* ((p (dummy-package "guix.scm"
@@ -164,4 +169,100 @@
                        ((("x" dep))
                         (eq? (package-replacement dep) findutils)))))))))))
 
+(test-equal "options->transformation, with-branch"
+  (git-checkout (url "https://example.org")
+                (branch "devel")
+                (recursive? #t))
+  (let* ((p (dummy-package "guix.scm"
+              (inputs `(("foo" ,grep)
+                        ("bar" ,(dummy-package "chbouib"
+                                  (source (origin
+                                            (method git-fetch)
+                                            (uri (git-reference
+                                                  (url "https://example.org")
+                                                  (commit "cabba9e")))
+                                            (sha256 #f)))))))))
+         (t (options->transformation '((with-branch . "chbouib=devel")))))
+    (with-store store
+      (let ((new (t store p)))
+        (and (not (eq? new p))
+             (match (package-inputs new)
+               ((("foo" dep1) ("bar" dep2))
+                (and (string=? (package-full-name dep1)
+                               (package-full-name grep))
+                     (string=? (package-name dep2) "chbouib")
+                     (package-source dep2)))))))))
+
+(test-equal "options->transformation, with-commit"
+  (git-checkout (url "https://example.org")
+                (commit "abcdef")
+                (recursive? #t))
+  (let* ((p (dummy-package "guix.scm"
+              (inputs `(("foo" ,grep)
+                        ("bar" ,(dummy-package "chbouib"
+                                  (source (origin
+                                            (method git-fetch)
+                                            (uri (git-reference
+                                                  (url "https://example.org")
+                                                  (commit "cabba9e")))
+                                            (sha256 #f)))))))))
+         (t (options->transformation '((with-commit . "chbouib=abcdef")))))
+    (with-store store
+      (let ((new (t store p)))
+        (and (not (eq? new p))
+             (match (package-inputs new)
+               ((("foo" dep1) ("bar" dep2))
+                (and (string=? (package-full-name dep1)
+                               (package-full-name grep))
+                     (string=? (package-name dep2) "chbouib")
+                     (package-source dep2)))))))))
+
+(test-equal "options->transformation, with-git-url"
+  (let ((source (git-checkout (url "https://example.org")
+                              (recursive? #t))))
+    (list source source))
+  (let* ((p (dummy-package "guix.scm"
+              (inputs `(("foo" ,grep)
+                        ("bar" ,(dummy-package "chbouib"
+                                  (native-inputs `(("x" ,grep)))))))))
+         (t (options->transformation '((with-git-url . "grep=https://example.org")))))
+    (with-store store
+      (let ((new (t store p)))
+        (and (not (eq? new p))
+             (match (package-inputs new)
+               ((("foo" dep1) ("bar" dep2))
+                (and (string=? (package-full-name dep1)
+                               (package-full-name grep))
+                     (string=? (package-name dep2) "chbouib")
+                     (match (package-native-inputs dep2)
+                       ((("x" dep3))
+                        (map package-source (list dep1 dep3))))))))))))
+
+(test-equal "options->transformation, with-git-url + with-branch"
+  ;; Combine the two options and make sure the 'with-branch' transformation
+  ;; comes after the 'with-git-url' transformation.
+  (let ((source (git-checkout (url "https://example.org")
+                              (branch "BRANCH")
+                              (recursive? #t))))
+    (list source source))
+  (let* ((p (dummy-package "guix.scm"
+              (inputs `(("foo" ,grep)
+                        ("bar" ,(dummy-package "chbouib"
+                                  (native-inputs `(("x" ,grep)))))))))
+         (t (options->transformation
+             (reverse '((with-git-url
+                         . "grep=https://example.org")
+                        (with-branch . "grep=BRANCH"))))))
+    (with-store store
+      (let ((new (t store p)))
+        (and (not (eq? new p))
+             (match (package-inputs new)
+               ((("foo" dep1) ("bar" dep2))
+                (and (string=? (package-name dep1) "grep")
+                     (string=? (package-name dep2) "chbouib")
+                     (match (package-native-inputs dep2)
+                       ((("x" dep3))
+                        (map package-source (list dep1 dep3))))))))))))
+
+
 (test-end)
diff --git a/tests/scripts.scm b/tests/scripts.scm
index 3901710953..efee271197 100644
--- a/tests/scripts.scm
+++ b/tests/scripts.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2015 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2015, 2019 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -25,19 +25,6 @@
 
 ;; Test the (guix scripts) module.
 
-(define-syntax-rule (with-environment-variable variable value body ...)
-  "Run BODY with VARIABLE set to VALUE."
-  (let ((orig (getenv variable)))
-    (dynamic-wind
-      (lambda ()
-        (setenv variable value))
-      (lambda ()
-        body ...)
-      (lambda ()
-        (if orig
-            (setenv variable orig)
-            (unsetenv variable))))))
-
 
 (test-begin "scripts")