diff options
Diffstat (limited to 'tests')
| -rw-r--r-- | tests/gexp.scm | 56 | ||||
| -rw-r--r-- | tests/guix-package.sh | 12 | ||||
| -rw-r--r-- | tests/hackage.scm | 71 | ||||
| -rw-r--r-- | tests/inferior.scm | 69 |
4 files changed, 180 insertions, 28 deletions
diff --git a/tests/gexp.scm b/tests/gexp.scm index 83fe811546..391a0f8be5 100644 --- a/tests/gexp.scm +++ b/tests/gexp.scm @@ -948,7 +948,7 @@ (return (and (zero? (close-pipe pipe)) (= (expt n 2) (string->number str))))))) -(test-assertm "gexp->script #:module-path" +(test-assert "gexp->script #:module-path" (call-with-temporary-directory (lambda (directory) (define str @@ -961,23 +961,24 @@ (define-public %fake! ,str)) port))) - (mlet* %store-monad ((exp -> (with-imported-modules '((guix base32)) - (gexp (begin - (use-modules (guix base32)) - (write (list %load-path - %fake!)))))) - (drv (gexp->script "guile-thing" exp - #:guile %bootstrap-guile - #:module-path (list directory))) - (out -> (derivation->output-path drv)) - (done (built-derivations (list drv)))) - (let* ((pipe (open-input-pipe out)) - (data (read pipe))) - (return (and (zero? (close-pipe pipe)) - (match data - ((load-path str*) - (and (string=? str* str) - (not (member directory load-path)))))))))))) + (run-with-store %store + (mlet* %store-monad ((exp -> (with-imported-modules '((guix base32)) + (gexp (begin + (use-modules (guix base32)) + (write (list %load-path + %fake!)))))) + (drv (gexp->script "guile-thing" exp + #:guile %bootstrap-guile + #:module-path (list directory))) + (out -> (derivation->output-path drv)) + (done (built-derivations (list drv)))) + (let* ((pipe (open-input-pipe out)) + (data (read pipe))) + (return (and (zero? (close-pipe pipe)) + (match data + ((load-path str*) + (and (string=? str* str) + (not (member directory load-path))))))))))))) (test-assertm "program-file" (let* ((n (random (expt 2 50))) @@ -996,7 +997,7 @@ (return (and (zero? (close-pipe pipe)) (= n (string->number str))))))))) -(test-assertm "program-file #:module-path" +(test-assert "program-file #:module-path" (call-with-temporary-directory (lambda (directory) (define text (random-text)) @@ -1014,14 +1015,15 @@ (file (program-file "program" exp #:guile %bootstrap-guile #:module-path (list directory)))) - (mlet* %store-monad ((drv (lower-object file)) - (out -> (derivation->output-path drv))) - (mbegin %store-monad - (built-derivations (list drv)) - (let* ((pipe (open-input-pipe out)) - (str (get-string-all pipe))) - (return (and (zero? (close-pipe pipe)) - (string=? text str)))))))))) + (run-with-store %store + (mlet* %store-monad ((drv (lower-object file)) + (out -> (derivation->output-path drv))) + (mbegin %store-monad + (built-derivations (list drv)) + (let* ((pipe (open-input-pipe out)) + (str (get-string-all pipe))) + (return (and (zero? (close-pipe pipe)) + (string=? text str))))))))))) (test-assertm "program-file & with-extensions" (let* ((exp (with-extensions (list %extension-package) diff --git a/tests/guix-package.sh b/tests/guix-package.sh index 3b3fa35cd8..cef3b3452e 100644 --- a/tests/guix-package.sh +++ b/tests/guix-package.sh @@ -185,6 +185,16 @@ grep -E 'emacs[[:blank:]]+42\.5\.9rc7[[:blank:]]+.*-emacs-42.5.9rc7' \ rm "$emacs_tarball" "$tmpfile" rmdir "$module_dir" +# Profiles with a relative file name. Make sure we don't create dangling +# symlinks--see bug report at +# <https://lists.gnu.org/archive/html/guix-devel/2018-07/msg00036.html>. +mkdir -p "$module_dir/foo" +( cd "$module_dir" ; \ + guix package --bootstrap -i guile-bootstrap -p foo/prof ) +test -f "$module_dir/foo/prof/bin/guile" +rm "$module_dir/foo"/* +rmdir "$module_dir/foo" +rmdir "$module_dir" # # Try with the default profile. @@ -215,7 +225,7 @@ do guix package --bootstrap --roll-back ! test -f "$HOME/.guix-profile/bin" ! test -f "$HOME/.guix-profile/lib" - test "`readlink "$default_profile"`" = "$default_profile-0-link" + test "`readlink "$default_profile"`" = "`basename $default_profile-0-link`" done # Check whether '-p ~/.guix-profile' makes any difference. diff --git a/tests/hackage.scm b/tests/hackage.scm index a4de8be91e..e17851a213 100644 --- a/tests/hackage.scm +++ b/tests/hackage.scm @@ -69,6 +69,65 @@ library mtl >= 2.0 && < 3 ") +;; Check "-any", "-none" when name is different. +(define test-cabal-4 + "name: foo +version: 1.0.0 +homepage: http://test.org +synopsis: synopsis +description: description +license: BSD3 +library + if impl(ghcjs -any) + Build-depends: ghc-a + if impl(ghc>=7.2&&<7.6) + Build-depends: ghc-b + if impl(ghc == 7.8) + Build-depends: + HTTP >= 4000.2.5 && < 4000.3, + mtl >= 2.0 && < 3 +") + +;; Check "-any", "-none". +(define test-cabal-5 + "name: foo +version: 1.0.0 +homepage: http://test.org +synopsis: synopsis +description: description +license: BSD3 +library + if impl(ghc == 7.8) + Build-depends: + HTTP >= 4000.2.5 && < 4000.3, + if impl(ghc -any) + Build-depends: mtl >= 2.0 && < 3 + if impl(ghc>=7.2&&<7.6) + Build-depends: ghc-b +") + +;; Check "custom-setup". +(define test-cabal-6 + "name: foo +build-type: Custom +version: 1.0.0 +homepage: http://test.org +synopsis: synopsis +description: description +license: BSD3 +custom-setup + setup-depends: base >= 4.7 && < 5, + Cabal >= 1.24, + haskell-gi == 0.21.* +library + if impl(ghc>=7.2&&<7.6) + Build-depends: ghc-b + if impl(ghc == 7.8) + Build-depends: + HTTP >= 4000.2.5 && < 4000.3, + mtl >= 2.0 && < 3 +") + ;; A fragment of a real Cabal file with minor modification to check precedence ;; of 'and' over 'or', missing final newline, spaces between keywords and ;; parentheses and between key and column. @@ -139,6 +198,18 @@ library (eval-test-with-cabal test-cabal-3 #:cabal-environment '(("impl" . "ghc-7.8")))) +(test-assert "hackage->guix-package test 4" + (eval-test-with-cabal test-cabal-4 + #:cabal-environment '(("impl" . "ghc-7.8")))) + +(test-assert "hackage->guix-package test 5" + (eval-test-with-cabal test-cabal-5 + #:cabal-environment '(("impl" . "ghc-7.8")))) + +(test-assert "hackage->guix-package test 6" + (eval-test-with-cabal test-cabal-6 + #:cabal-environment '(("impl" . "ghc-7.8")))) + (test-assert "read-cabal test 1" (match (call-with-input-string test-read-cabal-1 read-cabal) ((("name" ("test-me")) diff --git a/tests/inferior.scm b/tests/inferior.scm new file mode 100644 index 0000000000..5e0f8ae66e --- /dev/null +++ b/tests/inferior.scm @@ -0,0 +1,69 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2018 Ludovic Courtès <ludo@gnu.org> +;;; +;;; 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-inferior) + #:use-module (guix inferior) + #:use-module (guix packages) + #:use-module (gnu packages) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-64)) + +(define %top-srcdir + (dirname (search-path %load-path "guix.scm"))) + +(define %top-builddir + (dirname (search-path %load-compiled-path "guix.go"))) + + +(test-begin "inferior") + +(test-equal "open-inferior" + '(42 #t) + (let ((inferior (open-inferior %top-builddir + #:command "scripts/guix"))) + (and (inferior? inferior) + (let ((a (inferior-eval '(apply * '(6 7)) inferior)) + (b (inferior-eval '(@ (gnu packages base) coreutils) + inferior))) + (close-inferior inferior) + (list a (inferior-object? b)))))) + +(test-equal "inferior-packages" + (take (sort (fold-packages (lambda (package lst) + (alist-cons (package-name package) + (package-version package) + lst)) + '()) + (lambda (x y) + (string<? (car x) (car y)))) + 10) + (let* ((inferior (open-inferior %top-builddir + #:command "scripts/guix")) + (packages (inferior-packages inferior))) + (and (every string? (map inferior-package-synopsis packages)) + (begin + (close-inferior inferior) + (take (sort (map (lambda (package) + (cons (inferior-package-name package) + (inferior-package-version package))) + packages) + (lambda (x y) + (string<? (car x) (car y)))) + 10))))) + +(test-end "inferior") |