diff options
author | Leo Famulari <leo@famulari.name> | 2016-03-21 12:22:31 -0400 |
---|---|---|
committer | Leo Famulari <leo@famulari.name> | 2016-03-21 12:22:31 -0400 |
commit | 09ec508a4c14d1bc09622d98f796548d79ab0552 (patch) | |
tree | 86cc5a2a67d35ad796bfa33d67869d670d65822e /tests | |
parent | 2dbed47f5c09347c9af42c5f5bacfccbc1ab4aff (diff) | |
parent | 71cafa0472a15f2234e24d3c6d8019ebb38685b0 (diff) | |
download | guix-09ec508a4c14d1bc09622d98f796548d79ab0552.tar.gz |
Merge branch 'master' into core-updates
Diffstat (limited to 'tests')
-rw-r--r-- | tests/cpan.scm | 6 | ||||
-rw-r--r-- | tests/derivations.scm | 24 | ||||
-rw-r--r-- | tests/gexp.scm | 40 | ||||
-rw-r--r-- | tests/grafts.scm | 113 | ||||
-rw-r--r-- | tests/graph.scm | 4 | ||||
-rw-r--r-- | tests/guix-build.sh | 16 | ||||
-rw-r--r-- | tests/guix-daemon.sh | 10 | ||||
-rw-r--r-- | tests/guix-lint.sh | 2 | ||||
-rw-r--r-- | tests/guix-package.sh | 10 | ||||
-rw-r--r-- | tests/monads.scm | 6 | ||||
-rw-r--r-- | tests/packages.scm | 112 | ||||
-rw-r--r-- | tests/profiles.scm | 6 | ||||
-rw-r--r-- | tests/pypi.scm | 3 | ||||
-rw-r--r-- | tests/store.scm | 41 | ||||
-rw-r--r-- | tests/ui.scm | 6 | ||||
-rw-r--r-- | tests/upstream.scm | 49 | ||||
-rw-r--r-- | tests/utils.scm | 5 |
17 files changed, 381 insertions, 72 deletions
diff --git a/tests/cpan.scm b/tests/cpan.scm index 2f9513519e..583684104d 100644 --- a/tests/cpan.scm +++ b/tests/cpan.scm @@ -21,9 +21,13 @@ #:use-module (guix base32) #:use-module (guix hash) #:use-module (guix tests) + #:use-module (guix grafts) #:use-module (srfi srfi-64) #:use-module (ice-9 match)) +;; Globally disable grafts because they can trigger early builds. +(%graft? #f) + (define test-json "{ \"metadata\" : { @@ -44,7 +48,7 @@ ], \"abstract\" : \"Fizzle Fuzz\", \"download_url\" : \"http://example.com/Foo-Bar-0.1.tar.gz\", - \"author\" : \"GUIX\", + \"author\" : \"Guix\", \"version\" : \"0.1\" }") diff --git a/tests/derivations.scm b/tests/derivations.scm index 9b53019cc5..4d3b82fe1a 100644 --- a/tests/derivations.scm +++ b/tests/derivations.scm @@ -18,6 +18,7 @@ (define-module (test-derivations) #:use-module (guix derivations) + #:use-module (guix grafts) #:use-module (guix store) #:use-module (guix utils) #:use-module (guix hash) @@ -44,6 +45,9 @@ (define %store (open-connection-for-tests)) +;; Globally disable grafts because they can trigger early builds. +(%graft? #f) + (define (bootstrap-binary name) (let ((bin (search-bootstrap-binary name (%current-system)))) (and %store @@ -71,6 +75,7 @@ (lambda (e1 e2) (string<? (car e1) (car e2))))) + (test-begin "derivations") (test-assert "parse & export" @@ -499,6 +504,25 @@ (build-derivations %store (list drv)) #f))) +(test-assert "derivation #:disallowed-references, ok" + (let ((drv (derivation %store "disallowed" %bash + '("-c" "echo hello > $out") + #:inputs `((,%bash)) + #:disallowed-references '("out")))) + (build-derivations %store (list drv)))) + +(test-assert "derivation #:disallowed-references, not ok" + (let* ((txt (add-text-to-store %store "foo" "Hello, world.")) + (drv (derivation %store "disdisallowed" %bash + `("-c" ,(string-append "echo " txt "> $out")) + #:inputs `((,%bash) (,txt)) + #:disallowed-references (list txt)))) + (guard (c ((nix-protocol-error? c) + ;; There's no specific error message to check for. + #t)) + (build-derivations %store (list drv)) + #f))) + ;; Here we should get the value of $NIX_STATE_DIR that the daemon sees, which ;; is a unique value for each test process; this value is the same as the one ;; we see in the process executing this file since it is set by 'test-env'. diff --git a/tests/gexp.scm b/tests/gexp.scm index 87c774782a..75b907abee 100644 --- a/tests/gexp.scm +++ b/tests/gexp.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2014, 2015 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -20,6 +20,7 @@ #:use-module (guix store) #:use-module (guix monads) #:use-module (guix gexp) + #:use-module (guix grafts) #:use-module (guix derivations) #:use-module (guix packages) #:use-module (guix tests) @@ -39,6 +40,9 @@ (define %store (open-connection-for-tests)) +;; Globally disable grafts because they can trigger early builds. +(%graft? #f) + ;; For white-box testing. (define (gexp-inputs x) ((@@ (guix gexp) gexp-inputs) x)) @@ -334,7 +338,8 @@ (equal? refs2 (list file)))))) (test-assertm "gexp->derivation vs. grafts" - (mlet* %store-monad ((p0 -> (dummy-package "dummy" + (mlet* %store-monad ((graft? (set-grafting #f)) + (p0 -> (dummy-package "dummy" (arguments '(#:implicit-inputs? #f)))) (r -> (package (inherit p0) (name "DuMMY"))) @@ -342,9 +347,10 @@ (exp0 -> (gexp (frob (ungexp p0) (ungexp output)))) (exp1 -> (gexp (frob (ungexp p1) (ungexp output)))) (void (set-guile-for-build %bootstrap-guile)) - (drv0 (gexp->derivation "t" exp0)) - (drv1 (gexp->derivation "t" exp1)) - (drv1* (gexp->derivation "t" exp1 #:graft? #f))) + (drv0 (gexp->derivation "t" exp0 #:graft? #t)) + (drv1 (gexp->derivation "t" exp1 #:graft? #t)) + (drv1* (gexp->derivation "t" exp1 #:graft? #f)) + (_ (set-grafting graft?))) (return (and (not (string=? (derivation->output-path drv0) (derivation->output-path drv1))) (string=? (derivation->output-path drv0) @@ -594,6 +600,30 @@ (build-derivations %store (list drv)) #f))) +(test-assertm "gexp->derivation #:disallowed-references, allowed" + (mlet %store-monad ((drv (gexp->derivation "disallowed-refs" + #~(begin + (mkdir #$output) + (chdir #$output) + (symlink #$output "self") + (symlink #$%bootstrap-guile + "guile")) + #:disallowed-references '()))) + (built-derivations (list drv)))) + + +(test-assert "gexp->derivation #:disallowed-references" + (let ((drv (run-with-store %store + (gexp->derivation "disallowed-refs" + #~(begin + (mkdir #$output) + (chdir #$output) + (symlink #$%bootstrap-guile "guile")) + #:disallowed-references (list %bootstrap-guile))))) + (guard (c ((nix-protocol-error? c) #t)) + (build-derivations %store (list drv)) + #f))) + (define shebang (string-append "#!" (derivation->output-path (%guile-for-build)) "/bin/guile --no-auto-compile")) diff --git a/tests/grafts.scm b/tests/grafts.scm index 4a4122a3e9..4bc33709d6 100644 --- a/tests/grafts.scm +++ b/tests/grafts.scm @@ -17,12 +17,16 @@ ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. (define-module (test-grafts) + #:use-module (guix gexp) + #:use-module (guix monads) #:use-module (guix derivations) #:use-module (guix store) #:use-module (guix utils) #:use-module (guix grafts) #:use-module (guix tests) #:use-module ((gnu packages) #:select (search-bootstrap-binary)) + #:use-module (gnu packages bootstrap) + #:use-module (srfi srfi-1) #:use-module (srfi srfi-64) #:use-module (rnrs io ports)) @@ -42,7 +46,7 @@ (test-begin "grafts") -(test-assert "graft-derivation" +(test-assert "graft-derivation, grafted item is a direct dependency" (let* ((build `(begin (mkdir %output) (chdir %output) @@ -51,7 +55,7 @@ (lambda (output) (format output "foo/~a/bar" ,%mkdir))) (symlink ,%bash "sh"))) - (orig (build-expression->derivation %store "graft" build + (orig (build-expression->derivation %store "grafted" build #:inputs `(("a" ,%bash) ("b" ,%mkdir)))) (one (add-text-to-store %store "bash" "fake bash")) @@ -59,21 +63,100 @@ '(call-with-output-file %output (lambda (port) (display "fake mkdir" port))))) - (graft (graft-derivation %store orig - (list (graft - (origin %bash) - (replacement one)) - (graft - (origin %mkdir) - (replacement two)))))) - (and (build-derivations %store (list graft)) - (let ((two (derivation->output-path two)) - (graft (derivation->output-path graft))) + (grafted (graft-derivation %store orig + (list (graft + (origin %bash) + (replacement one)) + (graft + (origin %mkdir) + (replacement two)))))) + (and (build-derivations %store (list grafted)) + (let ((two (derivation->output-path two)) + (grafted (derivation->output-path grafted))) (and (string=? (format #f "foo/~a/bar" two) - (call-with-input-file (string-append graft "/text") + (call-with-input-file (string-append grafted "/text") get-string-all)) - (string=? (readlink (string-append graft "/sh")) one) - (string=? (readlink (string-append graft "/self")) graft)))))) + (string=? (readlink (string-append grafted "/sh")) one) + (string=? (readlink (string-append grafted "/self")) + grafted)))))) + +;; Make sure 'derivation-file-name' always gets to see an absolute file name. +(fluid-set! %file-port-name-canonicalization 'absolute) + +(test-assert "graft-derivation, grafted item is an indirect dependency" + (let* ((build `(begin + (mkdir %output) + (chdir %output) + (symlink %output "self") + (call-with-output-file "text" + (lambda (output) + (format output "foo/~a/bar" ,%mkdir))) + (symlink ,%bash "sh"))) + (dep (build-expression->derivation %store "dep" build + #:inputs `(("a" ,%bash) + ("b" ,%mkdir)))) + (orig (build-expression->derivation %store "thing" + '(symlink + (assoc-ref %build-inputs + "dep") + %output) + #:inputs `(("dep" ,dep)))) + (one (add-text-to-store %store "bash" "fake bash")) + (two (build-expression->derivation %store "mkdir" + '(call-with-output-file %output + (lambda (port) + (display "fake mkdir" port))))) + (grafted (graft-derivation %store orig + (list (graft + (origin %bash) + (replacement one)) + (graft + (origin %mkdir) + (replacement two)))))) + (and (build-derivations %store (list grafted)) + (let* ((two (derivation->output-path two)) + (grafted (derivation->output-path grafted)) + (dep (readlink grafted))) + (and (string=? (format #f "foo/~a/bar" two) + (call-with-input-file (string-append dep "/text") + get-string-all)) + (string=? (readlink (string-append dep "/sh")) one) + (string=? (readlink (string-append dep "/self")) dep) + (equal? (references %store grafted) (list dep)) + (lset= string=? + (list one two dep) + (references %store dep))))))) + +(test-assert "graft-derivation, no dependencies on grafted output" + (run-with-store %store + (mlet* %store-monad ((fake (text-file "bash" "Fake bash.")) + (graft -> (graft + (origin %bash) + (replacement fake))) + (drv (gexp->derivation "foo" #~(mkdir #$output))) + (grafted ((store-lift graft-derivation) drv + (list graft)))) + (return (eq? grafted drv))))) + +(test-assert "graft-derivation, multiple outputs" + (let* ((build `(begin + (symlink (assoc-ref %build-inputs "a") + (assoc-ref %outputs "one")) + (symlink (assoc-ref %outputs "one") + (assoc-ref %outputs "two")))) + (orig (build-expression->derivation %store "grafted" build + #:inputs `(("a" ,%bash)) + #:outputs '("one" "two"))) + (repl (add-text-to-store %store "bash" "fake bash")) + (grafted (graft-derivation %store orig + (list (graft + (origin %bash) + (replacement repl)))))) + (and (build-derivations %store (list grafted)) + (let ((one (derivation->output-path grafted "one")) + (two (derivation->output-path grafted "two"))) + (and (string=? (readlink one) repl) + (string=? (readlink two) one)))))) (test-end) diff --git a/tests/graph.scm b/tests/graph.scm index 43f7b733f9..4205b9b8c7 100644 --- a/tests/graph.scm +++ b/tests/graph.scm @@ -24,6 +24,7 @@ #:use-module (guix derivations) #:use-module (guix store) #:use-module (guix monads) + #:use-module (guix grafts) #:use-module (guix build-system gnu) #:use-module (guix build-system trivial) #:use-module (guix gexp) @@ -41,6 +42,9 @@ (define %store (open-connection-for-tests)) +;; Globally disable grafts because they can trigger early builds. +(%graft? #f) + (define (make-recording-backend) "Return a <graph-backend> and a thunk that returns the recorded nodes and edges." diff --git a/tests/guix-build.sh b/tests/guix-build.sh index 347cdfa4e4..6d4f97019a 100644 --- a/tests/guix-build.sh +++ b/tests/guix-build.sh @@ -43,6 +43,7 @@ trap "rm -rf $module_dir" EXIT cat > "$module_dir/foo.scm"<<EOF (define-module (foo) + #:use-module (guix tests) #:use-module (guix packages) #:use-module (guix download) #:use-module (guix build-system trivial)) @@ -88,6 +89,10 @@ cat > "$module_dir/foo.scm"<<EOF (synopsis "Dummy package") (description "bar is a dummy package for testing.") (license #f))) + +(define-public baz + (dummy-package "baz" (replacement foo))) + EOF GUIX_PACKAGE_PATH="$module_dir" @@ -97,6 +102,10 @@ export GUIX_PACKAGE_PATH guix build -d -S foo guix build -d -S foo | grep -e 'foo\.tar\.gz' +# 'baz' has a replacement so we should be getting the replacement's source. +(unset GUIX_BUILD_OPTIONS; + test "`guix build -d -S baz`" = "`guix build -d -S foo`") + guix build -d --sources=package foo guix build -d --sources=package foo | grep -e 'foo\.tar\.gz' @@ -161,8 +170,9 @@ then false; else true; fi # Parsing package names and versions. guix build -n time # PASS -guix build -n time-1.7 # PASS, version found -if guix build -n time-3.2; # FAIL, version not found +guix build -n time@1.7 # PASS, version found +guix build -n time-1.7 # PASS, deprecated version syntax +if guix build -n time@3.2; # FAIL, version not found then false; else true; fi if guix build -n something-that-will-never-exist; # FAIL then false; else true; fi @@ -207,7 +217,7 @@ guix build --file="$module_dir/gexp.scm" -d guix build --file="$module_dir/gexp.scm" -d | grep 'gexp\.drv' # Using 'GUIX_BUILD_OPTIONS'. -GUIX_BUILD_OPTIONS="--dry-run" +GUIX_BUILD_OPTIONS="--dry-run --no-grafts" export GUIX_BUILD_OPTIONS guix build emacs diff --git a/tests/guix-daemon.sh b/tests/guix-daemon.sh index 1f9c868293..7122eed0e6 100644 --- a/tests/guix-daemon.sh +++ b/tests/guix-daemon.sh @@ -1,5 +1,5 @@ # GNU Guix --- Functional package management for GNU -# Copyright © 2012, 2014, 2015 Ludovic Courtès <ludo@gnu.org> +# Copyright © 2012, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org> # # This file is part of GNU Guix. # @@ -27,8 +27,9 @@ guix build --version drv="`guix build emacs -d`" out="`guile -c ' \ - (use-modules (guix) (gnu packages emacs)) \ + (use-modules (guix) (guix grafts) (gnu packages emacs)) \ (define store (open-connection)) \ + (%graft? #f) (display (derivation->output-path (package-derivation store emacs)))'`" hash_part="`basename $out | cut -c 1-32`" @@ -88,9 +89,12 @@ guix-daemon --no-substitutes --listen="$socket" --disable-chroot \ daemon_pid=$! guile -c " - (use-modules (guix) (guix tests) (srfi srfi-34)) + (use-modules (guix) (guix grafts) (guix tests) (srfi srfi-34)) (define store (open-connection-for-tests \"$socket\")) + ;; Disable grafts to avoid building more than needed. + (%graft? #f) + (define (build-without-failing drv) (lambda (store) (guard (c ((nix-protocol-error? c) (values #t store))) diff --git a/tests/guix-lint.sh b/tests/guix-lint.sh index 5015b5cfb5..c105521ec7 100644 --- a/tests/guix-lint.sh +++ b/tests/guix-lint.sh @@ -75,4 +75,4 @@ if guix lint -c synopsis,invalid-checker dummy 2>&1 | \ then true; else false; fi # Make sure specifying multiple packages works. -guix lint -c inputs-should-be-native dummy dummy-42 dummy +guix lint -c inputs-should-be-native dummy dummy@42 dummy diff --git a/tests/guix-package.sh b/tests/guix-package.sh index cf1a185590..28c34dbc6a 100644 --- a/tests/guix-package.sh +++ b/tests/guix-package.sh @@ -207,13 +207,13 @@ cat > "$module_dir/foo.scm"<<EOF EOF guix package -A emacs-foo-bar -L "$module_dir" | grep 42 -guix package -i emacs-foo-bar-42 -n -L "$module_dir" +guix package -i emacs-foo-bar@42 -n -L "$module_dir" # Same thing using the 'GUIX_PACKAGE_PATH' environment variable. GUIX_PACKAGE_PATH="$module_dir" export GUIX_PACKAGE_PATH guix package -A emacs-foo-bar | grep 42 -guix package -i emacs-foo-bar-42 -n +guix package -i emacs-foo-bar@42 -n # Make sure patches that live under $GUIX_PACKAGE_PATH are found. cat > "$module_dir/emacs.patch"<<EOF @@ -261,7 +261,7 @@ unset GUIX_PACKAGE_PATH # Using 'GUIX_BUILD_OPTIONS'. available="`guix package -A | sort`" -GUIX_BUILD_OPTIONS="--dry-run" +GUIX_BUILD_OPTIONS="--dry-run --no-grafts" export GUIX_BUILD_OPTIONS # Make sure $GUIX_BUILD_OPTIONS is not simply appended to the command-line, @@ -270,7 +270,9 @@ available2="`guix package -A | sort`" test "$available2" = "$available" guix package -I -unset GUIX_BUILD_OPTIONS +# Restore '--no-grafts', which makes sure we don't end up building stuff when +# '--dry-run' is passed. +GUIX_BUILD_OPTIONS="--no-grafts" # Applying a manifest file. cat > "$module_dir/manifest.scm"<<EOF diff --git a/tests/monads.scm b/tests/monads.scm index 62a07a2bc6..4112bcb6cf 100644 --- a/tests/monads.scm +++ b/tests/monads.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -20,6 +20,7 @@ #:use-module (guix tests) #:use-module (guix store) #:use-module (guix monads) + #:use-module (guix grafts) #:use-module (guix derivations) #:use-module (guix packages) #:use-module (gnu packages) @@ -36,6 +37,9 @@ (define %store (open-connection-for-tests)) +;; Globally disable grafts because they can trigger early builds. +(%graft? #f) + (define %monads (list %identity-monad %store-monad %state-monad)) diff --git a/tests/packages.scm b/tests/packages.scm index 6315c2204f..823ede1f25 100644 --- a/tests/packages.scm +++ b/tests/packages.scm @@ -20,6 +20,7 @@ #:use-module (guix tests) #:use-module (guix store) #:use-module (guix monads) + #:use-module (guix grafts) #:use-module ((guix utils) ;; Rename the 'location' binding to allow proper syntax ;; matching when setting the 'location' field of a package. @@ -55,6 +56,10 @@ (define %store (open-connection-for-tests)) +;; Globally disable grafting to avoid rebuilding the world ('graft-derivation' +;; can trigger builds early.) +(%graft? #f) + (test-begin "packages") @@ -549,17 +554,23 @@ (package-cross-derivation %store p "mips64el-linux-gnu") #f))) -(test-equal "package-derivation, direct graft" - (package-derivation %store gnu-make) - (let ((p (package (inherit coreutils) - (replacement gnu-make)))) - (package-derivation %store p))) +;; XXX: The next two tests can trigger builds when the distro defines +;; replacements on core packages, so they're disable for lack of a better +;; solution. -(test-equal "package-cross-derivation, direct graft" - (package-cross-derivation %store gnu-make "mips64el-linux-gnu") - (let ((p (package (inherit coreutils) - (replacement gnu-make)))) - (package-cross-derivation %store p "mips64el-linux-gnu"))) +;; (test-equal "package-derivation, direct graft" +;; (package-derivation %store gnu-make #:graft? #f) +;; (let ((p (package (inherit coreutils) +;; (replacement gnu-make)))) +;; (package-derivation %store p #:graft? #t))) + +;; (test-equal "package-cross-derivation, direct graft" +;; (package-cross-derivation %store gnu-make "mips64el-linux-gnu" +;; #:graft? #f) +;; (let ((p (package (inherit coreutils) +;; (replacement gnu-make)))) +;; (package-cross-derivation %store p "mips64el-linux-gnu" +;; #:graft? #t))) (test-assert "package-grafts, indirect grafts" (let* ((new (dummy-package "dep" @@ -583,11 +594,13 @@ (arguments '(#:implicit-inputs? #f)) (inputs `(("dep" ,dep*))))) (target "mips64el-linux-gnu")) - (equal? (package-grafts %store dummy #:target target) - (list (graft - (origin (package-cross-derivation %store dep target)) - (replacement - (package-cross-derivation %store new target))))))) + ;; XXX: There might be additional grafts, for instance if the distro + ;; defines replacements for core packages like Perl. + (member (graft + (origin (package-cross-derivation %store dep target)) + (replacement + (package-cross-derivation %store new target))) + (package-grafts %store dummy #:target target)))) (test-assert "package-grafts, indirect grafts, propagated inputs" (let* ((new (dummy-package "dep" @@ -605,23 +618,51 @@ (origin (package-derivation %store dep)) (replacement (package-derivation %store new))))))) -(test-assert "package-derivation, indirect grafts" - (let* ((new (dummy-package "dep" - (arguments '(#:implicit-inputs? #f)))) - (dep (package (inherit new) (version "0.0"))) - (dep* (package (inherit dep) (replacement new))) - (dummy (dummy-package "dummy" - (arguments '(#:implicit-inputs? #f)) - (inputs `(("dep" ,dep*))))) - (guile (package-derivation %store (canonical-package guile-2.0) - #:graft? #f))) - (equal? (package-derivation %store dummy) - (graft-derivation %store - (package-derivation %store dummy #:graft? #f) - (package-grafts %store dummy) +(test-assert "package-grafts, same replacement twice" + (let* ((new (dummy-package "dep" + (version "1") + (arguments '(#:implicit-inputs? #f)))) + (dep (package (inherit new) (version "0") (replacement new))) + (p1 (dummy-package "intermediate1" + (arguments '(#:implicit-inputs? #f)) + (inputs `(("dep" ,dep))))) + (p2 (dummy-package "intermediate2" + (arguments '(#:implicit-inputs? #f)) + ;; Here we copy DEP to have an equivalent package that is not + ;; 'eq?' to DEP. This is similar to what happens with + ;; 'package-with-explicit-inputs' & co. + (inputs `(("dep" ,(package (inherit dep))))))) + (p3 (dummy-package "final" + (arguments '(#:implicit-inputs? #f)) + (inputs `(("p1" ,p1) ("p2" ,p2)))))) + (equal? (package-grafts %store p3) + (list (graft + (origin (package-derivation %store + (package (inherit dep) + (replacement #f)))) + (replacement (package-derivation %store new))))))) - ;; Use the same Guile as 'package-derivation'. - #:guile guile)))) +;;; XXX: Nowadays 'graft-derivation' needs to build derivations beforehand to +;;; find out about their run-time dependencies, so this test is no longer +;;; applicable since it would trigger a full rebuild. +;; +;; (test-assert "package-derivation, indirect grafts" +;; (let* ((new (dummy-package "dep" +;; (arguments '(#:implicit-inputs? #f)))) +;; (dep (package (inherit new) (version "0.0"))) +;; (dep* (package (inherit dep) (replacement new))) +;; (dummy (dummy-package "dummy" +;; (arguments '(#:implicit-inputs? #f)) +;; (inputs `(("dep" ,dep*))))) +;; (guile (package-derivation %store (canonical-package guile-2.0) +;; #:graft? #f))) +;; (equal? (package-derivation %store dummy) +;; (graft-derivation %store +;; (package-derivation %store dummy #:graft? #f) +;; (package-grafts %store dummy) + +;; ;; Use the same Guile as 'package-derivation'. +;; #:guile guile)))) (test-equal "package->bag" `("foo86-hurd" #f (,(package-source gnu-make)) @@ -747,6 +788,15 @@ (guix-package "-p" (derivation->output-path prof) "--search-paths")))))) +(test-equal "specification->package when not found" + 'quit + (catch 'quit + (lambda () + ;; This should call 'leave', producing an error message. + (specification->package "this-package-does-not-exist")) + (lambda (key . args) + key))) + (test-end "packages") diff --git a/tests/profiles.scm b/tests/profiles.scm index e659c2e26d..6714dfcaa7 100644 --- a/tests/profiles.scm +++ b/tests/profiles.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2014 Alex Kost <alezost@gmail.com> ;;; ;;; This file is part of GNU Guix. @@ -22,6 +22,7 @@ #:use-module (guix profiles) #:use-module (guix store) #:use-module (guix monads) + #:use-module (guix grafts) #:use-module (guix packages) #:use-module (guix derivations) #:use-module (guix build-system trivial) @@ -41,6 +42,9 @@ (define %store (open-connection-for-tests)) +;; Globally disable grafts because they can trigger early builds. +(%graft? #f) + (define-syntax-rule (test-assertm name exp) (test-assert name (run-with-store %store exp diff --git a/tests/pypi.scm b/tests/pypi.scm index 960b8cd32a..cf351a542f 100644 --- a/tests/pypi.scm +++ b/tests/pypi.scm @@ -84,7 +84,8 @@ baz > 13.37") ('version "1.0.0") ('source ('origin ('method 'url-fetch) - ('uri (pypi-uri "foo" version)) + ('uri (string-append "https://example.com/foo-" + version ".tar.gz")) ('sha256 ('base32 (? string? hash))))) diff --git a/tests/store.scm b/tests/store.scm index de070eab23..f7db7df966 100644 --- a/tests/store.scm +++ b/tests/store.scm @@ -196,6 +196,41 @@ (null? (references %store t1)) (null? (referrers %store t2))))) +(test-assert "references/substitutes missing reference info" + (with-store s + (set-build-options s #:use-substitutes? #f) + (guard (c ((nix-protocol-error? c) #t)) + (let* ((b (add-to-store s "bash" #t "sha256" + (search-bootstrap-binary "bash" + (%current-system)))) + (d (derivation s "the-thing" b '("--help") + #:inputs `((,b))))) + (references/substitutes s (list (derivation->output-path d) b)))))) + +(test-assert "references/substitutes with substitute info" + (with-store s + (set-build-options s #:use-substitutes? #t) + (let* ((t1 (add-text-to-store s "random1" (random-text))) + (t2 (add-text-to-store s "random2" (random-text) + (list t1))) + (t3 (add-text-to-store s "build" "echo -n $t2 > $out")) + (b (add-to-store s "bash" #t "sha256" + (search-bootstrap-binary "bash" + (%current-system)))) + (d (derivation s "the-thing" b `("-e" ,t3) + #:inputs `((,b) (,t3) (,t2)) + #:env-vars `(("t2" . ,t2)))) + (o (derivation->output-path d))) + (with-derivation-narinfo d + (sha256 => (sha256 (string->utf8 t2))) + (references => (list t2)) + + (equal? (references/substitutes s (list o t3 t2 t1)) + `((,t2) ;refs of O + () ;refs of T3 + (,t1) ;refs of T2 + ())))))) ;refs of T1 + (test-assert "requisites" (let* ((t1 (add-text-to-store %store "random1" (random-text) '())) @@ -415,7 +450,11 @@ (with-store s ;the right one again (set-build-options s #:use-substitutes? #t #:substitute-urls (%test-substitute-urls)) - (has-substitutes? s o)))))) + (has-substitutes? s o)) + (with-store s ;empty list of URLs + (set-build-options s #:use-substitutes? #t + #:substitute-urls '()) + (not (has-substitutes? s o))))))) (test-assert "substitute" (with-store s diff --git a/tests/ui.scm b/tests/ui.scm index bd4c907525..f28e623ccf 100644 --- a/tests/ui.scm +++ b/tests/ui.scm @@ -108,10 +108,10 @@ Second line" 24)) (package-specification->name+version+output spec)) list)) '("guile" - "guile-2.0.9" + "guile@2.0.9" "guile:debug" - "guile-2.0.9:debug" - "guile-cairo-1.4.1"))) + "guile@2.0.9:debug" + "guile-cairo@1.4.1"))) (test-equal "integer" '(1) diff --git a/tests/upstream.scm b/tests/upstream.scm new file mode 100644 index 0000000000..eb18dd6193 --- /dev/null +++ b/tests/upstream.scm @@ -0,0 +1,49 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2016 Ludovic Courtès <ludo@gnu.org> +;;; +;;; 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 (test-upstream) + #:use-module (guix upstream) + #:use-module (guix tests) + #:use-module (srfi srfi-64)) + + +(test-begin "upstream") + +(test-equal "coalesce-sources same version" + (list (upstream-source + (package "foo") (version "1") + (urls '("ftp://example.org/foo-1.tar.xz" + "ftp://example.org/foo-1.tar.gz")) + (signature-urls '("ftp://example.org/foo-1.tar.xz.sig" + "ftp://example.org/foo-1.tar.gz.sig")))) + + (coalesce-sources (list (upstream-source + (package "foo") (version "1") + (urls '("ftp://example.org/foo-1.tar.gz")) + (signature-urls + '("ftp://example.org/foo-1.tar.gz.sig"))) + (upstream-source + (package "foo") (version "1") + (urls '("ftp://example.org/foo-1.tar.xz")) + (signature-urls + '("ftp://example.org/foo-1.tar.xz.sig")))))) + +(test-end) + + +(exit (= (test-runner-fail-count (test-runner-current)) 0)) diff --git a/tests/utils.scm b/tests/utils.scm index a05faabc15..67b3724451 100644 --- a/tests/utils.scm +++ b/tests/utils.scm @@ -1,6 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2012, 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2014 Eric Bavier <bavier@member.fsf.org> +;;; Copyright © 2016 Mathieu Lirzin <mthl@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -59,14 +60,14 @@ ((name version) (let*-values (((full-name) (if version - (string-append name "-" version) + (string-append name "@" version) name)) ((name* version*) (package-name->name+version full-name))) (and (equal? name* name) (equal? version* version))))) '(("foo" "0.9.1b") - ("foo-bar" "1.0") + ("foo-14-bar" "320") ("foo-bar2" #f) ("guile" "2.0.6.65-134c9") ; as produced by `git-version-gen' ("nixpkgs" "1.0pre22125_a28fe19") |