diff options
Diffstat (limited to 'tests')
| -rw-r--r-- | tests/build-utils.scm | 49 | ||||
| -rw-r--r-- | tests/builders.scm | 128 | ||||
| -rw-r--r-- | tests/cran.scm | 10 | ||||
| -rw-r--r-- | tests/egg.scm | 27 | ||||
| -rw-r--r-- | tests/gem.scm | 15 | ||||
| -rw-r--r-- | tests/gexp.scm | 7 | ||||
| -rw-r--r-- | tests/gremlin.scm | 88 | ||||
| -rw-r--r-- | tests/guix-environment.sh | 8 | ||||
| -rw-r--r-- | tests/hackage.scm | 22 | ||||
| -rw-r--r-- | tests/lint.scm | 16 | ||||
| -rw-r--r-- | tests/opam.scm | 10 | ||||
| -rw-r--r-- | tests/pack.scm | 4 | ||||
| -rw-r--r-- | tests/packages.scm | 270 | ||||
| -rw-r--r-- | tests/print.scm | 4 | ||||
| -rw-r--r-- | tests/pypi.scm | 18 | ||||
| -rw-r--r-- | tests/store.scm | 3 | ||||
| -rw-r--r-- | tests/style.scm | 366 | ||||
| -rw-r--r-- | tests/utils.scm | 40 |
18 files changed, 924 insertions, 161 deletions
diff --git a/tests/build-utils.scm b/tests/build-utils.scm index 654b480ed9..6b131c0af8 100644 --- a/tests/build-utils.scm +++ b/tests/build-utils.scm @@ -1,6 +1,8 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2012, 2015, 2016, 2019, 2020 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2019 Ricardo Wurmus <rekado@elephly.net> +;;; Copyright © 2021 Maxim Cournoyer <maxim.cournoyer@gmail.com> +;;; Copyright © 2021 Maxime Devos <maximedevos@telenet.be> ;;; ;;; This file is part of GNU Guix. ;;; @@ -18,7 +20,7 @@ ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. -(define-module (test-build-utils) +(define-module (test build-utils) #:use-module (guix tests) #:use-module (guix build utils) #:use-module ((guix utils) @@ -241,4 +243,49 @@ print('hello world')")) "/some/other/path"))) #f))))) +(test-equal "substitute*, text contains a NUL byte, UTF-8" + "c\0d" + (with-fluids ((%default-port-encoding "UTF-8") + (%default-port-conversion-strategy 'error)) + ;; The GNU libc is locale sensitive. Depending on the value of LANG, the + ;; test could fail with "string contains #\\nul character: ~S" or "cannot + ;; convert wide string to output locale". + (setlocale LC_ALL "en_US.UTF-8") + (call-with-temporary-output-file + (lambda (file port) + (format port "a\0b") + (flush-output-port port) + + (substitute* file + (("a") "c") + (("b") "d")) + + (with-input-from-file file + (lambda _ + (get-string-all (current-input-port)))))))) + +(test-equal "search-input-file: exception if not found" + `((path) + (file . "does-not-exist")) + (guard (e ((search-error? e) + `((path . ,(search-error-path e)) + (file . ,(search-error-file e))))) + (search-input-file '() "does-not-exist"))) + +(test-equal "search-input-file: can find if existent" + (which "guile") + (search-input-file + `(("guile/bin" . ,(dirname (which "guile")))) + "guile")) + +(test-equal "search-input-file: can search in multiple directories" + (which "guile") + (call-with-temporary-directory + (lambda (directory) + (search-input-file + `(("irrelevant" . ,directory) + ("guile/bin" . ,(dirname (which "guile")))) + "guile")))) + + (test-end) diff --git a/tests/builders.scm b/tests/builders.scm index fdcf38ded3..f609631ae7 100644 --- a/tests/builders.scm +++ b/tests/builders.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013, 2014, 2015, 2019 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2012, 2013, 2014, 2015, 2018, 2019, 2021 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2021 Lars-Dominik Braun <lars@6xq.net> ;;; ;;; This file is part of GNU Guix. ;;; @@ -17,22 +18,27 @@ ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. -(define-module (test-builders) +(define-module (tests builders) #:use-module (guix download) #:use-module (guix build-system) #:use-module (guix build-system gnu) + #:use-module (guix build gnu-build-system) + #:use-module (guix build utils) + #:use-module (guix build-system python) #:use-module (guix store) + #:use-module (guix monads) #:use-module (guix utils) #:use-module (guix base32) #:use-module (guix derivations) #:use-module (gcrypt hash) #:use-module (guix tests) - #:use-module ((guix packages) - #:select (package? - package-derivation package-native-search-paths)) + #:use-module (guix packages) #:use-module (gnu packages bootstrap) #:use-module (ice-9 match) + #:use-module (ice-9 textual-ports) #:use-module (srfi srfi-1) + #:use-module (srfi srfi-11) + #:use-module (srfi srfi-34) #:use-module (srfi srfi-64)) ;; Test the higher-level builders. @@ -78,4 +84,116 @@ (test-assert "gnu-build-system" (build-system? gnu-build-system)) +(define unpack (assoc-ref %standard-phases 'unpack)) + +(define compressors '(("gzip" . "gz") + ("xz" . "xz") + ("bzip2" . "bz2") + (#f . #f))) + +(for-each + (match-lambda + ((comp . ext) + + (unless (network-reachable?) (test-skip 1)) ;for bootstrap binaries + (test-equal (string-append "gnu-build-system unpack phase, " + "single file (compression: " + (if comp comp "None") ")") + "expected text" + (let*-values + (((name) "test") + ((compressed-name) (if ext + (string-append name "." ext) + name)) + ((file hash) (test-file %store compressed-name "expected text"))) + (call-with-temporary-directory + (lambda (dir) + (with-directory-excursion dir + (unpack #:source file) + (call-with-input-file name get-string-all)))))))) + compressors) + + +;;; +;;; Test the sanity-check phase of the Python build system. +;;; + +(define* (make-python-dummy name #:key (setup-py-extra "") + (init-py "") (use-setuptools? #t)) + (dummy-package (string-append "python-dummy-" name) + (version "0.1") + (build-system python-build-system) + (arguments + `(#:tests? #f + #:use-setuptools? ,use-setuptools? + #:phases + (modify-phases %standard-phases + (replace 'unpack + (lambda _ + (mkdir-p "dummy") + (with-output-to-file "dummy/__init__.py" + (lambda _ + (display ,init-py))) + (with-output-to-file "setup.py" + (lambda _ + (format #t "\ +~a +setup( + name='dummy-~a', + version='0.1', + packages=['dummy'], + ~a + )" + (if ,use-setuptools? + "from setuptools import setup" + "from distutils.core import setup") + ,name ,setup-py-extra)))))))))) + +(define python-dummy-ok + (make-python-dummy "ok")) + +;; distutil won't install any metadata, so make sure our script does not fail +;; on a otherwise fine package. +(define python-dummy-no-setuptools + (make-python-dummy + "no-setuptools" #:use-setuptools? #f)) + +(define python-dummy-fail-requirements + (make-python-dummy "fail-requirements" + #:setup-py-extra "install_requires=['nonexistent'],")) + +(define python-dummy-fail-import + (make-python-dummy "fail-import" #:init-py "import nonexistent")) + +(define python-dummy-fail-console-script + (make-python-dummy "fail-console-script" + #:setup-py-extra (string-append "entry_points={'console_scripts': " + "['broken = dummy:nonexistent']},"))) + +(define (check-build-success store p) + (unless store (test-skip 1)) + (test-assert (string-append "python-build-system: " (package-name p)) + (let* ((drv (package-derivation store p))) + (build-derivations store (list drv))))) + +(define (check-build-failure store p) + (unless store (test-skip 1)) + (test-assert (string-append "python-build-system: " (package-name p)) + (let ((drv (package-derivation store p))) + (guard (c ((store-protocol-error? c) + (pk 'failure c #t))) ;good! + (build-derivations store (list drv)) + #f)))) ;bad: it should have failed + +(with-external-store store + (for-each (lambda (p) (check-build-success store p)) + (list + python-dummy-ok + python-dummy-no-setuptools)) + (for-each (lambda (p) (check-build-failure store p)) + (list + python-dummy-fail-requirements + python-dummy-fail-import + python-dummy-fail-console-script))) + (test-end "builders") diff --git a/tests/cran.scm b/tests/cran.scm index 70d2277198..e59b7daef7 100644 --- a/tests/cran.scm +++ b/tests/cran.scm @@ -117,15 +117,9 @@ Date/Publication: 2015-07-14 14:15:16 (? string? hash))))) ('properties ('quasiquote (('upstream-name . "My-Example")))) ('build-system 'r-build-system) - ('inputs - ('quasiquote - (("cairo" ('unquote 'cairo))))) + ('inputs ('list 'cairo)) ('propagated-inputs - ('quasiquote - (("r-bh" ('unquote 'r-bh)) - ("r-proto" ('unquote 'r-proto)) - ("r-rcpp" ('unquote 'r-rcpp)) - ("r-scales" ('unquote 'r-scales))))) + ('list 'r-bh 'r-proto 'r-rcpp 'r-scales)) ('home-page "http://gnu.org/s/my-example") ('synopsis "Example package") ('description diff --git a/tests/egg.scm b/tests/egg.scm index 0884d8d429..9e45a42443 100644 --- a/tests/egg.scm +++ b/tests/egg.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2021 Xinglu Chen <public@yoctocell.xyz> +;;; Copyright © 2021 Sarah Morgensen <iskarian@mgsn.dev> ;;; ;;; This file is part of GNU Guix. ;;; @@ -86,16 +87,9 @@ ('build-system 'chicken-build-system) ('arguments ('quasiquote ('#:egg-name "foo"))) ('native-inputs - ('quasiquote - (("chicken-test" ('unquote chicken-test)) - ("chicken-srfi-1" ('unquote chicken-srfi-1)) - ("chicken-begin-syntax" ('unquote chicken-begin-syntax))))) - ('inputs - ('quasiquote - (("libgit2" ('unquote libgit2))))) - ('propagated-inputs - ('quasiquote - (("chicken-datatype" ('unquote chicken-datatype))))) + ('list 'chicken-test 'chicken-srfi-1 'chicken-begin-syntax)) + ('inputs ('list 'libgit2)) + ('propagated-inputs ('list 'chicken-datatype)) ('home-page "https://wiki.call-cc.org/egg/foo") ('synopsis "Example egg") ('description #f) @@ -108,16 +102,9 @@ ('source (? file-like? source)) ('build-system 'chicken-build-system) ('arguments ('quasiquote ('#:egg-name "bar"))) - ('native-inputs - ('quasiquote - (("chicken-test" ('unquote chicken-test)) - ("chicken-begin-syntax" ('unquote chicken-begin-syntax))))) - ('inputs - ('quasiquote - (("libgit2" ('unquote libgit2))))) - ('propagated-inputs - ('quasiquote - (("chicken-datatype" ('unquote chicken-datatype))))) + ('native-inputs ('list 'chicken-test 'chicken-begin-syntax)) + ('inputs ('list 'libgit2)) + ('propagated-inputs ('list 'chicken-datatype)) ('home-page "https://wiki.call-cc.org/egg/bar") ('synopsis "Example egg") ('description #f) diff --git a/tests/gem.scm b/tests/gem.scm index 751bba656f..c8fe15398e 100644 --- a/tests/gem.scm +++ b/tests/gem.scm @@ -2,6 +2,7 @@ ;;; Copyright © 2015 David Thompson <davet@gnu.org> ;;; Copyright © 2016 Ricardo Wurmus <rekado@elephly.net> ;;; Copyright © 2018 Oleg Pykhalov <go.wigust@gmail.com> +;;; Copyright © 2021 Sarah Morgensen <iskarian@mgsn.dev> ;;; ;;; This file is part of GNU Guix. ;;; @@ -93,10 +94,7 @@ ('base32 "1a270mlajhrmpqbhxcqjqypnvgrq4pgixpv3w9gwp1wrrapnwrzk")))) ('build-system 'ruby-build-system) - ('propagated-inputs - ('quasiquote - (("bundler" ('unquote 'bundler)) - ("ruby-bar" ('unquote 'ruby-bar))))) + ('propagated-inputs ('list 'bundler 'ruby-bar)) ('synopsis "A cool gem") ('description "This package provides a cool gem") ('home-page "https://example.com") @@ -132,9 +130,7 @@ ('base32 "1a270mlajhrmpqbhxcqjqypnvgrq4pgixpv3w9gwp1wrrapnwrzk")))) ('build-system 'ruby-build-system) - ('propagated-inputs - ('quasiquote - (('"bundler" ('unquote 'bundler))))) + ('propagated-inputs ('list 'bundler)) ('synopsis "Another cool gem") ('description "Another cool gem") ('home-page "https://example.com") @@ -165,10 +161,7 @@ ('base32 "1a270mlajhrmpqbhxcqjqypnvgrq4pgixpv3w9gwp1wrrapnwrzk")))) ('build-system 'ruby-build-system) - ('propagated-inputs - ('quasiquote - (("bundler" ('unquote 'bundler)) - ("ruby-bar" ('unquote 'ruby-bar))))) + ('propagated-inputs ('list 'bundler 'ruby-bar)) ('synopsis "A cool gem") ('description "This package provides a cool gem") ('home-page "https://example.com") diff --git a/tests/gexp.scm b/tests/gexp.scm index 39a47d4e8c..709a198e1e 100644 --- a/tests/gexp.scm +++ b/tests/gexp.scm @@ -127,6 +127,13 @@ (null? (gexp-inputs exp)) (gexp->sexp* exp)))) +(test-equal "sexp->gexp" + '(a b (c d) e) + (let ((exp (sexp->gexp '(a b (c d) e)))) + (and (gexp? exp) + (null? (gexp-inputs exp)) + (gexp->sexp* exp)))) + (test-equal "unquote" '(display `(foo ,(+ 2 3))) (let ((exp (gexp (display `(foo ,(+ 2 3)))))) diff --git a/tests/gremlin.scm b/tests/gremlin.scm index b0bb7a8e49..9af899c89a 100644 --- a/tests/gremlin.scm +++ b/tests/gremlin.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2015, 2018 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2015, 2018, 2020 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -23,9 +23,12 @@ #:use-module (guix build gremlin) #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) + #:use-module (srfi srfi-34) #:use-module (srfi srfi-64) #:use-module (rnrs io ports) #:use-module (ice-9 popen) + #:use-module (ice-9 rdelim) + #:use-module (ice-9 regex) #:use-module (ice-9 match)) (define %guile-executable @@ -57,6 +60,44 @@ (string-take lib (string-contains lib ".so"))) (elf-dynamic-info-needed dyninfo)))))) +(unless (and %guile-executable (not (getenv "LD_LIBRARY_PATH")) + (file-needed %guile-executable) ;statically linked? + ;; When Guix has been built on a foreign distro, using a + ;; toolchain and libraries from that foreign distro, it is not + ;; unusual for the runpath to be empty. + (pair? (file-runpath %guile-executable))) + (test-skip 1)) +(test-assert "file-needed/recursive" + (let* ((needed (file-needed/recursive %guile-executable)) + (pipe (dynamic-wind + (lambda () + ;; Tell ld.so to list loaded objects, like 'ldd' does. + (setenv "LD_TRACE_LOADED_OBJECTS" "yup")) + (lambda () + (open-pipe* OPEN_READ %guile-executable)) + (lambda () + (unsetenv "LD_TRACE_LOADED_OBJECTS"))))) + (define ldd-rx + (make-regexp "^[[:blank:]]+([[:graph:]]+ => )?([[:graph:]]+) .*$")) + + (define (read-ldd-output port) + ;; Read from PORT output in GNU ldd format. + (let loop ((result '())) + (match (read-line port) + ((? eof-object?) + (reverse result)) + ((= (cut regexp-exec ldd-rx <>) m) + (if m + (loop (cons (match:substring m 2) result)) + (loop result)))))) + + (define ground-truth + (remove (cut string-prefix? "linux-vdso.so" <>) + (read-ldd-output pipe))) + + (and (zero? (close-pipe pipe)) + (lset= string=? (pk 'truth ground-truth) (pk 'needed needed))))) + (test-equal "expand-origin" '("OOO/../lib" "OOO" @@ -96,4 +137,49 @@ (close-pipe pipe) str))))))) +(unless c-compiler + (test-skip 1)) +(test-equal "set-file-runpath + file-runpath" + "hello\n" + (call-with-temporary-directory + (lambda (directory) + (with-directory-excursion directory + (call-with-output-file "t.c" + (lambda (port) + (display "int main () { puts(\"hello\"); }" port))) + + (invoke c-compiler "t.c" + "-Wl,--enable-new-dtags" "-Wl,-rpath=/xxxxxxxxx") + + (let ((original-runpath (file-runpath "a.out"))) + (and (member "/xxxxxxxxx" original-runpath) + (guard (c ((runpath-too-long-error? c) + (string=? "a.out" (runpath-too-long-error-file c)))) + (set-file-runpath "a.out" (list (make-string 777 #\y)))) + (let ((runpath (delete "/xxxxxxxxx" original-runpath))) + (set-file-runpath "a.out" runpath) + (equal? runpath (file-runpath "a.out"))) + (let* ((pipe (open-input-pipe "./a.out")) + (str (get-string-all pipe))) + (close-pipe pipe) + str))))))) + +(unless c-compiler + (test-skip 1)) +(test-equal "elf-dynamic-info-soname" + "libfoo.so.2" + (call-with-temporary-directory + (lambda (directory) + (with-directory-excursion directory + (call-with-output-file "t.c" + (lambda (port) + (display "// empty file" port))) + (invoke c-compiler "t.c" + "-shared" "-Wl,-soname,libfoo.so.2") + (let* ((dyninfo (elf-dynamic-info + (parse-elf (call-with-input-file "a.out" + get-bytevector-all)))) + (soname (elf-dynamic-info-soname dyninfo))) + soname))))) + (test-end "gremlin") diff --git a/tests/guix-environment.sh b/tests/guix-environment.sh index afadcbe195..fe2430b658 100644 --- a/tests/guix-environment.sh +++ b/tests/guix-environment.sh @@ -192,7 +192,7 @@ then # Make sure the bootstrap binaries are all listed where they belong. grep -E "^export PATH=\"$profile/bin\"" "$tmpdir/a" - grep -E "^export CPATH=\"$profile/include\"" "$tmpdir/a" + grep -E "^export C_INCLUDE_PATH=\"$profile/include\"" "$tmpdir/a" grep -E "^export LIBRARY_PATH=\"$profile/lib\"" "$tmpdir/a" for dep in bootstrap-binaries-0 gcc-bootstrap-0 glibc-bootstrap-0 do @@ -206,8 +206,8 @@ then # as returned by '--search-paths'. guix environment --bootstrap --no-substitutes --pure \ -e '(@ (guix tests) gnu-make-for-tests)' \ - -- /bin/sh -c 'echo $PATH $CPATH $LIBRARY_PATH' > "$tmpdir/b" - ( . "$tmpdir/a" ; echo $PATH $CPATH $LIBRARY_PATH ) > "$tmpdir/c" + -- /bin/sh -c 'echo $PATH $C_INCLUDE_PATH $LIBRARY_PATH' > "$tmpdir/b" + ( . "$tmpdir/a" ; echo $PATH $C_INCLUDE_PATH $LIBRARY_PATH ) > "$tmpdir/c" cmp "$tmpdir/b" "$tmpdir/c" rm "$tmpdir"/* @@ -228,7 +228,7 @@ then # Make sure the bootstrap binaries are all listed where they belong. grep -E "^export PATH=\"$profile/bin\"" "$tmpdir/a" - grep -E "^export CPATH=\"$profile/include\"" "$tmpdir/a" + grep -E "^export C_INCLUDE_PATH=\"$profile/include\"" "$tmpdir/a" grep -E "^export LIBRARY_PATH=\"$profile/lib\"" "$tmpdir/a" for dep in bootstrap-binaries-0 gcc-bootstrap-0 glibc-bootstrap-0 \ guile-bootstrap diff --git a/tests/hackage.scm b/tests/hackage.scm index 53972fc643..073e35ad05 100644 --- a/tests/hackage.scm +++ b/tests/hackage.scm @@ -2,6 +2,7 @@ ;;; Copyright © 2015 Federico Beffa <beffa@fbengineering.ch> ;;; Copyright © 2019 Robert Vollmert <rob@vllmrt.net> ;;; Copyright © 2021 Xinglu Chen <public@yoctocell.xyz> +;;; Copyright © 2021 Sarah Morgensen <iskarian@mgsn.dev> ;;; ;;; This file is part of GNU Guix. ;;; @@ -178,9 +179,7 @@ library ('base32 (? string? hash))))) ('build-system 'haskell-build-system) - ('inputs - ('quasiquote - (("ghc-http" ('unquote 'ghc-http))))) + ('inputs ('list 'ghc-http)) ('home-page "http://test.org") ('synopsis (? string?)) ('description (? string?)) @@ -223,13 +222,8 @@ library ('base32 (? string? hash))))) ('build-system 'haskell-build-system) - ('inputs - ('quasiquote - (("ghc-b" ('unquote 'ghc-b)) - ("ghc-http" ('unquote 'ghc-http))))) - ('native-inputs - ('quasiquote - (("ghc-haskell-gi" ('unquote 'ghc-haskell-gi))))) + ('inputs ('list 'ghc-b 'ghc-http)) + ('native-inputs ('list 'ghc-haskell-gi)) ('home-page "http://test.org") ('synopsis (? string?)) ('description (? string?)) @@ -353,9 +347,7 @@ executable cabal ('base32 (? string? hash))))) ('build-system 'haskell-build-system) - ('inputs - ('quasiquote - (("ghc-http" ('unquote 'ghc-http))))) + ('inputs ('list 'ghc-http)) ('arguments ('quasiquote ('#:cabal-revision @@ -419,9 +411,7 @@ executable cabal ('base32 (? string? hash))))) ('build-system 'haskell-build-system) - ('inputs - ('quasiquote - (("ghc-http" ('unquote 'ghc-http))))) + ('inputs ('list 'ghc-http)) ('home-page "http://test.org") ('synopsis (? string?)) ('description (? string?)) diff --git a/tests/lint.scm b/tests/lint.scm index 0f51b9ef79..dfb45ef60d 100644 --- a/tests/lint.scm +++ b/tests/lint.scm @@ -366,6 +366,20 @@ `(("python-setuptools" ,python-setuptools)))))) (check-inputs-should-not-be-an-input-at-all pkg)))) +(test-assert "input labels: no warnings" + (let ((pkg (dummy-package "x" + (inputs `(("glib" ,glib) + ("pkg-config" ,pkg-config)))))) + (null? (check-input-labels pkg)))) + +(test-equal "input labels: one warning" + "label 'pkgkonfig' does not match package name 'pkg-config'" + (single-lint-warning-message + (let ((pkg (dummy-package "x" + (inputs `(("glib" ,glib) + ("pkgkonfig" ,pkg-config)))))) + (check-input-labels pkg)))) + (test-equal "explicit #:sh argument to 'wrap-program' is acceptable" '() (let* ((phases @@ -572,7 +586,7 @@ (single-lint-warning-message (check-patch-headers pkg))))) (test-equal "derivation: invalid arguments" - "failed to create x86_64-linux derivation: (wrong-type-arg \"map\" \"Wrong type argument: ~S\" (invalid-module) ())" + "failed to create x86_64-linux derivation: (match-error \"match\" \"no matching pattern\" invalid-module)" (match (let ((pkg (dummy-package "x" (arguments '(#:imported-modules (invalid-module)))))) diff --git a/tests/opam.scm b/tests/opam.scm index 1536b74339..f2e9a7103c 100644 --- a/tests/opam.scm +++ b/tests/opam.scm @@ -1,6 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2018 Julien Lepiller <julien@lepiller.eu> ;;; Copyright © 2021 Xinglu Chen <public@yoctocell.xyz> +;;; Copyright © 2021 Sarah Morgensen <iskarian@mgsn.dev> ;;; ;;; This file is part of GNU Guix. ;;; @@ -99,13 +100,8 @@ url { ('base32 (? string? hash))))) ('build-system 'ocaml-build-system) - ('propagated-inputs - ('quasiquote - (("ocaml-zarith" ('unquote 'ocaml-zarith))))) - ('native-inputs - ('quasiquote - (("ocaml-alcotest" ('unquote 'ocaml-alcotest)) - ("ocamlbuild" ('unquote 'ocamlbuild))))) + ('propagated-inputs ('list 'ocaml-zarith)) + ('native-inputs ('list 'ocaml-alcotest 'ocamlbuild)) ('home-page "https://example.org/") ('synopsis "Some example package") ('description "This package is just an example.") diff --git a/tests/pack.scm b/tests/pack.scm index e9b4c36e0e..98bfedf21c 100644 --- a/tests/pack.scm +++ b/tests/pack.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2018 Ricardo Wurmus <rekado@elephly.net> ;;; Copyright © 2021 Maxim Cournoyer <maxim.cournoyer@gmail.com> ;;; @@ -54,7 +54,7 @@ ;; Compressor that uses the bootstrap 'gzip'. ((@ (guix scripts pack) compressor) "gzip" ".gz" - #~(#+(file-append %bootstrap-coreutils&co "/bin/gzip") "-6n"))) + #~(list #+(file-append %bootstrap-coreutils&co "/bin/gzip") "-6n"))) (define %tar-bootstrap %bootstrap-coreutils&co) diff --git a/tests/packages.scm b/tests/packages.scm index 2a290bc353..2e1ca10dc4 100644 --- a/tests/packages.scm +++ b/tests/packages.scm @@ -1,6 +1,8 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org> -;;; Copyright © Jan (janneke) Nieuwenhuizen <janneke@gnu.org> +;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org> +;;; Copyright © 2021 Maxim Cournoyer <maxim.cournoyer@gmail.com> +;;; Copyright © 2021 Maxime Devos <maximedevos@telenet.be> ;;; ;;; This file is part of GNU Guix. ;;; @@ -17,13 +19,14 @@ ;;; 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-packages) +(define-module (tests packages) #:use-module (guix tests) #:use-module (guix store) #:use-module (guix monads) #:use-module (guix grafts) - #:use-module ((guix gexp) #:select (local-file local-file-file)) + #:use-module (guix gexp) #:use-module (guix utils) + #:use-module ((guix build utils) #:select (tarball?)) #:use-module ((guix diagnostics) ;; Rename the 'location' binding to allow proper syntax ;; matching when setting the 'location' field of a package. @@ -32,6 +35,7 @@ (else name)))) #:use-module ((gcrypt hash) #:prefix gcrypt:) #:use-module (guix derivations) + #:use-module (guix download) #:use-module (guix packages) #:use-module (guix grafts) #:use-module (guix search-paths) @@ -51,6 +55,7 @@ #:use-module (gnu packages version-control) #:use-module (gnu packages xml) #:use-module (srfi srfi-1) + #:use-module (srfi srfi-11) #:use-module (srfi srfi-26) #:use-module (srfi srfi-34) #:use-module (srfi srfi-35) @@ -133,7 +138,7 @@ ;; inputs. See <https://bugs.gnu.org/35872>. (let* ((dep (dummy-package "dep" (version "2"))) (old (dummy-package "foo" (version "1") - (propagated-inputs `(("dep" ,dep))))) + (propagated-inputs (list dep)))) (drv (package-derivation %store old)) (tx (mock ((gnu packages) find-best-packages-by-name (const (list old))) @@ -221,7 +226,7 @@ (bar (dummy-package "bar" (version "0") (replacement old))) (new (dummy-package "foo" (version "1") - (inputs `(("bar" ,bar))))) + (inputs (list bar)))) (tx (mock ((gnu packages) find-best-packages-by-name (const (list new))) (transaction-upgrade-entry @@ -271,13 +276,13 @@ (test-assert "package-transitive-inputs" (let* ((a (dummy-package "a")) (b (dummy-package "b" - (propagated-inputs `(("a" ,a))))) + (propagated-inputs (list a)))) (c (dummy-package "c" - (inputs `(("a" ,a))))) + (inputs (list a)))) (d (dummy-package "d" (propagated-inputs `(("x" "something.drv"))))) (e (dummy-package "e" - (inputs `(("b" ,b) ("c" ,c) ("d" ,d)))))) + (inputs (list b c d))))) (and (null? (package-transitive-inputs a)) (equal? `(("a" ,a)) (package-transitive-inputs b)) (equal? `(("a" ,a)) (package-transitive-inputs c)) @@ -323,19 +328,19 @@ (b (dummy-package "b" (build-system trivial-build-system) (supported-systems '("x" "y")) - (inputs `(("a" ,a))))) + (inputs (list a)))) (c (dummy-package "c" (build-system trivial-build-system) (supported-systems '("y" "z")) - (inputs `(("b" ,b))))) + (inputs (list b)))) (d (dummy-package "d" (build-system trivial-build-system) (supported-systems '("x" "y" "z")) - (inputs `(("b" ,b) ("c" ,c))))) + (inputs (list b c)))) (e (dummy-package "e" (build-system trivial-build-system) (supported-systems '("x" "y" "z")) - (inputs `(("d" ,d)))))) + (inputs (list d))))) (list (package-transitive-supported-systems a) (package-transitive-supported-systems b) (package-transitive-supported-systems c) @@ -351,13 +356,13 @@ (build-system trivial-build-system)))))) (let* ((a (dummy-package/no-implicit "a")) (b (dummy-package/no-implicit "b" - (propagated-inputs `(("a" ,a))))) + (propagated-inputs (list a)))) (c (dummy-package/no-implicit "c" - (inputs `(("a" ,a))))) + (inputs (list a)))) (d (dummy-package/no-implicit "d" - (native-inputs `(("b" ,b))))) + (native-inputs (list b)))) (e (dummy-package/no-implicit "e" - (inputs `(("c" ,c) ("d" ,d)))))) + (inputs (list c d))))) (lset= eq? (list a b c d e) (package-closure (list e)) @@ -380,12 +385,11 @@ (u (dummy-origin)) (i (dummy-origin)) (a (dummy-package "a")) - (b (dummy-package "b" - (inputs `(("a" ,a) ("i" ,i))))) + (b (dummy-package "b" (inputs (list a i)))) (c (package (inherit b) (source o))) (d (dummy-package "d" (build-system trivial-build-system) - (source u) (inputs `(("c" ,c)))))) + (source u) (inputs (list c))))) (test-assert "package-direct-sources, no source" (null? (package-direct-sources a))) (test-equal "package-direct-sources, #f source" @@ -453,7 +457,7 @@ (supported-systems '("x86_64-linux")))) (p (dummy-package "foo" (build-system gnu-build-system) - (inputs `(("d" ,d))) + (inputs (list d)) (supported-systems '("x86_64-linux" "armhf-linux"))))) (and (supported-package? p "x86_64-linux") (not (supported-package? p "i686-linux")) @@ -578,6 +582,11 @@ (build-derivations %store (list drv)) (call-with-input-file output get-string-all))) + +;;; +;;; Source derivation with snippets. +;;; + (unless (network-reachable?) (test-skip 1)) (test-equal "package-source-derivation, snippet" "OK" @@ -633,11 +642,96 @@ (and (build-derivations %store (list (pk 'snippet-drv drv))) (call-with-input-file out get-string-all)))) +;; Note: lzip is not part of bootstrap-coreutils&co, so is not included to +;; avoid having to rebuild the world. +(define compressors '(("gzip" . "gz") + ("xz" . "xz") + ("bzip2" . "bz2") + (#f . #f))) + +(for-each + (match-lambda + ((comp . ext) + (unless (network-reachable?) (test-skip 1)) + (test-equal (string-append "origin->derivation, single file with snippet " + "(compression: " (if comp comp "None") ")") + "2 + 2 = 4" + (let*-values + (((name) "maths") + ((compressed-name) (if comp + (string-append name "." ext) + name)) + ((file hash) (test-file %store compressed-name "2 + 2 = 5")) + ;; Create an origin using the above computed file and its hash. + ((source) (origin + (method url-fetch) + (uri (string-append "file://" file)) + (file-name compressed-name) + (patch-inputs `(("tar" ,%bootstrap-coreutils&co) + ("xz" ,%bootstrap-coreutils&co) + ("bzip2" ,%bootstrap-coreutils&co) + ("gzip" ,%bootstrap-coreutils&co))) + (patch-guile %bootstrap-guile) + (modules '((guix build utils))) + (snippet `(substitute* ,name + (("5") "4"))) + (hash (content-hash hash)))) + ;; Build origin. + ((drv) (run-with-store %store (origin->derivation source))) + ((out) (derivation->output-path drv))) + ;; Decompress the resulting tar.xz and return its content. + (and (build-derivations %store (list drv)) + (if (tarball? out) + (let* ((bin #~(string-append #+%bootstrap-coreutils&co + "/bin")) + (f (computed-file + name + (with-imported-modules '((guix build utils)) + #~(begin + (use-modules (guix build utils)) + (setenv "PATH" #+bin) + (invoke "tar" "xvf" #+out) + (copy-file #+name #$output))))) + (drv (run-with-store %store (lower-object f))) + (_ (build-derivations %store (list drv)))) + (call-with-input-file (derivation->output-path drv) + get-string-all)) + (call-with-input-file out get-string-all))))))) + compressors) + (test-assert "return value" (let ((drv (package-derivation %store (dummy-package "p")))) (and (derivation? drv) (file-exists? (derivation-file-name drv))))) +(test-assert "package-derivation, inputs deduplicated" + (let* ((dep (dummy-package "dep")) + (p0 (dummy-package "p" (inputs (list dep)))) + (p1 (package (inherit p0) + (inputs `(("dep" ,(package (inherit dep))) + ,@(package-inputs p0)))))) + ;; Here P1 ends up with two non-eq? copies of DEP, under the same label. + ;; They should be deduplicated so that P0 and P1 lead to the same + ;; derivation rather than P1 ending up with duplicate entries in its + ;; '%build-inputs' variable. + (string=? (derivation-file-name (package-derivation %store p0)) + (derivation-file-name (package-derivation %store p1))))) + +(test-assert "package-derivation, different system" + ;; Make sure the 'system' argument of 'package-derivation' is respected. + (let* ((system (if (string=? (%current-system) "x86_64-linux") + "aarch64-linux" + "x86_64-linux")) + (drv (package-derivation %store (dummy-package "p") + system #:graft? #f))) + (define right-system? + (mlambdaq (drv) + (and (string=? (derivation-system drv) system) + (every (compose right-system? derivation-input-derivation) + (derivation-inputs drv))))) + + (right-system? drv))) + (test-assert "package-output" (let* ((package (dummy-package "p")) (drv (package-derivation %store package))) @@ -665,7 +759,7 @@ (let ((dummy (dummy-package "foo" (inputs `(("x" ,(current-module))))))) (test-equal "&package-input-error" - (list dummy (current-module)) + (list dummy `("x" ,(current-module))) (guard (c ((package-input-error? c) (list (package-error-package c) (package-error-invalid-input c)))) @@ -676,7 +770,7 @@ (parameterize ((%graft? #f)) (let* ((dep (dummy-package "dep")) (p (dummy-package "p" - (inputs `(("dep" ,dep "non-existent")))))) + (inputs (list `(,dep "non-existent")))))) (guard (c ((derivation-missing-output-error? c) (and (string=? (derivation-missing-output c) "non-existent") (equal? (package-derivation %store dep) @@ -779,19 +873,23 @@ (test-assert "search paths" (let* ((p (make-prompt-tag "return-search-paths")) + (t (make-parameter "guile-0")) (s (build-system - (name 'raw) - (description "Raw build system with direct store access") - (lower (lambda* (name #:key source inputs system target - #:allow-other-keys) - (bag - (name name) - (system system) (target target) - (build-inputs inputs) - (build - (lambda* (store name inputs + (name 'raw) + (description "Raw build system with direct store access") + (lower (lambda* (name #:key source inputs system target + #:allow-other-keys) + (bag + (name name) + (system system) (target target) + (build-inputs inputs) + (build + (lambda* (name inputs #:key outputs system search-paths) - search-paths))))))) + (if (string=? name (t)) + (abort-to-prompt p search-paths) + (gexp->derivation name + #~(mkdir #$output)))))))))) (x (list (search-path-specification (variable "GUILE_LOAD_PATH") (files '("share/guile/site/2.0"))) @@ -816,8 +914,10 @@ (lambda (k search-paths) search-paths)))))) (and (null? (collect (package-derivation %store a))) - (equal? x (collect (package-derivation %store b))) - (equal? x (collect (package-derivation %store c))))))) + (parameterize ((t "guile-foo-0")) + (equal? x (collect (package-derivation %store b)))) + (parameterize ((t "guile-bar-0")) + (equal? x (collect (package-derivation %store c)))))))) (test-assert "package-transitive-native-search-paths" (let* ((sp (lambda (name) @@ -828,12 +928,12 @@ (p1 (dummy-package "p1" (native-search-paths (sp "PATH1")))) (p2 (dummy-package "p2" (native-search-paths (sp "PATH2")) - (inputs `(("p0" ,p0))) - (propagated-inputs `(("p1" ,p1))))) + (inputs (list p0)) + (propagated-inputs (list p1)))) (p3 (dummy-package "p3" (native-search-paths (sp "PATH3")) - (native-inputs `(("p0" ,p0))) - (propagated-inputs `(("p2" ,p2)))))) + (native-inputs (list p0)) + (propagated-inputs (list p2))))) (lset= string=? '("PATH1" "PATH2" "PATH3") (map search-path-specification-variable @@ -887,7 +987,7 @@ (dep* (package (inherit dep) (replacement new))) (dummy (dummy-package "dummy" (arguments '(#:implicit-inputs? #f)) - (inputs `(("dep" ,dep*)))))) + (inputs (list dep*))))) (equal? (package-grafts %store dummy) (list (graft (origin (package-derivation %store dep)) @@ -919,11 +1019,11 @@ (dep (package (inherit new) (version "0.0"))) (dep* (package (inherit dep) (replacement new))) (prop (dummy-package "propagated" - (propagated-inputs `(("dep" ,dep*))) + (propagated-inputs (list dep*)) (arguments '(#:implicit-inputs? #f)))) (dummy (dummy-package "dummy" (arguments '(#:implicit-inputs? #f)) - (inputs `(("prop" ,prop)))))) + (inputs (list prop))))) (equal? (package-grafts %store dummy) (list (graft (origin (package-derivation %store dep)) @@ -936,16 +1036,16 @@ (dep (package (inherit new) (version "0") (replacement new))) (p1 (dummy-package "intermediate1" (arguments '(#:implicit-inputs? #f)) - (inputs `(("dep" ,dep))))) + (inputs (list 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))))))) + (inputs (list (package (inherit dep)))))) (p3 (dummy-package "final" (arguments '(#:implicit-inputs? #f)) - (inputs `(("p1" ,p1) ("p2" ,p2)))))) + (inputs (list p1 p2))))) (equal? (package-grafts %store p3) (list (graft (origin (package-derivation %store @@ -963,8 +1063,7 @@ (p0* (package (inherit p0) (version "1.1"))) (p1 (dummy-package "p1" (arguments '(#:implicit-inputs? #f)) - (inputs `(("p0" ,p0) - ("p0:lib" ,p0 "lib")))))) + (inputs (list p0 `(,p0 "lib")))))) (lset= equal? (pk (package-grafts %store p1)) (list (graft (origin (package-derivation %store p0)) @@ -1012,7 +1111,7 @@ #t))))) (p2r (dummy-package "P2" (build-system trivial-build-system) - (inputs `(("p1" ,p1))) + (inputs (list p1)) (arguments `(#:guile ,%bootstrap-guile #:builder (let ((out (assoc-ref %outputs "out"))) @@ -1033,7 +1132,7 @@ #t))))) (p3 (dummy-package "p3" (build-system trivial-build-system) - (inputs `(("p2" ,p2))) + (inputs (list p2)) (arguments `(#:guile ,%bootstrap-guile #:builder (let ((out (assoc-ref %outputs "out"))) @@ -1091,18 +1190,18 @@ (bag (name name) (system system) (target target) (build-inputs native-inputs) (host-inputs inputs) - (build (lambda* (store name inputs - #:key system target - #:allow-other-keys) - (build-expression->derivation - store "foo" '(mkdir %output)))))))) + (build (lambda* (name inputs + #:key system target + #:allow-other-keys) + (gexp->derivation "foo" + #~(mkdir #$output)))))))) (bs (build-system (name 'build-system-without-cross-compilation) (description "Does not support cross compilation.") (lower lower))) (dep (dummy-package "dep" (build-system bs))) (pkg (dummy-package "example" - (native-inputs `(("dep" ,dep))))) + (native-inputs (list dep)))) (do-not-build (lambda (continue store lst . _) lst))) (equal? (with-build-handler do-not-build (parameterize ((%current-target-system "powerpc64le-linux-gnu") @@ -1129,9 +1228,9 @@ (test-assert "package->bag, propagated inputs" (let* ((dep (dummy-package "dep")) (prop (dummy-package "prop" - (propagated-inputs `(("dep" ,dep))))) + (propagated-inputs (list dep)))) (dummy (dummy-package "dummy" - (inputs `(("prop" ,prop))))) + (inputs (list prop)))) (inputs (bag-transitive-inputs (package->bag dummy #:graft? #f)))) (match (assoc "dep" inputs) (("dep" package) @@ -1144,7 +1243,7 @@ `(("libxml2" ,libxml2)) '())))) (pkg (dummy-package "foo" - (native-inputs `(("dep" ,dep))))) + (native-inputs (list dep)))) (bag (package->bag pkg (%current-system) "i586-gnu"))) (equal? (parameterize ((%current-system "x86_64-linux")) (bag-transitive-inputs bag)) @@ -1157,19 +1256,20 @@ `(("libxml2" ,libxml2)) '())))) (pkg (dummy-package "foo" - (native-inputs `(("dep" ,dep))))) + (native-inputs (list dep)))) (bag (package->bag pkg (%current-system) "foo86-hurd"))) (equal? (parameterize ((%current-target-system "foo64-gnu")) (bag-transitive-inputs bag)) (parameterize ((%current-target-system #f)) (bag-transitive-inputs bag))))) -(test-assert "bag->derivation" +(test-assertm "bag->derivation" (parameterize ((%graft? #f)) (let ((bag (package->bag gnu-make)) (drv (package-derivation %store gnu-make))) (parameterize ((%current-system "foox86-hurd")) ;should have no effect - (equal? drv (bag->derivation %store bag)))))) + (mlet %store-monad ((bag-drv (bag->derivation bag))) + (return (equal? drv bag-drv))))))) (test-assert "bag->derivation, cross-compilation" (parameterize ((%graft? #f)) @@ -1178,7 +1278,8 @@ (drv (package-cross-derivation %store gnu-make target))) (parameterize ((%current-system "foox86-hurd") ;should have no effect (%current-target-system "foo64-linux-gnu")) - (equal? drv (bag->derivation %store bag)))))) + (mlet %store-monad ((bag-drv (bag->derivation bag))) + (return (equal? drv bag-drv))))))) (when (or (not (network-reachable?)) (shebang-too-long?)) (test-skip 1)) @@ -1461,11 +1562,11 @@ (build-system trivial-build-system))) (glib (dummy-package "glib" (build-system trivial-build-system) - (propagated-inputs `(("libffi" ,libffi))))) + (propagated-inputs (list libffi)))) (gobject (dummy-package "gobject-introspection" (build-system trivial-build-system) - (inputs `(("glib" ,glib))) - (propagated-inputs `(("libffi" ,libffi))))) + (inputs (list glib)) + (propagated-inputs (list libffi)))) (rewrite (package-input-rewriting/spec `(("glib" . ,identity))))) (and (= (length (package-transitive-inputs gobject)) @@ -1482,11 +1583,11 @@ (build-system trivial-build-system))) (glib (dummy-package "glib" (build-system trivial-build-system) - (propagated-inputs `(("libffi" ,libffi))))) + (propagated-inputs (list libffi)))) (gobject (dummy-package "gobject-introspection" (build-system trivial-build-system) - (inputs `(("glib" ,glib))) - (propagated-inputs `(("libffi" ,libffi))))) + (inputs (list glib)) + (propagated-inputs (list libffi)))) (rewrite (package-input-rewriting `((,glib . ,glib))))) (and (= (length (package-transitive-inputs gobject)) (length (package-transitive-inputs (rewrite gobject)))) @@ -1764,6 +1865,39 @@ (package-location (specification->package "guile@2")) (specification->location "guile@2")) +(test-eq "this-package-input, exists" + hello + (package-arguments + (dummy-package "a" + (inputs `(("hello" ,hello))) + (arguments (this-package-input "hello"))))) + +(test-eq "this-package-input, exists in propagated-inputs" + hello + (package-arguments + (dummy-package "a" + (propagated-inputs `(("hello" ,hello))) + (arguments (this-package-input "hello"))))) + +(test-eq "this-package-input, does not exist" + #f + (package-arguments + (dummy-package "a" + (arguments (this-package-input "hello"))))) + +(test-eq "this-package-native-input, exists" + hello + (package-arguments + (dummy-package "a" + (native-inputs `(("hello" ,hello))) + (arguments (this-package-native-input "hello"))))) + +(test-eq "this-package-native-input, does not exists" + #f + (package-arguments + (dummy-package "a" + (arguments (this-package-native-input "hello"))))) + (test-end "packages") ;;; Local Variables: diff --git a/tests/print.scm b/tests/print.scm index 3386590d3a..1b24e12f2e 100644 --- a/tests/print.scm +++ b/tests/print.scm @@ -60,8 +60,8 @@ (base32 "070pwb7brdcn1mfvplkd56vjc7lbz4iznzkqvfsakvgbv68k71ah")))) (build-system (@ (guix build-system gnu) gnu-build-system)) - (inputs `(("coreutils" ,(@ (gnu packages base) coreutils)) - ("glibc" ,(@ (gnu packages base) glibc) "debug"))) + (inputs (list (@ (gnu packages base) coreutils) + `(,(@ (gnu packages base) glibc) "debug"))) (home-page "http://gnu.org") (synopsis "Dummy") (description "This is a dummy package.") diff --git a/tests/pypi.scm b/tests/pypi.scm index f421d6d9df..bb81e91839 100644 --- a/tests/pypi.scm +++ b/tests/pypi.scm @@ -213,13 +213,8 @@ Requires-Dist: pytest (>=3.1.0); extra == 'testing' ('base32 (? string? hash))))) ('build-system 'python-build-system) - ('propagated-inputs - ('quasiquote - (("python-bar" ('unquote 'python-bar)) - ("python-foo" ('unquote 'python-foo))))) - ('native-inputs - ('quasiquote - (("python-pytest" ('unquote 'python-pytest))))) + ('propagated-inputs ('list 'python-bar 'python-foo)) + ('native-inputs ('list 'python-pytest)) ('home-page "http://example.com") ('synopsis "summary") ('description "summary") @@ -282,13 +277,8 @@ Requires-Dist: pytest (>=3.1.0); extra == 'testing' ('base32 (? string? hash))))) ('build-system 'python-build-system) - ('propagated-inputs - ('quasiquote - (("python-bar" ('unquote 'python-bar)) - ("python-baz" ('unquote 'python-baz))))) - ('native-inputs - ('quasiquote - (("python-pytest" ('unquote 'python-pytest))))) + ('propagated-inputs ('list 'python-bar 'python-baz)) + ('native-inputs ('list 'python-pytest)) ('home-page "http://example.com") ('synopsis "summary") ('description "summary") diff --git a/tests/store.scm b/tests/store.scm index 3266fa7a82..d77c26192a 100644 --- a/tests/store.scm +++ b/tests/store.scm @@ -534,7 +534,8 @@ (d (build-expression->derivation %store "foo" `(display ,s) #:guile-for-build - (package-derivation s %bootstrap-guile (%current-system))))) + (package-derivation %store %bootstrap-guile + (%current-system))))) (guard (c ((store-protocol-error? c) #t)) (build-derivations %store (list d)))))))) "Here’s a Greek letter: λ.")) diff --git a/tests/style.scm b/tests/style.scm new file mode 100644 index 0000000000..ada9197fc1 --- /dev/null +++ b/tests/style.scm @@ -0,0 +1,366 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2021 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 (tests-style) + #:use-module (guix packages) + #:use-module (guix scripts style) + #:use-module ((guix utils) #:select (call-with-temporary-directory)) + #:use-module ((guix build utils) #:select (substitute*)) + #:use-module (guix diagnostics) + #:use-module (gnu packages acl) + #:use-module (gnu packages multiprecision) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-64) + #:use-module (ice-9 match) + #:use-module (ice-9 rdelim) + #:use-module (ice-9 pretty-print)) + +(define (call-with-test-package inputs proc) + (call-with-temporary-directory + (lambda (directory) + (call-with-output-file (string-append directory "/my-packages.scm") + (lambda (port) + (pretty-print + `(begin + (define-module (my-packages) + #:use-module (guix) + #:use-module (guix licenses) + #:use-module (gnu packages acl) + #:use-module (gnu packages base) + #:use-module (gnu packages multiprecision) + #:use-module (srfi srfi-1)) + + (define base + (package + (inherit coreutils) + (inputs '()) + (native-inputs '()) + (propagated-inputs '()))) + + (define (sdl-union . lst) + (package + (inherit base) + (name "sdl-union"))) + + (define-public my-coreutils + (package + (inherit base) + ,@inputs + (name "my-coreutils")))) + port))) + + (proc directory)))) + +(define test-directory + ;; Directory where the package definition lives. + (make-parameter #f)) + +(define-syntax-rule (with-test-package fields exp ...) + (call-with-test-package fields + (lambda (directory) + (define file + (string-append directory "/my-packages.scm")) + + ;; Run as a separate process to make sure FILE is reloaded. + (system* "guix" "style" "-L" directory "my-coreutils") + (system* "cat" file) + + (load file) + (parameterize ((test-directory directory)) + exp ...)))) + +(define* (read-lines port line #:optional (count 1)) + "Read COUNT lines from PORT, starting from LINE." + (let loop ((lines '()) + (count count)) + (cond ((< (port-line port) (- line 1)) + (read-char port) + (loop lines count)) + ((zero? count) + (string-concatenate-reverse lines)) + (else + (match (read-line port 'concat) + ((? eof-object?) + (loop lines 0)) + (line + (loop (cons line lines) (- count 1)))))))) + +(define* (read-package-field package field #:optional (count 1)) + (let* ((location (package-field-location package field)) + (file (location-file location)) + (line (location-line location))) + (call-with-input-file (if (string-prefix? "/" file) + file + (string-append (test-directory) "/" + file)) + (lambda (port) + (read-lines port line count))))) + + +(test-begin "style") + +(test-equal "nothing to rewrite" + '() + (with-test-package '() + (package-direct-inputs (@ (my-packages) my-coreutils)))) + +(test-equal "input labels, mismatch" + (list `(("foo" ,gmp) ("bar" ,acl)) + " (inputs `((\"foo\" ,gmp) (\"bar\" ,acl)))\n") + (with-test-package '((inputs `(("foo" ,gmp) ("bar" ,acl)))) + (list (package-direct-inputs (@ (my-packages) my-coreutils)) + (read-package-field (@ (my-packages) my-coreutils) 'inputs)))) + +(test-equal "input labels, simple" + (list `(("gmp" ,gmp) ("acl" ,acl)) + " (inputs (list gmp acl))\n") + (with-test-package '((inputs `(("gmp" ,gmp) ("acl" ,acl)))) + (list (package-direct-inputs (@ (my-packages) my-coreutils)) + (read-package-field (@ (my-packages) my-coreutils) 'inputs)))) + +(test-equal "input labels, long list with one item per line" + (list (concatenate (make-list 4 `(("gmp" ,gmp) ("acl" ,acl)))) + "\ + (list gmp + acl + gmp + acl + gmp + acl + gmp + acl))\n") + (with-test-package '((inputs `(("gmp" ,gmp) ("acl" ,acl) + ("gmp" ,gmp) ("acl" ,acl) + ("gmp" ,gmp) ("acl" ,acl) + ("gmp" ,gmp) ("acl" ,acl)))) + (list (package-direct-inputs (@ (my-packages) my-coreutils)) + (read-package-field (@ (my-packages) my-coreutils) 'inputs 8)))) + +(test-equal "input labels, sdl-union" + "\ + (list gmp acl + (sdl-union 1 2 3 4)))\n" + (with-test-package '((inputs `(("gmp" ,gmp) ("acl" ,acl) + ("sdl-union" ,(sdl-union 1 2 3 4))))) + (read-package-field (@ (my-packages) my-coreutils) 'inputs 2))) + +(test-equal "input labels, output" + (list `(("gmp" ,gmp "debug") ("acl" ,acl)) + " (inputs (list `(,gmp \"debug\") acl))\n") + (with-test-package '((inputs `(("gmp" ,gmp "debug") ("acl" ,acl)))) + (list (package-direct-inputs (@ (my-packages) my-coreutils)) + (read-package-field (@ (my-packages) my-coreutils) 'inputs)))) + +(test-equal "input labels, prepend" + (list `(("gmp" ,gmp) ("acl" ,acl)) + "\ + (modify-inputs (package-propagated-inputs coreutils) + (prepend gmp acl)))\n") + (with-test-package '((inputs `(("gmp" ,gmp) ("acl" ,acl) + ,@(package-propagated-inputs coreutils)))) + (list (package-inputs (@ (my-packages) my-coreutils)) + (read-package-field (@ (my-packages) my-coreutils) 'inputs 2)))) + +(test-equal "input labels, prepend + delete" + (list `(("gmp" ,gmp) ("acl" ,acl)) + "\ + (modify-inputs (package-propagated-inputs coreutils) + (delete \"gmp\") + (prepend gmp acl)))\n") + (with-test-package '((inputs `(("gmp" ,gmp) + ("acl" ,acl) + ,@(alist-delete "gmp" + (package-propagated-inputs coreutils))))) + (list (package-inputs (@ (my-packages) my-coreutils)) + (read-package-field (@ (my-packages) my-coreutils) 'inputs 3)))) + +(test-equal "input labels, prepend + delete multiple" + (list `(("gmp" ,gmp) ("acl" ,acl)) + "\ + (modify-inputs (package-propagated-inputs coreutils) + (delete \"foo\" \"bar\" \"baz\") + (prepend gmp acl)))\n") + (with-test-package '((inputs `(("gmp" ,gmp) + ("acl" ,acl) + ,@(fold alist-delete + (package-propagated-inputs coreutils) + '("foo" "bar" "baz"))))) + (list (package-inputs (@ (my-packages) my-coreutils)) + (read-package-field (@ (my-packages) my-coreutils) 'inputs 3)))) + +(test-equal "input labels, replace" + (list '() ;there's no "gmp" input to replace + "\ + (modify-inputs (package-propagated-inputs coreutils) + (replace \"gmp\" gmp)))\n") + (with-test-package '((inputs `(("gmp" ,gmp) + ,@(alist-delete "gmp" + (package-propagated-inputs coreutils))))) + (list (package-inputs (@ (my-packages) my-coreutils)) + (read-package-field (@ (my-packages) my-coreutils) 'inputs 2)))) + +(test-equal "input labels, 'safe' policy" + (list `(("gmp" ,gmp) ("acl" ,acl)) + "\ + (inputs (list gmp acl))\n") + (call-with-test-package '((inputs `(("GMP" ,gmp) ("ACL" ,acl))) + (arguments '())) ;no build system arguments + (lambda (directory) + (define file + (string-append directory "/my-packages.scm")) + + (system* "guix" "style" "-L" directory "my-coreutils" + "--input-simplification=safe") + + (load file) + (list (package-inputs (@ (my-packages) my-coreutils)) + (read-package-field (@ (my-packages) my-coreutils) 'inputs))))) + +(test-equal "input labels, 'safe' policy, nothing changed" + (list `(("GMP" ,gmp) ("ACL" ,acl)) + "\ + (inputs `((\"GMP\" ,gmp) (\"ACL\" ,acl)))\n") + (call-with-test-package '((inputs `(("GMP" ,gmp) ("ACL" ,acl))) + ;; Non-empty argument list, so potentially unsafe + ;; input simplification. + (arguments + '(#:configure-flags + (assoc-ref %build-inputs "GMP")))) + (lambda (directory) + (define file + (string-append directory "/my-packages.scm")) + + (system* "guix" "style" "-L" directory "my-coreutils" + "--input-simplification=safe") + + (load file) + (list (package-inputs (@ (my-packages) my-coreutils)) + (read-package-field (@ (my-packages) my-coreutils) 'inputs))))) + +(test-equal "input labels, margin comment" + (list `(("gmp" ,gmp)) + `(("acl" ,acl)) + " (inputs (list gmp)) ;margin comment\n" + " (native-inputs (list acl)) ;another one\n") + (call-with-test-package '((inputs `(("gmp" ,gmp))) + (native-inputs `(("acl" ,acl)))) + (lambda (directory) + (define file + (string-append directory "/my-packages.scm")) + + (substitute* file + (("\"gmp\"(.*)$" _ rest) + (string-append "\"gmp\"" (string-trim-right rest) + " ;margin comment\n")) + (("\"acl\"(.*)$" _ rest) + (string-append "\"acl\"" (string-trim-right rest) + " ;another one\n"))) + (system* "cat" file) + + (system* "guix" "style" "-L" directory "my-coreutils") + + (load file) + (list (package-inputs (@ (my-packages) my-coreutils)) + (package-native-inputs (@ (my-packages) my-coreutils)) + (read-package-field (@ (my-packages) my-coreutils) 'inputs) + (read-package-field (@ (my-packages) my-coreutils) 'native-inputs))))) + +(test-equal "input labels, margin comment on long list" + (list (concatenate (make-list 4 `(("gmp" ,gmp) ("acl" ,acl)))) + "\ + (list gmp ;margin comment + acl + gmp ;margin comment + acl + gmp ;margin comment + acl + gmp ;margin comment + acl))\n") + (call-with-test-package '((inputs `(("gmp" ,gmp) ("acl" ,acl) + ("gmp" ,gmp) ("acl" ,acl) + ("gmp" ,gmp) ("acl" ,acl) + ("gmp" ,gmp) ("acl" ,acl)))) + (lambda (directory) + (define file + (string-append directory "/my-packages.scm")) + + (substitute* file + (("\"gmp\"(.*)$" _ rest) + (string-append "\"gmp\"" (string-trim-right rest) + " ;margin comment\n"))) + (system* "cat" file) + + (system* "guix" "style" "-L" directory "my-coreutils") + + (load file) + (list (package-inputs (@ (my-packages) my-coreutils)) + (read-package-field (@ (my-packages) my-coreutils) 'inputs 8))))) + +(test-equal "input labels, line comment" + (list `(("gmp" ,gmp) ("acl" ,acl)) + "\ + (inputs (list gmp + ;; line comment! + acl))\n") + (call-with-test-package '((inputs `(("gmp" ,gmp) ("acl" ,acl)))) + (lambda (directory) + (define file + (string-append directory "/my-packages.scm")) + + (substitute* file + ((",gmp\\)(.*)$" _ rest) + (string-append ",gmp)\n ;; line comment!\n" rest))) + + (system* "guix" "style" "-L" directory "my-coreutils") + + (load file) + (list (package-inputs (@ (my-packages) my-coreutils)) + (read-package-field (@ (my-packages) my-coreutils) 'inputs 3))))) + +(test-equal "input labels, modify-inputs and margin comment" + (list `(("gmp" ,gmp) ("acl" ,acl) ("mpfr" ,mpfr)) + "\ + (modify-inputs (package-propagated-inputs coreutils) + (prepend gmp ;margin comment + acl ;another one + mpfr)))\n") + (call-with-test-package '((inputs + `(("gmp" ,gmp) ("acl" ,acl) ("mpfr" ,mpfr) + ,@(package-propagated-inputs coreutils)))) + (lambda (directory) + (define file + (string-append directory "/my-packages.scm")) + + (substitute* file + ((",gmp\\)(.*)$" _ rest) + (string-append ",gmp) ;margin comment\n" rest)) + ((",acl\\)(.*)$" _ rest) + (string-append ",acl) ;another one\n" rest))) + + (system* "guix" "style" "-L" directory "my-coreutils") + + (load file) + (list (package-inputs (@ (my-packages) my-coreutils)) + (read-package-field (@ (my-packages) my-coreutils) 'inputs 4))))) + +(test-end) + +;; Local Variables: +;; eval: (put 'with-test-package 'scheme-indent-function 1) +;; eval: (put 'call-with-test-package 'scheme-indent-function 1) +;; End: diff --git a/tests/utils.scm b/tests/utils.scm index 7fcbb25552..648e91f242 100644 --- a/tests/utils.scm +++ b/tests/utils.scm @@ -3,6 +3,7 @@ ;;; Copyright © 2014 Eric Bavier <bavier@member.fsf.org> ;;; Copyright © 2016 Mathieu Lirzin <mthl@gnu.org> ;;; Copyright © 2021 Simon Tournier <zimon.toutoune@gmail.com> +;;; Copyright © 2021 Maxime Devos <maximedevos@telenet.be> ;;; ;;; This file is part of GNU Guix. ;;; @@ -289,6 +290,45 @@ skip these tests." (string-closest "hello" '("kikoo" "helo" "hihihi" "halo")) (string-closest "hello" '("aaaaa" "12345" "hellohello" "h")))) +(test-equal "target-linux?" + '(#t #f #f #t) + (map target-linux? + '("i686-linux-gnu" "i686-w64-mingw32" + ;; Checking that "gnu" is present is not sufficient, + ;; as GNU/Hurd exists. + "i686-pc-gnu" + ;; Some targets have a suffix. + "arm-linux-gnueabihf"))) + +(test-equal "target-mingw?" + '(#f #f #t) + (map target-mingw? + '("i686-linux-gnu" "i686-pc-gnu" + "i686-w64-mingw32"))) + +(test-equal "target-x86-32?" + '(#f #f #f #t #t #t #t #f) + ;; These are (according to Wikipedia) two RISC architectures + ;; by Intel and presumably not compatible with the x86-32 series. + (map target-x86-32? + '("i860-gnu" "i960-gnu" + ;; This is a 16-bit architecture + "i286-gnu" + ;; These are part of the x86-32 series. + "i386-gnu" "i486-gnu" "i586-gnu" "i686-gnu" + ;; Maybe this one will exist some day, but not yet. + "i786-gnu"))) + +(test-equal "target-x86-64?" + '(#t #f #f #f) + (map target-x86-64? + `("x86_64-linux-gnu" "i386-linux-gnu" + ;; Just because it includes "64" doesn't make it 64-bit. + "aarch64-linux-gnu" + ;; Note that (expt 2 109) in decimal notation starts with 64. + ;; However, it isn't 32-bit. + ,(format #f "x86_~a-linux-gnu" (expt 2 109))))) + (test-end) (false-if-exception (delete-file temp-file)) |