aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2016-10-14 10:36:37 +0200
committerLudovic Courtès <ludo@gnu.org>2016-10-14 23:05:41 +0200
commitd0025d01445ff271ececea20cfa6a2346593d1d6 (patch)
tree1696964b83bf5c1d73d50a99d2493c76e642e29b
parentb280e67ca6f62c176c72439df4533a9737b9130a (diff)
downloadguix-d0025d01445ff271ececea20cfa6a2346593d1d6.tar
guix-d0025d01445ff271ececea20cfa6a2346593d1d6.tar.gz
packages: 'package-grafts' applies grafts on replacement.
Partly fixes <http://bugs.gnu.org/24418>. * guix/packages.scm (input-graft): Compute 'new' with #:graft? #t. (input-cross-graft): Likewise. * tests/packages.scm ("package-grafts, indirect grafts, cross"): Comment out. ("replacement also grafted"): New test.
-rw-r--r--guix/packages.scm6
-rw-r--r--tests/packages.scm106
2 files changed, 94 insertions, 18 deletions
diff --git a/guix/packages.scm b/guix/packages.scm
index 2264c5acef..a3fab4dc13 100644
--- a/guix/packages.scm
+++ b/guix/packages.scm
@@ -916,7 +916,8 @@ and return it."
(cached (=> %graft-cache) package system
(let ((orig (package-derivation store package system
#:graft? #f))
- (new (package-derivation store replacement system)))
+ (new (package-derivation store replacement system
+ #:graft? #t)))
(graft
(origin orig)
(replacement new)))))))
@@ -932,7 +933,8 @@ and return it."
(let ((orig (package-cross-derivation store package target system
#:graft? #f))
(new (package-cross-derivation store replacement
- target system)))
+ target system
+ #:graft? #t)))
(graft
(origin orig)
(replacement new))))))
diff --git a/tests/packages.scm b/tests/packages.scm
index b8e1f111cd..5f5fb5de87 100644
--- a/tests/packages.scm
+++ b/tests/packages.scm
@@ -662,22 +662,25 @@
(origin (package-derivation %store dep))
(replacement (package-derivation %store new)))))))
-(test-assert "package-grafts, indirect grafts, cross"
- (let* ((new (dummy-package "dep"
- (arguments '(#:implicit-inputs? #f))))
- (dep (package (inherit new) (version "0.0")))
- (dep* (package (inherit dep) (replacement new)))
- (dummy (dummy-package "dummy"
- (arguments '(#:implicit-inputs? #f))
- (inputs `(("dep" ,dep*)))))
- (target "mips64el-linux-gnu"))
- ;; XXX: There might be additional grafts, for instance if the distro
- ;; defines replacements for core packages like Perl.
- (member (graft
- (origin (package-cross-derivation %store dep target))
- (replacement
- (package-cross-derivation %store new target)))
- (package-grafts %store dummy #:target target))))
+;; XXX: This test would require building the cross toolchain just to see if it
+;; needs grafting, which is obviously too expensive, and thus disabled.
+;;
+;; (test-assert "package-grafts, indirect grafts, cross"
+;; (let* ((new (dummy-package "dep"
+;; (arguments '(#:implicit-inputs? #f))))
+;; (dep (package (inherit new) (version "0.0")))
+;; (dep* (package (inherit dep) (replacement new)))
+;; (dummy (dummy-package "dummy"
+;; (arguments '(#:implicit-inputs? #f))
+;; (inputs `(("dep" ,dep*)))))
+;; (target "mips64el-linux-gnu"))
+;; ;; XXX: There might be additional grafts, for instance if the distro
+;; ;; defines replacements for core packages like Perl.
+;; (member (graft
+;; (origin (package-cross-derivation %store dep target))
+;; (replacement
+;; (package-cross-derivation %store new target)))
+;; (package-grafts %store dummy #:target target))))
(test-assert "package-grafts, indirect grafts, propagated inputs"
(let* ((new (dummy-package "dep"
@@ -719,6 +722,77 @@
(replacement #f))))
(replacement (package-derivation %store new)))))))
+(test-assert "replacement also grafted"
+ ;; We build a DAG as below, where dotted arrows represent replacements and
+ ;; solid arrows represent dependencies:
+ ;;
+ ;; P1 ·············> P1R
+ ;; |\__________________.
+ ;; v v
+ ;; P2 ·············> P2R
+ ;; |
+ ;; v
+ ;; P3
+ ;;
+ ;; We want to make sure that:
+ ;; grafts(P3) = (P1,P1R) + (P2, grafted(P2R, (P1,P1R)))
+ ;; where:
+ ;; (A,B) is a graft to replace A by B
+ ;; grafted(DRV,G) denoted DRV with graft G applied
+ (let* ((p1r (dummy-package "P1"
+ (build-system trivial-build-system)
+ (arguments
+ `(#:guile ,%bootstrap-guile
+ #:builder (let ((out (assoc-ref %outputs "out")))
+ (mkdir out)
+ (call-with-output-file
+ (string-append out "/replacement")
+ (const #t)))))))
+ (p1 (package
+ (inherit p1r) (name "p1") (replacement p1r)
+ (arguments
+ `(#:guile ,%bootstrap-guile
+ #:builder (mkdir (assoc-ref %outputs "out"))))))
+ (p2r (dummy-package "P2"
+ (build-system trivial-build-system)
+ (inputs `(("p1" ,p1)))
+ (arguments
+ `(#:guile ,%bootstrap-guile
+ #:builder (let ((out (assoc-ref %outputs "out")))
+ (mkdir out)
+ (chdir out)
+ (symlink (assoc-ref %build-inputs "p1") "p1")
+ (call-with-output-file (string-append out "/replacement")
+ (const #t)))))))
+ (p2 (package
+ (inherit p2r) (name "p2") (replacement p2r)
+ (arguments
+ `(#:guile ,%bootstrap-guile
+ #:builder (let ((out (assoc-ref %outputs "out")))
+ (mkdir out)
+ (chdir out)
+ (symlink (assoc-ref %build-inputs "p1")
+ "p1"))))))
+ (p3 (dummy-package "p3"
+ (build-system trivial-build-system)
+ (inputs `(("p2" ,p2)))
+ (arguments
+ `(#:guile ,%bootstrap-guile
+ #:builder (let ((out (assoc-ref %outputs "out")))
+ (mkdir out)
+ (chdir out)
+ (symlink (assoc-ref %build-inputs "p2")
+ "p2")))))))
+ (lset= equal?
+ (package-grafts %store p3)
+ (list (graft
+ (origin (package-derivation %store p1 #:graft? #f))
+ (replacement (package-derivation %store p1r)))
+ (graft
+ (origin (package-derivation %store p2 #:graft? #f))
+ (replacement
+ (package-derivation %store p2r #:graft? #t)))))))
+
;;; XXX: Nowadays 'graft-derivation' needs to build derivations beforehand to
;;; find out about their run-time dependencies, so this test is no longer
;;; applicable since it would trigger a full rebuild.