summaryrefslogtreecommitdiff
path: root/tests
diff options
context:
space:
mode:
Diffstat (limited to 'tests')
-rw-r--r--tests/containers.scm53
-rw-r--r--tests/guix-pack-relocatable.sh6
-rw-r--r--tests/guix-pack.sh5
-rw-r--r--tests/hackage.scm5
-rw-r--r--tests/pack.scm368
-rw-r--r--tests/rpm.scm86
6 files changed, 341 insertions, 182 deletions
diff --git a/tests/containers.scm b/tests/containers.scm
index 608902c41a..70d5ba2d30 100644
--- a/tests/containers.scm
+++ b/tests/containers.scm
@@ -1,6 +1,6 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2015 David Thompson <[email protected]>
-;;; Copyright © 2016, 2017, 2019 Ludovic Courtès <[email protected]>
+;;; Copyright © 2016, 2017, 2019, 2023 Ludovic Courtès <[email protected]>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -31,7 +31,8 @@
#:use-module (guix tests)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-64)
- #:use-module (ice-9 match))
+ #:use-module (ice-9 match)
+ #:use-module ((ice-9 ftw) #:select (scandir)))
(define (assert-exit x)
(primitive-exit (if x 0 1)))
@@ -176,21 +177,11 @@
(close start-in)
(container-excursion pid
(lambda ()
- ;; Fork again so that the pid is within the context of
- ;; the joined pid namespace instead of the original pid
- ;; namespace.
- (match (primitive-fork)
- (0
- ;; Check that all of the namespace identifiers are
- ;; the same as the container process.
- (assert-exit
- (equal? container-namespaces
- (namespaces (getpid)))))
- (fork-pid
- (match (waitpid fork-pid)
- ((_ . status)
- (primitive-exit
- (status:exit-val status)))))))))))
+ ;; Check that all of the namespace identifiers are
+ ;; the same as the container process.
+ (assert-exit
+ (equal? container-namespaces
+ (namespaces (getpid)))))))))
(close end-in)
;; Stop the container.
(write 'done end-out)
@@ -203,9 +194,10 @@
42
;; The parent and child are in the same namespaces. 'container-excursion'
;; should notice that and avoid calling 'setns' since that would fail.
- (container-excursion (getpid)
- (lambda ()
- (primitive-exit 42))))
+ (status:exit-val
+ (container-excursion (getpid)
+ (lambda ()
+ (primitive-exit 42)))))
(skip-if-unsupported)
(test-assert "container-excursion*"
@@ -236,6 +228,27 @@
(* 6 7))))
(skip-if-unsupported)
+(test-equal "container-excursion*, /proc"
+ '("1" "2")
+ (call-with-temporary-directory
+ (lambda (root)
+ (let* ((pid (run-container root '()
+ %namespaces 1
+ (lambda ()
+ (sleep 100))))
+ (result (container-excursion* pid
+ (lambda ()
+ ;; We expect to see exactly two processes in this
+ ;; namespace.
+ (scandir "/proc"
+ (lambda (file)
+ (char-set-contains?
+ char-set:digit
+ (string-ref file 0))))))))
+ (kill pid SIGKILL)
+ result))))
+
+(skip-if-unsupported)
(test-equal "eval/container, exit status"
42
(let* ((store (open-connection-for-tests))
diff --git a/tests/guix-pack-relocatable.sh b/tests/guix-pack-relocatable.sh
index b90bc7f891..46120c9ee6 100644
--- a/tests/guix-pack-relocatable.sh
+++ b/tests/guix-pack-relocatable.sh
@@ -1,5 +1,5 @@
# GNU Guix --- Functional package management for GNU
-# Copyright © 2018, 2019, 2020 Ludovic Courtès <[email protected]>
+# Copyright © 2018, 2019, 2020, 2023 Ludovic Courtès <[email protected]>
# Copyright © 2020 Eric Bavier <[email protected]>
#
# This file is part of GNU Guix.
@@ -82,6 +82,7 @@ then
tarball="`guix pack -R -S /Bin=bin sed`"
(cd "$test_directory"; tar xvf "$tarball")
+ chmod +w "$test_directory"
run_without_store "$test_directory/Bin/sed" --version > "$test_directory/output"
grep 'GNU sed' "$test_directory/output"
@@ -104,6 +105,7 @@ case "`uname -m`" in
tarball="`guix pack -RR -S /Bin=bin sed`"
tar tvf "$tarball" | grep /bin/proot
(cd "$test_directory"; tar xf "$tarball")
+ chmod +w "$test_directory"
run_without_store GUIX_EXECUTION_ENGINE="proot" \
"$test_directory/Bin/sed" --version > "$test_directory/output"
grep 'GNU sed' "$test_directory/output"
@@ -195,6 +197,7 @@ EOF
# Run '/bin/daemon', which forks, then wait for the child, send it SIGHUP
# so that it dumps its view of the store, and make sure the child and
# parent both see the same store contents.
+ chmod +w "$test_directory"
(cd "$test_directory"; run_without_store ./bin/daemon)
wait_for_file "$test_directory/pid"
kill -HUP $(cat "$test_directory/pid")
@@ -241,6 +244,7 @@ cat >"$test_directory/manifest.scm" <<'EOF'
EOF
tarball="`guix pack -RR -S /opt= -m $test_directory/manifest.scm`"
(cd "$test_directory"; tar xvf "$tarball")
+chmod +w "$test_directory"
( export GUIX_PROFILE=$test_directory/opt
. $GUIX_PROFILE/etc/profile
run_without_store "$test_directory/opt/bin/hello" > "$test_directory/output" )
diff --git a/tests/guix-pack.sh b/tests/guix-pack.sh
index 6fc9e3723b..a13e0ededf 100644
--- a/tests/guix-pack.sh
+++ b/tests/guix-pack.sh
@@ -1,6 +1,6 @@
# GNU Guix --- Functional package management for GNU
# Copyright © 2018 Chris Marusich <[email protected]>
-# Copyright © 2018, 2019, 2020, 2022 Ludovic Courtès <[email protected]>
+# Copyright © 2018, 2019, 2020, 2022, 2023 Ludovic Courtès <[email protected]>
#
# This file is part of GNU Guix.
#
@@ -114,7 +114,8 @@ guix pack --dry-run --bootstrap --target=arm-linux-gnueabihf coreutils
guix pack -R --dry-run --bootstrap -S /mybin=bin guile-bootstrap
# Make sure package transformation options are honored.
-mkdir -p "$test_directory"
+chmod -Rf +w "$test_directory"; rm -r "$test_directory"
+mkdir -p "$test_directory" -m 755
drv1="`guix pack --no-grafts -n guile 2>&1 | grep pack.*\.drv`"
drv2="`guix pack --no-grafts -n --with-source=guile=$test_directory guile 2>&1 | grep pack.*\.drv`"
test -n "$drv1"
diff --git a/tests/hackage.scm b/tests/hackage.scm
index ad2ee4b7f9..8eea818ebd 100644
--- a/tests/hackage.scm
+++ b/tests/hackage.scm
@@ -201,6 +201,7 @@ library
('base32
(? string? hash)))))
('build-system 'haskell-build-system)
+ ('properties '(quote ((upstream-name . "foo"))))
('inputs ('list 'ghc-http))
('home-page "http://test.org")
('synopsis (? string?))
@@ -241,6 +242,7 @@ library
('base32
(? string? hash)))))
('build-system 'haskell-build-system)
+ ('properties '(quote ((upstream-name . "foo"))))
('inputs ('list 'ghc-b 'ghc-http))
('native-inputs ('list 'ghc-haskell-gi))
('home-page "http://test.org")
@@ -471,6 +473,7 @@ library
('base32
(? string? hash)))))
('build-system 'haskell-build-system)
+ ('properties '(quote ((upstream-name . "foo"))))
('inputs ('list 'ghc-c))
('home-page "http://test.org")
('synopsis (? string?))
@@ -520,6 +523,7 @@ executable cabal
('base32
(? string? hash)))))
('build-system 'haskell-build-system)
+ ('properties '(quote ((upstream-name . "foo"))))
('inputs ('list 'ghc-http))
('arguments
('quasiquote
@@ -610,6 +614,7 @@ executable cabal
('base32
(? string? hash)))))
('build-system 'haskell-build-system)
+ ('properties '(quote ((upstream-name . "foo"))))
('inputs ('list 'ghc-http))
('home-page "http://test.org")
('synopsis (? string?))
diff --git a/tests/pack.scm b/tests/pack.scm
index a4c388d93e..87187bb62c 100644
--- a/tests/pack.scm
+++ b/tests/pack.scm
@@ -1,7 +1,7 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <[email protected]>
;;; Copyright © 2018 Ricardo Wurmus <[email protected]>
-;;; Copyright © 2021 Maxim Cournoyer <[email protected]>
+;;; Copyright © 2021, 2023 Maxim Cournoyer <[email protected]>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -28,13 +28,16 @@
#:use-module (guix tests)
#:use-module (guix gexp)
#:use-module (guix modules)
+ #:use-module (guix utils)
#:use-module (gnu packages)
#:use-module ((gnu packages base) #:select (glibc-utf8-locales))
#:use-module (gnu packages bootstrap)
+ #:use-module ((gnu packages package-management) #:select (rpm))
#:use-module ((gnu packages compression) #:select (squashfs-tools))
#:use-module ((gnu packages debian) #:select (dpkg))
#:use-module ((gnu packages guile) #:select (guile-sqlite3))
#:use-module ((gnu packages gnupg) #:select (guile-gcrypt))
+ #:use-module ((gnu packages linux) #:select (fakeroot))
#:use-module (srfi srfi-64))
(define %store
@@ -59,6 +62,17 @@
(define %ar-bootstrap %bootstrap-binutils)
+;;; This is a variant of the RPM package configured so that its database can
+;;; be created on a writable location readily available inside the build
+;;; container ("/tmp").
+(define rpm-for-tests
+ (package
+ (inherit rpm)
+ (arguments (substitute-keyword-arguments (package-arguments rpm)
+ ((#:configure-flags flags '())
+ #~(cons "--localstatedir=/tmp"
+ (delete "--localstatedir=/var" #$flags)))))))
+
(test-begin "pack")
@@ -74,44 +88,43 @@
-> "bin/guile"))
#:compressor %gzip-compressor
#:archiver %tar-bootstrap))
- (check (gexp->derivation
- "check-tarball"
- (with-imported-modules '((guix build utils))
- #~(begin
- (use-modules (guix build utils)
- (srfi srfi-1))
-
- (define store
- ;; The unpacked store.
- (string-append "." (%store-directory) "/"))
-
- (define (canonical? file)
- ;; Return #t if FILE is read-only and its mtime is 1.
- (let ((st (lstat file)))
- (or (not (string-prefix? store file))
- (eq? 'symlink (stat:type st))
- (and (= 1 (stat:mtime st))
- (zero? (logand #o222
- (stat:mode st)))))))
-
- (define bin
- (string-append "." #$profile "/bin"))
-
- (setenv "PATH"
- (string-append #$%tar-bootstrap "/bin"))
- (system* "tar" "xvf" #$tarball)
- (mkdir #$output)
- (exit
- (and (file-exists? (string-append bin "/guile"))
- (file-exists? store)
- (every canonical?
- (find-files "." (const #t)
- #:directories? #t))
- (string=? (string-append #$%bootstrap-guile "/bin")
- (readlink bin))
- (string=? (string-append ".." #$profile
- "/bin/guile")
- (readlink "bin/Guile")))))))))
+ (check (gexp->derivation "check-tarball"
+ (with-imported-modules '((guix build utils))
+ #~(begin
+ (use-modules (guix build utils)
+ (srfi srfi-1))
+
+ (define store
+ ;; The unpacked store.
+ (string-append "." (%store-directory) "/"))
+
+ (define (canonical? file)
+ ;; Return #t if FILE is read-only and its mtime is 1.
+ (let ((st (lstat file)))
+ (or (not (string-prefix? store file))
+ (eq? 'symlink (stat:type st))
+ (and (= 1 (stat:mtime st))
+ (zero? (logand #o222
+ (stat:mode st)))))))
+
+ (define bin
+ (string-append "." #$profile "/bin"))
+
+ (setenv "PATH"
+ (string-append #$%tar-bootstrap "/bin"))
+ (system* "tar" "xvf" #$tarball)
+ (mkdir #$output)
+ (exit
+ (and (file-exists? (string-append bin "/guile"))
+ (file-exists? store)
+ (every canonical?
+ (find-files "." (const #t)
+ #:directories? #t))
+ (string=? (string-append #$%bootstrap-guile "/bin")
+ (readlink bin))
+ (string=? (string-append ".." #$profile
+ "/bin/guile")
+ (readlink "bin/Guile")))))))))
(built-derivations (list check))))
;; The following test needs guile-sqlite3, libgcrypt, etc. as a consequence of
@@ -125,23 +138,22 @@
(test-assertm "self-contained-tarball + localstatedir" store
(mlet* %store-monad
((guile (set-guile-for-build (default-guile)))
- (profile (profile-derivation (packages->manifest
- (list %bootstrap-guile))
- #:hooks '()
- #:locales? #f))
+ (profile -> (profile
+ (content (packages->manifest (list %bootstrap-guile)))
+ (hooks '())
+ (locales? #f)))
(tarball (self-contained-tarball "tar-pack" profile
#:localstatedir? #t))
- (check (gexp->derivation
- "check-tarball"
- #~(let ((bin (string-append "." #$profile "/bin")))
- (setenv "PATH"
- (string-append #$%tar-bootstrap "/bin"))
- (system* "tar" "xvf" #$tarball)
- (mkdir #$output)
- (exit
- (and (file-exists? "var/guix/db/db.sqlite")
- (string=? (string-append #$%bootstrap-guile "/bin")
- (readlink bin))))))))
+ (check (gexp->derivation "check-tarball"
+ #~(let ((bin (string-append "." #$profile "/bin")))
+ (setenv "PATH"
+ (string-append #$%tar-bootstrap "/bin"))
+ (system* "tar" "xvf" #$tarball)
+ (mkdir #$output)
+ (exit
+ (and (file-exists? "var/guix/db/db.sqlite")
+ (string=? (string-append #$%bootstrap-guile "/bin")
+ (readlink bin))))))))
(built-derivations (list check))))
(unless store (test-skip 1))
@@ -154,135 +166,132 @@
("λ" regular (data "lambda")))))
(tarball (self-contained-tarball "tar-pack" tree
#:localstatedir? #t))
- (check (gexp->derivation
- "check-tarball"
- (with-extensions (list guile-sqlite3 guile-gcrypt)
- (with-imported-modules (source-module-closure
- '((guix store database)))
- #~(begin
- (use-modules (guix store database)
- (rnrs io ports)
- (srfi srfi-1))
-
- (define (valid-file? basename data)
- (define file
- (string-append "./" #$tree "/" basename))
-
- (string=? (call-with-input-file (pk 'file file)
- get-string-all)
- data))
-
- (setenv "PATH"
- (string-append #$%tar-bootstrap "/bin"))
- (system* "tar" "xvf" #$tarball)
-
- (sql-schema
- #$(local-file (search-path %load-path
- "guix/store/schema.sql")))
- (with-database "var/guix/db/db.sqlite" db
- ;; Make sure non-ASCII file names are properly
- ;; handled.
- (setenv "GUIX_LOCPATH"
- #+(file-append glibc-utf8-locales
- "/lib/locale"))
- (setlocale LC_ALL "en_US.utf8")
-
- (mkdir #$output)
- (exit
- (and (every valid-file?
- '("α" "λ")
- '("alpha" "lambda"))
- (integer? (path-id db #$tree)))))))))))
+ (check (gexp->derivation "check-tarball"
+ (with-extensions (list guile-sqlite3 guile-gcrypt)
+ (with-imported-modules (source-module-closure
+ '((guix store database)))
+ #~(begin
+ (use-modules (guix store database)
+ (rnrs io ports)
+ (srfi srfi-1))
+
+ (define (valid-file? basename data)
+ (define file
+ (string-append "./" #$tree "/" basename))
+
+ (string=? (call-with-input-file (pk 'file file)
+ get-string-all)
+ data))
+
+ (setenv "PATH"
+ (string-append #$%tar-bootstrap "/bin"))
+ (system* "tar" "xvf" #$tarball)
+
+ (sql-schema
+ #$(local-file (search-path %load-path
+ "guix/store/schema.sql")))
+ (with-database "var/guix/db/db.sqlite" db
+ ;; Make sure non-ASCII file names are properly
+ ;; handled.
+ (setenv "GUIX_LOCPATH"
+ #+(file-append glibc-utf8-locales
+ "/lib/locale"))
+ (setlocale LC_ALL "en_US.utf8")
+
+ (mkdir #$output)
+ (exit
+ (and (every valid-file?
+ '("α" "λ")
+ '("alpha" "lambda"))
+ (integer? (path-id db #$tree)))))))))))
(built-derivations (list check))))
(unless store (test-skip 1))
(test-assertm "docker-image + localstatedir" store
(mlet* %store-monad
((guile (set-guile-for-build (default-guile)))
- (profile (profile-derivation (packages->manifest
- (list %bootstrap-guile))
- #:hooks '()
- #:locales? #f))
+ (profile -> (profile
+ (content (packages->manifest (list %bootstrap-guile)))
+ (hooks '())
+ (locales? #f)))
(tarball (docker-image "docker-pack" profile
#:symlinks '(("/bin/Guile" -> "bin/guile"))
#:localstatedir? #t))
- (check (gexp->derivation
- "check-tarball"
- (with-imported-modules '((guix build utils))
- #~(begin
- (use-modules (guix build utils)
- (ice-9 match))
-
- (define bin
- (string-append "." #$profile "/bin"))
-
- (setenv "PATH" (string-append #$%tar-bootstrap "/bin"))
- (mkdir "base")
- (with-directory-excursion "base"
- (invoke "tar" "xvf" #$tarball))
-
- (match (find-files "base" "layer.tar")
- ((layer)
- (invoke "tar" "xvf" layer)))
-
- (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)))
- (string=? (string-append #$profile "/bin/guile")
- (pk 'guilelink (readlink "bin/Guile"))))
- (mkdir #$output)))))))
+ (check (gexp->derivation "check-tarball"
+ (with-imported-modules '((guix build utils))
+ #~(begin
+ (use-modules (guix build utils)
+ (ice-9 match))
+
+ (define bin
+ (string-append "." #$profile "/bin"))
+
+ (setenv "PATH" (string-append #$%tar-bootstrap "/bin"))
+ (mkdir "base")
+ (with-directory-excursion "base"
+ (invoke "tar" "xvf" #$tarball))
+
+ (match (find-files "base" "layer.tar")
+ ((layer)
+ (invoke "tar" "xvf" layer)))
+
+ (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)))
+ (string=? (string-append #$profile "/bin/guile")
+ (pk 'guilelink (readlink "bin/Guile"))))
+ (mkdir #$output)))))))
(built-derivations (list check))))
(unless store (test-skip 1))
(test-assertm "squashfs-image + localstatedir" store
(mlet* %store-monad
((guile (set-guile-for-build (default-guile)))
- (profile (profile-derivation (packages->manifest
- (list %bootstrap-guile))
- #:hooks '()
- #:locales? #f))
+ (profile -> (profile
+ (content (packages->manifest (list %bootstrap-guile)))
+ (hooks '())
+ (locales? #f)))
(image (squashfs-image "squashfs-pack" profile
#:symlinks '(("/bin" -> "bin"))
#:localstatedir? #t))
- (check (gexp->derivation
- "check-tarball"
- (with-imported-modules '((guix build utils))
- #~(begin
- (use-modules (guix build utils)
- (ice-9 match))
-
- (define bin
- (string-append "." #$profile "/bin"))
-
- (setenv "PATH"
- (string-append #$squashfs-tools "/bin"))
- (invoke "unsquashfs" #$image)
- (with-directory-excursion "squashfs-root"
- (when (and (file-exists? (string-append bin
- "/guile"))
- (file-exists? "var/guix/db/db.sqlite")
- (string=? (string-append #$%bootstrap-guile "/bin")
- (pk 'binlink (readlink bin)))
-
- ;; This is a relative symlink target.
- (string=? (string-drop
- (string-append #$profile "/bin")
- 1)
- (pk 'guilelink (readlink "bin"))))
- (mkdir #$output))))))))
+ (check (gexp->derivation "check-tarball"
+ (with-imported-modules '((guix build utils))
+ #~(begin
+ (use-modules (guix build utils)
+ (ice-9 match))
+
+ (define bin
+ (string-append "." #$profile "/bin"))
+
+ (setenv "PATH"
+ (string-append #$squashfs-tools "/bin"))
+ (invoke "unsquashfs" #$image)
+ (with-directory-excursion "squashfs-root"
+ (when (and (file-exists? (string-append bin
+ "/guile"))
+ (file-exists? "var/guix/db/db.sqlite")
+ (string=? (string-append #$%bootstrap-guile "/bin")
+ (pk 'binlink (readlink bin)))
+
+ ;; This is a relative symlink target.
+ (string=? (string-drop
+ (string-append #$profile "/bin")
+ 1)
+ (pk 'guilelink (readlink "bin"))))
+ (mkdir #$output))))))))
(built-derivations (list check))))
(unless store (test-skip 1))
(test-assertm "deb archive with symlinks and control files" store
(mlet* %store-monad
((guile (set-guile-for-build (default-guile)))
- (profile (profile-derivation (packages->manifest
- (list %bootstrap-guile))
- #:hooks '()
- #:locales? #f))
+ (profile -> (profile
+ (content (packages->manifest (list %bootstrap-guile)))
+ (hooks '())
+ (locales? #f)))
(deb (debian-archive
"deb-pack" profile
#:compressor %gzip-compressor
@@ -361,6 +370,47 @@
(assert (file-exists? "triggers"))
(mkdir #$output))))))
+ (built-derivations (list check))))
+
+ (unless store (test-skip 1))
+ (test-assertm "rpm archive can be installed/uninstalled" store
+ (mlet* %store-monad
+ ((guile (set-guile-for-build (default-guile)))
+ (profile -> (profile
+ (content (packages->manifest (list %bootstrap-guile)))
+ (hooks '())
+ (locales? #f)))
+ (rpm-pack (rpm-archive "rpm-pack" profile
+ #:compressor %gzip-compressor
+ #:symlinks '(("/bin/guile" -> "bin/guile"))
+ #:extra-options '(#:relocatable? #t)))
+ (check
+ (gexp->derivation "check-rpm-pack"
+ (with-imported-modules (source-module-closure
+ '((guix build utils)))
+ #~(begin
+ (use-modules (guix build utils))
+
+ (define fakeroot #+(file-append fakeroot "/bin/fakeroot"))
+ (define rpm #+(file-append rpm-for-tests "/bin/rpm"))
+ (mkdir-p "/tmp/lib/rpm")
+
+ ;; Install the RPM package. This causes RPM to validate the
+ ;; signatures, header as well as the file digests, which
+ ;; makes it a rather thorough test.
+ (mkdir "test-prefix")
+ (invoke fakeroot rpm "--install"
+ (string-append "--prefix=" (getcwd) "/test-prefix")
+ #$rpm-pack)
+
+ ;; Invoke the installed Guile command.
+ (invoke "./test-prefix/bin/guile" "--version")
+
+ ;; Uninstall the RPM package.
+ (invoke fakeroot rpm "--erase" "guile-bootstrap")
+
+ ;; Required so the above is run.
+ (mkdir #$output))))))
(built-derivations (list check)))))
(test-end)
diff --git a/tests/rpm.scm b/tests/rpm.scm
new file mode 100644
index 0000000000..f40b36fe60
--- /dev/null
+++ b/tests/rpm.scm
@@ -0,0 +1,86 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2023 Maxim Cournoyer <[email protected]>
+;;;
+;;; 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-rpm)
+ #:use-module (guix rpm)
+ #:use-module (rnrs bytevectors)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-26)
+ #:use-module (srfi srfi-64)
+ #:use-module (srfi srfi-71))
+
+;; For white-box testing.
+(define-syntax-rule (expose-internal name)
+ (define name (@@ (guix rpm) name)))
+
+(expose-internal RPMTAG_ARCH)
+(expose-internal RPMTAG_LICENSE)
+(expose-internal RPMTAG_NAME)
+(expose-internal RPMTAG_OS)
+(expose-internal RPMTAG_RELEASE)
+(expose-internal RPMTAG_SUMMARY)
+(expose-internal RPMTAG_VERSION)
+(expose-internal header-entry-count)
+(expose-internal header-entry-tag)
+(expose-internal header-entry-value)
+(expose-internal header-entry?)
+(expose-internal make-header)
+(expose-internal make-header-entry)
+(expose-internal make-header-index+data)
+
+(test-begin "rpm")
+
+(test-equal "lead must be 96 bytes long"
+ 96
+ (length (generate-lead "hello-2.12.1")))
+
+(define header-entries
+ (list (make-header-entry RPMTAG_NAME 1 "hello")
+ (make-header-entry RPMTAG_VERSION 1 "2.12.1")
+ (make-header-entry RPMTAG_RELEASE 1 "0")
+ (make-header-entry RPMTAG_SUMMARY 1
+ "Hello, GNU world: An example GNU package")
+ (make-header-entry RPMTAG_LICENSE 1 "GPL 3 or later")
+ (make-header-entry RPMTAG_OS 1 "Linux")
+ (make-header-entry RPMTAG_ARCH 1 "x86_64")))
+
+(define expected-header-index-length
+ (* 16 (length header-entries))) ;16 bytes per index entry
+
+(define expected-header-data-length
+ (+ (length header-entries) ;to account for null bytes
+ (fold + 0 (map (compose string-length (cut header-entry-value <>))
+ header-entries))))
+
+(let ((index data (make-header-index+data header-entries)))
+ (test-equal "header index"
+ expected-header-index-length
+ (length index))
+
+ ;; This test depends on the fact that only STRING entries are used, and that
+ ;; they are composed of single byte characters and the delimiting null byte.
+ (test-equal "header data"
+ expected-header-data-length
+ (length data)))
+
+(test-equal "complete header section"
+ (+ 16 ;leading magic + count bytes
+ expected-header-index-length expected-header-data-length)
+ (length (make-header header-entries)))
+
+(test-end)
generated by cgit v1.2.3 (git 2.45.2) at 2025-04-12 23:07:37 +0000