diff options
Diffstat (limited to 'tests')
| -rw-r--r-- | tests/pack.scm | 201 |
1 files changed, 101 insertions, 100 deletions
diff --git a/tests/pack.scm b/tests/pack.scm index 0864a4b78a..cf249f861b 100644 --- a/tests/pack.scm +++ b/tests/pack.scm @@ -239,15 +239,14 @@ ((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))))))) + (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)) @@ -310,71 +309,72 @@ (plain-file "postinst" "echo running configure script\n")))) (check - (gexp->derivation "check-deb-pack" - (with-imported-modules '((guix build utils)) - #~(begin - (use-modules (guix build utils) - (ice-9 match) - (ice-9 popen) - (ice-9 rdelim) - (ice-9 textual-ports) - (rnrs base)) - - (setenv "PATH" (string-join - (list (string-append #+%tar-bootstrap "/bin") - (string-append #+dpkg "/bin") - (string-append #+%ar-bootstrap "/bin")) - ":")) - - ;; Validate the output of 'dpkg --info'. - (let* ((port (open-pipe* OPEN_READ "dpkg" "--info" #$deb)) - (info (get-string-all port)) - (exit-val (status:exit-val (close-pipe port)))) - (assert (zero? exit-val)) - - (assert (string-contains - info - (string-append "Package: " - #+(package-name %bootstrap-guile)))) - - (assert (string-contains - info - (string-append "Version: " - #+(package-version %bootstrap-guile))))) - - ;; Sanity check .deb contents. - (invoke "ar" "-xv" #$deb) - (assert (file-exists? "debian-binary")) - (assert (file-exists? "data.tar.gz")) - (assert (file-exists? "control.tar.gz")) - - ;; Verify there are no hard links in data.tar.gz, as hard - ;; links would cause dpkg to fail unpacking the archive. - (define hard-links - (let ((port (open-pipe* OPEN_READ "tar" "-tvf" "data.tar.gz"))) - (let loop ((hard-links '())) - (match (read-line port) - ((? eof-object?) - (assert (zero? (status:exit-val (close-pipe port)))) - hard-links) - (line - (if (string-prefix? "u" line) - (loop (cons line hard-links)) - (loop hard-links))))))) - - (unless (null? hard-links) - (error "hard links found in data.tar.gz" hard-links)) - - ;; Verify the presence of the control files. - (invoke "tar" "-xf" "control.tar.gz") - (assert (file-exists? "control")) - (assert (and (file-exists? "postinst") - (= #o111 ;script is executable - (logand #o111 (stat:perms - (stat "postinst")))))) - (assert (file-exists? "triggers")) - - (mkdir #$output)))))) + (gexp->derivation + "check-deb-pack" + (with-imported-modules '((guix build utils)) + #~(begin + (use-modules (guix build utils) + (ice-9 match) + (ice-9 popen) + (ice-9 rdelim) + (ice-9 textual-ports) + (rnrs base)) + + (setenv "PATH" (string-join + (list (string-append #+%tar-bootstrap "/bin") + (string-append #+dpkg "/bin") + (string-append #+%ar-bootstrap "/bin")) + ":")) + + ;; Validate the output of 'dpkg --info'. + (let* ((port (open-pipe* OPEN_READ "dpkg" "--info" #$deb)) + (info (get-string-all port)) + (exit-val (status:exit-val (close-pipe port)))) + (assert (zero? exit-val)) + + (assert (string-contains + info + (string-append "Package: " + #+(package-name %bootstrap-guile)))) + + (assert (string-contains + info + (string-append "Version: " + #+(package-version %bootstrap-guile))))) + + ;; Sanity check .deb contents. + (invoke "ar" "-xv" #$deb) + (assert (file-exists? "debian-binary")) + (assert (file-exists? "data.tar.gz")) + (assert (file-exists? "control.tar.gz")) + + ;; Verify there are no hard links in data.tar.gz, as hard + ;; links would cause dpkg to fail unpacking the archive. + (define hard-links + (let ((port (open-pipe* OPEN_READ "tar" "-tvf" "data.tar.gz"))) + (let loop ((hard-links '())) + (match (read-line port) + ((? eof-object?) + (assert (zero? (status:exit-val (close-pipe port)))) + hard-links) + (line + (if (string-prefix? "u" line) + (loop (cons line hard-links)) + (loop hard-links))))))) + + (unless (null? hard-links) + (error "hard links found in data.tar.gz" hard-links)) + + ;; Verify the presence of the control files. + (invoke "tar" "-xf" "control.tar.gz") + (assert (file-exists? "control")) + (assert (and (file-exists? "postinst") + (= #o111 ;script is executable + (logand #o111 (stat:perms + (stat "postinst")))))) + (assert (file-exists? "triggers")) + + (mkdir #$output)))))) (built-derivations (list check)))) (unless store (test-skip 1)) @@ -390,32 +390,33 @@ #: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)))))) + (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) |