diff options
Diffstat (limited to 'tests')
| -rw-r--r-- | tests/boot-parameters.scm | 23 | ||||
| -rw-r--r-- | tests/gexp.scm | 14 | ||||
| -rw-r--r-- | tests/graph.scm | 2 | ||||
| -rw-r--r-- | tests/guix-build.sh | 6 | ||||
| -rw-r--r-- | tests/guix-pack-relocatable.sh | 108 | ||||
| -rw-r--r-- | tests/packages.scm | 43 | ||||
| -rw-r--r-- | tests/publish.scm | 83 | ||||
| -rw-r--r-- | tests/transformations.scm (renamed from tests/scripts-build.scm) | 270 |
8 files changed, 410 insertions, 139 deletions
diff --git a/tests/boot-parameters.scm b/tests/boot-parameters.scm index d7e579bc89..a00b227551 100644 --- a/tests/boot-parameters.scm +++ b/tests/boot-parameters.scm @@ -46,6 +46,9 @@ (define %default-initrd (string-append %default-initrd-path "/initrd.cpio.gz")) (define %default-root-device (uuid "abcdef12-3456-7890-abcd-ef1234567890")) (define %default-store-device (uuid "01234567-89ab-cdef-0123-456789abcdef")) +(define %default-btrfs-subvolume "testfs") +(define %default-store-directory-prefix + (string-append "/" %default-btrfs-subvolume)) (define %default-store-mount-point (%store-prefix)) (define %default-multiboot-modules '()) (define %default-locale "es_ES.utf8") @@ -63,6 +66,7 @@ (multiboot-modules %default-multiboot-modules) (locale %default-locale) (store-device %default-store-device) + (store-directory-prefix %default-store-directory-prefix) (store-mount-point %default-store-mount-point))) (define %default-operating-system @@ -81,7 +85,10 @@ (file-system (device %default-store-device) (mount-point %default-store-mount-point) - (type "btrfs")) + (type "btrfs") + (options + (string-append "subvol=" + %default-btrfs-subvolume))) %base-file-systems)))) (define (quote-uuid uuid) @@ -103,6 +110,7 @@ (with-store #t) (store-device (quote-uuid %default-store-device)) + (store-directory-prefix %default-store-directory-prefix) (store-mount-point %default-store-mount-point)) (define (generate-boot-parameters) (define (sexp-or-nothing fmt val) @@ -117,10 +125,12 @@ (sexp-or-nothing " (kernel-arguments ~S)" kernel-arguments) (sexp-or-nothing " (initrd ~S)" initrd) (if with-store - (format #false " (store~a~a)" + (format #false " (store~a~a~a)" (sexp-or-nothing " (device ~S)" store-device) (sexp-or-nothing " (mount-point ~S)" - store-mount-point)) + store-mount-point) + (sexp-or-nothing " (directory-prefix ~S)" + store-directory-prefix)) "") (sexp-or-nothing " (locale ~S)" locale) (sexp-or-nothing " (bootloader-name ~a)" bootloader-name) @@ -149,6 +159,7 @@ (test-read-boot-parameters #:store-device #false) (test-read-boot-parameters #:store-device 'false) (test-read-boot-parameters #:store-mount-point #false) + (test-read-boot-parameters #:store-directory-prefix #false) (test-read-boot-parameters #:multiboot-modules #false) (test-read-boot-parameters #:locale #false) (test-read-boot-parameters #:bootloader-name #false @@ -253,4 +264,10 @@ (operating-system-boot-parameters %default-operating-system %default-root-device))) +(test-equal "from os, store-directory-prefix" + %default-store-directory-prefix + (boot-parameters-store-directory-prefix + (operating-system-boot-parameters %default-operating-system + %default-root-device))) + (test-end "boot-parameters") diff --git a/tests/gexp.scm b/tests/gexp.scm index 1beeb67c21..686334af61 100644 --- a/tests/gexp.scm +++ b/tests/gexp.scm @@ -30,6 +30,7 @@ #:use-module (gnu packages) #:use-module (gnu packages base) #:use-module (gnu packages bootstrap) + #:use-module ((guix diagnostics) #:select (guix-warning-port)) #:use-module (srfi srfi-1) #:use-module (srfi srfi-34) #:use-module (srfi srfi-64) @@ -818,6 +819,17 @@ '() (gexp-modules #t)) +(test-assert "gexp-modules, warning" + (string-match "tests/gexp.scm:[0-9]+:[0-9]+: warning: \ +importing.* \\(guix config\\) from the host" + (call-with-output-string + (lambda (port) + (parameterize ((guix-warning-port port)) + (let* ((x (with-imported-modules '((guix config)) + #~(+ 1 2 3))) + (y #~(+ 39 #$x))) + (gexp-modules y))))))) + (test-assertm "gexp->derivation #:modules" (mlet* %store-monad ((build -> #~(begin @@ -1413,7 +1425,7 @@ (test-assert "printer" (string-match "^#<gexp \\(string-append .*#<package coreutils.*\ - \"/bin/uname\"\\) [[:xdigit:]]+>$" + \"/bin/uname\"\\) [[:graph:]]+tests/gexp\\.scm:[0-9]+:[0-9]+ [[:xdigit:]]+>$" (with-output-to-string (lambda () (write diff --git a/tests/graph.scm b/tests/graph.scm index 0663d13b49..e374dad1a5 100644 --- a/tests/graph.scm +++ b/tests/graph.scm @@ -198,7 +198,7 @@ edges." (test-assert "reverse bag DAG" (let-values (((dune bap ocaml-base) - (values (specification->package "dune") + (values (specification->package "ocaml4.07-dune") (specification->package "bap") (specification->package "ocaml4.07-base"))) ((backend nodes+edges) (make-recording-backend))) diff --git a/tests/guix-build.sh b/tests/guix-build.sh index 4a58ea1476..b7602e668c 100644 --- a/tests/guix-build.sh +++ b/tests/guix-build.sh @@ -289,6 +289,12 @@ drv1=`guix build glib -d` drv2=`guix build glib -d --with-input=libreoffice=inkscape` test "$drv1" = "$drv2" +# '--with-graft' should have no effect when using '--no-grafts'. +# See <https://bugs.gnu.org/43890>. +drv1=`guix build inkscape -d --no-grafts` +drv2=`guix build inkscape -d --no-grafts --with-graft=glib=glib-networking` +test "$drv1" = "$drv2" + # Rewriting implicit inputs. drv1=`guix build hello -d` drv2=`guix build hello -d --with-input=gcc=gcc-toolchain` diff --git a/tests/guix-pack-relocatable.sh b/tests/guix-pack-relocatable.sh index a960ecd209..2beb1b1eb6 100644 --- a/tests/guix-pack-relocatable.sh +++ b/tests/guix-pack-relocatable.sh @@ -1,5 +1,6 @@ # GNU Guix --- Functional package management for GNU # Copyright © 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org> +# Copyright © 2020 Eric Bavier <bavier@posteo.net> # # This file is part of GNU Guix. # @@ -58,6 +59,19 @@ run_without_store () fi } +# Wait for the given file to show up. Error out if it doesn't show up in a +# timely fashion. +wait_for_file () +{ + i=0 + while ! test -f "$1" && test $i -lt 20 + do + sleep 0.3 + i=`expr $i + 1` + done + test -f "$1" +} + test_directory="`mktemp -d`" export test_directory trap 'chmod -Rf +w "$test_directory"; rm -rf "$test_directory"' EXIT @@ -98,6 +112,7 @@ case "`uname -m`" in run_without_store GUIX_EXECUTION_ENGINE="fakechroot" \ "$test_directory/Bin/sed" --version > "$test_directory/output" grep 'GNU sed' "$test_directory/output" + unset GUIX_EXECUTION_ENGINE chmod -Rf +w "$test_directory"; rm -rf "$test_directory"/* @@ -129,12 +144,105 @@ case "`uname -m`" in ;; esac +if unshare -r true +then + # Check what happens if the wrapped binary forks and leaves child + # processes behind, like a daemon. The root file system should remain + # available to those child processes. See <https://bugs.gnu.org/44261>. + cat > "$test_directory/manifest.scm" <<EOF +(use-modules (guix)) + +(define daemon + (program-file "daemon" + #~(begin + (use-modules (ice-9 match) + (ice-9 ftw)) + + (call-with-output-file "parent-store" + (lambda (port) + (write (scandir (ungexp (%store-prefix))) + port))) + + (match (primitive-fork) + (0 (sigaction SIGHUP (const #t)) + (call-with-output-file "pid" + (lambda (port) + (display (getpid) port))) + (pause) + (call-with-output-file "child-store" + (lambda (port) + (write (scandir (ungexp (%store-prefix))) + port)))) + (_ #t))))) + +(define package + (computed-file "package" + #~(let ((out (ungexp output))) + (mkdir out) + (mkdir (string-append out "/bin")) + (symlink (ungexp daemon) + (string-append out "/bin/daemon"))))) + +(manifest (list (manifest-entry + (name "daemon") + (version "0") + (item package)))) +EOF + + tarball="$(guix pack -S /bin=bin -R -m "$test_directory/manifest.scm")" + (cd "$test_directory"; tar xf "$tarball") + + # Run '/bin/daemon', which forks, then wait for the child, send it SIGHUP + # so that it dumps its view of the store, and make sure the child and + # parent both see the same store contents. + (cd "$test_directory"; run_without_store ./bin/daemon) + wait_for_file "$test_directory/pid" + kill -HUP $(cat "$test_directory/pid") + wait_for_file "$test_directory/child-store" + diff -u "$test_directory/parent-store" "$test_directory/child-store" + + chmod -Rf +w "$test_directory"; rm -rf "$test_directory"/* +fi + # Ensure '-R' works with outputs other than "out". tarball="`guix pack -R -S /share=share groff:doc`" (cd "$test_directory"; tar xf "$tarball") test -d "$test_directory/share/doc/groff/html" +chmod -Rf +w "$test_directory"; rm -rf "$test_directory"/* # Ensure '-R' applies to propagated inputs. Failing to do that, it would fail # with a profile collision error in this case because 'python-scipy' # propagates 'python-numpy'. See <https://bugs.gnu.org/42510>. guix pack -RR python-numpy python-scipy --no-grafts -n + +# Check that packages that mix executable and support files (e.g. git) in the +# "binary" directories still work after wrapped. +cat >"$test_directory/manifest.scm" <<'EOF' +(use-modules (guix) (guix profiles) (guix search-paths) + (gnu packages bootstrap)) +(manifest + (list (manifest-entry + (name "test") (version "0") + (item (file-union "test" + `(("bin/hello" + ,(program-file + "hello" + #~(begin + (add-to-load-path (getenv "HELLO_EXEC_PATH")) + (display (load-from-path "msg"))(newline)) + #:guile %bootstrap-guile)) + ("libexec/hello/msg" + ,(plain-file "msg" "42"))))) + (search-paths + (list (search-path-specification + (variable "HELLO_EXEC_PATH") + (files '("libexec/hello")) + (separator #f))))))) +EOF +tarball="`guix pack -RR -S /opt= -m $test_directory/manifest.scm`" +(cd "$test_directory"; tar xvf "$tarball") +( export GUIX_PROFILE=$test_directory/opt + . $GUIX_PROFILE/etc/profile + run_without_store "$test_directory/opt/bin/hello" > "$test_directory/output" ) +cat "$test_directory/output" +test "`cat $test_directory/output`" = "42" diff --git a/tests/packages.scm b/tests/packages.scm index 2d13d91344..18e8e16e74 100644 --- a/tests/packages.scm +++ b/tests/packages.scm @@ -1450,6 +1450,49 @@ (eq? foo grep) (eq? bar dep)))))) +(test-assert "package-input-rewriting/spec, identity" + ;; Make sure that 'package-input-rewriting/spec' doesn't gratuitously + ;; introduce variants. In this case, the LIBFFI propagated input should not + ;; be duplicated when passing GOBJECT through REWRITE. + ;; See <https://issues.guix.gnu.org/43890>. + (let* ((libffi (dummy-package "libffi" + (build-system trivial-build-system))) + (glib (dummy-package "glib" + (build-system trivial-build-system) + (propagated-inputs `(("libffi" ,libffi))))) + (gobject (dummy-package "gobject-introspection" + (build-system trivial-build-system) + (inputs `(("glib" ,glib))) + (propagated-inputs `(("libffi" ,libffi))))) + (rewrite (package-input-rewriting/spec + `(("glib" . ,identity))))) + (and (= (length (package-transitive-inputs gobject)) + (length (package-transitive-inputs (rewrite gobject)))) + (string=? (derivation-file-name + (package-derivation %store (rewrite gobject))) + (derivation-file-name + (package-derivation %store gobject)))))) + +(test-assert "package-input-rewriting, identity" + ;; Similar to the test above, but with 'package-input-rewriting'. + ;; See <https://issues.guix.gnu.org/43890>. + (let* ((libffi (dummy-package "libffi" + (build-system trivial-build-system))) + (glib (dummy-package "glib" + (build-system trivial-build-system) + (propagated-inputs `(("libffi" ,libffi))))) + (gobject (dummy-package "gobject-introspection" + (build-system trivial-build-system) + (inputs `(("glib" ,glib))) + (propagated-inputs `(("libffi" ,libffi))))) + (rewrite (package-input-rewriting `((,glib . ,glib))))) + (and (= (length (package-transitive-inputs gobject)) + (length (package-transitive-inputs (rewrite gobject)))) + (string=? (derivation-file-name + (package-derivation %store (rewrite gobject))) + (derivation-file-name + (package-derivation %store gobject)))))) + (test-equal "package-patched-vulnerabilities" '(("CVE-2015-1234") ("CVE-2016-1234" "CVE-2018-4567") diff --git a/tests/publish.scm b/tests/publish.scm index 1c3b2785fb..e46e6256b7 100644 --- a/tests/publish.scm +++ b/tests/publish.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2015 David Thompson <davet@gnu.org> +;;; Copyright © 2020 by Amar M. Singh <nly@disroot.org> ;;; Copyright © 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. @@ -412,7 +413,8 @@ References: ~%" (call-with-new-thread (lambda () (guix-publish "--port=6797" "-C2" - (string-append "--cache=" cache))))))) + (string-append "--cache=" cache) + "--cache-bypass-threshold=0")))))) (wait-until-ready 6797) (let* ((base "http://localhost:6797/") (part (store-path-hash-part %item)) @@ -461,7 +463,8 @@ References: ~%" (call-with-new-thread (lambda () (guix-publish "--port=6794" "-Cgzip:2" "-Clzip:2" - (string-append "--cache=" cache))))))) + (string-append "--cache=" cache) + "--cache-bypass-threshold=0")))))) (wait-until-ready 6794) (let* ((base "http://localhost:6794/") (part (store-path-hash-part %item)) @@ -516,7 +519,8 @@ References: ~%" (call-with-new-thread (lambda () (guix-publish "--port=6796" "-C2" "--ttl=42h" - (string-append "--cache=" cache))))))) + (string-append "--cache=" cache) + "--cache-bypass-threshold=0")))))) (wait-until-ready 6796) (let* ((base "http://localhost:6796/") (part (store-path-hash-part item)) @@ -580,12 +584,79 @@ References: ~%" (basename item) ".narinfo")) (response (http-get url))) - (and (= 404 (response-code response)) + (and (= 200 (response-code response)) ;we're below the threshold (wait-for-file cached) (begin (delete-paths %store (list item)) (response-code (pk 'response (http-get url)))))))))) +(test-equal "with cache, cache bypass" + 200 + (call-with-temporary-directory + (lambda (cache) + (let ((thread (with-separate-output-ports + (call-with-new-thread + (lambda () + (guix-publish "--port=6788" "-C" "gzip" + (string-append "--cache=" cache))))))) + (wait-until-ready 6788) + + (let* ((base "http://localhost:6788/") + (item (add-text-to-store %store "random" (random-text))) + (part (store-path-hash-part item)) + (narinfo (string-append base part ".narinfo")) + (nar (string-append base "nar/gzip/" (basename item))) + (cached (string-append cache "/gzip/" (basename item) + ".narinfo"))) + ;; We're below the default cache bypass threshold, so NAR and NARINFO + ;; should immediately return 200. The NARINFO request should trigger + ;; caching, and the next request to NAR should return 200 as well. + (and (let ((response (pk 'r1 (http-get nar)))) + (and (= 200 (response-code response)) + (not (response-content-length response)))) ;not known + (= 200 (response-code (http-get narinfo))) + (begin + (wait-for-file cached) + (let ((response (pk 'r2 (http-get nar)))) + (and (> (response-content-length response) + (stat:size (stat item))) + (response-code response)))))))))) + +(test-equal "with cache, cache bypass, unmapped hash part" + 200 + + ;; This test reproduces the bug described in <https://bugs.gnu.org/44442>: + ;; the daemon connection would be closed as a side effect of a nar request + ;; for a non-existing file name. + (call-with-temporary-directory + (lambda (cache) + (let ((thread (with-separate-output-ports + (call-with-new-thread + (lambda () + (guix-publish "--port=6787" "-C" "gzip" + (string-append "--cache=" cache))))))) + (wait-until-ready 6787) + + (let* ((base "http://localhost:6787/") + (item (add-text-to-store %store "random" (random-text))) + (part (store-path-hash-part item)) + (narinfo (string-append base part ".narinfo")) + (nar (string-append base "nar/gzip/" (basename item))) + (cached (string-append cache "/gzip/" (basename item) + ".narinfo"))) + ;; The first response used to be 500 and to terminate the daemon + ;; connection as a side effect. + (and (= (response-code + (http-get (string-append base "nar/gzip/" + (make-string 32 #\e) + "-does-not-exist"))) + 404) + (= 200 (response-code (http-get nar))) + (= 200 (response-code (http-get narinfo))) + (begin + (wait-for-file cached) + (response-code (http-get nar))))))))) + (test-equal "/log/NAME" `(200 #t application/x-bzip2) (let ((drv (run-with-store %store @@ -613,6 +684,10 @@ References: ~%" (let ((uri (publish-uri "/log/does-not-exist"))) (response-code (http-get uri)))) +(test-equal "/signing-key.pub" + 200 + (response-code (http-get (publish-uri "/signing-key.pub")))) + (test-equal "non-GET query" '(200 404) (let ((path (string-append "/" (store-path-hash-part %item) diff --git a/tests/scripts-build.scm b/tests/transformations.scm index 6925374baa..07ed8b1234 100644 --- a/tests/scripts-build.scm +++ b/tests/transformations.scm @@ -16,15 +16,16 @@ ;;; 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-scripts-build) +(define-module (test-transformations) #:use-module (guix tests) #:use-module (guix store) + #:use-module ((guix gexp) #:select (lower-object)) #:use-module (guix derivations) #:use-module (guix packages) #:use-module (guix git-download) #:use-module (guix build-system) #:use-module (guix build-system gnu) - #:use-module (guix scripts build) + #:use-module (guix transformations) #:use-module (guix ui) #:use-module (guix utils) #:use-module (guix git) @@ -37,13 +38,12 @@ #:use-module (srfi srfi-64)) -(test-begin "scripts-build") +(test-begin "transformations") (test-assert "options->transformation, no transformations" (let ((p (dummy-package "foo")) (t (options->transformation '()))) - (with-store store - (eq? (t store p) p)))) + (eq? (t p) p))) (test-assert "options->transformation, with-source" ;; Our pseudo-package is called 'guix.scm' so the 'guix.scm' source should @@ -52,9 +52,11 @@ (s (search-path %load-path "guix.scm")) (t (options->transformation `((with-source . ,s))))) (with-store store - (let ((new (t store p))) + (let* ((new (t p)) + (source (run-with-store store + (lower-object (package-source new))))) (and (not (eq? new p)) - (string=? (package-source new) + (string=? source (add-to-store store "guix.scm" #t "sha256" s))))))) @@ -64,12 +66,9 @@ (let* ((p (dummy-package "guix.scm" (replacement coreutils))) (s (search-path %load-path "guix.scm")) (t (options->transformation `((with-source . ,s))))) - (with-store store - (let ((new (t store p))) - (and (not (eq? new p)) - (string=? (package-source new) - (add-to-store store "guix.scm" #t "sha256" s)) - (not (package-replacement new))))))) + (let ((new (t p))) + (and (not (eq? new p)) + (not (package-replacement new)))))) (test-assert "options->transformation, with-source, with version" ;; Our pseudo-package is called 'guix.scm' so the 'guix.scm-2.0' source @@ -82,11 +81,13 @@ (t (options->transformation `((with-source . ,f))))) (copy-file s f) (with-store store - (let ((new (t store p))) + (let* ((new (t p)) + (source (run-with-store store + (lower-object (package-source new))))) (and (not (eq? new p)) (string=? (package-name new) (package-name p)) (string=? (package-version new) "42.0") - (string=? (package-source new) + (string=? source (add-to-store store (basename f) #t "sha256" f)))))))))) @@ -95,13 +96,12 @@ (let* ((p (dummy-package "foobar")) (s (search-path %load-path "guix.scm")) (t (options->transformation `((with-source . ,s))))) - (with-store store - (let* ((port (open-output-string)) - (new (parameterize ((guix-warning-port port)) - (t store p)))) - (and (eq? new p) - (string-contains (get-output-string port) - "had no effect")))))) + (let* ((port (open-output-string)) + (new (parameterize ((guix-warning-port port)) + (t p)))) + (and (eq? new p) + (string-contains (get-output-string port) + "had no effect"))))) (test-assert "options->transformation, with-source, PKG=URI" (let* ((p (dummy-package "foo")) @@ -109,12 +109,14 @@ (f (string-append "foo=" s)) (t (options->transformation `((with-source . ,f))))) (with-store store - (let ((new (t store p))) + (let* ((new (t p)) + (source (run-with-store store + (lower-object (package-source new))))) (and (not (eq? new p)) (string=? (package-name new) (package-name p)) (string=? (package-version new) (package-version p)) - (string=? (package-source new) + (string=? source (add-to-store store (basename s) #t "sha256" s))))))) @@ -124,11 +126,13 @@ (f (string-append "foo@42.0=" s)) (t (options->transformation `((with-source . ,f))))) (with-store store - (let ((new (t store p))) + (let* ((new (t p)) + (source (run-with-store store + (lower-object (package-source new))))) (and (not (eq? new p)) (string=? (package-name new) (package-name p)) (string=? (package-version new) "42.0") - (string=? (package-source new) + (string=? source (add-to-store store (basename s) #t "sha256" s))))))) @@ -140,20 +144,19 @@ (native-inputs `(("x" ,grep))))))))) (t (options->transformation '((with-input . "coreutils=busybox") (with-input . "grep=findutils"))))) - (with-store store - (let ((new (t store p))) - (and (not (eq? new p)) - (match (package-inputs new) - ((("foo" dep1) ("bar" dep2) ("baz" dep3)) - (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)) - (string=? (package-full-name dep) - (package-full-name findutils)))))))))))) + (let ((new (t p))) + (and (not (eq? new p)) + (match (package-inputs new) + ((("foo" dep1) ("bar" dep2) ("baz" dep3)) + (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)) + (string=? (package-full-name dep) + (package-full-name findutils))))))))))) (test-assert "options->transformation, with-graft" (let* ((p (dummy-package "guix.scm" @@ -161,23 +164,22 @@ ("bar" ,(dummy-package "chbouib" (native-inputs `(("x" ,grep))))))))) (t (options->transformation '((with-graft . "grep=findutils"))))) - (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-full-name (package-replacement dep1)) - (package-full-name findutils)) - (string=? (package-name dep2) "chbouib") - (match (package-native-inputs dep2) - ((("x" dep)) - (with-store store - (string=? (derivation-file-name - (package-derivation store findutils)) - (derivation-file-name - (package-derivation store dep)))))))))))))) + (let ((new (t 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-full-name (package-replacement dep1)) + (package-full-name findutils)) + (string=? (package-name dep2) "chbouib") + (match (package-native-inputs dep2) + ((("x" dep)) + (with-store store + (string=? (derivation-file-name + (package-derivation store findutils)) + (derivation-file-name + (package-derivation store dep))))))))))))) (test-equal "options->transformation, with-branch" (git-checkout (url "https://example.org") @@ -193,15 +195,14 @@ (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))))))))) + (let ((new (t 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") @@ -217,15 +218,14 @@ (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))))))))) + (let ((new (t 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") @@ -236,17 +236,16 @@ ("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)))))))))))) + (let ((new (t 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 @@ -263,16 +262,15 @@ (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)))))))))))) + (let ((new (t 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))))))))))) (define* (depends-on-toolchain? p #:optional (toolchain "gcc-toolchain")) "Return true if P depends on TOOLCHAIN instead of the default tool chain." @@ -302,21 +300,20 @@ ;; Here we check that the transformation applies to DEP0 and all its ;; dependents: DEP0 must use GCC-TOOLCHAIN, DEP1 must use GCC-TOOLCHAIN ;; and the DEP0 that uses GCC-TOOLCHAIN, and so on. - (with-store store - (let ((new (t store p))) - (and (depends-on-toolchain? new "gcc-toolchain") - (match (bag-build-inputs (package->bag new)) - ((("foo" dep0) ("bar" dep1) _ ...) - (and (depends-on-toolchain? dep1 "gcc-toolchain") - (not (depends-on-toolchain? dep0 "gcc-toolchain")) - (string=? (package-full-name dep0) - (package-full-name grep)) - (match (bag-build-inputs (package->bag dep1)) - ((("x" dep) _ ...) - (and (depends-on-toolchain? dep "gcc-toolchain") - (match (bag-build-inputs (package->bag dep)) - ((("y" dep) _ ...) ;this one is unchanged - (eq? dep grep)))))))))))))) + (let ((new (t p))) + (and (depends-on-toolchain? new "gcc-toolchain") + (match (bag-build-inputs (package->bag new)) + ((("foo" dep0) ("bar" dep1) _ ...) + (and (depends-on-toolchain? dep1 "gcc-toolchain") + (not (depends-on-toolchain? dep0 "gcc-toolchain")) + (string=? (package-full-name dep0) + (package-full-name grep)) + (match (bag-build-inputs (package->bag dep1)) + ((("x" dep) _ ...) + (and (depends-on-toolchain? dep "gcc-toolchain") + (match (bag-build-inputs (package->bag dep)) + ((("y" dep) _ ...) ;this one is unchanged + (eq? dep grep))))))))))))) (test-equal "options->transformation, with-c-toolchain twice" (package-full-name grep) @@ -330,23 +327,37 @@ (t (options->transformation '((with-c-toolchain . "chbouib=clang-toolchain") (with-c-toolchain . "stuff=clang-toolchain"))))) - (with-store store - (let ((new (t store p))) - (and (depends-on-toolchain? new "clang-toolchain") - (match (bag-build-inputs (package->bag new)) - ((("foo" dep0) ("bar" dep1) ("baz" dep2) _ ...) - (and (depends-on-toolchain? dep0 "clang-toolchain") - (depends-on-toolchain? dep1 "clang-toolchain") - (not (depends-on-toolchain? dep2 "clang-toolchain")) - (package-full-name dep2))))))))) + (let ((new (t p))) + (and (depends-on-toolchain? new "clang-toolchain") + (match (bag-build-inputs (package->bag new)) + ((("foo" dep0) ("bar" dep1) ("baz" dep2) _ ...) + (and (depends-on-toolchain? dep0 "clang-toolchain") + (depends-on-toolchain? dep1 "clang-toolchain") + (not (depends-on-toolchain? dep2 "clang-toolchain")) + (package-full-name dep2)))))))) (test-assert "options->transformation, with-c-toolchain, no effect" (let ((p (dummy-package "thingie")) (t (options->transformation '((with-c-toolchain . "does-not-exist=gcc-toolchain"))))) ;; When it has no effect, '--with-c-toolchain' returns P. - (with-store store - (eq? (t store p) p)))) + (eq? (t p) p))) + +(test-equal "options->transformation, with-debug-info" + '(#:strip-binaries? #f) + (let* ((dep (dummy-package "chbouib")) + (p (dummy-package "thingie" + (build-system gnu-build-system) + (inputs `(("foo" ,dep) + ("bar" ,grep))))) + (t (options->transformation + '((with-debug-info . "chbouib"))))) + (let ((new (t p))) + (match (package-inputs new) + ((("foo" dep0) ("bar" dep1)) + (and (string=? (package-full-name dep1) + (package-full-name grep)) + (package-arguments (package-replacement dep0)))))))) (test-assert "options->transformation, without-tests" (let* ((dep (dummy-package "dep")) @@ -354,14 +365,13 @@ (inputs `(("dep" ,dep))))) (t (options->transformation '((without-tests . "dep") (without-tests . "tar"))))) - (with-store store - (let ((new (t store p))) - (match (bag-direct-inputs (package->bag new)) - ((("dep" dep) ("tar" tar) _ ...) - ;; TODO: Check whether TAR has #:tests? #f when transformations - ;; apply to implicit inputs. - (equal? (package-arguments dep) - '(#:tests? #f)))))))) + (let ((new (t p))) + (match (bag-direct-inputs (package->bag new)) + ((("dep" dep) ("tar" tar) _ ...) + ;; TODO: Check whether TAR has #:tests? #f when transformations + ;; apply to implicit inputs. + (equal? (package-arguments dep) + '(#:tests? #f))))))) (test-end) |