diff options
| -rw-r--r-- | guix/scripts/pack.scm | 32 |
1 files changed, 23 insertions, 9 deletions
diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm index c8d8546e29..3634326102 100644 --- a/guix/scripts/pack.scm +++ b/guix/scripts/pack.scm @@ -4,6 +4,7 @@ ;;; Copyright © 2018 Konrad Hinsen <konrad.hinsen@fastmail.net> ;;; Copyright © 2018 Chris Marusich <cmmarusich@gmail.com> ;;; Copyright © 2018 Efraim Flashner <efraim@flashner.co.il> +;;; Copyright © 2020 Eric Bavier <bavier@posteo.net> ;;; ;;; This file is part of GNU Guix. ;;; @@ -673,9 +674,11 @@ last resort for relocation." (guix build union))) #~(begin (use-modules (guix build utils) - ((guix build union) #:select (relative-file-name)) + ((guix build union) #:select (symlink-relative)) + (srfi srfi-1) (ice-9 ftw) - (ice-9 match)) + (ice-9 match) + (ice-9 receive)) (define input ;; The OUTPUT* output of PACKAGE. @@ -726,15 +729,26 @@ last resort for relocation." (mkdir target) (for-each (lambda (file) (unless (member file '("." ".." "bin" "sbin" "libexec")) - (let ((file* (string-append input "/" file))) - (symlink (relative-file-name target file*) - (string-append target "/" file))))) + (symlink-relative (string-append input "/" file) + (string-append target "/" file)))) (scandir input)) - (for-each build-wrapper - (append (find-files (string-append input "/bin")) - (find-files (string-append input "/sbin")) - (find-files (string-append input "/libexec"))))))) + (receive (executables others) + (partition executable-file? + (append (find-files (string-append input "/bin")) + (find-files (string-append input "/sbin")) + (find-files (string-append input "/libexec")))) + ;; Wrap only executables, since the wrapper will eventually need + ;; to execve them. E.g. git's "libexec" directory contains many + ;; shell scripts that are source'd from elsewhere, which fails if + ;; they are wrapped. + (for-each build-wrapper executables) + ;; Link any other non-executable files + (for-each (lambda (old) + (let ((new (string-append target (strip-store-prefix old)))) + (mkdir-p (dirname new)) + (symlink-relative old new))) + others))))) (computed-file (string-append (cond ((package? package) |