05/10: pack: ‘-R’ (once) does not include fakechroot fallback.

[guix-commits]

civodul pushed a commit to branch master
in repository guix.

commit a15db2ee5090441c08d9a642d9284ef3ccdd95d0
Author: Ludovic Courtès <ludovic.courtes@inria.fr>
AuthorDate: Fri Apr 12 11:48:26 2024 +0200

    pack: ‘-R’ (once) does not include fakechroot fallback.
    
    Previously, ‘guix pack -R’ would build a wrapper containing both the
    “userns” and “fakechroot” engines, instead of providing nothing but the
    “userns” engine as the manual says.  This patch fixes it.
    
    * guix/scripts/pack.scm (wrapped-package): Add #:fakechroot?
    [build]: When FAKECHROOT? is false, ‘elf-loader-compile-flags’ always
    returns '().
    
    Change-Id: Ic75cc8c36bf0a3881f299b274d78bd9fc2d4e2bb
---
 guix/scripts/pack.scm | 82 ++++++++++++++++++++++++++-------------------------
 1 file changed, 42 insertions(+), 40 deletions(-)

diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm
index 3e45c34895..fe4df042d7 100644
--- a/guix/scripts/pack.scm
+++ b/guix/scripts/pack.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2015, 2017-2023 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2015, 2017-2024 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2017, 2018 Ricardo Wurmus <rekado@elephly.net>
 ;;; Copyright © 2018 Konrad Hinsen <konrad.hinsen@fastmail.net>
 ;;; Copyright © 2018 Chris Marusich <cmmarusich@gmail.com>
@@ -1066,10 +1066,11 @@ please email '~a'~%")
                           #:optional
                           (output* "out")
                           (compiler (c-compiler))
-                          #:key proot?)
+                          #:key proot? (fakechroot? 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."
+last resort for relocation.  When FAKECHROOT? is true, include
+libfakechroot.so and related ld.so machinery as a fallback."
   (define runner
     (local-file (search-auxiliary-file "run-in-namespace.c")))
 
@@ -1161,43 +1162,44 @@ last resort for relocation."
           (define (elf-loader-compile-flags program)
             ;; Return the cpp flags defining macros for the ld.so/fakechroot
             ;; wrapper of PROGRAM.
-
-            ;; TODO: Handle scripts by wrapping their interpreter.
-            (if (elf-file? program)
-                (let* ((bv      (call-with-input-file program
-                                  get-bytevector-all))
-                       (elf     (parse-elf bv))
-                       (interp  (elf-interpreter elf))
-                       (gconv   (and interp
-                                     (string-append (dirname interp)
-                                                    "/gconv"))))
-                  (if interp
-                      (list (string-append "-DPROGRAM_INTERPRETER=\""
-                                           interp "\"")
-                            (string-append "-DFAKECHROOT_LIBRARY=\""
-                                           #$(fakechroot-library) "\"")
-
-                            (string-append "-DLOADER_AUDIT_MODULE=\""
-                                           #$(audit-module) "\"")
-
-                            ;; XXX: Normally (runpath #$(audit-module)) is
-                            ;; enough.  However, to work around
-                            ;; 
<https://sourceware.org/bugzilla/show_bug.cgi?id=26634>
-                            ;; (glibc <= 2.32), pass the whole search path of
-                            ;; PROGRAM, which presumably is a superset of that
-                            ;; of the audit module.
-                            (string-append "-DLOADER_AUDIT_RUNPATH={ "
-                                           (string-join
-                                            (map object->string
-                                                 (runpath program))
-                                            ", " 'suffix)
-                                           "NULL }")
-                            (if gconv
-                                (string-append "-DGCONV_DIRECTORY=\""
-                                               gconv "\"")
-                                "-UGCONV_DIRECTORY"))
-                      '()))
-                '()))
+            #$(if fakechroot?
+                  ;; TODO: Handle scripts by wrapping their interpreter.
+                  #~(if (elf-file? program)
+                        (let* ((bv      (call-with-input-file program
+                                          get-bytevector-all))
+                               (elf     (parse-elf bv))
+                               (interp  (elf-interpreter elf))
+                               (gconv   (and interp
+                                             (string-append (dirname interp)
+                                                            "/gconv"))))
+                          (if interp
+                              (list (string-append "-DPROGRAM_INTERPRETER=\""
+                                                   interp "\"")
+                                    (string-append "-DFAKECHROOT_LIBRARY=\""
+                                                   #$(fakechroot-library) "\"")
+
+                                    (string-append "-DLOADER_AUDIT_MODULE=\""
+                                                   #$(audit-module) "\"")
+
+                                    ;; XXX: Normally (runpath 
#$(audit-module)) is
+                                    ;; enough.  However, to work around
+                                    ;; 
<https://sourceware.org/bugzilla/show_bug.cgi?id=26634>
+                                    ;; (glibc <= 2.32), pass the whole search 
path of
+                                    ;; PROGRAM, which presumably is a superset 
of that
+                                    ;; of the audit module.
+                                    (string-append "-DLOADER_AUDIT_RUNPATH={ "
+                                                   (string-join
+                                                    (map object->string
+                                                         (runpath program))
+                                                    ", " 'suffix)
+                                                   "NULL }")
+                                    (if gconv
+                                        (string-append "-DGCONV_DIRECTORY=\""
+                                                       gconv "\"")
+                                        "-UGCONV_DIRECTORY"))
+                              '()))
+                        '())
+                  #~'()))
 
           (define (build-wrapper program)
             ;; Build a user-namespace wrapper for PROGRAM.