diff options
Diffstat (limited to 'tests')
| -rw-r--r-- | tests/build-utils.scm | 49 | ||||
| -rw-r--r-- | tests/builders.scm | 123 | ||||
| -rw-r--r-- | tests/gexp.scm | 7 | ||||
| -rw-r--r-- | tests/gremlin.scm | 84 | ||||
| -rw-r--r-- | tests/lint.scm | 2 | ||||
| -rw-r--r-- | tests/packages.scm | 137 |
6 files changed, 369 insertions, 33 deletions
diff --git a/tests/build-utils.scm b/tests/build-utils.scm index 654b480ed9..6b131c0af8 100644 --- a/tests/build-utils.scm +++ b/tests/build-utils.scm @@ -1,6 +1,8 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2012, 2015, 2016, 2019, 2020 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2019 Ricardo Wurmus <rekado@elephly.net> +;;; Copyright © 2021 Maxim Cournoyer <maxim.cournoyer@gmail.com> +;;; Copyright © 2021 Maxime Devos <maximedevos@telenet.be> ;;; ;;; This file is part of GNU Guix. ;;; @@ -18,7 +20,7 @@ ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. -(define-module (test-build-utils) +(define-module (test build-utils) #:use-module (guix tests) #:use-module (guix build utils) #:use-module ((guix utils) @@ -241,4 +243,49 @@ print('hello world')")) "/some/other/path"))) #f))))) +(test-equal "substitute*, text contains a NUL byte, UTF-8" + "c\0d" + (with-fluids ((%default-port-encoding "UTF-8") + (%default-port-conversion-strategy 'error)) + ;; The GNU libc is locale sensitive. Depending on the value of LANG, the + ;; test could fail with "string contains #\\nul character: ~S" or "cannot + ;; convert wide string to output locale". + (setlocale LC_ALL "en_US.UTF-8") + (call-with-temporary-output-file + (lambda (file port) + (format port "a\0b") + (flush-output-port port) + + (substitute* file + (("a") "c") + (("b") "d")) + + (with-input-from-file file + (lambda _ + (get-string-all (current-input-port)))))))) + +(test-equal "search-input-file: exception if not found" + `((path) + (file . "does-not-exist")) + (guard (e ((search-error? e) + `((path . ,(search-error-path e)) + (file . ,(search-error-file e))))) + (search-input-file '() "does-not-exist"))) + +(test-equal "search-input-file: can find if existent" + (which "guile") + (search-input-file + `(("guile/bin" . ,(dirname (which "guile")))) + "guile")) + +(test-equal "search-input-file: can search in multiple directories" + (which "guile") + (call-with-temporary-directory + (lambda (directory) + (search-input-file + `(("irrelevant" . ,directory) + ("guile/bin" . ,(dirname (which "guile")))) + "guile")))) + + (test-end) diff --git a/tests/builders.scm b/tests/builders.scm index fdcf38ded3..f36a8c9f59 100644 --- a/tests/builders.scm +++ b/tests/builders.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013, 2014, 2015, 2019 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2012, 2013, 2014, 2015, 2018, 2019 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2021 Lars-Dominik Braun <lars@6xq.net> ;;; ;;; This file is part of GNU Guix. ;;; @@ -17,22 +18,26 @@ ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. -(define-module (test-builders) +(define-module (tests builders) #:use-module (guix download) #:use-module (guix build-system) #:use-module (guix build-system gnu) + #:use-module (guix build gnu-build-system) + #:use-module (guix build utils) + #:use-module (guix build-system python) #:use-module (guix store) + #:use-module (guix monads) #:use-module (guix utils) #:use-module (guix base32) #:use-module (guix derivations) #:use-module (gcrypt hash) #:use-module (guix tests) - #:use-module ((guix packages) - #:select (package? - package-derivation package-native-search-paths)) + #:use-module (guix packages) #:use-module (gnu packages bootstrap) #:use-module (ice-9 match) + #:use-module (ice-9 textual-ports) #:use-module (srfi srfi-1) + #:use-module (srfi srfi-11) #:use-module (srfi srfi-64)) ;; Test the higher-level builders. @@ -78,4 +83,112 @@ (test-assert "gnu-build-system" (build-system? gnu-build-system)) +(define unpack (assoc-ref %standard-phases 'unpack)) + +(define compressors '(("gzip" . "gz") + ("xz" . "xz") + ("bzip2" . "bz2") + (#f . #f))) + +(for-each + (match-lambda + ((comp . ext) + + (unless (network-reachable?) (test-skip 1)) ;for bootstrap binaries + (test-equal (string-append "gnu-build-system unpack phase, " + "single file (compression: " + (if comp comp "None") ")") + "expected text" + (let*-values + (((name) "test") + ((compressed-name) (if ext + (string-append name "." ext) + name)) + ((file hash) (test-file %store compressed-name "expected text"))) + (call-with-temporary-directory + (lambda (dir) + (with-directory-excursion dir + (unpack #:source file) + (call-with-input-file name get-string-all)))))))) + compressors) + + +;;; +;;; Test the sanity-check phase of the Python build system. +;;; + +(define* (make-python-dummy name #:key (setup-py-extra "") + (init-py "") (use-setuptools? #t)) + (dummy-package (string-append "python-dummy-" name) + (version "0.1") + (build-system python-build-system) + (arguments + `(#:tests? #f + #:use-setuptools? ,use-setuptools? + #:phases + (modify-phases %standard-phases + (replace 'unpack + (lambda _ + (mkdir-p "dummy") + (with-output-to-file "dummy/__init__.py" + (lambda _ + (display ,init-py))) + (with-output-to-file "setup.py" + (lambda _ + (format #t "\ +~a +setup( + name='dummy-~a', + version='0.1', + packages=['dummy'], + ~a + )" + (if ,use-setuptools? + "from setuptools import setup" + "from distutils.core import setup") + ,name ,setup-py-extra)))))))))) + +(define python-dummy-ok + (make-python-dummy "ok")) + +;; distutil won't install any metadata, so make sure our script does not fail +;; on a otherwise fine package. +(define python-dummy-no-setuptools + (make-python-dummy + "no-setuptools" #:use-setuptools? #f)) + +(define python-dummy-fail-requirements + (make-python-dummy "fail-requirements" + #:setup-py-extra "install_requires=['nonexistent'],")) + +(define python-dummy-fail-import + (make-python-dummy "fail-import" #:init-py "import nonexistent")) + +(define python-dummy-fail-console-script + (make-python-dummy "fail-console-script" + #:setup-py-extra (string-append "entry_points={'console_scripts': " + "['broken = dummy:nonexistent']},"))) + +(define (check-build-success store p) + (unless store (test-skip 1)) + (test-assert (string-append "python-build-system: " (package-name p)) + (let* ((drv (package-derivation store p))) + (build-derivations store (list drv))))) + +(define (check-build-failure store p) + (unless store (test-skip 1)) + (test-assert (string-append "python-build-system: " (package-name p)) + (not (false-if-exception (package-derivation store python-dummy-fail-requirements))))) + +(with-external-store store + (for-each (lambda (p) (check-build-success store p)) + (list + python-dummy-ok + python-dummy-no-setuptools)) + (for-each (lambda (p) (check-build-failure store p)) + (list + python-dummy-fail-requirements + python-dummy-fail-import + python-dummy-fail-console-script))) + (test-end "builders") diff --git a/tests/gexp.scm b/tests/gexp.scm index 834e78b9a0..64c3107ef7 100644 --- a/tests/gexp.scm +++ b/tests/gexp.scm @@ -96,6 +96,13 @@ (null? (gexp-inputs exp)) (gexp->sexp* exp)))) +(test-equal "sexp->gexp" + '(a b (c d) e) + (let ((exp (sexp->gexp '(a b (c d) e)))) + (and (gexp? exp) + (null? (gexp-inputs exp)) + (gexp->sexp* exp)))) + (test-equal "unquote" '(display `(foo ,(+ 2 3))) (let ((exp (gexp (display `(foo ,(+ 2 3)))))) diff --git a/tests/gremlin.scm b/tests/gremlin.scm index b0bb7a8e49..f20a79f4d6 100644 --- a/tests/gremlin.scm +++ b/tests/gremlin.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2015, 2018 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2015, 2018, 2020 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -23,9 +23,12 @@ #:use-module (guix build gremlin) #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) + #:use-module (srfi srfi-34) #:use-module (srfi srfi-64) #:use-module (rnrs io ports) #:use-module (ice-9 popen) + #:use-module (ice-9 rdelim) + #:use-module (ice-9 regex) #:use-module (ice-9 match)) (define %guile-executable @@ -57,6 +60,40 @@ (string-take lib (string-contains lib ".so"))) (elf-dynamic-info-needed dyninfo)))))) +(unless (and %guile-executable (not (getenv "LD_LIBRARY_PATH")) + (file-needed %guile-executable)) ;statically linked? + (test-skip 1)) +(test-assert "file-needed/recursive" + (let* ((needed (file-needed/recursive %guile-executable)) + (pipe (dynamic-wind + (lambda () + ;; Tell ld.so to list loaded objects, like 'ldd' does. + (setenv "LD_TRACE_LOADED_OBJECTS" "yup")) + (lambda () + (open-pipe* OPEN_READ %guile-executable)) + (lambda () + (unsetenv "LD_TRACE_LOADED_OBJECTS"))))) + (define ldd-rx + (make-regexp "^[[:blank:]]+([[:graph:]]+ => )?([[:graph:]]+) .*$")) + + (define (read-ldd-output port) + ;; Read from PORT output in GNU ldd format. + (let loop ((result '())) + (match (read-line port) + ((? eof-object?) + (reverse result)) + ((= (cut regexp-exec ldd-rx <>) m) + (if m + (loop (cons (match:substring m 2) result)) + (loop result)))))) + + (define ground-truth + (remove (cut string-prefix? "linux-vdso.so" <>) + (read-ldd-output pipe))) + + (and (zero? (close-pipe pipe)) + (lset= string=? (pk 'truth ground-truth) (pk 'needed needed))))) + (test-equal "expand-origin" '("OOO/../lib" "OOO" @@ -96,4 +133,49 @@ (close-pipe pipe) str))))))) +(unless c-compiler + (test-skip 1)) +(test-equal "set-file-runpath + file-runpath" + "hello\n" + (call-with-temporary-directory + (lambda (directory) + (with-directory-excursion directory + (call-with-output-file "t.c" + (lambda (port) + (display "int main () { puts(\"hello\"); }" port))) + + (invoke c-compiler "t.c" + "-Wl,--enable-new-dtags" "-Wl,-rpath=/xxxxxxxxx") + + (let ((original-runpath (file-runpath "a.out"))) + (and (member "/xxxxxxxxx" original-runpath) + (guard (c ((runpath-too-long-error? c) + (string=? "a.out" (runpath-too-long-error-file c)))) + (set-file-runpath "a.out" (list (make-string 777 #\y)))) + (let ((runpath (delete "/xxxxxxxxx" original-runpath))) + (set-file-runpath "a.out" runpath) + (equal? runpath (file-runpath "a.out"))) + (let* ((pipe (open-input-pipe "./a.out")) + (str (get-string-all pipe))) + (close-pipe pipe) + str))))))) + +(unless c-compiler + (test-skip 1)) +(test-equal "elf-dynamic-info-soname" + "libfoo.so.2" + (call-with-temporary-directory + (lambda (directory) + (with-directory-excursion directory + (call-with-output-file "t.c" + (lambda (port) + (display "// empty file" port))) + (invoke c-compiler "t.c" + "-shared" "-Wl,-soname,libfoo.so.2") + (let* ((dyninfo (elf-dynamic-info + (parse-elf (call-with-input-file "a.out" + get-bytevector-all)))) + (soname (elf-dynamic-info-soname dyninfo))) + soname))))) + (test-end "gremlin") diff --git a/tests/lint.scm b/tests/lint.scm index fae346e724..6222c3b15a 100644 --- a/tests/lint.scm +++ b/tests/lint.scm @@ -476,7 +476,7 @@ (single-lint-warning-message (check-patch-headers pkg))))) (test-equal "derivation: invalid arguments" - "failed to create x86_64-linux derivation: (wrong-type-arg \"map\" \"Wrong type argument: ~S\" (invalid-module) ())" + "failed to create x86_64-linux derivation: (match-error \"match\" \"no matching pattern\" invalid-module)" (match (let ((pkg (dummy-package "x" (arguments '(#:imported-modules (invalid-module)))))) diff --git a/tests/packages.scm b/tests/packages.scm index 2a290bc353..47d10af5bc 100644 --- a/tests/packages.scm +++ b/tests/packages.scm @@ -1,6 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org> -;;; Copyright © Jan (janneke) Nieuwenhuizen <janneke@gnu.org> +;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org> +;;; Copyright © 2021 Maxim Cournoyer <maxim.cournoyer@gmail.com> ;;; ;;; This file is part of GNU Guix. ;;; @@ -17,13 +18,14 @@ ;;; 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-packages) +(define-module (tests packages) #:use-module (guix tests) #:use-module (guix store) #:use-module (guix monads) #:use-module (guix grafts) - #:use-module ((guix gexp) #:select (local-file local-file-file)) + #:use-module (guix gexp) #:use-module (guix utils) + #:use-module ((guix build utils) #:select (tarball?)) #:use-module ((guix diagnostics) ;; Rename the 'location' binding to allow proper syntax ;; matching when setting the 'location' field of a package. @@ -32,6 +34,7 @@ (else name)))) #:use-module ((gcrypt hash) #:prefix gcrypt:) #:use-module (guix derivations) + #:use-module (guix download) #:use-module (guix packages) #:use-module (guix grafts) #:use-module (guix search-paths) @@ -51,6 +54,7 @@ #:use-module (gnu packages version-control) #:use-module (gnu packages xml) #:use-module (srfi srfi-1) + #:use-module (srfi srfi-11) #:use-module (srfi srfi-26) #:use-module (srfi srfi-34) #:use-module (srfi srfi-35) @@ -578,6 +582,11 @@ (build-derivations %store (list drv)) (call-with-input-file output get-string-all))) + +;;; +;;; Source derivation with snippets. +;;; + (unless (network-reachable?) (test-skip 1)) (test-equal "package-source-derivation, snippet" "OK" @@ -633,11 +642,81 @@ (and (build-derivations %store (list (pk 'snippet-drv drv))) (call-with-input-file out get-string-all)))) +;; Note: lzip is not part of bootstrap-coreutils&co, so is not included to +;; avoid having to rebuild the world. +(define compressors '(("gzip" . "gz") + ("xz" . "xz") + ("bzip2" . "bz2") + (#f . #f))) + +(for-each + (match-lambda + ((comp . ext) + (unless (network-reachable?) (test-skip 1)) + (test-equal (string-append "origin->derivation, single file with snippet " + "(compression: " (if comp comp "None") ")") + "2 + 2 = 4" + (let*-values + (((name) "maths") + ((compressed-name) (if comp + (string-append name "." ext) + name)) + ((file hash) (test-file %store compressed-name "2 + 2 = 5")) + ;; Create an origin using the above computed file and its hash. + ((source) (origin + (method url-fetch) + (uri (string-append "file://" file)) + (file-name compressed-name) + (patch-inputs `(("tar" ,%bootstrap-coreutils&co) + ("xz" ,%bootstrap-coreutils&co) + ("bzip2" ,%bootstrap-coreutils&co) + ("gzip" ,%bootstrap-coreutils&co))) + (patch-guile %bootstrap-guile) + (modules '((guix build utils))) + (snippet `(substitute* ,name + (("5") "4"))) + (hash (content-hash hash)))) + ;; Build origin. + ((drv) (run-with-store %store (origin->derivation source))) + ((out) (derivation->output-path drv))) + ;; Decompress the resulting tar.xz and return its content. + (and (build-derivations %store (list drv)) + (if (tarball? out) + (let* ((bin #~(string-append #+%bootstrap-coreutils&co + "/bin")) + (f (computed-file + name + (with-imported-modules '((guix build utils)) + #~(begin + (use-modules (guix build utils)) + (setenv "PATH" #+bin) + (invoke "tar" "xvf" #+out) + (copy-file #+name #$output))))) + (drv (run-with-store %store (lower-object f))) + (_ (build-derivations %store (list drv)))) + (call-with-input-file (derivation->output-path drv) + get-string-all)) + (call-with-input-file out get-string-all))))))) + compressors) + (test-assert "return value" (let ((drv (package-derivation %store (dummy-package "p")))) (and (derivation? drv) (file-exists? (derivation-file-name drv))))) +(test-assert "package-derivation, inputs deduplicated" + (let* ((dep (dummy-package "dep")) + (p0 (dummy-package "p" (inputs `(("dep" ,dep))))) + (p1 (package (inherit p0) + (inputs `(("dep" ,(package (inherit dep))) + ,@(package-inputs p0)))))) + ;; Here P1 ends up with two non-eq? copies of DEP, under the same label. + ;; They should be deduplicated so that P0 and P1 lead to the same + ;; derivation rather than P1 ending up with duplicate entries in its + ;; '%build-inputs' variable. + (string=? (derivation-file-name (package-derivation %store p0)) + (derivation-file-name (package-derivation %store p1))))) + (test-assert "package-output" (let* ((package (dummy-package "p")) (drv (package-derivation %store package))) @@ -665,7 +744,7 @@ (let ((dummy (dummy-package "foo" (inputs `(("x" ,(current-module))))))) (test-equal "&package-input-error" - (list dummy (current-module)) + (list dummy `("x" ,(current-module))) (guard (c ((package-input-error? c) (list (package-error-package c) (package-error-invalid-input c)))) @@ -779,19 +858,23 @@ (test-assert "search paths" (let* ((p (make-prompt-tag "return-search-paths")) + (t (make-parameter "guile-0")) (s (build-system - (name 'raw) - (description "Raw build system with direct store access") - (lower (lambda* (name #:key source inputs system target - #:allow-other-keys) - (bag - (name name) - (system system) (target target) - (build-inputs inputs) - (build - (lambda* (store name inputs + (name 'raw) + (description "Raw build system with direct store access") + (lower (lambda* (name #:key source inputs system target + #:allow-other-keys) + (bag + (name name) + (system system) (target target) + (build-inputs inputs) + (build + (lambda* (name inputs #:key outputs system search-paths) - search-paths))))))) + (if (string=? name (t)) + (abort-to-prompt p search-paths) + (gexp->derivation name + #~(mkdir #$output)))))))))) (x (list (search-path-specification (variable "GUILE_LOAD_PATH") (files '("share/guile/site/2.0"))) @@ -816,8 +899,10 @@ (lambda (k search-paths) search-paths)))))) (and (null? (collect (package-derivation %store a))) - (equal? x (collect (package-derivation %store b))) - (equal? x (collect (package-derivation %store c))))))) + (parameterize ((t "guile-foo-0")) + (equal? x (collect (package-derivation %store b)))) + (parameterize ((t "guile-bar-0")) + (equal? x (collect (package-derivation %store c)))))))) (test-assert "package-transitive-native-search-paths" (let* ((sp (lambda (name) @@ -1091,11 +1176,11 @@ (bag (name name) (system system) (target target) (build-inputs native-inputs) (host-inputs inputs) - (build (lambda* (store name inputs - #:key system target - #:allow-other-keys) - (build-expression->derivation - store "foo" '(mkdir %output)))))))) + (build (lambda* (name inputs + #:key system target + #:allow-other-keys) + (gexp->derivation "foo" + #~(mkdir #$output)))))))) (bs (build-system (name 'build-system-without-cross-compilation) (description "Does not support cross compilation.") @@ -1164,12 +1249,13 @@ (parameterize ((%current-target-system #f)) (bag-transitive-inputs bag))))) -(test-assert "bag->derivation" +(test-assertm "bag->derivation" (parameterize ((%graft? #f)) (let ((bag (package->bag gnu-make)) (drv (package-derivation %store gnu-make))) (parameterize ((%current-system "foox86-hurd")) ;should have no effect - (equal? drv (bag->derivation %store bag)))))) + (mlet %store-monad ((bag-drv (bag->derivation bag))) + (return (equal? drv bag-drv))))))) (test-assert "bag->derivation, cross-compilation" (parameterize ((%graft? #f)) @@ -1178,7 +1264,8 @@ (drv (package-cross-derivation %store gnu-make target))) (parameterize ((%current-system "foox86-hurd") ;should have no effect (%current-target-system "foo64-linux-gnu")) - (equal? drv (bag->derivation %store bag)))))) + (mlet %store-monad ((bag-drv (bag->derivation bag))) + (return (equal? drv bag-drv))))))) (when (or (not (network-reachable?)) (shebang-too-long?)) (test-skip 1)) |