01/03: pack: '-R' honors the requested output.

[guix-commits]

civodul pushed a commit to branch master
in repository guix.

commit b908fcd8c02c26b1e6cdc636b63306a01a21b994
Author: Ludovic Courtès <address@hidden>
Date:   Fri Aug 23 17:45:17 2019 +0200

    pack: '-R' honors the requested output.
    
    Fixes <https://bugs.gnu.org/36925>.
    Reported by Jesse Gibbons <address@hidden>.
    
    * guix/scripts/pack.scm (wrapped-package): Add 'output*' parameter.
    [build]: Define 'input' and 'target'; use them instead of #$package and
     #$output, respectively.
    (wrapped-manifest-entry): New procedure.
    (map-manifest-entries): Call PROC directly.
    (guix-pack): Pass WRAPPED-MANIFEST-ENTRY to 'map-manifest-entries'.
---
 guix/scripts/pack.scm          | 49 ++++++++++++++++++++++++++++--------------
 tests/guix-pack-relocatable.sh |  6 ++++++
 2 files changed, 39 insertions(+), 16 deletions(-)

diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm
index fdb9898..794d2ee 100644
--- a/guix/scripts/pack.scm
+++ b/guix/scripts/pack.scm
@@ -611,8 +611,13 @@ please email '~a'~%")
 ;;;
 
 (define* (wrapped-package package
-                          #:optional (compiler (c-compiler))
+                          #:optional
+                          (output* "out")
+                          (compiler (c-compiler))
                           #:key proot?)
+  "Return the OUTPUT of PACKAGE with its binaries wrapped such that they are
+relocatable.  When PROOT? is true, include PRoot in the result and use it as a
+last resort for relocation."
   (define runner
     (local-file (search-auxiliary-file "run-in-namespace.c")))
 
@@ -629,6 +634,14 @@ please email '~a'~%")
                        (ice-9 ftw)
                        (ice-9 match))
 
+          (define input
+            ;; The OUTPUT* output of PACKAGE.
+            (ungexp package output*))
+
+          (define target
+            ;; The output we are producing.
+            (ungexp output output*))
+
           (define (strip-store-prefix file)
             ;; Given a file name like "/gnu/store/…-foo-1.2/bin/foo", return
             ;; "/bin/foo".
@@ -648,7 +661,7 @@ please email '~a'~%")
               (("@STORE_DIRECTORY@") (%store-directory)))
 
             (let* ((base   (strip-store-prefix program))
-                   (result (string-append #$output "/" base))
+                   (result (string-append target "/" base))
                    (proot  #$(and proot?
                                   #~(string-drop
                                      #$(file-append (proot) "/bin/proot")
@@ -667,18 +680,18 @@ please email '~a'~%")
 
           ;; Link the top-level files of PACKAGE so that search paths are
           ;; properly defined in PROFILE/etc/profile.
-          (mkdir #$output)
+          (mkdir target)
           (for-each (lambda (file)
                       (unless (member file '("." ".." "bin" "sbin" "libexec"))
-                        (let ((file* (string-append #$package "/" file)))
-                          (symlink (relative-file-name #$output file*)
-                                   (string-append #$output "/" file)))))
-                    (scandir #$package))
+                        (let ((file* (string-append input "/" file)))
+                          (symlink (relative-file-name target file*)
+                                   (string-append target "/" file)))))
+                    (scandir input))
 
           (for-each build-wrapper
-                    (append (find-files #$(file-append package "/bin"))
-                            (find-files #$(file-append package "/sbin"))
-                            (find-files #$(file-append package 
"/libexec")))))))
+                    (append (find-files (string-append input "/bin"))
+                            (find-files (string-append input "/sbin"))
+                            (find-files (string-append input "/libexec")))))))
 
   (computed-file (string-append
                   (cond ((package? package)
@@ -691,14 +704,18 @@ please email '~a'~%")
                   "R")
                  build))
 
+(define (wrapped-manifest-entry entry . args)
+  (manifest-entry
+    (inherit entry)
+    (item (apply wrapped-package
+                 (manifest-entry-item entry)
+                 (manifest-entry-output entry)
+                 args))))
+
 (define (map-manifest-entries proc manifest)
   "Apply PROC to all the entries of MANIFEST and return a new manifest."
   (make-manifest
-   (map (lambda (entry)
-          (manifest-entry
-            (inherit entry)
-            (item (proc (manifest-entry-item entry)))))
-        (manifest-entries manifest))))
+   (map proc (manifest-entries manifest))))
 
 
 ;;;
@@ -960,7 +977,7 @@ Create a bundle of PACKAGE.\n"))
                                 ;; 'glibc-bootstrap' lacks 'libc.a'.
                                 (if relocatable?
                                     (map-manifest-entries
-                                     (cut wrapped-package <> #:proot? proot?)
+                                     (cut wrapped-manifest-entry <> #:proot? 
proot?)
                                      manifest)
                                     manifest)))
                  (pack-format (assoc-ref opts 'format))
diff --git a/tests/guix-pack-relocatable.sh b/tests/guix-pack-relocatable.sh
index ebada62..e93610e 100644
--- a/tests/guix-pack-relocatable.sh
+++ b/tests/guix-pack-relocatable.sh
@@ -78,3 +78,9 @@ else
     "$test_directory/Bin/sed" --version > "$test_directory/output"
 fi
 grep 'GNU sed' "$test_directory/output"
+chmod -Rf +w "$test_directory"; rm -rf "$test_directory"/*
+
+# Ensure '-R' works with outputs other than "out".
+tarball="`guix pack -R -S /share=share groff:doc`"
+(cd "$test_directory"; tar xvf "$tarball")
+test -d "$test_directory/share/doc/groff/html"