diff options
Diffstat (limited to 'guix/scripts/pack.scm')
| -rw-r--r-- | guix/scripts/pack.scm | 51 |
1 files changed, 34 insertions, 17 deletions
diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm index 0b66da01f9..06509ace2d 100644 --- a/guix/scripts/pack.scm +++ b/guix/scripts/pack.scm @@ -5,6 +5,7 @@ ;;; Copyright © 2018 Chris Marusich <cmmarusich@gmail.com> ;;; Copyright © 2018 Efraim Flashner <efraim@flashner.co.il> ;;; Copyright © 2020 Tobias Geerinckx-Rice <me@tobias.gr> +;;; Copyright © 2020 Eric Bavier <bavier@posteo.net> ;;; ;;; This file is part of GNU Guix. ;;; @@ -42,6 +43,7 @@ #:use-module (guix search-paths) #:use-module (guix build-system gnu) #:use-module (guix scripts build) + #:use-module (guix transformations) #:use-module ((guix self) #:select (make-config.scm)) #:use-module (gnu packages) #:use-module (gnu packages bootstrap) @@ -135,9 +137,11 @@ dependencies are registered." (define build (with-extensions gcrypt-sqlite3&co - (with-imported-modules (source-module-closure - '((guix build store-copy) - (guix store database))) + (with-imported-modules `(((guix config) => ,(make-config.scm)) + ,@(source-module-closure + '((guix build store-copy) + (guix store database)) + #:select? not-config?)) #~(begin (use-modules (guix store database) (guix build store-copy) @@ -748,12 +752,13 @@ last resort for relocation." (guix elf))) #~(begin (use-modules (guix build utils) - ((guix build union) #:select (relative-file-name)) + ((guix build union) #:select (symlink-relative)) (guix elf) (guix build gremlin) (ice-9 binary-ports) (ice-9 ftw) (ice-9 match) + (ice-9 receive) (srfi srfi-1) (rnrs bytevectors)) @@ -847,7 +852,7 @@ last resort for relocation." (("@STORE_DIRECTORY@") (%store-directory))) (let* ((base (strip-store-prefix program)) - (result (string-append target "/" base)) + (result (string-append target base)) (proot #$(and proot? #~(string-drop #$(file-append (proot) "/bin/proot") @@ -856,6 +861,9 @@ last resort for relocation." (mkdir-p (dirname result)) (apply invoke #$compiler "-std=gnu99" "-static" "-Os" "-g0" "-Wall" "run.c" "-o" result + (string-append "-DWRAPPER_PROGRAM=\"" + (canonicalize-path (dirname result)) "/" + (basename result) "\"") (append (if proot (list (string-append "-DPROOT_PROGRAM=\"" proot "\"")) @@ -870,16 +878,27 @@ 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 - ;; Note: Trailing slash in case these are symlinks. - (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? + ;; Note: Trailing slash in case these are symlinks. + (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) @@ -1043,8 +1062,6 @@ last resort for relocation." Create a bundle of PACKAGE.\n")) (show-build-options-help) (newline) - (show-transformation-options-help) - (newline) (display (G_ " -f, --format=FORMAT build a pack in the given FORMAT")) (display (G_ " @@ -1118,9 +1135,9 @@ Create a bundle of PACKAGE.\n")) (let* ((transform (options->transformation opts)) (packages (map (match-lambda (((? package? package) output) - (list (transform store package) output)) + (list (transform package) output)) ((? package? package) - (list (transform store package) "out"))) + (list (transform package) "out"))) (reverse (filter-map maybe-package-argument opts)))) (manifests (filter-map (match-lambda |