summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--guix/scripts/pack.scm49
-rw-r--r--tests/guix-pack-relocatable.sh6
2 files changed, 39 insertions, 16 deletions
diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm
index fdb98983bf..794d2ee390 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 ebada62c01..e93610eedc 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"