diff options
Diffstat (limited to 'tests')
| -rw-r--r-- | tests/derivations.scm | 22 | ||||
| -rw-r--r-- | tests/gexp.scm | 72 | ||||
| -rw-r--r-- | tests/lint.scm | 110 | ||||
| -rw-r--r-- | tests/profiles.scm | 37 |
4 files changed, 241 insertions, 0 deletions
diff --git a/tests/derivations.scm b/tests/derivations.scm index 19bcebcb21..855b059d16 100644 --- a/tests/derivations.scm +++ b/tests/derivations.scm @@ -151,6 +151,28 @@ ;; the contents. (valid-path? %store (derivation->output-path drv))))) +(test-assert "identical files are deduplicated" + (let* ((build1 (add-text-to-store %store "one.sh" + "echo hello, world > \"$out\"\n" + '())) + (build2 (add-text-to-store %store "two.sh" + "# Hey!\necho hello, world > \"$out\"\n" + '())) + (drv1 (derivation %store "foo" + %bash `(,build1) + #:inputs `((,%bash) (,build1)))) + (drv2 (derivation %store "bar" + %bash `(,build2) + #:inputs `((,%bash) (,build2))))) + (and (build-derivations %store (list drv1 drv2)) + (let ((file1 (derivation->output-path drv1)) + (file2 (derivation->output-path drv2))) + (and (valid-path? %store file1) (valid-path? %store file2) + (string=? (call-with-input-file file1 get-string-all) + "hello, world\n") + (= (stat:ino (lstat file1)) + (stat:ino (lstat file2)))))))) + (test-assert "fixed-output-derivation?" (let* ((builder (add-text-to-store %store "my-fixed-builder.sh" "echo -n hello > $out" '())) diff --git a/tests/gexp.scm b/tests/gexp.scm index bf52401c66..ea4df48403 100644 --- a/tests/gexp.scm +++ b/tests/gexp.scm @@ -324,6 +324,78 @@ (return (string=? (derivation-file-name drv) (derivation-file-name xdrv))))) +(test-assertm "gexp->derivation, store copy" + (let ((build-one #~(call-with-output-file #$output + (lambda (port) + (display "This is the one." port)))) + (build-two (lambda (one) + #~(begin + (mkdir #$output) + (symlink #$one (string-append #$output "/one")) + (call-with-output-file (string-append #$output "/two") + (lambda (port) + (display "This is the second one." port)))))) + (build-drv #~(begin + (use-modules (guix build store-copy)) + + (mkdir #$output) + (populate-store '("graph") #$output)))) + (mlet* %store-monad ((one (gexp->derivation "one" build-one)) + (two (gexp->derivation "two" (build-two one))) + (drv (gexp->derivation "store-copy" build-drv + #:references-graphs + `(("graph" ,two)) + #:modules + '((guix build store-copy) + (guix build utils)))) + (ok? (built-derivations (list drv))) + (out -> (derivation->output-path drv))) + (let ((one (derivation->output-path one)) + (two (derivation->output-path two))) + (return (and ok? + (file-exists? (string-append out "/" one)) + (file-exists? (string-append out "/" two)) + (file-exists? (string-append out "/" two "/two")) + (string=? (readlink (string-append out "/" two "/one")) + one))))))) + +(test-assertm "gexp->derivation #:references-graphs" + (mlet* %store-monad + ((one (text-file "one" "hello, world")) + (two (gexp->derivation "two" + #~(symlink #$one #$output:chbouib))) + (drv (gexp->derivation "ref-graphs" + #~(begin + (use-modules (guix build store-copy)) + (with-output-to-file #$output + (lambda () + (write (call-with-input-file "guile" + read-reference-graph)))) + (with-output-to-file #$output:one + (lambda () + (write (call-with-input-file "one" + read-reference-graph)))) + (with-output-to-file #$output:two + (lambda () + (write (call-with-input-file "two" + read-reference-graph))))) + #:references-graphs `(("one" ,one) + ("two" ,two "chbouib") + ("guile" ,%bootstrap-guile)) + #:modules '((guix build store-copy) + (guix build utils)))) + (ok? (built-derivations (list drv))) + (guile-drv (package->derivation %bootstrap-guile)) + (g-one -> (derivation->output-path drv "one")) + (g-two -> (derivation->output-path drv "two")) + (g-guile -> (derivation->output-path drv))) + (return (and ok? + (equal? (call-with-input-file g-one read) (list one)) + (equal? (call-with-input-file g-two read) + (list one (derivation->output-path two "chbouib"))) + (equal? (call-with-input-file g-guile read) + (list (derivation->output-path guile-drv))))))) + (define shebang (string-append "#!" (derivation->output-path (%guile-for-build)) "/bin/guile --no-auto-compile")) diff --git a/tests/lint.scm b/tests/lint.scm new file mode 100644 index 0000000000..56558c904f --- /dev/null +++ b/tests/lint.scm @@ -0,0 +1,110 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2012, 2013 Cyril Roelandt <tipecaml@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-packages) + #:use-module (guix build download) + #:use-module (guix build-system gnu) + #:use-module (guix packages) + #:use-module (guix scripts lint) + #:use-module (guix ui) + #:use-module (gnu packages) + #:use-module (gnu packages pkg-config) + #:use-module (srfi srfi-64)) + +;; Test the linter. + + +(test-begin "lint") + +(define-syntax-rule (dummy-package name* extra-fields ...) + (package extra-fields ... (name name*) (version "0") (source #f) + (build-system gnu-build-system) + (synopsis #f) (description #f) + (home-page #f) (license #f) )) + +(define (call-with-warnings thunk) + (let ((port (open-output-string))) + (parameterize ((guix-warning-port port)) + (thunk)) + (get-output-string port))) + +(test-assert "synopsis: ends with a period" + (->bool + (string-contains (call-with-warnings + (lambda () + (let ((pkg (dummy-package "x" + (synopsis "Bad synopsis.")))) + (check-synopsis-style pkg)))) + "no period allowed at the end of the synopsis"))) + +(test-assert "synopsis: ends with 'etc.'" + (->bool + (string-null? (call-with-warnings + (lambda () + (let ((pkg (dummy-package "x" + (synopsis "Foo, bar, etc.")))) + (check-synopsis-style pkg))))))) + +(test-assert "synopsis: starts with 'A'" + (->bool + (string-contains (call-with-warnings + (lambda () + (let ((pkg (dummy-package "x" + (synopsis "A bad synopŝis")))) + (check-synopsis-style pkg)))) + "no article allowed at the beginning of the synopsis"))) + +(test-assert "synopsis: starts with 'An'" + (->bool + (string-contains (call-with-warnings + (lambda () + (let ((pkg (dummy-package "x" + (synopsis "An awful synopsis")))) + (check-synopsis-style pkg)))) + "no article allowed at the beginning of the synopsis"))) + +(test-assert "inputs: pkg-config is probably a native input" + (->bool + (string-contains + (call-with-warnings + (lambda () + (let ((pkg (dummy-package "x" + (inputs `(("pkg-config" ,pkg-config)))))) + (check-inputs-should-be-native pkg)))) + "pkg-config should probably be a native input"))) + +(test-assert "patches: file names" + (->bool + (string-contains + (call-with-warnings + (lambda () + (let ((pkg (dummy-package "x" + (source + (origin + (method url-fetch) + (uri "someurl") + (sha256 "somesha") + (patches (list "/path/to/y.patch"))))))) + (check-patches pkg)))) + "file names of patches should start with the package name"))) + +(test-end "lint") + + +(exit (= (test-runner-fail-count (test-runner-current)) 0)) diff --git a/tests/profiles.scm b/tests/profiles.scm index 047c5ba49b..99f1fd2763 100644 --- a/tests/profiles.scm +++ b/tests/profiles.scm @@ -26,6 +26,8 @@ #:use-module (guix derivations) #:use-module (gnu packages bootstrap) #:use-module (ice-9 match) + #:use-module (ice-9 regex) + #:use-module (srfi srfi-11) #:use-module (srfi srfi-64)) ;; Test the (guix profiles) module. @@ -53,6 +55,13 @@ (manifest-entry (inherit guile-2.0.9) (output "debug"))) +(define glibc + (manifest-entry + (name "glibc") + (version "2.19") + (item "/gnu/store/...") + (output "out"))) + (test-begin "profiles") @@ -136,6 +145,34 @@ (equal? m1 m2) (null? (manifest-entries m3))))) +(test-assert "manifest-transaction-effects" + (let* ((m0 (manifest (list guile-1.8.8))) + (t (manifest-transaction + (install (list guile-2.0.9 glibc)) + (remove (list (manifest-pattern (name "coreutils"))))))) + (let-values (((remove install upgrade) + (manifest-transaction-effects m0 t))) + (and (null? remove) + (equal? (list glibc) install) + (equal? (list (cons guile-1.8.8 guile-2.0.9)) upgrade))))) + +(test-assert "manifest-show-transaction" + (let* ((m (manifest (list guile-1.8.8))) + (t (manifest-transaction (install (list guile-2.0.9))))) + (let-values (((remove install upgrade) + (manifest-transaction-effects m t))) + (with-store store + (and (string-match "guile\t1.8.8 → 2.0.9" + (with-fluids ((%default-port-encoding "UTF-8")) + (with-error-to-string + (lambda () + (manifest-show-transaction store m t))))) + (string-match "guile\t1.8.8 -> 2.0.9" + (with-fluids ((%default-port-encoding "ISO-8859-1")) + (with-error-to-string + (lambda () + (manifest-show-transaction store m t)))))))))) + (test-assert "profile-derivation" (run-with-store %store (mlet* %store-monad |