diff options
Diffstat (limited to 'tests')
| -rw-r--r-- | tests/build-utils.scm | 12 | ||||
| -rw-r--r-- | tests/cache.scm | 30 | ||||
| -rw-r--r-- | tests/crate.scm | 36 | ||||
| -rw-r--r-- | tests/derivations.scm | 31 | ||||
| -rw-r--r-- | tests/elm.scm | 8 | ||||
| -rw-r--r-- | tests/gem.scm | 12 | ||||
| -rw-r--r-- | tests/gexp.scm | 59 | ||||
| -rw-r--r-- | tests/git.scm | 22 | ||||
| -rw-r--r-- | tests/go.scm | 8 | ||||
| -rw-r--r-- | tests/gremlin.scm | 2 | ||||
| -rw-r--r-- | tests/guix-build.sh | 17 | ||||
| -rw-r--r-- | tests/guix-package.sh | 4 | ||||
| -rw-r--r-- | tests/guix-shell-export-manifest.sh | 3 | ||||
| -rw-r--r-- | tests/guix-style.sh | 26 | ||||
| -rw-r--r-- | tests/guix-system.sh | 11 | ||||
| -rw-r--r-- | tests/hexpm.scm | 8 | ||||
| -rw-r--r-- | tests/import-utils.scm | 8 | ||||
| -rw-r--r-- | tests/lint.scm | 62 | ||||
| -rw-r--r-- | tests/minetest.scm | 2 | ||||
| -rw-r--r-- | tests/modules.scm | 18 | ||||
| -rw-r--r-- | tests/pack.scm | 41 | ||||
| -rw-r--r-- | tests/packages.scm | 25 | ||||
| -rw-r--r-- | tests/print.scm | 7 | ||||
| -rw-r--r-- | tests/profiles.scm | 7 | ||||
| -rw-r--r-- | tests/pypi.scm | 109 | ||||
| -rw-r--r-- | tests/store-deduplication.scm | 58 | ||||
| -rw-r--r-- | tests/style.scm | 25 | ||||
| -rw-r--r-- | tests/syscalls.scm | 13 | ||||
| -rw-r--r-- | tests/texlive.scm | 307 | ||||
| -rw-r--r-- | tests/toml.scm | 469 | ||||
| -rw-r--r-- | tests/transformations.scm | 31 |
31 files changed, 1316 insertions, 155 deletions
diff --git a/tests/build-utils.scm b/tests/build-utils.scm index 7f4f12ccc7..3babf5d544 100644 --- a/tests/build-utils.scm +++ b/tests/build-utils.scm @@ -41,17 +41,17 @@ '((a . 1) (x . 42) (b . 2) (c . 3)) (alist-cons-before 'b 'x 42 '((a . 1) (b . 2) (c . 3)))) -(test-equal "alist-cons-before, reference not found" - '((a . 1) (b . 2) (c . 3) (x . 42)) - (alist-cons-before 'z 'x 42 '((a . 1) (b . 2) (c . 3)))) +(test-assert "alist-cons-before, reference not found" + (not (false-if-exception + (alist-cons-before 'z 'x 42 '((a . 1) (b . 2) (c . 3)))))) (test-equal "alist-cons-after" '((a . 1) (b . 2) (x . 42) (c . 3)) (alist-cons-after 'b 'x 42 '((a . 1) (b . 2) (c . 3)))) -(test-equal "alist-cons-after, reference not found" - '((a . 1) (b . 2) (c . 3) (x . 42)) - (alist-cons-after 'z 'x 42 '((a . 1) (b . 2) (c . 3)))) +(test-assert "alist-cons-after, reference not found" + (not (false-if-exception + (alist-cons-after 'z 'x 42 '((a . 1) (b . 2) (c . 3)))))) (test-equal "alist-replace" '((a . 1) (b . 77) (c . 3)) diff --git a/tests/cache.scm b/tests/cache.scm index d495ace2bd..e8ad083d40 100644 --- a/tests/cache.scm +++ b/tests/cache.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2017, 2020 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2017, 2020, 2024 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2022 Simon Tournier <zimon.toutoune@gmail.com> ;;; ;;; This file is part of GNU Guix. @@ -22,7 +22,9 @@ #:use-module (srfi srfi-1) #:use-module (srfi srfi-19) #:use-module (srfi srfi-64) + #:use-module ((guix build syscalls) #:select (lock-file)) #:use-module ((guix utils) #:select (call-with-temporary-directory)) + #:use-module ((rnrs io ports) #:select (get-string-all)) #:use-module (ice-9 match)) (test-begin "cache") @@ -75,6 +77,32 @@ (lambda (port) (display 0 port))))) +(let ((pid #f)) + (test-equal "maybe-remove-expired-cache-entries, cleanup needed but lock taken" + '() + (test-cache-cleanup cache + (let ((in+out (pipe))) + (match (primitive-fork) + (0 (dynamic-wind + (const #t) + (lambda () + (close-port (car in+out)) + (let ((port (lock-file + (string-append cache "/last-expiry-cleanup")))) + (display 0 port) + (display "done!\n" (cdr in+out)) + (close-port (cdr in+out)) + (sleep 100))) + (lambda () + (primitive-exit 0)))) + (n + (set! pid n) + (close-port (cdr in+out)) + (pk 'chr (get-string-all (car in+out))) + (close-port (car in+out))))))) + + (when pid (kill pid SIGKILL))) + (test-equal "maybe-remove-expired-cache-entries, empty cache" '("a" "b" "c") (test-cache-cleanup cache diff --git a/tests/crate.scm b/tests/crate.scm index ce2f08aade..5b4ad08c3c 100644 --- a/tests/crate.scm +++ b/tests/crate.scm @@ -503,7 +503,7 @@ (("rust-leaf-alice" ('unquote 'rust-leaf-alice-0.7)))))) (home-page "http://example.com") (synopsis "summary") - (description "summary") + (description "This package provides summary.") (license (list license:expat license:asl2.0)))) (string=? test-source-hash hash)) @@ -592,7 +592,7 @@ ('quasiquote (#:skip-build? #t))) (home-page "http://example.com") (synopsis "summary") - (description "summary") + (description "This package provides summary.") (license (list license:expat license:asl2.0)))) (define-public 'rust-leaf-alice-0.7 (package @@ -611,7 +611,7 @@ (arguments ('quasiquote (#:skip-build? #t))) (home-page "http://example.com") (synopsis "summary") - (description "summary") + (description "This package provides summary.") (license (list license:expat license:asl2.0)))) (define-public 'rust-leaf-bob-3 (package @@ -630,7 +630,7 @@ (arguments ('quasiquote (#:skip-build? #t))) (home-page "http://example.com") (synopsis "summary") - (description "summary") + (description "This package provides summary.") (license (list license:expat license:asl2.0)))) (define-public 'rust-intermediate-b-1 (package @@ -653,7 +653,7 @@ ('unquote rust-leaf-bob-3)))))) (home-page "http://example.com") (synopsis "summary") - (description "summary") + (description "This package provides summary.") (license (list license:expat license:asl2.0)))) (define-public 'rust-intermediate-a-1 (package @@ -680,7 +680,7 @@ ('unquote rust-leaf-bob-3)))))) (home-page "http://example.com") (synopsis "summary") - (description "summary") + (description "This package provides summary.") (license (list license:expat license:asl2.0)))) (define-public 'rust-root-1 (package @@ -711,7 +711,7 @@ ('unquote rust-intermediate-c-1)))))) (home-page "http://example.com") (synopsis "summary") - (description "summary") + (description "This package provides summary.") (license (list license:expat license:asl2.0))))) #t) (x @@ -740,7 +740,7 @@ ('unquote rust-leaf-alice-0.7)))))) (home-page "http://example.com") (synopsis "summary") - (description "summary") + (description "This package provides summary.") (license (list license:expat license:asl2.0)))) (define-public 'rust-leaf-alice-0.7 (package @@ -758,7 +758,7 @@ (build-system cargo-build-system) (home-page "http://example.com") (synopsis "summary") - (description "summary") + (description "This package provides summary.") (license (list license:expat license:asl2.0)))) (define-public 'rust-leaf-bob-3 (package @@ -776,7 +776,7 @@ (build-system cargo-build-system) (home-page "http://example.com") (synopsis "summary") - (description "summary") + (description "This package provides summary.") (license (list license:expat license:asl2.0)))) (define-public 'rust-intermediate-b-1 (package @@ -798,7 +798,7 @@ ('unquote rust-leaf-bob-3)))))) (home-page "http://example.com") (synopsis "summary") - (description "summary") + (description "This package provides summary.") (license (list license:expat license:asl2.0)))) (define-public 'rust-intermediate-a-1 (package @@ -824,7 +824,7 @@ ('unquote rust-leaf-bob-3)))))) (home-page "http://example.com") (synopsis "summary") - (description "summary") + (description "This package provides summary.") (license (list license:expat license:asl2.0)))) (define-public 'rust-root-1 (package @@ -855,7 +855,7 @@ ('unquote rust-intermediate-c-1)))))) (home-page "http://example.com") (synopsis "summary") - (description "summary") + (description "This package provides summary.") (license (list license:expat license:asl2.0))))) #t) (x @@ -972,7 +972,7 @@ ('unquote 'rust-leaf-bob-4.0.0-yanked)))))) (home-page "http://example.com") (synopsis "summary") - (description "summary") + (description "This package provides summary.") (license (list license:expat license:asl2.0))))) #t) (x @@ -1038,7 +1038,7 @@ (build-system cargo-build-system) (home-page "http://example.com") (synopsis "summary") - (description "summary") + (description "This package provides summary.") (license (list license:expat license:asl2.0)))) (define-public 'rust-leaf-bob-3.0.2-yanked (package @@ -1058,7 +1058,7 @@ (build-system cargo-build-system) (home-page "http://example.com") (synopsis "summary") - (description "summary") + (description "This package provides summary.") (license (list license:expat license:asl2.0)))) (define-public 'rust-leaf-bob-3 (package @@ -1076,7 +1076,7 @@ (build-system cargo-build-system) (home-page "http://example.com") (synopsis "summary") - (description "summary") + (description "This package provides summary.") (license (list license:expat license:asl2.0)))) (define-public 'rust-bar-1 (package @@ -1103,7 +1103,7 @@ ('unquote 'rust-leaf-bob-4.0.0-yanked)))))) (home-page "http://example.com") (synopsis "summary") - (description "summary") + (description "This package provides summary.") (license (list license:expat license:asl2.0))))) #t) (x diff --git a/tests/derivations.scm b/tests/derivations.scm index 0e87778981..efcd21f324 100644 --- a/tests/derivations.scm +++ b/tests/derivations.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012-2023 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2012-2024 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -29,7 +29,8 @@ #:use-module (guix tests git) #:use-module (guix tests http) #:use-module ((guix packages) #:select (package-derivation base32)) - #:use-module ((guix build utils) #:select (executable-file?)) + #:use-module ((guix build utils) + #:select (executable-file? strip-store-file-name)) #:use-module ((guix hash) #:select (file-hash*)) #:use-module ((git oid) #:select (oid->string)) #:use-module ((git reference) #:select (reference-name->oid)) @@ -1157,6 +1158,32 @@ #:mode (build-mode check)) (list drv dep)))))) +(test-equal "derivation-build-plan, topological ordering" + (make-list 5 '("0.drv" "1.drv" "2.drv" "3.drv" "4.drv")) + (with-store store + (define (test _) + (let* ((simple-derivation + (lambda (name . deps) + (build-expression->derivation + store name + `(begin ,(random-text) (mkdir %output)) + #:inputs (map (lambda (n dep) + (list (number->string n) dep)) + (iota (length deps)) + deps)))) + (drv0 (simple-derivation "0")) + (drv1 (simple-derivation "1" drv0)) + (drv2 (simple-derivation "2" drv1)) + (drv3 (simple-derivation "3" drv2 drv0)) + (drv4 (simple-derivation "4" drv3 drv1))) + (map (compose strip-store-file-name derivation-file-name) + (derivation-build-plan store (list (derivation-input drv4)))))) + + ;; This is probabilistic: if the traversal is buggy, it may or may not + ;; produce the wrong ordering, depending on a variety of actors. Thus, + ;; try multiple times. + (map test (iota 5)))) + (test-assert "derivation-input-fold" (let* ((builder (add-text-to-store %store "my-builder.sh" "echo hello, world > \"$out\"\n" diff --git a/tests/elm.scm b/tests/elm.scm index c30623da03..279a66a25f 100644 --- a/tests/elm.scm +++ b/tests/elm.scm @@ -249,15 +249,13 @@ package definition." version (base32 ,(? string? hash)))) (build-system elm-build-system) - (propagated-inputs - ,'`(("elm-core" ,elm-core))) - (inputs - ,'`(("elm-json" ,elm-json))) + (propagated-inputs (list elm-core)) + (inputs (list elm-json)) (home-page "https://package.elm-lang.org/packages/elm-guix/demo/3.0.0") (synopsis "A test for `(guix import elm)`") (description - "This package provides a test for `(guix import elm)`") + "This package provides a test for `(guix import elm)`.") (properties '((upstream-name . "elm-guix/demo"))) (license license:gpl3+))) (equal? (directory-sha256 elm-guix-demo-dir) diff --git a/tests/gem.scm b/tests/gem.scm index 7e2436e3fb..dae29437e5 100644 --- a/tests/gem.scm +++ b/tests/gem.scm @@ -117,7 +117,7 @@ (build-system ruby-build-system) (propagated-inputs (list bundler ruby-bar)) (synopsis "A cool gem") - (description "This package provides a cool gem") + (description "This package provides a cool gem.") (home-page "https://example.com") (license (list license:expat license:asl2.0))) #t) @@ -146,7 +146,7 @@ (build-system ruby-build-system) (propagated-inputs (list bundler ruby-bar)) (synopsis "A cool gem") - (description "This package provides a cool gem") + (description "This package provides a cool gem.") (home-page "https://example.com") (license (list license:expat license:asl2.0))) #t) @@ -182,7 +182,7 @@ (build-system ruby-build-system) (propagated-inputs (list bundler)) (synopsis "Another cool gem") - (description "Another cool gem") + (description "Another cool gem.") (home-page "https://example.com") (license #f)) ;no licensing info (package @@ -198,7 +198,7 @@ (build-system ruby-build-system) (propagated-inputs (list bundler ruby-bar)) (synopsis "A cool gem") - (description "This package provides a cool gem") + (description "This package provides a cool gem.") (home-page "https://example.com") (license (list license:expat license:asl2.0)))) #t) @@ -234,7 +234,7 @@ (build-system ruby-build-system) (propagated-inputs (list bundler)) (synopsis "Another cool gem") - (description "Another cool gem") + (description "Another cool gem.") (home-page "https://example.com") (license #f)) ;no licensing info (package @@ -250,7 +250,7 @@ (build-system ruby-build-system) (propagated-inputs (list bundler ruby-bar)) (synopsis "A cool gem") - (description "This package provides a cool gem") + (description "This package provides a cool gem.") (home-page "https://example.com") (license (list license:expat license:asl2.0)))) #t) diff --git a/tests/gexp.scm b/tests/gexp.scm index 905009caee..e066076c5c 100644 --- a/tests/gexp.scm +++ b/tests/gexp.scm @@ -47,6 +47,13 @@ (define %store (open-connection-for-tests)) +(define (bootstrap-guile-effective-version) + ;; TODO The package version of %bootstrap-guile is incorrect for + ;; riscv64-linux + (if (string=? "riscv64-linux" (%current-system)) + "3.0" + (package-version %bootstrap-guile))) + ;; Globally disable grafts because they can trigger early builds. (%graft? #f) @@ -244,6 +251,12 @@ (let ((file (local-file (string-copy "../base32.scm")))) (local-file-absolute-file-name file))))) +(test-equal "local-file, non-literal source relative file name" + (current-filename) + (let ((file (local-file (assume-source-relative-file-name + (string-append "gexp" ".scm"))))) + (local-file-absolute-file-name file))) + (test-assert "local-file, relative file name, within gexp" (let* ((file (search-path %load-path "guix/base32.scm")) (interned (add-to-store %store "base32.scm" #f "sha256" file))) @@ -931,6 +944,33 @@ (and (file=? (string-append dir "/a/b/c") q-scm* stat) (file=? (string-append dir "/p/q") plain* stat))))))) +(test-assert "imported-files does not create symlinks" + ;; 'imported-files' should always produce a directory with regular files, + ;; whether or not it's going through 'imported-files/derivation'. + ;; See <https://issues.guix.gnu.org/73275>. + (call-with-temporary-directory + (lambda (directory) + (symlink (search-path %load-path "guix/store.scm") + (in-vicinity directory "store.scm")) + + (run-with-store %store + (mlet* %store-monad + ((files1 -> `(("x" . ,(in-vicinity directory "store.scm")))) + (files2 -> `(,@files1 + ("y" . ,(plain-file "foo.scm" "#t")))) + (import1 (imported-files files1)) + (import2-drv (imported-files files2)) + (import2 -> (derivation->output-path import2-drv)) + (_ (built-derivations (list import2-drv)))) + (return (and (eq? (stat:type (lstat (in-vicinity import1 "x"))) + 'regular) + (eq? (stat:type (lstat (in-vicinity import2 "x"))) + 'regular) + (file=? (in-vicinity import1 "x") + (search-path %load-path "guix/store.scm")) + (file=? (in-vicinity import2 "x") + (search-path %load-path "guix/store.scm"))))))))) + (test-equal "gexp-modules & ungexp" '((bar) (foo)) ((@@ (guix gexp) gexp-modules) @@ -1099,8 +1139,8 @@ importing.* \\(guix config\\) from the host" (write (list the-answer (multiply 2)) port))))))) (drv (gexp->derivation "thingie" build - ;; %BOOTSTRAP-GUILE is 2.0. - #:effective-version "2.0")) + #:effective-version + (bootstrap-guile-effective-version))) (out -> (derivation->output-path drv))) (mbegin %store-monad (built-derivations (list drv)) @@ -1120,7 +1160,8 @@ importing.* \\(guix config\\) from the host" mkdir-p the-answer)))) (lexp (lower-gexp exp - #:effective-version "2.0"))) + #:effective-version + (bootstrap-guile-effective-version)))) (define (matching-input drv output) (lambda (input) (and (eq? (derivation-input-derivation input) drv) @@ -1134,12 +1175,15 @@ importing.* \\(guix config\\) from the host" (lowered-gexp-inputs lexp)) (member (string-append (derivation->output-path extension-drv) - "/share/guile/site/2.0") + "/share/guile/site/" + (bootstrap-guile-effective-version)) (lowered-gexp-load-path lexp)) (= 2 (length (lowered-gexp-load-path lexp))) (member (string-append (derivation->output-path extension-drv) - "/lib/guile/2.0/site-ccache") + "/lib/guile/" + (bootstrap-guile-effective-version) + "/site-ccache") (lowered-gexp-load-compiled-path lexp)) (= 2 (length (lowered-gexp-load-compiled-path lexp))) (eq? (derivation-input-derivation (lowered-gexp-guile lexp)) @@ -1149,7 +1193,10 @@ importing.* \\(guix config\\) from the host" (mlet* %store-monad ((thing -> (program-file "prog" #~(display "hi!"))) (exp -> #~(list #$(raw-derivation-file thing))) (drv (lower-object thing)) - (lexp (lower-gexp exp #:effective-version "2.0"))) + (lexp (lower-gexp + exp + #:effective-version + (bootstrap-guile-effective-version)))) (return (and (equal? `(list ,(derivation-file-name drv)) (lowered-gexp-sexp lexp)) (equal? (list (derivation-file-name drv)) diff --git a/tests/git.scm b/tests/git.scm index ad43435b67..9ccd04f0cd 100644 --- a/tests/git.scm +++ b/tests/git.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2019, 2020, 2022 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2019-2020, 2022, 2024 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2021 Xinglu Chen <public@yoctocell.xyz ;;; ;;; This file is part of GNU Guix. @@ -259,4 +259,24 @@ ;; COMMIT should be the ID of the commit object, not that of the tag. (string=? commit head)))))) +(test-assert "update-cached-checkout, untracked files removed" + (call-with-temporary-directory + (lambda (cache) + (with-temporary-git-repository directory + '((add "a.txt" "A") + (add ".gitignore" ".~\n") + (commit "First commit")) + (let ((directory commit relation + (update-cached-checkout directory + #:ref '() + #:cache-directory cache))) + (close-port + (open-output-file (in-vicinity cache "stale-untracked-file"))) + (let ((directory2 commit2 relation2 + (update-cached-checkout directory + #:ref '() + #:cache-directory cache))) + (not (file-exists? + (in-vicinity cache "stale-untracked-file"))))))))) + (test-end "git") diff --git a/tests/go.scm b/tests/go.scm index d2e8846b30..1ba089c788 100644 --- a/tests/go.scm +++ b/tests/go.scm @@ -136,7 +136,9 @@ replace ( (define fixtures-go-check-test (let ((version - "{\"Version\":\"v0.0.0-20201130134442-10cb98267c6c\",\"Time\":\"2020-11-30T13:44:42Z\"}") + "{\"Version\":\"v0.0.0-20201130134442-10cb98267c6c\",\"Time\":\"2020-11-30T13:44:42Z\"}") + (go.info + "{\"Version\":\"v0.0.0-20201130134442-10cb98267c6c\",\"Time\":\"2020-11-30T13:44:42Z\"}") (go.mod "module gopkg.in/check.v1 @@ -174,6 +176,8 @@ require github.com/kr/pretty v0.2.1 . ,go.mod) ("https://proxy.golang.org/github.com/go-check/check/@latest" . ,version) + ("https://proxy.golang.org/github.com/go-check/check/@v/v0.0.0-20201130134442-10cb98267c6c.info" + . ,go.info) ("https://github.com/go-check/check?go-get=1" . ,go-get) ("https://pkg.go.dev/github.com/go-check/check" @@ -389,7 +393,7 @@ require github.com/kr/pretty v0.2.1 (arguments (list #:import-path "github.com/go-check/check")) (propagated-inputs - `(("go-github-com-kr-pretty" ,go-github-com-kr-pretty))) + (list go-github-com-kr-pretty)) (home-page "https://github.com/go-check/check") (synopsis "Instructions") (description "Package check is a rich testing extension for Go's testing \ diff --git a/tests/gremlin.scm b/tests/gremlin.scm index 3dbb8d3643..280b1d8819 100644 --- a/tests/gremlin.scm +++ b/tests/gremlin.scm @@ -136,6 +136,7 @@ (with-directory-excursion directory (call-with-output-file "t.c" (lambda (port) + (display "#include <stdio.h>\n" port) (display "int main () { puts(\"hello\"); }" port))) (invoke c-compiler "t.c" "-Wl,--enable-new-dtags" "-Wl,-rpath=/foo" "-Wl,-rpath=/bar") @@ -164,6 +165,7 @@ (with-directory-excursion directory (call-with-output-file "t.c" (lambda (port) + (display "#include <stdio.h>\n" port) (display "int main () { puts(\"hello\"); }" port))) (invoke c-compiler "t.c" diff --git a/tests/guix-build.sh b/tests/guix-build.sh index 4eab0e38b6..6d46d571a9 100644 --- a/tests/guix-build.sh +++ b/tests/guix-build.sh @@ -1,5 +1,5 @@ # GNU Guix --- Functional package management for GNU -# Copyright © 2012-2014, 2016-2023 Ludovic Courtès <ludo@gnu.org> +# Copyright © 2012-2014, 2016-2024 Ludovic Courtès <ludo@gnu.org> # Copyright © 2020 Marius Bakke <mbakke@fastmail.com> # Copyright © 2021 Chris Marusich <cmmarusich@gmail.com> # @@ -161,6 +161,10 @@ export GUIX_PACKAGE_PATH guix build -d -S foo guix build -d -S foo | grep -e 'foo\.tar\.gz' +# Make sure '-s' has an effect together with '-S'. +test "$(guix build -Sd coreutils -s x86_64-linux)" \ + != "$(guix build -Sd coreutils -s aarch64-linux)" + # '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`") @@ -186,6 +190,17 @@ test `guix build -d --sources=transitive foo \ | grep -e 'foo\.tar\.gz' -e 'bar\.tar\.gz' -e 'bar\.dat' \ | wc -l` -eq 3 +# Building the inputs. +guix build -D hello -n +test `guix build -D hello -d \ + | grep -e 'glibc.*\.drv$' -e 'gcc.*\.drv$' -e 'binutils.*\.drv$' \ + | wc -l` -ge 3 + +# Building the dependents. +test `guix build -P1 libgit2 -P1 libssh -d \ + | grep -e 'guile-git.*\.drv$' -e 'guile-ssh.*\.drv$' \ + -e 'libgit2-[0-9].*\.drv$' -e 'libssh-[0-9].*\.drv$' \ + | wc -l` -eq 4 # Unbound variable in thunked field. cat > "$module_dir/foo.scm" <<EOF diff --git a/tests/guix-package.sh b/tests/guix-package.sh index 945d59cdfb..000cd4df11 100644 --- a/tests/guix-package.sh +++ b/tests/guix-package.sh @@ -2,6 +2,8 @@ # Copyright © 2012-2022 Ludovic Courtès <ludo@gnu.org> # Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org> # Copyright © 2022 Josselin Poiret <dev@jpoiret.xyz> +# Copyright © 2022 Josselin Poiret <dev@jpoiret.xyz> +# Copyright © 2024 Janneke Nieuwenhuizen <janneke@gnu.org> # # This file is part of GNU Guix. # @@ -124,7 +126,7 @@ guix package --show=emacs@42 && false # Search. LC_MESSAGES=C export LC_MESSAGES -test "`guix package -s "An example GNU package" | grep ^name:`" = \ +test "`guix package -s "Example GNU package" | grep ^name:`" = \ "name: hello" test -z "`guix package -s "n0t4r341p4ck4g3"`" diff --git a/tests/guix-shell-export-manifest.sh b/tests/guix-shell-export-manifest.sh index 6c42c40f3b..fd0b4e47a9 100644 --- a/tests/guix-shell-export-manifest.sh +++ b/tests/guix-shell-export-manifest.sh @@ -1,5 +1,6 @@ # GNU Guix --- Functional package management for GNU # Copyright © 2022 Ludovic Courtès <ludo@gnu.org> +# Copyright © 2024 Janneke Nieuwenhuizen <janneke@gnu.org> # # This file is part of GNU Guix. # @@ -83,7 +84,7 @@ guix build -m "$manifest" -d | \ guix shell --export-manifest -D guile -D python-itsdangerous > "$manifest" guix build -m "$manifest" -d | grep "$(guix build libffi -d)" guix build -m "$manifest" -d | \ - grep "$(guix build -e '(@ (gnu packages python) python)' -d)" + grep "$(guix build -e '(@ (gnu packages python) python-sans-pip-wrapper)' -d)" # Test various combinations to make sure generated code uses interfaces # correctly. diff --git a/tests/guix-style.sh b/tests/guix-style.sh index 2de879d5e3..9333139435 100644 --- a/tests/guix-style.sh +++ b/tests/guix-style.sh @@ -58,6 +58,24 @@ cat > "$tmpfile" <<EOF ;; The services. (services (cons (service mcron-service-type) %base-services))) +;; Incomplete package definitions in alphabetical order. + +(define-public pkg + (package + (name "bar") + (version "2"))) + +;; The comment below belongs to the foo package. +(define-public pkg + (package + (name "bar") + (version "1"))) +;; Incomplete package definitions in alphabetical order. + +(define-public pkg + (package + (name "foo") + (version "2"))) EOF cp "$tmpfile" "$tmpfile.bak" @@ -78,3 +96,11 @@ test "$initial_hash" != "$(guix hash "$tmpfile")" guix style -f "$tmpfile" test "$initial_hash" = "$(guix hash "$tmpfile")" + +# Swap foo and bar packages. +sed -i "$tmpfile" -e 's/"foo"/"bar"/g' +sed -i "$tmpfile" -e '0,/"bar"/{s//"foo"/}' +test "$initial_hash" != "$(guix hash "$tmpfile")" + +guix style -fA "$tmpfile" +test "$initial_hash" = "$(guix hash "$tmpfile")" diff --git a/tests/guix-system.sh b/tests/guix-system.sh index 29e490c3d4..99147cf332 100644 --- a/tests/guix-system.sh +++ b/tests/guix-system.sh @@ -1,5 +1,5 @@ # GNU Guix --- Functional package management for GNU -# Copyright © 2014-2022 Ludovic Courtès <ludo@gnu.org> +# Copyright © 2014-2022, 2024 Ludovic Courtès <ludo@gnu.org> # Copyright © 2017 Tobias Geerinckx-Rice <me@tobias.gr> # Copyright © 2018 Chris Marusich <cmmarusich@gmail.com> # @@ -355,17 +355,22 @@ for example in gnu/system/examples/*.tmpl; do # Skip it. continue ;; + *desktop*) + # This image uses 'grub-efi-bootloader' so it needs a GPT + # partition. + options="-t efi-raw --system=x86_64-linux";; *) options="" ;; esac - guix system -n disk-image $options "$example" + guix system -n image $options "$example" done # Make sure the desktop image can be built on major architectures. for system in x86_64-linux aarch64-linux do - guix system -n image -s "$system" gnu/system/examples/desktop.tmpl + guix system -n image -s "$system" -t efi-raw \ + gnu/system/examples/desktop.tmpl done # Verify that the images can be built. diff --git a/tests/hexpm.scm b/tests/hexpm.scm index 5df9af0ca6..1e746f9b34 100644 --- a/tests/hexpm.scm +++ b/tests/hexpm.scm @@ -152,7 +152,7 @@ (build-system rebar-build-system) (inputs (list erlang-blubb erlang-fasel)) (synopsis "A cool package") - (description "This package provides a cool package") + (description "This package provides a cool package.") (home-page "https://hex.pm/packages/bla") (license (list license:expat license:asl2.0))) #t) @@ -212,7 +212,7 @@ (build-system mix-build-system) (inputs (list erlang-fasel)) (synopsis "Another cool package") - (description "Another cool package") + (description "Another cool package.") (home-page "https://hex.pm/packages/blubb") (license license:expat)) (package @@ -227,7 +227,7 @@ "1k6d70mxwqgq78jrbr7yqnw187yki74jnagybi7nacrj4a67qjha")))) (build-system gnu-build-system) (synopsis "Yet another cool package") - (description "Yet another cool package") + (description "Yet another cool package.") (home-page "https://hex.pm/packages/fasel") (license "GPL")) (package @@ -243,7 +243,7 @@ (build-system rebar-build-system) (inputs (list erlang-blubb erlang-fasel)) (synopsis "A cool package") - (description "This package provides a cool package") + (description "This package provides a cool package.") (home-page "https://hex.pm/packages/bla") (license (list license:expat license:asl2.0)))) #t) diff --git a/tests/import-utils.scm b/tests/import-utils.scm index 229e6eafaa..607349203c 100644 --- a/tests/import-utils.scm +++ b/tests/import-utils.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2015, 2017, 2022, 2023 Ricardo Wurmus <rekado@elephly.net> +;;; Copyright © 2015, 2017, 2022, 2023, 2024 Ricardo Wurmus <rekado@elephly.net> ;;; Copyright © 2016 Ben Woodcroft <donttrustben@gmail.com> ;;; Copyright © 2020 Martin Becze <mjbecze@riseup.net> ;;; Copyright © 2021 Sarah Morgensen <iskarian@mgsn.dev> @@ -42,7 +42,7 @@ Trust me Mr. Hendrix, M. Night Shyamalan et al. \ Differences are hard to spot, e.g. in CLOS vs. GOOPS.")) (test-equal "beautify-description: transform fragment into sentence" - "This package provides a function to establish world peace" + "This package provides a function to establish world peace." (beautify-description "A function to establish world peace")) (test-equal "beautify-description: remove single quotes" @@ -65,6 +65,10 @@ Differences are hard to spot, e.g. in CLOS vs. GOOPS.")) "Code (@code{DelayedMatrix}, @code{MaMa}, or @code{MeMe}) should be wrapped." (beautify-description "Code (DelayedMatrix, MaMa, or MeMe) should be wrapped.")) +(test-equal "beautify-description: wrap function names in @code" + "The main functions are: @code{haplo.em()} and @code{haplo.power()}; FYI." + (beautify-description "The main functions are: haplo.em() and haplo.power(); FYI.")) + (test-equal "license->symbol" 'license:lgpl2.0 (license->symbol license:lgpl2.0)) diff --git a/tests/lint.scm b/tests/lint.scm index 95d82d7490..3e9dbd29db 100644 --- a/tests/lint.scm +++ b/tests/lint.scm @@ -11,6 +11,7 @@ ;;; Copyright © 2020 Tobias Geerinckx-Rice <me@tobias.gr> ;;; Copyright © 2021 Xinglu Chen <public@yoctocell.xyz> ;;; Copyright © 2021, 2023 Maxime Devos <maximedevos@telenet.be> +;;; Copyright © 2024 Gabriel Wicki <gabriel@erlikon.ch> ;;; ;;; This file is part of GNU Guix. ;;; @@ -120,6 +121,11 @@ (description "bad description.")))) (check-description-style pkg)))) +(test-equal "description: may start with texinfo markup" + '() + (check-description-style + (dummy-package "x" (description "@emph{Maxwell Equations of Software}")))) + (test-equal "description: may start with a digit" '() (let ((pkg (dummy-package "x" @@ -132,6 +138,30 @@ (description "x is a dummy package.")))) (check-description-style pkg))) +(test-equal "description: may start with beginning of package name" + '() + (let ((pkg (dummy-package "xyz-0.1" + (description "xyz is a dummy package.")))) + (check-description-style pkg))) + +(test-equal "description: may start with end of package name" + '() + (let ((pkg (dummy-package "foobar-xyz" + (description "xyz is a dummy package.")))) + (check-description-style pkg))) + +(test-equal "description: may start with non-hyphenated package name" + '() + (let ((pkg (dummy-package "foobar-xyz-minimal" + (description "foobar_xyz is a dummy package.")))) + (check-description-style pkg))) + +(test-equal "description: may start with end of package name" + '() + (let ((pkg (dummy-package "foo-bar" + (description "bar is some thing in foo.")))) + (check-description-style pkg))) + (test-equal "description: two spaces after end of sentence" "sentences in description should be followed by two spaces; possible infraction at 3" (single-lint-warning-message @@ -143,7 +173,7 @@ '() (let ((pkg (dummy-package "x" (description - "E.g. Foo, i.e. Bar resp. Baz (a.k.a. DVD).")))) + "O. Person e.g. Foo, i.e. Bar resp. Baz (a.k.a. DVD). Name et al. cf. some paper.")))) (check-description-style pkg))) (test-equal "description: may not contain trademark signs: ™" @@ -171,14 +201,14 @@ "description contains leading whitespace" (single-lint-warning-message (let ((pkg (dummy-package "x" - (description " Whitespace.")))) + (description " Whitespace.")))) (check-description-style pkg)))) (test-equal "description: trailing whitespace" "description contains trailing whitespace" (single-lint-warning-message (let ((pkg (dummy-package "x" - (description "Whitespace. ")))) + (description "Whitespace. ")))) (check-description-style pkg)))) (test-equal "description: pluralized 'This package'" @@ -189,12 +219,18 @@ (check-description-style pkg)))) (test-equal "description: grammar 'allows to'" - "description contains typo 'allows to'" + "description contains typo 'allows to '" (single-lint-warning-message (let ((pkg (dummy-package "x" (description "This package allows to do stuff.")))) (check-description-style pkg)))) +(test-equal "description: grammar 'allows to' 2" + '() + (let ((pkg (dummy-package "x" + (description "This package allows tokenization.")))) + (check-description-style pkg))) + (test-equal "synopsis: not a string" "invalid synopsis: #f" (single-lint-warning-message @@ -277,6 +313,12 @@ (check-synopsis-style pkg))) string<?)) +(test-equal "synopsis: starts with texinfo markup" + '() + (let ((pkg (dummy-package "x" + (synopsis "@code{help}")))) + (check-synopsis-style pkg))) + (test-equal "synopsis: too long" "synopsis should be less than 80 characters long" (single-lint-warning-message @@ -359,18 +401,18 @@ '() (check-compiler-for-target (dummy-package "x" - (arguments - (list #:make-flags - #~(list (string-append "CC=" (cc-for-target)))))))) + (arguments + (list #:make-flags + #~(list (string-append "CC=" (cc-for-target)))))))) (test-equal "compiler-for-target: CC=gcc is acceptable when target=#false" '() (check-compiler-for-target ;; This (dummy) package consists purely of architecture-independent data. (dummy-package "tzdata" - (arguments - (list #:target #false - #:make-flags #~(list "CC=gcc")))))) + (arguments + (list #:target #false + #:make-flags #~(list "CC=gcc")))))) ;; The emacs-build-system sets #:tests? #f by default. (test-equal "tests-true: #:tests? #t acceptable for emacs packages" diff --git a/tests/minetest.scm b/tests/minetest.scm index 78469bf95b..bf1313ee22 100644 --- a/tests/minetest.scm +++ b/tests/minetest.scm @@ -48,7 +48,7 @@ (home-page "https://example.org/foo") (repo "https://example.org/foo.git") (synopsis "synopsis") - (guix-description "description") + (guix-description "description.") (guix-license '(list license:cc-by-sa4.0 license:lgpl3+)) (inputs '()) diff --git a/tests/modules.scm b/tests/modules.scm index e70d2d9e08..4a42da25b7 100644 --- a/tests/modules.scm +++ b/tests/modules.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2016, 2017 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2016-2017, 2024 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -18,7 +18,7 @@ (define-module (test-modules) #:use-module (guix modules) - #:use-module ((guix build-system gnu) #:select (%gnu-build-system-modules)) + #:use-module ((guix build-system gnu) #:select (%default-gnu-imported-modules)) #:use-module ((guix utils) #:select (call-with-temporary-directory)) #:use-module (srfi srfi-1) #:use-module (srfi srfi-34) @@ -30,9 +30,9 @@ (lset= equal? (live-module-closure '((guix build gnu-build-system))) (source-module-closure '((guix build gnu-build-system))) - %gnu-build-system-modules - (source-module-closure %gnu-build-system-modules) - (live-module-closure %gnu-build-system-modules))) + %default-gnu-imported-modules + (source-module-closure %default-gnu-imported-modules) + (live-module-closure %default-gnu-imported-modules))) (test-assert "closure of (gnu build install)" (lset= equal? @@ -65,4 +65,12 @@ (source-module-closure '((baz)) (list directory) #:select? (const #t)))))) +(test-equal "file-name->module-name" + '(guix foo) + (file-name->module-name "guix/foo.scm")) + +(test-equal "file-name->module-name, leading dot" + '(guix foo) + (file-name->module-name "./guix/foo.scm")) + (test-end) diff --git a/tests/pack.scm b/tests/pack.scm index 40897a5589..1c1e312557 100644 --- a/tests/pack.scm +++ b/tests/pack.scm @@ -3,6 +3,7 @@ ;;; Copyright © 2018 Ricardo Wurmus <rekado@elephly.net> ;;; Copyright © 2021, 2023 Maxim Cournoyer <maxim.cournoyer@gmail.com> ;;; Copyright © 2023 Oleg Pykhalov <go.wigust@gmail.com> +;;; Copyright © 2024 Noé Lopez <noelopez@free.fr> ;;; ;;; This file is part of GNU Guix. ;;; @@ -32,7 +33,8 @@ #:use-module (guix utils) #:use-module ((guix build utils) #:select (%store-directory)) #:use-module (gnu packages) - #:use-module ((gnu packages base) #:select (libc-utf8-locales-for-target)) + #:use-module ((gnu packages base) #:select (libc-utf8-locales-for-target + hello)) #:use-module (gnu packages bootstrap) #:use-module ((gnu packages package-management) #:select (rpm)) #:use-module ((gnu packages compression) #:select (squashfs-tools)) @@ -328,6 +330,7 @@ (when (and (file-exists? (string-append bin "/guile")) (file-exists? "var/guix/db/db.sqlite") + (file-is-directory? "tmp") (string=? (string-append #$%bootstrap-guile "/bin") (pk 'binlink (readlink bin))) @@ -340,6 +343,42 @@ (built-derivations (list check)))) (unless store (test-skip 1)) + (test-assertm "appimage" + (mlet* %store-monad + ((guile (set-guile-for-build (default-guile))) + (profile -> (profile + (content (packages->manifest (list %bootstrap-guile hello))) + (hooks '()) + (locales? #f))) + (image (self-contained-appimage "hello-appimage" profile + #:entry-point "bin/hello" + #:extra-options + (list #:relocatable? #t))) + (check (gexp->derivation + "check-appimage" + #~(invoke #$image)))) + (built-derivations (list check)))) + + (unless store (test-skip 1)) + (test-assertm "appimage + localstatedir" + (mlet* %store-monad + ((guile (set-guile-for-build (default-guile))) + (profile -> (profile + (content (packages->manifest (list %bootstrap-guile hello))) + (hooks '()) + (locales? #f))) + (image (self-contained-appimage "hello-appimage" profile + #:entry-point "bin/hello" + #:localstatedir? #t + #:extra-options + (list #:relocatable? #t))) + (check (gexp->derivation + "check-appimage" + #~(begin + (invoke #$image))))) + (built-derivations (list check)))) + + (unless store (test-skip 1)) (test-assertm "deb archive with symlinks and control files" (mlet* %store-monad ((guile (set-guile-for-build (default-guile))) diff --git a/tests/packages.scm b/tests/packages.scm index a623628447..1d901505aa 100644 --- a/tests/packages.scm +++ b/tests/packages.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012-2023 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2012-2024 Ludovic Courtès <ludo@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> @@ -1628,6 +1628,21 @@ (match (delete-duplicates pythons eq?) ((p) (eq? p python))))) +(test-assert "package-input-rewriting/spec, replace hidden package" + ;; Rewrite hidden packages when requested. + (let* ((python (hidden-package python)) + (p0 (dummy-package "chbouib" + (build-system trivial-build-system) + (inputs (list python)))) + (rewrite (package-input-rewriting/spec + `(("python" . ,(const sed))) + #:replace-hidden? #t)) + (p1 (rewrite p0))) + (match (package-inputs p1) + ((("python" python)) + (and (string=? (package-full-name python) + (package-full-name sed))))))) + (test-equal "package-input-rewriting/spec, graft" (derivation-file-name (package-derivation %store sed)) @@ -2036,6 +2051,14 @@ (dummy-package "a" (arguments (this-package-native-input "hello"))))) +(test-equal "this-package-input, origin" + "http://example.org/foo.tar.gz" + (origin-uri + (package-arguments + (dummy-package "a" + (inputs (list (dummy-origin (uri "http://example.org/foo.tar.gz")))) + (arguments (this-package-input "foo.tar.gz")))))) + (test-eq "modify-inputs, replace" coreutils ;; Replace an input; notice that the label in unchanged. diff --git a/tests/print.scm b/tests/print.scm index b4f193b905..f068d380b7 100644 --- a/tests/print.scm +++ b/tests/print.scm @@ -61,8 +61,13 @@ (base32 "070pwb7brdcn1mfvplkd56vjc7lbz4iznzkqvfsakvgbv68k71ah")))) (build-system (@ (guix build-system gnu) gnu-build-system)) + + ;; Note: For this test, pick variables that do not have aliases; otherwise + ;; 'package->code' might pick one of the other variable names in a + ;; non-deterministic fashion. (inputs (list (@ (gnu packages base) coreutils) - `(,(@ (gnu packages base) glibc) "debug"))) + `(,(@ (gnu packages base) gnu-make) "debug"))) + (home-page "http://gnu.org") (synopsis "Dummy") (description "This is a dummy package.") diff --git a/tests/profiles.scm b/tests/profiles.scm index ddd6d74f3b..e448137cff 100644 --- a/tests/profiles.scm +++ b/tests/profiles.scm @@ -463,7 +463,6 @@ (target -> "arm-linux-gnueabihf") (grep (package->cross-derivation packages:grep target)) (sed (package->cross-derivation packages:sed target)) - (locales (package->derivation (packages:libc-utf8-locales-for-target))) (drv (profile-derivation manifest #:hooks '() #:locales? #t @@ -475,15 +474,11 @@ (and (string-suffix? name input) input))) (derivation-inputs drv)))) - ;; The inputs for grep and sed should be cross-build derivations, but that - ;; for the glibc-utf8-locales should be a native build. (return (and (string=? (derivation-system drv) (%current-system)) (string=? (find-input packages:grep) (derivation-file-name grep)) (string=? (find-input packages:sed) - (derivation-file-name sed)) - (string=? (find-input (packages:libc-utf8-locales-for-target)) - (derivation-file-name locales)))))) + (derivation-file-name sed)))))) (test-assert "package->manifest-entry defaults to \"out\"" (let ((outputs (package-outputs packages:glibc))) diff --git a/tests/pypi.scm b/tests/pypi.scm index 42b39cde73..fe00e429b7 100644 --- a/tests/pypi.scm +++ b/tests/pypi.scm @@ -112,6 +112,20 @@ Mock coverage ") +(define test-pyproject.toml "\ +[build-system] +requires = [\"dummy-build-dep-a\", \"dummy-build-dep-b\"] + +[project] +dependencies = [ + \"dummy-dep-a\", + \"dummy-dep-b\", +] + +[project.optional-dependencies] +test = [\"dummy-test-dep-a\", \"dummy-test-dep-b\"] +") + (define test-metadata "\ Classifier: Programming Language :: Python :: 3.7 Requires-Dist: baz ~= 3 @@ -315,7 +329,86 @@ files specified by SPECS. Return its file name." (native-inputs (list python-pytest)) (home-page "http://example.com") (synopsis "summary") - (description "summary") + (description "summary.") + (license license:lgpl2.0)) + (and (string=? default-sha256/base32 hash) + (equal? (pypi->guix-package "foo" #:version "1.0.0") + (pypi->guix-package "foo")) + (guard (c ((error? c) #t)) + (pypi->guix-package "foo" #:version "42")))) + (x + (pk 'fail x #f)))))) + +(test-assert "pypi->guix-package, no wheel, no requires.txt, but pyproject.toml" + (let ((tarball (pypi-tarball + "foo-1.0.0" + `(("pyproject.toml" ,test-pyproject.toml)))) + (twice (lambda (lst) (append lst lst)))) + (with-pypi (twice `(("/foo-1.0.0.tar.gz" 200 ,(file-dump tarball)) + ("/foo-1.0.0-py2.py3-none-any.whl" 404 "") + ("/foo/json" 200 ,(lambda (port) + (display (foo-json) port))))) + ;; Not clearing the memoization cache here would mean returning the value + ;; computed in the previous test. + (invalidate-memoization! pypi->guix-package) + (match (pypi->guix-package "foo") + (`(package + (name "python-foo") + (version "1.0.0") + (source (origin + (method url-fetch) + (uri (pypi-uri "foo" version)) + (sha256 + (base32 ,(? string? hash))))) + (build-system pyproject-build-system) + (propagated-inputs (list python-dummy-dep-a python-dummy-dep-b)) + (native-inputs (list python-dummy-build-dep-a python-dummy-build-dep-b + python-dummy-test-dep-a python-dummy-test-dep-b)) + (home-page "http://example.com") + (synopsis "summary") + (description "summary.") + (license license:lgpl2.0)) + (and (string=? default-sha256/base32 hash) + (equal? (pypi->guix-package "foo" #:version "1.0.0") + (pypi->guix-package "foo")) + (guard (c ((error? c) #t)) + (pypi->guix-package "foo" #:version "42")))) + (x + (pk 'fail x #f)))))) + +(test-assert "pypi->guix-package, no wheel, but requires.txt and pyproject.toml" + (let ((tarball (pypi-tarball + "foo-1.0.0" + `(("foo-1.0.0/pyproject.toml" ,test-pyproject.toml) + ("foo-1.0.0/bizarre.egg-info/requires.txt" + ,test-requires.txt)))) + (twice (lambda (lst) (append lst lst)))) + (with-pypi (twice `(("/foo-1.0.0.tar.gz" 200 ,(file-dump tarball)) + ("/foo-1.0.0-py2.py3-none-any.whl" 404 "") + ("/foo/json" 200 ,(lambda (port) + (display (foo-json) port))))) + ;; Not clearing the memoization cache here would mean returning the value + ;; computed in the previous test. + (invalidate-memoization! pypi->guix-package) + (match (pypi->guix-package "foo") + (`(package + (name "python-foo") + (version "1.0.0") + (source (origin + (method url-fetch) + (uri (pypi-uri "foo" version)) + (sha256 + (base32 ,(? string? hash))))) + (build-system pyproject-build-system) + ;; Information from requires.txt and pyproject.toml is combined. + (propagated-inputs (list python-bar python-dummy-dep-a python-dummy-dep-b + python-foo)) + (native-inputs (list python-dummy-build-dep-a python-dummy-build-dep-b + python-dummy-test-dep-a python-dummy-test-dep-b + python-pytest)) + (home-page "http://example.com") + (synopsis "summary") + (description "summary.") (license license:lgpl2.0)) (and (string=? default-sha256/base32 hash) (equal? (pypi->guix-package "foo" #:version "1.0.0") @@ -326,12 +419,10 @@ files specified by SPECS. Return its file name." (pk 'fail x #f)))))) (test-skip (if (which "zip") 0 1)) -(test-assert "pypi->guix-package, wheels" +(test-assert "pypi->guix-package, no requires.txt, but wheel." (let ((tarball (pypi-tarball "foo-1.0.0" - '(("foo-1.0.0/foo.egg-info/requires.txt" - "wrong data \ -to make sure we're testing wheels")))) + '(("foo-1.0.0/foo.egg-info/.empty" "")))) (wheel (wheel-file "foo-1.0.0" `(("METADATA" ,test-metadata))))) (with-pypi `(("/foo-1.0.0.tar.gz" 200 ,(file-dump tarball)) @@ -356,13 +447,13 @@ to make sure we're testing wheels")))) (native-inputs (list python-pytest)) (home-page "http://example.com") (synopsis "summary") - (description "summary") + (description "summary.") (license license:lgpl2.0)) (string=? default-sha256/base32 hash)) (x (pk 'fail x #f)))))) -(test-assert "pypi->guix-package, no usable requirement file." +(test-assert "pypi->guix-package, no usable requirement file, no wheel." (let ((tarball (pypi-tarball "foo-1.0.0" '(("foo.egg-info/.empty" ""))))) (with-pypi `(("/foo-1.0.0.tar.gz" 200 ,(file-dump tarball)) @@ -384,7 +475,7 @@ to make sure we're testing wheels")))) (build-system pyproject-build-system) (home-page "http://example.com") (synopsis "summary") - (description "summary") + (description "summary.") (license license:lgpl2.0)) (string=? default-sha256/base32 hash)) (x @@ -414,7 +505,7 @@ to make sure we're testing wheels")))) (native-inputs (list python-pytest)) (home-page "http://example.com") (synopsis "summary") - (description "summary") + (description "summary.") (license license:lgpl2.0)) (string=? default-sha256/base32 hash)) (x diff --git a/tests/store-deduplication.scm b/tests/store-deduplication.scm index f1845035d8..f116ff9834 100644 --- a/tests/store-deduplication.scm +++ b/tests/store-deduplication.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2018, 2020-2022 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2018, 2020-2022, 2024 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -24,10 +24,27 @@ #:use-module (guix build utils) #:use-module (rnrs bytevectors) #:use-module (ice-9 binary-ports) + #:use-module (ice-9 match) #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) #:use-module (srfi srfi-64)) +(define (cartesian-product . lst) + "Return the Cartesian product of all the given lists." + (match lst + ((head) + (map list head)) + ((head . rest) + (let ((others (apply cartesian-product rest))) + (append-map (lambda (init) + (map (lambda (lst) + (cons init lst)) + others)) + head))) + (() + '()))) + + (test-begin "store-deduplication") (test-equal "deduplicate, below %deduplication-minimum-size" @@ -166,4 +183,43 @@ (cut string-append store <>)) '("/a" "/b" "/c")))))))) +(for-each (match-lambda + ((initial-gap middle-gap final-gap) + (test-assert + (format #f "copy-file/deduplicate, sparse files (holes: ~a/~a/~a)" + initial-gap middle-gap final-gap) + (call-with-temporary-directory + (lambda (store) + (let ((source (string-append store "/source"))) + (call-with-output-file source + (lambda (port) + (seek port initial-gap SEEK_CUR) + (display "hi!" port) + (seek port middle-gap SEEK_CUR) + (display "bye." port) + (when (> final-gap 0) + (seek port (- final-gap 1) SEEK_CUR) + (put-u8 port 0)))) + + (for-each (lambda (target) + (copy-file/deduplicate source + (string-append store target) + #:store store)) + '("/a" "/b" "/c")) + (system* "du" "-h" source) + (system* "du" "-h" "--apparent-size" source) + (system* "du" "-h" (string-append store "/a")) + (system* "du" "-h" "--apparent-size" (string-append store "/a")) + (and (directory-exists? (string-append store "/.links")) + (file=? source (string-append store "/a")) + (apply = (map (compose stat:ino stat + (cut string-append store <>)) + '("/a" "/b" "/c"))) + (let ((st (pk 'S (stat (string-append store "/a"))))) + (<= (* 512 (stat:blocks st)) + (stat:size st)))))))))) + (cartesian-product '(0 3333 8192) + '(8192 9999 16384 22222) + '(0 8192))) + (test-end "store-deduplication") diff --git a/tests/style.scm b/tests/style.scm index 5e38549606..3125f4cb1b 100644 --- a/tests/style.scm +++ b/tests/style.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2021-2023 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2021-2024 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -500,6 +500,29 @@ (load file) (read-package-field (@ (my-packages) my-coreutils) 'arguments 7)))) +(test-equal "gexpify arguments, substitute-keyword-arguments + unquote-splicing" + "\ + (substitute-keyword-arguments (package-arguments coreutils) + ((#:make-flags flags + #~'()) + #~(cons \"-DXYZ=yes\" + #$@(if #t flags + '())))))\n" + (call-with-test-package '((arguments + (substitute-keyword-arguments + (package-arguments coreutils) + ((#:make-flags flags ''()) + `(cons "-DXYZ=yes" ,@(if #t flags '())))))) + (lambda (directory) + (define file + (string-append directory "/my-packages.scm")) + + (system* "guix" "style" "-L" directory "my-coreutils" + "-S" "arguments") + + (load file) + (read-package-field (@ (my-packages) my-coreutils) 'arguments 6)))) + (test-equal "gexpify arguments, append substitute-keyword-arguments" "\ (append (list #:tests? #f) diff --git a/tests/syscalls.scm b/tests/syscalls.scm index 7cf67c060d..13f4f11721 100644 --- a/tests/syscalls.scm +++ b/tests/syscalls.scm @@ -383,6 +383,19 @@ (close-port file) result))))))))) +(test-equal "lock-file + unlock-file" + 'hello + (call-with-temporary-directory + (lambda (directory) + (let* ((file (in-vicinity directory "lock")) + (out (lock-file file #:wait? #f))) + (display "hello" out) + (unlock-file out) + (let* ((in (lock-file file "r0")) + (content (read in))) + (unlock-file in) + content))))) + (test-equal "set-thread-name" "Syscall Test" (let ((name (thread-name))) diff --git a/tests/texlive.scm b/tests/texlive.scm index fac9faf714..8e7e596962 100644 --- a/tests/texlive.scm +++ b/tests/texlive.scm @@ -1,6 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2017, 2022 Ricardo Wurmus <rekado@elephly.net> -;;; Copyright © 2023 Nicolas Goaziou <mail@nicolasgoaziou.fr> +;;; Copyright © 2023, 2024 Nicolas Goaziou <mail@nicolasgoaziou.fr> ;;; ;;; This file is part of GNU Guix. ;;; @@ -32,7 +32,8 @@ (test-begin "texlive") (define %fake-tlpdb - '(("12many" + '((database-revision . 12345) + ("12many" . ((name . "12many") (catalogue @@ -162,6 +163,16 @@ "texmf-dist/tex/lollipop/lollipop.ini" "texmf-dist/tex/lollipop/lollipop.tex") (catalogue-license . "gpl3")) + ("m-tx" + (name . "m-tx") + (shortdesc . "A preprocessor for pmx") + (longdesc . "M-Tx is a preprocessor to pmx") + (depend "m-tx.ARCH") + (runfiles "texmf-dist/scripts/m-tx/m-tx.lua")) + ("m-tx.x86_64-linux" + (name . "m-tx.x86_64-linux") + (binfiles "bin/x86_64-linux/m-tx" + "bin/x86_64-linux/prepmx")) ("pax" (name . "pax") (shortdesc . "Extract and reinsert PDF...") @@ -180,6 +191,9 @@ (shortdesc . "x86_64-linux files of pax") (binfiles "bin/x86_64-linux/pdfannotextractor")) + ("r_und_s" + (name . "r_und_s") + (runfiles "texmf-dist/tex/latex/r_und_s/r_und_s.sty")) ("stricttex" . ((name . "stricttex") @@ -329,7 +343,22 @@ completely compatible with Plain TeX.") "texmf-dist/fonts/tfm/public/trsym/trsy12.tfm" "texmf-dist/tex/latex/trsym/trsym.sty" "texmf-dist/tex/latex/trsym/utrsy.fd") - (catalogue-license . "lppl")))) + (catalogue-license . "lppl")) + ("vlna" + (name . "vlna") + (shortdesc . "Add ~ after non-syllabic preposition") + (longdesc . "Preprocessor for TeX source") + (depend "vlna.ARCH") + (docfiles "texmf-dist/doc/man/man1/vlna.1")) + ("vlna.x86_64-linux" + (shortdesc "x86_64-linux files of vlna") + (binfiles "bin/x86_64-linux/vlna")) + ("web" + (depend "web.ARCH") + (docfiles "texmf-dist/doc/man/man1/tangle.1")) + ("web.x86_64-linux" + (name . "web.x86_64-linux") + (binfiles "bin/x86_64-linux/tangle")))) (test-assert "texlive->guix-package, no docfiles" ;; Replace network resources with sample data. @@ -344,16 +373,21 @@ completely compatible with Plain TeX.") (lambda () (display "source"))))) (let ((result (texlive->guix-package "example" - #:package-database - (lambda _ %fake-tlpdb)))) + #:version "0" + #:database %fake-tlpdb))) (match result (('package ('name "texlive-example") ('version _) - ('source ('texlive-origin - 'name 'version - ('list "tex/latex/example/") - ('base32 (? string? hash)))) + ('source ('origin + ('method 'svn-multi-fetch) + ('uri ('svn-multi-reference + ('url ('texlive-packages-repository 'version)) + ('revision 12345) + ('locations ('list "tex/latex/example/")))) + ('file-name ('git-file-name 'name 'version)) + ('sha256 + ('base32 (? string? hash))))) ('build-system 'texlive-build-system) ('home-page (? string?)) ('synopsis (? string?)) @@ -378,21 +412,27 @@ completely compatible with Plain TeX.") (lambda () (display "source"))))) (let ((result (texlive->guix-package "texsis" - #:package-database - (lambda _ %fake-tlpdb)))) + #:version "0" + #:database %fake-tlpdb))) (match result (('package ('name "texlive-texsis") ('version _) - ('source ('texlive-origin - 'name 'version - ('list "bibtex/bst/texsis/" - "doc/man/man1/texsis.1" - "doc/man/man1/texsis.man1.pdf" - "doc/otherformats/texsis/base/" - "tex/texsis/base/" - "tex/texsis/config/") - ('base32 (? string? hash)))) + ('source ('origin + ('method 'svn-multi-fetch) + ('uri ('svn-multi-reference + ('url ('texlive-packages-repository 'version)) + ('revision 12345) + ('locations + ('list "bibtex/bst/texsis/" + "doc/man/man1/texsis.1" + "doc/man/man1/texsis.man1.pdf" + "doc/otherformats/texsis/base/" + "tex/texsis/base/" + "tex/texsis/config/")))) + ('file-name ('git-file-name 'name 'version)) + ('sha256 + ('base32 (? string? hash))))) ('outputs ''("out" "doc")) ('build-system 'texlive-build-system) ('propagated-inputs @@ -424,8 +464,8 @@ completely compatible with Plain TeX.") (lambda () (display "source"))))) (let ((result (texlive->guix-package "trsym" - #:package-database - (lambda _ %fake-tlpdb)))) + #:version "0" + #:database %fake-tlpdb))) (match result (('package ('name _) @@ -458,18 +498,23 @@ completely compatible with Plain TeX.") (lambda () (display "source"))))) (let ((result (texlive->guix-package "12many" - #:package-database - (lambda _ %fake-tlpdb)))) + #:version "0" + #:database %fake-tlpdb))) (match result (('package ('name "texlive-12many") ('version _) - ('source ('texlive-origin - 'name 'version - ('list "doc/latex/12many/" - "source/latex/12many/" - "tex/latex/12many/") - ('base32 (? string? hash)))) + ('source ('origin + ('method 'svn-multi-fetch) + ('uri ('svn-multi-reference + ('url ('texlive-packages-repository 'version)) + ('revision 12345) + ('locations ('list "doc/latex/12many/" + "source/latex/12many/" + "tex/latex/12many/")))) + ('file-name ('git-file-name 'name 'version)) + ('sha256 + ('base32 (? string? hash))))) ('outputs ''("out" "doc")) ('build-system 'texlive-build-system) ('home-page "https://ctan.org/pkg/one2many") @@ -495,17 +540,23 @@ completely compatible with Plain TeX.") (lambda () (display "source"))))) (let ((result (texlive->guix-package "chs-physics-report" - #:package-database - (lambda _ %fake-tlpdb)))) + #:version "0" + #:database %fake-tlpdb))) (match result (('package ('name "texlive-chs-physics-report") ('version _) - ('source ('texlive-origin - 'name 'version - ('list "doc/latex/chs-physics-report/" - "tex/latex/chs-physics-report/") - ('base32 (? string? hash)))) + ('source ('origin + ('method 'svn-multi-fetch) + ('uri ('svn-multi-reference + ('url ('texlive-packages-repository 'version)) + ('revision 12345) + ('locations + ('list "doc/latex/chs-physics-report/" + "tex/latex/chs-physics-report/")))) + ('file-name ('git-file-name 'name 'version)) + ('sha256 + ('base32 (? string? hash))))) ('outputs ''("out" "doc")) ('build-system 'texlive-build-system) ('home-page (? string?)) @@ -531,12 +582,12 @@ completely compatible with Plain TeX.") (lambda () (display "source"))))) (let ((result (texlive->guix-package "collection-texworks" - #:package-database - (lambda _ %fake-tlpdb)))) + #:version "0" + #:database %fake-tlpdb))) (match result (('package ('name "texlive-collection-texworks") - ('version _) + ('version '%texlive-version) ('source #f) ('build-system 'trivial-build-system) ('arguments @@ -567,17 +618,22 @@ completely compatible with Plain TeX.") (lambda () (display "source"))))) (let ((result (texlive->guix-package "lollipop" - #:package-database - (lambda _ %fake-tlpdb)))) + #:version "0" + #:database %fake-tlpdb))) (match result (('package ('name "texlive-lollipop") ('version _) - ('source ('texlive-origin - 'name 'version - ('list "doc/otherformats/lollipop/" - "tex/lollipop/") - ('base32 (? string? hash)))) + ('source ('origin + ('method 'svn-multi-fetch) + ('uri ('svn-multi-reference + ('url ('texlive-packages-repository 'version)) + ('revision 12345) + ('locations ('list "doc/otherformats/lollipop/" + "tex/lollipop/")))) + ('file-name ('git-file-name 'name 'version)) + ('sha256 + ('base32 (? string? hash))))) ('outputs ''("out" "doc")) ('build-system 'texlive-build-system) ('arguments ('list '#:create-formats ('gexp ('list "lollipop")))) @@ -604,8 +660,8 @@ completely compatible with Plain TeX.") (lambda () (display "source"))))) (let ((result (texlive->guix-package "adforn" - #:package-database - (lambda _ %fake-tlpdb)))) + #:version "0" + #:database %fake-tlpdb))) (match result (('package ('name "texlive-adforn") @@ -636,8 +692,8 @@ completely compatible with Plain TeX.") (lambda () (display "source"))))) (let ((result (texlive->guix-package "collection-basic" - #:package-database - (lambda _ %fake-tlpdb)))) + #:version "0" + #:database %fake-tlpdb))) (match result (('package ('name "texlive-collection-basic") @@ -671,8 +727,8 @@ completely compatible with Plain TeX.") (lambda () (display "source"))))) (let ((result (texlive->guix-package "tex" - #:package-database - (lambda _ %fake-tlpdb)))) + #:version "0" + #:database %fake-tlpdb))) (match result (('package ('name "texlive-tex") @@ -706,8 +762,8 @@ completely compatible with Plain TeX.") (lambda () (display "source"))))) (let ((result (texlive->guix-package "authorindex" - #:package-database - (lambda _ %fake-tlpdb)))) + #:version "0" + #:database %fake-tlpdb))) (match result (('package ('name "texlive-authorindex") @@ -740,8 +796,8 @@ completely compatible with Plain TeX.") (lambda () (display "source"))))) (let ((result (texlive->guix-package "cyrillic-bin" - #:package-database - (lambda _ %fake-tlpdb)))) + #:version "0" + #:database %fake-tlpdb))) (match result (('package ('name "texlive-cyrillic-bin") @@ -775,8 +831,8 @@ completely compatible with Plain TeX.") (lambda () (display "source"))))) (let ((result (texlive->guix-package "pax" - #:package-database - (lambda _ %fake-tlpdb)))) + #:version "0" + #:database %fake-tlpdb))) (match result (('package ('name "texlive-pax") @@ -798,4 +854,137 @@ completely compatible with Plain TeX.") (format #t "~s~%" result) (pk 'fail result #f))))))) +(test-assert "texlive->guix-package, propagated binaries, no script" + ;; Replace network resources with sample data. + (mock ((guix build svn) svn-fetch + (lambda* (url revision directory + #:key (svn-command "svn") + (user-name #f) + (password #f) + (recursive? #t)) + (mkdir-p directory) + (with-output-to-file (string-append directory "/foo") + (lambda () + (display "source"))))) + (let ((result (texlive->guix-package "vlna" + #:version "0" + #:database %fake-tlpdb))) + (match result + (('package + ('name "texlive-vlna") + ('version _) + ('source _) + ('outputs _) + ('build-system 'texlive-build-system) + ('propagated-inputs + ('list 'texlive-vlna-bin)) + ('home-page _) + ('synopsis _) + ('description _) + ('license _)) + #true) + (_ + (begin + (format #t "~s~%" result) + (pk 'fail result #f))))))) + +(test-assert "texlive->guix-package, propagated binaries and scripts" + ;; Replace network resources with sample data. + (mock ((guix build svn) svn-fetch + (lambda* (url revision directory + #:key (svn-command "svn") + (user-name #f) + (password #f) + (recursive? #t)) + (mkdir-p directory) + (with-output-to-file (string-append directory "/foo") + (lambda () + (display "source"))))) + (let ((result (texlive->guix-package "m-tx" + #:version "0" + #:database %fake-tlpdb))) + (match result + (('package + ('name "texlive-m-tx") + ('version _) + ('source _) + ('build-system 'texlive-build-system) + ('arguments + ('list '#:link-scripts ('gexp ('list "m-tx.lua")))) + ('propagated-inputs + ('list 'texlive-m-tx-bin)) + ('home-page _) + ('synopsis _) + ('description _) + ('license _)) + #true) + (_ + (begin + (format #t "~s~%" result) + (pk 'fail result #f))))))) + +(test-assert "texlive->guix-package, with skipped propagated binaries" + ;; Replace network resources with sample data. + (mock ((guix build svn) svn-fetch + (lambda* (url revision directory + #:key (svn-command "svn") + (user-name #f) + (password #f) + (recursive? #t)) + (mkdir-p directory) + (with-output-to-file (string-append directory "/foo") + (lambda () + (display "source"))))) + (let ((result (texlive->guix-package "web" + #:version "0" + #:database %fake-tlpdb))) + (match result + (('package + ('name "texlive-web") + ('version _) + ('source _) + ('outputs _) + ('build-system 'texlive-build-system) + ('home-page _) + ('synopsis _) + ('description _) + ('license _)) + #true) + (_ + (begin + (format #t "~s~%" result) + (pk 'fail result #f))))))) + +(test-assert "texlive->guix-package, with upstream-name property" + ;; Replace network resources with sample data. + (mock ((guix build svn) svn-fetch + (lambda* (url revision directory + #:key (svn-command "svn") + (user-name #f) + (password #f) + (recursive? #t)) + (mkdir-p directory) + (with-output-to-file (string-append directory "/foo") + (lambda () + (display "source"))))) + (let ((result (texlive->guix-package "r_und_s" + #:version "0" + #:database %fake-tlpdb))) + (match result + (('package + ('name "texlive-r-und-s") + ('version _) + ('source _) + ('properties _) + ('build-system 'texlive-build-system) + ('home-page _) + ('synopsis _) + ('description _) + ('license _)) + #true) + (_ + (begin + (format #t "~s~%" result) + (pk 'fail result #f))))))) + (test-end "texlive") diff --git a/tests/toml.scm b/tests/toml.scm new file mode 100644 index 0000000000..cd8e4d2338 --- /dev/null +++ b/tests/toml.scm @@ -0,0 +1,469 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2023 Lars-Dominik Braun <lars@6xq.net> +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. + +(define-module (test-toml) + #:use-module (guix build toml) + #:use-module (guix tests) + #:use-module (srfi srfi-19) ; For datetime. + #:use-module (srfi srfi-64) + #:use-module (ice-9 match)) + +(test-begin "toml") + +;; Tests taken from https://toml.io/en/v1.0.0 + +(test-error "parse-toml: Unspecified key" + &file-not-consumed + (parse-toml "key = # INVALID")) + +(test-error "parse-toml: Missing EOL" + &file-not-consumed + (parse-toml "first = \"Tom\" last = \"Preston-Werner\" # INVALID")) + +(test-equal "parse-toml: Bare keys" + '(("key" . "value") ("bare_key" . "value") ("bare-key" . "value") ("1234" . "value")) + (parse-toml "key = \"value\" +bare_key = \"value\" +bare-key = \"value\" +1234 = \"value\"")) + +(test-equal "parse-toml: Quoted keys" + '(("127.0.0.1" . "value") + ("character encoding" . "value") + ("ʎǝʞ" . "value") + ("key2" . "value") + ("quoted \"value\"" . "value")) + (parse-toml "\"127.0.0.1\" = \"value\" +\"character encoding\" = \"value\" +\"ʎǝʞ\" = \"value\" +'key2' = \"value\" +'quoted \"value\"' = \"value\"")) + +(test-equal "parse-toml: No key" + #f + (parse-toml "= \"no key name\"")) + +(test-equal "parse-toml: Empty key" + '(("" . "blank")) + (parse-toml "\"\" = \"blank\"")) + +(test-equal "parse-toml: Dotted keys" + '(("name" . "Orange") + ("physical" ("color" . "orange") + ("shape" . "round")) + ("site" ("google.com" . #t))) + (parse-toml "name = \"Orange\" +physical.color = \"orange\" +physical.shape = \"round\" +site.\"google.com\" = true")) + +(test-equal "parse-toml: Dotted keys with whitespace" + '(("fruit" ("name" . "banana") ("color" . "yellow") ("flavor" . "banana"))) + (parse-toml "fruit.name = \"banana\" # this is best practice +fruit. color = \"yellow\" # same as fruit.color +fruit . flavor = \"banana\" # same as fruit.flavor")) + +(test-error "parse-toml: Multiple keys" + &already-defined + (parse-toml "name = \"Tom\" +name = \"Pradyun\"")) + +(test-equal "parse-toml: Implicit tables" + '(("fruit" ("apple" ("smooth" . #t)) ("orange" . 2))) + (parse-toml "fruit.apple.smooth = true +fruit.orange = 2")) + +(test-error "parse-toml: Write to value" + &already-defined + (parse-toml "fruit.apple = 1 +fruit.apple.smooth = true")) + +(test-equal "parse-toml: String" + '(("str" . "I'm a string. \"You can quote me\". Name\tJos\u00E9\nLocation\tSF.")) + (parse-toml "str = \"I'm a string. \\\"You can quote me\\\". Name\\tJos\\u00E9\\nLocation\\tSF.\"")) + +(test-equal "parse-toml: Empty string" + '(("str1" . "") + ("str2" . "") + ("str3" . "") + ("str4" . "")) + (parse-toml "str1 = \"\" +str2 = '' +str3 = \"\"\"\"\"\" +str4 = ''''''")) + +(test-equal "parse-toml: Multi-line basic strings" + '(("str1" . "Roses are red\nViolets are blue") + ("str2" . "The quick brown fox jumps over the lazy dog.") + ("str3" . "The quick brown fox jumps over the lazy dog.") + ("str4" . "Here are two quotation marks: \"\". Simple enough.") + ("str5" . "Here are three quotation marks: \"\"\".") + ("str6" . "Here are fifteen quotation marks: \"\"\"\"\"\"\"\"\"\"\"\"\"\"\".") + ("str7" . "\"This,\" she said, \"is just a pointless statement.\"")) + (parse-toml "str1 = \"\"\" +Roses are red +Violets are blue\"\"\" + +str2 = \"\"\" +The quick brown \\ + + + fox jumps over \\ + the lazy dog.\"\"\" + +str3 = \"\"\"\\ + The quick brown \\ + fox jumps over \\ + the lazy dog.\\ + \"\"\" + +str4 = \"\"\"Here are two quotation marks: \"\". Simple enough.\"\"\" +# str5 = \"\"\"Here are three quotation marks: \"\"\".\"\"\" # INVALID +str5 = \"\"\"Here are three quotation marks: \"\"\\\".\"\"\" +str6 = \"\"\"Here are fifteen quotation marks: \"\"\\\"\"\"\\\"\"\"\\\"\"\"\\\"\"\"\\\".\"\"\" + +# \"This,\" she said, \"is just a pointless statement.\" +str7 = \"\"\"\"This,\" she said, \"is just a pointless statement.\"\"\"\"")) + +(test-equal "parse-toml: Literal string" + '(("winpath" . "C:\\Users\\nodejs\\templates") + ("winpath2" . "\\\\ServerX\\admin$\\system32\\") + ("quoted" . "Tom \"Dubs\" Preston-Werner") + ("regex" . "<\\i\\c*\\s*>")) + (parse-toml "winpath = 'C:\\Users\\nodejs\\templates' +winpath2 = '\\\\ServerX\\admin$\\system32\\' +quoted = 'Tom \"Dubs\" Preston-Werner' +regex = '<\\i\\c*\\s*>'")) + +(test-equal "parse-toml: Multi-line literal strings" + '(("regex2" . "I [dw]on't need \\d{2} apples") + ("lines" . "The first newline is\ntrimmed in raw strings.\n All other whitespace\n is preserved.\n") + ("quot15" . "Here are fifteen quotation marks: \"\"\"\"\"\"\"\"\"\"\"\"\"\"\"") + ("apos15" . "Here are fifteen apostrophes: '''''''''''''''") + ("str" . "'That,' she said, 'is still pointless.'")) + (parse-toml "regex2 = '''I [dw]on't need \\d{2} apples''' +lines = ''' +The first newline is +trimmed in raw strings. + All other whitespace + is preserved. +''' +quot15 = '''Here are fifteen quotation marks: \"\"\"\"\"\"\"\"\"\"\"\"\"\"\"''' + +# apos15 = '''Here are fifteen apostrophes: '''''''''''''''''' # INVALID +apos15 = \"Here are fifteen apostrophes: '''''''''''''''\" + +# 'That,' she said, 'is still pointless.' +str = ''''That,' she said, 'is still pointless.''''")) + +(test-equal "parse-toml: Decimal integer" + '(("int1" . 99) ("int2" . 42) ("int3" . 0) ("int4" . -17)) + (parse-toml "int1 = +99 +int2 = 42 +int3 = 0 +int4 = -17")) + +(test-equal "parse-toml: Decimal integer underscores" + '(("int5" . 1000) ("int6" . 5349221) ("int7" . 5349221) ("int8" . 12345)) + (parse-toml "int5 = 1_000 +int6 = 5_349_221 +int7 = 53_49_221 # Indian number system grouping +int8 = 1_2_3_4_5 # VALID but discouraged")) + +(test-equal "parse-toml: Hexadecimal" + `(("hex1" . ,#xdeadbeef) ("hex2" . ,#xdeadbeef) ("hex3" . ,#xdeadbeef)) + (parse-toml "hex1 = 0xDEADBEEF +hex2 = 0xdeadbeef +hex3 = 0xdead_beef")) + +(test-equal "parse-toml: Octal" + `(("oct1" . ,#o01234567) ("oct2" . #o755)) + (parse-toml "oct1 = 0o01234567 +oct2 = 0o755")) + +(test-equal "parse-toml: Binary" + `(("bin1" . ,#b11010110)) + (parse-toml "bin1 = 0b11010110")) + +(test-equal "parse-toml: Float" + '(("flt1" . 1.0) + ("flt2" . 3.1415) + ("flt3" . -0.01) + ("flt4" . 5e+22) + ("flt5" . 1e06) + ("flt6" . -2e-2) + ("flt7" . 6.626e-34) + ("flt8" . 224617.445991228)) + (parse-toml "# fractional +flt1 = +1.0 +flt2 = 3.1415 +flt3 = -0.01 + +# exponent +flt4 = 5e+22 +flt5 = 1e06 +flt6 = -2E-2 + +# both +flt7 = 6.626e-34 + +flt8 = 224_617.445_991_228")) + +(test-equal "parse-toml: Float" + '(("sf1" . +inf.0) + ("sf2" . +inf.0) + ("sf3" . -inf.0) + ("sf4" . +nan.0) + ("sf5" . +nan.0) + ("sf6" . -nan.0)) + (parse-toml "# infinity +sf1 = inf # positive infinity +sf2 = +inf # positive infinity +sf3 = -inf # negative infinity + +# not a number +sf4 = nan # actual sNaN/qNaN encoding is implementation-specific +sf5 = +nan # same as `nan` +sf6 = -nan # valid, actual encoding is implementation-specific")) + +(test-equal "parse-toml: Boolean" + '(("bool1" . #t) + ("bool2" . #f)) + (parse-toml "bool1 = true +bool2 = false")) + +(test-equal "parse-toml: Offset date-time" + `(("odt1" . ,(make-date #f 0 32 7 27 5 1979 0)) + ("odt2" . ,(make-date #f 0 32 0 27 5 1979 (* -7 60 60))) + ("odt3" . ,(make-date 999999 0 32 0 27 5 1979 (* 7 60 60))) + ("odt4" . ,(make-date #f 0 32 7 27 5 1979 0))) + (parse-toml "odt1 = 1979-05-27T07:32:00Z +odt2 = 1979-05-27T00:32:00-07:00 +odt3 = 1979-05-27T00:32:00.999999+07:00 +odt4 = 1979-05-27 07:32:00Z")) + +(test-equal "parse-toml: Local date-time" + `(("ldt1" . ,(make-date #f 0 32 7 27 5 1979 #f)) + ("ldt2" . ,(make-date 999999 0 32 0 27 5 1979 #f))) + (parse-toml "ldt1 = 1979-05-27T07:32:00 +ldt2 = 1979-05-27T00:32:00.999999")) + +(test-equal "parse-toml: Local date" + `(("ld1" . ,(make-date #f #f #f #f 27 5 1979 #f))) + (parse-toml "ld1 = 1979-05-27")) + +(test-equal "parse-toml: Local time" + `(("lt1" . ,(make-date #f 0 32 7 #f #f #f #f)) + ("lt2" . ,(make-date 999999 0 32 0 #f #f #f #f))) + (parse-toml "lt1 = 07:32:00 +lt2 = 00:32:00.999999")) + +(test-equal "parse-toml: Arrays" + '(("integers" 1 2 3) + ("colors" "red" "yellow" "green") + ("nested_arrays_of_ints" (1 2) (3 4 5)) + ("nested_mixed_array" (1 2) ("a" "b" "c")) + ("string_array" "all" "strings") + ("numbers" 0.1 0.2 0.5 1 2 5) + ("contributors" "Foo Bar <foo@example.com>" (("name" . "Baz Qux") ("email" . "bazqux@example.com") ("url" . "https://example.com/bazqux"))) + ("integers2" 1 2 3) + ("integers3" 1 2)) + (parse-toml "integers = [ 1, 2, 3 ] +colors = [ \"red\", \"yellow\", \"green\" ] +nested_arrays_of_ints = [ [ 1, 2 ], [3, 4, 5] ] +nested_mixed_array = [ [ 1, 2 ], [\"a\", \"b\", \"c\"] ] +string_array = [ \"all\", 'strings' ] + +# Mixed-type arrays are allowed +numbers = [ 0.1, 0.2, 0.5, 1, 2, 5 ] +contributors = [ + \"Foo Bar <foo@example.com>\", + { name = \"Baz Qux\", email = \"bazqux@example.com\", url = \"https://example.com/bazqux\" } +] + +integers2 = [ + 1, 2, 3 +] + +integers3 = [ + 1, + 2, # this is ok +]")) + +(test-equal "parse-toml: Arrays of empty strings" + '(("empty1" "") + ("empty2" "" "") + ("empty3" "" "" "") + ("emptyraw1" "") + ("emptyraw2" "" "") + ("emptyraw3" "" "" "") + ("emptyml1" "") + ("emptyml2" "" "") + ("emptyml3" "" "" "") + ("emptyrawml1" "") + ("emptyrawml2" "" "") + ("emptyrawml3" "" "" "")) + (parse-toml "empty1 = [ \"\" ] +empty2 = [ \"\", \"\" ] +empty3 = [ \"\", \"\", \"\" ] +emptyraw1 = [ '' ] +emptyraw2 = [ '', '' ] +emptyraw3 = [ '', '', '' ] +emptyml1 = [ \"\"\"\"\"\" ] +emptyml2 = [ \"\"\"\"\"\", \"\"\"\"\"\" ] +emptyml3 = [ \"\"\"\"\"\", \"\"\"\"\"\", \"\"\"\"\"\" ] +emptyrawml1 = [ '''''' ] +emptyrawml2 = [ '''''', '''''' ] +emptyrawml3 = [ '''''', '''''', '''''' ] +")) + +(test-equal "parse-toml: Tables" + '(("table-1" ("key1" . "some string") + ("key2" . 123)) + ("table-2" ("key1" . "another string") + ("key2" . 456))) + (parse-toml "[table-1] +key1 = \"some string\" +key2 = 123 + +[table-2] +key1 = \"another string\" +key2 = 456")) + + +(test-equal "parse-toml: Dotted table" + '(("dog" ("tater.man" ("type" ("name" . "pug"))))) + (parse-toml "[dog.\"tater.man\"] +type.name = \"pug\"")) + + +(test-equal "parse-toml: Dotted table with whitespace" + '(("a" ("b" ("c" ("x" . 1)))) + ("d" ("e" ("f" ("x" . 1)))) + ("g" ("h" ("i" ("x" . 1)))) + ("j" ("ʞ" ("l" ("x" . 1))))) + (parse-toml "[a.b.c] # this is best practice +x=1 +[ d.e.f ] # same as [d.e.f] +x=1 +[ g . h . i ] # same as [g.h.i] +x=1 +[ j . \"ʞ\" . 'l' ] # same as [j.\"ʞ\".'l'] +x=1")) + +;; XXX: technically this is not allowed, but we permit it. +(test-equal "parse-toml: Multiple tables" + '(("fruit" ("apple" . "red") ("orange" . "orange"))) + (parse-toml "[fruit] +apple = \"red\" + +[fruit] +orange = \"orange\"")) + +(test-equal "parse-toml: Assignment to non-table" + #f + (parse-toml "[fruit] +apple = \"red\" + +[fruit.apple] +texture = \"smooth\"")) + +(test-equal "parse-toml: Dotted keys create tables" + '(("fruit" ("apple" ("color" . "red") ("taste" ("sweet" . #t))))) + (parse-toml "fruit.apple.color = \"red\" +fruit.apple.taste.sweet = true")) + +(test-equal "parse-toml: Inline tables" + '(("name" ("first" . "Tom") ("last" . "Preston-Werner")) + ("point" ("x" . 1) ("y" . 2)) + ("animal" ("type" ("name" . "pug")))) + (parse-toml "name = { first = \"Tom\", last = \"Preston-Werner\" } +point = { x = 1, y = 2 } +animal = { type.name = \"pug\" }")) + +(test-error "parse-toml: Invalid assignment to inline table" + #t + (parse-toml "[product] +type = { name = \"Nail\" } +type.edible = false # INVALID")) + +;; We do not catch this semantic error yet. +(test-expect-fail 1) +(test-error "parse-toml: Invalid assignment to implicit table" + #f + (parse-toml "[product] +type.name = \"Nail\" +type = { edible = false } # INVALID")) + +;; Not implemented. +(test-expect-fail 1) +(test-equal "parse-toml: Array of tables" + '(("products" (("name" . "Hammer") ("sku" . 738594937)) + () + (("name" . "Nail") ("sku" . 284758393) ("color" . "gray")))) + (parse-toml "[[products]] +name = \"Hammer\" +sku = 738594937 + +[[products]] # empty table within the array + +[[products]] +name = \"Nail\" +sku = 284758393 + +color = \"gray\"")) + +;; Not implemented. +(test-expect-fail 1) +(test-equal "parse-toml: Array of tables" + '(("fruits" ((("name" . "apple") + ("physical" (("color" . "red") ("shape" . "round"))) + ("varieties" ((("name" . "red delicious")) (("name" . "granny smith"))))) + (("name" . "banana") + ("varieties" (((("name" . "plantain"))))))))) + (parse-toml "[[fruits]] +name = \"apple\" + +[fruits.physical] # subtable +color = \"red\" +shape = \"round\" + +[[fruits.varieties]] # nested array of tables +name = \"red delicious\" + +[[fruits.varieties]] +name = \"granny smith\" + + +[[fruits]] +name = \"banana\" + +[[fruits.varieties]] +name = \"plantain\"")) + +;; Not implemented. +(test-expect-fail 1) +(test-error "parse-toml: Assignment to statically defined array" + #f + (parse-toml "fruits = [] + +[[fruits]] +x=1")) + +(test-end "toml") + diff --git a/tests/transformations.scm b/tests/transformations.scm index 755211d65d..5285d98f17 100644 --- a/tests/transformations.scm +++ b/tests/transformations.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2016-2017, 2019-2023 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2016-2017, 2019-2024 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2021 Marius Bakke <marius@gnu.org> ;;; ;;; This file is part of GNU Guix. @@ -497,6 +497,35 @@ (let ((new (t coreutils))) (assq-ref (package-properties new) 'transformations)))) +(test-equal "package-with-upstream-version" + '("42.0" "42.0" + ("http://example.org") + ("a" "b") (do something)) + (mock ((guix upstream) %updaters + (delay (list (upstream-updater + (name 'dummy) + (pred (const #t)) + (description "") + (import (const (upstream-source + (package "foo") + (version "42.0") + (urls '("http://example.org"))))))))) + (let* ((old (dummy-package "foo" (version "1.0") + (source (dummy-origin + (patches '("a" "b")) + (snippet '(do something)))))) + (new (package-with-upstream-version old)) + (new+patches (package-with-upstream-version + old #:preserve-patches? #t))) + (list (package-version new) (package-version new+patches) + + ;; Source of NEW is directly an <upstream-source>. + (upstream-source-urls (package-source new)) + + ;; Check that #:preserve-patches? #t gave us an origin. + (origin-patches (package-source new+patches)) + (origin-snippet (package-source new+patches)))))) + (test-equal "options->transformation, with-latest" "42.0" (mock ((guix upstream) %updaters |