diff options
author | Christopher Baines <mail@cbaines.net> | 2020-11-29 14:19:55 +0000 |
---|---|---|
committer | Christopher Baines <mail@cbaines.net> | 2020-11-29 17:34:18 +0000 |
commit | ff01206345e2306cc633db48e0b29eab9077091a (patch) | |
tree | 25c7ee17005dadc9bf4fae3f0873e03a4704f782 /guix/scripts/pack.scm | |
parent | ed2545f0fa0e2ad99d5a0c45f532c539b299b9fb (diff) | |
parent | 7c2e67400ffaef8eb6f30ef7126c976ee3d7e36c (diff) | |
download | guix-patches-ff01206345e2306cc633db48e0b29eab9077091a.tar guix-patches-ff01206345e2306cc633db48e0b29eab9077091a.tar.gz |
Merge remote-tracking branch 'origin/master' into core-updates
Diffstat (limited to 'guix/scripts/pack.scm')
-rw-r--r-- | guix/scripts/pack.scm | 54 |
1 files changed, 39 insertions, 15 deletions
diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm index ea2a96d5a1..6e0a16f033 100644 --- a/guix/scripts/pack.scm +++ b/guix/scripts/pack.scm @@ -6,6 +6,7 @@ ;;; Copyright © 2018 Efraim Flashner <efraim@flashner.co.il> ;;; Copyright © 2020 Tobias Geerinckx-Rice <me@tobias.gr> ;;; Copyright © 2020 Maxim Cournoyer <maxim.cournoyer@gmail.com> +;;; Copyright © 2020 Eric Bavier <bavier@posteo.net> ;;; ;;; This file is part of GNU Guix. ;;; @@ -44,6 +45,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) @@ -59,11 +61,16 @@ #:use-module (srfi srfi-37) #:use-module (ice-9 match) #:export (compressor? + compressor-name + compressor-extenstion + compressor-command + %compressors lookup-compressor self-contained-tarball docker-image squashfs-image + %formats guix-pack)) ;; Type of a compression tool. @@ -142,9 +149,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) @@ -757,12 +766,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)) @@ -856,7 +866,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") @@ -865,6 +875,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 "\"")) @@ -879,16 +892,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) @@ -1127,9 +1151,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 |