aboutsummaryrefslogtreecommitdiff
path: root/tests
diff options
context:
space:
mode:
Diffstat (limited to 'tests')
-rw-r--r--tests/build-utils.scm12
-rw-r--r--tests/cache.scm30
-rw-r--r--tests/crate.scm36
-rw-r--r--tests/derivations.scm31
-rw-r--r--tests/elm.scm8
-rw-r--r--tests/gem.scm12
-rw-r--r--tests/gexp.scm59
-rw-r--r--tests/git.scm22
-rw-r--r--tests/go.scm8
-rw-r--r--tests/gremlin.scm2
-rw-r--r--tests/guix-build.sh17
-rw-r--r--tests/guix-package.sh4
-rw-r--r--tests/guix-shell-export-manifest.sh3
-rw-r--r--tests/guix-style.sh26
-rw-r--r--tests/guix-system.sh11
-rw-r--r--tests/hexpm.scm8
-rw-r--r--tests/import-utils.scm8
-rw-r--r--tests/lint.scm62
-rw-r--r--tests/minetest.scm2
-rw-r--r--tests/modules.scm18
-rw-r--r--tests/pack.scm41
-rw-r--r--tests/packages.scm25
-rw-r--r--tests/print.scm7
-rw-r--r--tests/profiles.scm7
-rw-r--r--tests/pypi.scm109
-rw-r--r--tests/store-deduplication.scm58
-rw-r--r--tests/style.scm25
-rw-r--r--tests/syscalls.scm13
-rw-r--r--tests/texlive.scm307
-rw-r--r--tests/toml.scm469
-rw-r--r--tests/transformations.scm31
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