diff options
Diffstat (limited to 'tests')
| -rw-r--r-- | tests/derivations.scm | 34 | ||||
| -rw-r--r-- | tests/grafts.scm | 81 | ||||
| -rw-r--r-- | tests/packages.scm | 3 |
3 files changed, 83 insertions, 35 deletions
diff --git a/tests/derivations.scm b/tests/derivations.scm index db96e26ab1..9b53019cc5 100644 --- a/tests/derivations.scm +++ b/tests/derivations.scm @@ -929,40 +929,6 @@ ((p2 . _) (string<? p1 p2))))))))))))) - -(test-assert "graft-derivation" - (let* ((build `(begin - (mkdir %output) - (chdir %output) - (symlink %output "self") - (call-with-output-file "text" - (lambda (output) - (format output "foo/~a/bar" ,%mkdir))) - (symlink ,%bash "sh"))) - (orig (build-expression->derivation %store "graft" build - #:inputs `(("a" ,%bash) - ("b" ,%mkdir)))) - (one (add-text-to-store %store "bash" "fake bash")) - (two (build-expression->derivation %store "mkdir" - '(call-with-output-file %output - (lambda (port) - (display "fake mkdir" port))))) - (graft (graft-derivation %store "graft" orig - (list (graft - (origin %bash) - (replacement one)) - (graft - (origin %mkdir) - (replacement two)))))) - (and (build-derivations %store (list graft)) - (let ((two (derivation->output-path two)) - (graft (derivation->output-path graft))) - (and (string=? (format #f "foo/~a/bar" two) - (call-with-input-file (string-append graft "/text") - get-string-all)) - (string=? (readlink (string-append graft "/sh")) one) - (string=? (readlink (string-append graft "/self")) graft)))))) - (test-equal "map-derivation" "hello" (let* ((joke (package-derivation %store guile-1.8)) diff --git a/tests/grafts.scm b/tests/grafts.scm new file mode 100644 index 0000000000..c11403be19 --- /dev/null +++ b/tests/grafts.scm @@ -0,0 +1,81 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2014, 2015, 2016 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-grafts) + #:use-module (guix derivations) + #:use-module (guix store) + #:use-module (guix utils) + #:use-module (guix grafts) + #:use-module (guix tests) + #:use-module ((gnu packages) #:select (search-bootstrap-binary)) + #:use-module (srfi srfi-64) + #:use-module (rnrs io ports)) + +(define %store + (open-connection-for-tests)) + +(define (bootstrap-binary name) + (let ((bin (search-bootstrap-binary name (%current-system)))) + (and %store + (add-to-store %store name #t "sha256" bin)))) + +(define %bash + (bootstrap-binary "bash")) +(define %mkdir + (bootstrap-binary "mkdir")) + + +(test-begin "grafts") + +(test-assert "graft-derivation" + (let* ((build `(begin + (mkdir %output) + (chdir %output) + (symlink %output "self") + (call-with-output-file "text" + (lambda (output) + (format output "foo/~a/bar" ,%mkdir))) + (symlink ,%bash "sh"))) + (orig (build-expression->derivation %store "graft" build + #:inputs `(("a" ,%bash) + ("b" ,%mkdir)))) + (one (add-text-to-store %store "bash" "fake bash")) + (two (build-expression->derivation %store "mkdir" + '(call-with-output-file %output + (lambda (port) + (display "fake mkdir" port))))) + (graft (graft-derivation %store "graft" orig + (list (graft + (origin %bash) + (replacement one)) + (graft + (origin %mkdir) + (replacement two)))))) + (and (build-derivations %store (list graft)) + (let ((two (derivation->output-path two)) + (graft (derivation->output-path graft))) + (and (string=? (format #f "foo/~a/bar" two) + (call-with-input-file (string-append graft "/text") + get-string-all)) + (string=? (readlink (string-append graft "/sh")) one) + (string=? (readlink (string-append graft "/self")) graft)))))) + +(test-end) + + +(exit (= (test-runner-fail-count (test-runner-current)) 0)) diff --git a/tests/packages.scm b/tests/packages.scm index 9d37fb68d6..68ab3f897b 100644 --- a/tests/packages.scm +++ b/tests/packages.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2012, 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -29,6 +29,7 @@ #:use-module (guix hash) #:use-module (guix derivations) #:use-module (guix packages) + #:use-module (guix grafts) #:use-module (guix search-paths) #:use-module (guix build-system) #:use-module (guix build-system trivial) |