ryan77627/guix
1
0
Fork 0
mirror of https://git.in.rschanz.org/ryan77627/guix.git synced 2024-12-25 05:48:07 -05:00
Code Issues Projects Releases Packages Wiki Activity Actions

pack: '-R' honors the requested output.

Browse source 
Fixes <https://bugs.gnu.org/36925>.
Reported by Jesse Gibbons <jgibbons2357@gmail.com>.

* 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'.
This commit is contained in:
Ludovic Courtès 2019-08-23 17:45:17 +02:00
parent d78bc23411
commit b908fcd8c0
No known key found for this signature in database
GPG key ID: 090B11993D9AEBB5
2 changed files with 39 additions and 16 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

49
guix/scripts/pack.scm
View file

@ -611,8 +611,13 @@ (define (output-file args)
;;; ;;;
(define* (wrapped-package package (define* (wrapped-package package
#:optional (compiler (c-compiler)) #:optional
(output* "out")
(compiler (c-compiler))
#:key proot?) #: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 (define runner
(local-file (search-auxiliary-file "run-in-namespace.c"))) (local-file (search-auxiliary-file "run-in-namespace.c")))
@ -629,6 +634,14 @@ (define build
(ice-9 ftw) (ice-9 ftw)
(ice-9 match)) (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) (define (strip-store-prefix file)
;; Given a file name like "/gnu/store/…-foo-1.2/bin/foo", return ;; Given a file name like "/gnu/store/…-foo-1.2/bin/foo", return
;; "/bin/foo". ;; "/bin/foo".
@ -648,7 +661,7 @@ (define (build-wrapper program)
(("@STORE_DIRECTORY@") (%store-directory))) (("@STORE_DIRECTORY@") (%store-directory)))
(let* ((base (strip-store-prefix program)) (let* ((base (strip-store-prefix program))
(result (string-append #$output "/" base)) (result (string-append target "/" base))
(proot #$(and proot? (proot #$(and proot?
#~(string-drop #~(string-drop
#$(file-append (proot) "/bin/proot") #$(file-append (proot) "/bin/proot")
@ -667,18 +680,18 @@ (define (build-wrapper program)
;; Link the top-level files of PACKAGE so that search paths are ;; Link the top-level files of PACKAGE so that search paths are
;; properly defined in PROFILE/etc/profile. ;; properly defined in PROFILE/etc/profile.
(mkdir #$output) (mkdir target)
(for-each (lambda (file) (for-each (lambda (file)
(unless (member file '("." ".." "bin" "sbin" "libexec")) (unless (member file '("." ".." "bin" "sbin" "libexec"))
(let ((file* (string-append #$package "/" file))) (let ((file* (string-append input "/" file)))
(symlink (relative-file-name #$output file*) (symlink (relative-file-name target file*)
(string-append #$output "/" file))))) (string-append target "/" file)))))
(scandir #$package)) (scandir input))
(for-each build-wrapper (for-each build-wrapper
(append (find-files #$(file-append package "/bin")) (append (find-files (string-append input "/bin"))
(find-files #$(file-append package "/sbin")) (find-files (string-append input "/sbin"))
(find-files #$(file-append package "/libexec"))))))) (find-files (string-append input "/libexec")))))))
(computed-file (string-append (computed-file (string-append
(cond ((package? package) (cond ((package? package)
@ -691,14 +704,18 @@ (define (build-wrapper program)
"R") "R")
build)) 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) (define (map-manifest-entries proc manifest)
"Apply PROC to all the entries of MANIFEST and return a new manifest." "Apply PROC to all the entries of MANIFEST and return a new manifest."
(make-manifest (make-manifest
(map (lambda (entry) (map proc (manifest-entries manifest))))
(manifest-entry
(inherit entry)
(item (proc (manifest-entry-item entry)))))
(manifest-entries manifest))))
;;; ;;;
@ -960,7 +977,7 @@ (define properties
;; 'glibc-bootstrap' lacks 'libc.a'. ;; 'glibc-bootstrap' lacks 'libc.a'.
(if relocatable? (if relocatable?
(map-manifest-entries (map-manifest-entries
(cut wrapped-package <> #:proot? proot?) (cut wrapped-manifest-entry <> #:proot? proot?)
manifest) manifest)
manifest))) manifest)))
(pack-format (assoc-ref opts 'format)) (pack-format (assoc-ref opts 'format))

6
tests/guix-pack-relocatable.sh
View file

@ -78,3 +78,9 @@ else
"$test_directory/Bin/sed" --version > "$test_directory/output" "$test_directory/Bin/sed" --version > "$test_directory/output"
fi fi
grep 'GNU sed' "$test_directory/output" 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"