summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2016-10-17 23:43:33 +0200
committerLudovic Courtès <ludo@gnu.org>2016-10-17 23:59:03 +0200
commit3d47aa81ba4c19b45ce9a9ff0ece0252777ea8ed (patch)
treef12190e8ba332d08806100441dfdfec8acd80586
parent645b9df858683dc05ffa04c9eb2fdc45ccef4a65 (diff)
grafts: Apply the right grafts in the presence of multiple outputs.
Fixes <http://bugs.gnu.org/24712>. * guix/grafts.scm (cumulative-grafts): Add grafts for all the outputs of DRV. * tests/grafts.scm ("graft-derivation, replaced derivation has multiple outputs"): New test.
-rw-r--r--guix/grafts.scm15
-rw-r--r--tests/grafts.scm48
2 files changed, 61 insertions, 2 deletions
diff --git a/guix/grafts.scm b/guix/grafts.scm
index 80ae27e9b0..dda7c1d235 100644
--- a/guix/grafts.scm
+++ b/guix/grafts.scm
@@ -280,8 +280,19 @@ derivations to the corresponding set of grafts."
(let* ((new (graft-derivation/shallow store drv applicable
#:guile guile
#:system system))
- (grafts (cons (graft (origin drv) (replacement new))
- grafts)))
+
+ ;; Replace references to any of the outputs of DRV,
+ ;; even if that's more than needed. This is so that
+ ;; the result refers only to the outputs of NEW and
+ ;; not to those of DRV.
+ (grafts (append (map (lambda (output)
+ (graft
+ (origin drv)
+ (origin-output output)
+ (replacement new)
+ (replacement-output output)))
+ (derivation-output-names drv))
+ grafts)))
(return/cache cache grafts))))))))))))
(define* (graft-derivation store drv grafts
diff --git a/tests/grafts.scm b/tests/grafts.scm
index 4eff06b4b3..6454a03b1f 100644
--- a/tests/grafts.scm
+++ b/tests/grafts.scm
@@ -201,6 +201,54 @@
(and (string=? (readlink one) repl)
(string=? (readlink two) one))))))
+(test-assert "graft-derivation, replaced derivation has multiple outputs"
+ ;; Here we have a replacement just for output "one" of P1 and not for the
+ ;; other output. Make sure the graft for P1:one correctly applies to the
+ ;; dependents of P1. See <http://bugs.gnu.org/24712>.
+ (let* ((p1 (build-expression->derivation
+ %store "p1"
+ `(let ((one (assoc-ref %outputs "one"))
+ (two (assoc-ref %outputs "two")))
+ (mkdir one)
+ (mkdir two))
+ #:outputs '("one" "two")))
+ (p1r (build-expression->derivation
+ %store "P1"
+ `(let ((other (assoc-ref %outputs "ONE")))
+ (mkdir other)
+ (call-with-output-file (string-append other "/replacement")
+ (const #t)))
+ #:outputs '("ONE")))
+ (p2 (build-expression->derivation
+ %store "p2"
+ `(let ((out (assoc-ref %outputs "aaa")))
+ (mkdir (assoc-ref %outputs "zzz"))
+ (mkdir out) (chdir out)
+ (symlink (assoc-ref %build-inputs "p1:one") "one")
+ (symlink (assoc-ref %build-inputs "p1:two") "two"))
+ #:outputs '("aaa" "zzz")
+ #:inputs `(("p1:one" ,p1 "one")
+ ("p1:two" ,p1 "two"))))
+ (p3 (build-expression->derivation
+ %store "p3"
+ `(symlink (assoc-ref %build-inputs "p2:aaa")
+ (assoc-ref %outputs "out"))
+ #:inputs `(("p2:aaa" ,p2 "aaa")
+ ("p2:zzz" ,p2 "zzz"))))
+ (p1g (graft
+ (origin p1)
+ (origin-output "one")
+ (replacement p1r)
+ (replacement-output "ONE")))
+ (p3d (graft-derivation %store p3 (list p1g))))
+ (and (build-derivations %store (list p3d))
+ (let ((out (derivation->output-path (pk 'p2d p3d))))
+ (and (not (string=? (readlink out)
+ (derivation->output-path p2 "aaa")))
+ (string=? (derivation->output-path p1 "two")
+ (readlink (string-append out "/two")))
+ (file-exists? (string-append out "/one/replacement")))))))
+
(test-assert "graft-derivation, renaming" ;<http://bugs.gnu.org/23132>
(let* ((build `(begin
(use-modules (guix build utils))