03/03: grafts: Consider all the outputs in the graft mapping.

[Ludovic Courtès]

civodul pushed a commit to branch master
in repository guix.

commit f376dc3acb69a7345a7e945a37a78f63ac626edb
Author: Ludovic Courtès <address@hidden>
Date:   Sat Feb 27 23:28:35 2016 +0100

    grafts: Consider all the outputs in the graft mapping.
    
    Before that, outputs of a derivation could be left referring to the
    ungrafted version of the derivation.
    
    * guix/grafts.scm (graft-derivation)[outputs]: Change to a list of
    name/file pairs.
    * guix/grafts.scm (graft-derivation)[build]: Add 'old-outputs' variable
    and use it when computing 'mapping'.  Use 'mapping' directly.
    * tests/grafts.scm ("graft-derivation, multiple outputs"): New test.
---
 guix/grafts.scm  |   23 +++++++++++++++--------
 tests/grafts.scm |   20 ++++++++++++++++++++
 2 files changed, 35 insertions(+), 8 deletions(-)

diff --git a/guix/grafts.scm b/guix/grafts.scm
index 339f273..ea53959 100644
--- a/guix/grafts.scm
+++ b/guix/grafts.scm
@@ -82,9 +82,10 @@ applied."
          grafts))
 
   (define outputs
-    (match (derivation-outputs drv)
-      (((names . outputs) ...)
-       (map derivation-output-path outputs))))
+    (map (match-lambda
+           ((name . output)
+            (cons name (derivation-output-path output))))
+         (derivation-outputs drv)))
 
   (define output-names
     (derivation-output-names drv))
@@ -95,14 +96,20 @@ applied."
                     (guix build utils)
                     (ice-9 match))
 
-       (let ((mapping ',mapping))
+       (let* ((old-outputs ',outputs)
+              (mapping (append ',mapping
+                               (map (match-lambda
+                                      ((name . file)
+                                       (cons (assoc-ref old-outputs name)
+                                             file)))
+                                    %outputs))))
          (for-each (lambda (input output)
                      (format #t "grafting '~a' -> '~a'...~%" input output)
                      (force-output)
-                     (rewrite-directory input output
-                                        `((,input . ,output)
-                                          ,@mapping)))
-                   ',outputs
+                     (rewrite-directory input output mapping))
+                   (match old-outputs
+                     (((names . files) ...)
+                      files))
                    (match %outputs
                      (((names . files) ...)
                       files))))))
diff --git a/tests/grafts.scm b/tests/grafts.scm
index 4a4122a..9fe314d 100644
--- a/tests/grafts.scm
+++ b/tests/grafts.scm
@@ -75,6 +75,26 @@
                 (string=? (readlink (string-append graft "/sh")) one)
                 (string=? (readlink (string-append graft "/self")) graft))))))
 
+(test-assert "graft-derivation, multiple outputs"
+  (let* ((build `(begin
+                   (symlink (assoc-ref %build-inputs "a")
+                            (assoc-ref %outputs "one"))
+                   (symlink (assoc-ref %outputs "one")
+                            (assoc-ref %outputs "two"))))
+         (orig  (build-expression->derivation %store "grafted" build
+                                              #:inputs `(("a" ,%bash))
+                                              #:outputs '("one" "two")))
+         (repl  (add-text-to-store %store "bash" "fake bash"))
+         (grafted (graft-derivation %store orig
+                                    (list (graft
+                                            (origin %bash)
+                                            (replacement repl))))))
+    (and (build-derivations %store (list grafted))
+         (let ((one (derivation->output-path grafted "one"))
+               (two (derivation->output-path grafted "two")))
+           (and (string=? (readlink one) repl)
+                (string=? (readlink two) one))))))
+
 (test-end)