diff options
Diffstat (limited to 'tests')
| -rw-r--r-- | tests/containers.scm | 53 | ||||
| -rw-r--r-- | tests/guix-pack-relocatable.sh | 6 | ||||
| -rw-r--r-- | tests/guix-pack.sh | 5 | ||||
| -rw-r--r-- | tests/hackage.scm | 5 | ||||
| -rw-r--r-- | tests/pack.scm | 368 | ||||
| -rw-r--r-- | tests/rpm.scm | 86 |
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 <davet@gnu.org> -;;; Copyright © 2016, 2017, 2019 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2016, 2017, 2019, 2023 Ludovic Courtès <ludo@gnu.org> ;;; ;;; 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 <ludo@gnu.org> +# Copyright © 2018, 2019, 2020, 2023 Ludovic Courtès <ludo@gnu.org> # Copyright © 2020 Eric Bavier <bavier@posteo.net> # # 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 <cmmarusich@gmail.com> -# Copyright © 2018, 2019, 2020, 2022 Ludovic Courtès <ludo@gnu.org> +# Copyright © 2018, 2019, 2020, 2022, 2023 Ludovic Courtès <ludo@gnu.org> # # 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 <ludo@gnu.org> ;;; Copyright © 2018 Ricardo Wurmus <rekado@elephly.net> -;;; Copyright © 2021 Maxim Cournoyer <maxim.cournoyer@gmail.com> +;;; Copyright © 2021, 2023 Maxim Cournoyer <maxim.cournoyer@gmail.com> ;;; ;;; 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 <maxim.cournoyer@gmail.com> +;;; +;;; 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) |