04/05: grafts: Apply the right grafts in the presence of multiple outputs.

[Ludovic Courtès]

civodul pushed a commit to branch master
in repository guix.

commit 3d47aa81ba4c19b45ce9a9ff0ece0252777ea8ed
Author: Ludovic Courtès <address@hidden>
Date:   Mon Oct 17 23:43:33 2016 +0200

    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.
---
 guix/grafts.scm  |   15 +++++++++++++--
 tests/grafts.scm |   48 ++++++++++++++++++++++++++++++++++++++++++++++++
 2 files changed, 61 insertions(+), 2 deletions(-)

diff --git a/guix/grafts.scm b/guix/grafts.scm
index 80ae27e..dda7c1d 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 4eff06b..6454a03 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))