[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
01/02: packages: 'package-grafts' applies grafts on replacement.
|
From: |
Ludovic Court鑣 |
|
Subject: |
01/02: packages: 'package-grafts' applies grafts on replacement. |
|
Date: |
Fri, 14 Oct 2016 21:32:27 +0000 (UTC) |
civodul pushed a commit to branch master
in repository guix.
commit d0025d01445ff271ececea20cfa6a2346593d1d6
Author: Ludovic Court猫s <address@hidden>
Date: Fri Oct 14 10:36:37 2016 +0200
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.
---
guix/packages.scm | 6 ++-
tests/packages.scm | 106 ++++++++++++++++++++++++++++++++++++++++++++--------
2 files changed, 94 insertions(+), 18 deletions(-)
diff --git a/guix/packages.scm b/guix/packages.scm
index 2264c5a..a3fab4d 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 b8e1f11..5f5fb5d 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.