diff options
Diffstat (limited to 'guix')
| -rw-r--r-- | guix/build-system/android-ndk.scm | 127 | ||||
| -rw-r--r-- | guix/build/android-ndk-build-system.scm | 88 | ||||
| -rw-r--r-- | guix/build/profiles.scm | 14 | ||||
| -rw-r--r-- | guix/build/union.scm | 48 | ||||
| -rw-r--r-- | guix/gexp.scm | 37 | ||||
| -rw-r--r-- | guix/packages.scm | 13 | ||||
| -rw-r--r-- | guix/profiles.scm | 19 | ||||
| -rw-r--r-- | guix/scripts/lint.scm | 2 | ||||
| -rw-r--r-- | guix/scripts/pack.scm | 218 | ||||
| -rw-r--r-- | guix/search-paths.scm | 15 | ||||
| -rw-r--r-- | guix/utils.scm | 24 |
11 files changed, 568 insertions, 37 deletions
diff --git a/guix/build-system/android-ndk.scm b/guix/build-system/android-ndk.scm new file mode 100644 index 0000000000..dbfa626a19 --- /dev/null +++ b/guix/build-system/android-ndk.scm @@ -0,0 +1,127 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2016 Danny Milosavljevic <dannym@scratchpost.org> +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. + +(define-module (guix build-system android-ndk) + #:use-module (guix search-paths) + #:use-module (guix store) + #:use-module (guix utils) + #:use-module (guix derivations) + #:use-module (guix packages) + #:use-module (guix build-system) + #:use-module (guix build-system gnu) + #:use-module (ice-9 match) + #:use-module (srfi srfi-26) + #:export (android-ndk-build-system)) + +(define %android-ndk-build-system-modules + ;; Build-side modules imported by default. + `((guix build android-ndk-build-system) + (guix build syscalls) + ,@%gnu-build-system-modules)) + +(define* (android-ndk-build store name inputs + #:key + (tests? #t) + (test-target #f) + (phases '(@ (guix build android-ndk-build-system) + %standard-phases)) + (outputs '("out")) + (make-flags ''()) + (search-paths '()) + (system (%current-system)) + (guile #f) + (imported-modules %android-ndk-build-system-modules) + (modules '((guix build android-ndk-build-system) + (guix build utils)))) + "Build SOURCE using Android NDK, and with INPUTS." + (define builder + `(begin + (use-modules ,@modules) + (android-ndk-build #:name ,name + #:source ,(match (assoc-ref inputs "source") + (((? derivation? source)) + (derivation->output-path source)) + ((source) + source) + (source + source)) + #:system ,system + #:test-target ,test-target + #:tests? ,tests? + #:phases ,phases + #:make-flags (cons* "-f" + ,(string-append + (derivation->output-path + (car (assoc-ref inputs "android-build"))) + "/share/android/build/core/main.mk") + ,make-flags) + #:outputs %outputs + #:search-paths ',(map search-path-specification->sexp + search-paths) + #:inputs %build-inputs))) + + (define guile-for-build + (match guile + ((? package?) + (package-derivation store guile system #:graft? #f)) + (#f ; the default + (let* ((distro (resolve-interface '(gnu packages commencement))) + (guile (module-ref distro 'guile-final))) + (package-derivation store guile system #:graft? #f))))) + + (build-expression->derivation store name builder + #:inputs inputs + #:system system + #:modules imported-modules + #:outputs outputs + #:guile-for-build guile-for-build)) + +(define* (lower name + #:key source inputs native-inputs outputs system target + #:allow-other-keys + #:rest arguments) + "Return a bag for NAME." + + (define private-keywords + '(#:source #:target #:inputs #:native-inputs #:outputs)) + + (and (not target) ;; TODO: support cross-compilation + (bag + (name name) + (system system) + (target target) + (host-inputs `(,@(if source + `(("source" ,source)) + '()) + ,@inputs + + ;; Keep the standard inputs of 'gnu-build-system' + ,@(standard-packages))) + (build-inputs `(("android-build" ,(module-ref (resolve-interface '(gnu packages android)) 'android-make-stub)) + ("android-googletest" ,(module-ref (resolve-interface '(gnu packages android)) 'android-googletest)) + ,@native-inputs)) + (outputs outputs) + (build android-ndk-build) + (arguments (strip-keyword-arguments private-keywords arguments))))) + +(define android-ndk-build-system + (build-system + (name 'android-ndk) + (description + "Android NDK build system, to build Android NDK packages") + (lower lower))) diff --git a/guix/build/android-ndk-build-system.scm b/guix/build/android-ndk-build-system.scm new file mode 100644 index 0000000000..3c8f726d1d --- /dev/null +++ b/guix/build/android-ndk-build-system.scm @@ -0,0 +1,88 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2018 Danny Milosavljevic <dannym@scratchpost.org> +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. + +(define-module (guix build android-ndk-build-system) + #:use-module ((guix build gnu-build-system) #:prefix gnu:) + #:use-module (guix build syscalls) + #:use-module (guix build utils) + #:use-module (ice-9 popen) + #:use-module (ice-9 rdelim) + #:use-module (ice-9 ftw) + #:use-module (ice-9 format) + #:use-module (ice-9 match) + #:use-module (rnrs io ports) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-26) + #:export (%standard-phases + android-ndk-build)) + +;; Commentary: +;; +;; Builder-side code of the Android NDK build system. +;; +;; Code: + +(define* (configure #:key inputs outputs #:allow-other-keys) + (let ((library-directories (filter-map (match-lambda + ((name . path) + (if (eq? 'directory (stat:type (stat path))) + path + #f))) + inputs))) + (setenv "CC" "gcc") + (setenv "CXX" "g++") + (setenv "CPPFLAGS" + (string-join + (map (cut string-append "-I " <> "/include") library-directories) + " ")) + (setenv "LDFLAGS" + (string-append "-L . " + (string-join + (map (lambda (x) + (string-append "-L " x "/lib" " -Wl,-rpath=" x "/lib")) + library-directories) + " "))) + #t)) + +(define* (install #:key inputs outputs (make-flags '()) #:allow-other-keys) + (let ((out (assoc-ref outputs "out"))) + (apply invoke "make" "install" + (string-append "prefix=" out) + make-flags) + #t)) + +(define* (check #:key target inputs outputs (tests? (not target)) (make-flags '()) #:allow-other-keys) + (if tests? + (begin + (apply invoke "make" "check" make-flags) + (when (and (file-exists? "tests") tests?) + (with-directory-excursion "tests" + (apply invoke "make" "check" make-flags)))) + (format #t "test suite not run~%")) + #t) + +(define %standard-phases + (modify-phases gnu:%standard-phases + (replace 'configure configure) + (replace 'install install) + (replace 'check check))) + +(define* (android-ndk-build #:key inputs (phases %standard-phases) + #:allow-other-keys #:rest args) + "Build the given Android NDK package, applying all of PHASES in order." + (apply gnu:gnu-build #:inputs inputs #:phases phases args)) diff --git a/guix/build/profiles.scm b/guix/build/profiles.scm index b4160fba1b..819688a913 100644 --- a/guix/build/profiles.scm +++ b/guix/build/profiles.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2015, 2017 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2015, 2017, 2018 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -24,6 +24,7 @@ #:use-module (ice-9 ftw) #:use-module (ice-9 match) #:use-module (ice-9 pretty-print) + #:re-export (symlink-relative) ;for convenience #:export (ensure-writable-directory build-profile)) @@ -129,12 +130,15 @@ instead make DIRECTORY a \"real\" directory containing symlinks." (apply throw args)))))) (define* (build-profile output inputs - #:key manifest search-paths) - "Build a user profile from INPUTS in directory OUTPUT. Write MANIFEST, an -sexp, to OUTPUT/manifest. Create OUTPUT/etc/profile with Bash definitions for --all the variables listed in SEARCH-PATHS." + #:key manifest search-paths + (symlink symlink)) + "Build a user profile from INPUTS in directory OUTPUT, using SYMLINK to +create symlinks. Write MANIFEST, an sexp, to OUTPUT/manifest. Create +OUTPUT/etc/profile with Bash definitions for -all the variables listed in +SEARCH-PATHS." ;; Make the symlinks. (union-build output inputs + #:symlink symlink #:log-port (%make-void-port "w")) ;; Store meta-data. diff --git a/guix/build/union.scm b/guix/build/union.scm index 1179f1234b..24b366af45 100644 --- a/guix/build/union.scm +++ b/guix/build/union.scm @@ -27,7 +27,10 @@ #:use-module (rnrs io ports) #:export (union-build - warn-about-collision)) + warn-about-collision + + relative-file-name + symlink-relative)) ;;; Commentary: ;;; @@ -174,4 +177,47 @@ returns #f, skip the faulty file altogether." (union-of-directories output (delete-duplicates inputs))) + +;;; +;;; Relative symlinks. +;;; + +(define %not-slash + (char-set-complement (char-set #\/))) + +(define (relative-file-name reference file) + "Given REFERENCE and FILE, both of which are absolute file names, return the +file name of FILE relative to REFERENCE. + + (relative-file-name \"/gnu/store/foo\" \"/gnu/store/bin/bar\") + => \"../bin/bar\" + +Note that this is from a purely lexical standpoint; conversely, \"..\" is +*not* resolved lexically on POSIX in the presence of symlinks." + (if (and (string-prefix? "/" file) (string-prefix? "/" reference)) + (let loop ((reference (string-tokenize reference %not-slash)) + (file (string-tokenize file %not-slash))) + (define (finish) + (string-join (append (make-list (length reference) "..") file) + "/")) + + (match reference + (() + (finish)) + ((head . tail) + (match file + (() + (finish)) + ((head* . tail*) + (if (string=? head head*) + (loop tail tail*) + (finish))))))) + file)) + +(define (symlink-relative old new) + "Assuming both OLD and NEW are absolute file names, make NEW a symlink to +OLD, but using a relative file name." + (symlink (relative-file-name (dirname new) old) + new)) + ;;; union.scm ends here diff --git a/guix/gexp.scm b/guix/gexp.scm index 5ffe505be1..c6d70e4e36 100644 --- a/guix/gexp.scm +++ b/guix/gexp.scm @@ -664,7 +664,9 @@ The other arguments are as for 'derivation'." (imported-modules %modules #:system system #:module-path module-path - #:guile guile-for-build) + #:guile guile-for-build + #:deprecation-warnings + deprecation-warnings) (return #f))) (compiled (if (pair? %modules) (compiled-modules %modules @@ -974,7 +976,15 @@ environment." (define* (imported-files files #:key (name "file-import") (system (%current-system)) - (guile (%guile-for-build))) + (guile (%guile-for-build)) + + ;; XXX: The only reason we have + ;; #:deprecation-warnings is because (guix build + ;; utils), which we use here, relies on _IO*, which + ;; is deprecated in 2.2. On the next full-rebuild + ;; cycle, we should disable such warnings + ;; unconditionally. + (deprecation-warnings #f)) "Return a derivation that imports FILES into STORE. FILES must be a list of (FINAL-PATH . FILE) pairs. Each FILE is mapped to FINAL-PATH in the resulting store path. FILE can be either a file name, or a file-like object, @@ -1010,13 +1020,25 @@ as returned by 'local-file' for example." (gexp->derivation name build #:system system #:guile-for-build guile - #:local-build? #t))) + #:local-build? #t + + ;; TODO: On the next rebuild cycle, set to "no" + ;; unconditionally. + #:env-vars + (case deprecation-warnings + ((#f) + '(("GUILE_WARN_DEPRECATED" . "no"))) + ((detailed) + '(("GUILE_WARN_DEPRECATED" . "detailed"))) + (else + '()))))) (define* (imported-modules modules #:key (name "module-import") (system (%current-system)) (guile (%guile-for-build)) - (module-path %load-path)) + (module-path %load-path) + (deprecation-warnings #f)) "Return a derivation that contains the source files of MODULES, a list of module names such as `(ice-9 q)'. All of MODULES must be either names of modules to be found in the MODULE-PATH search path, or a module name followed @@ -1041,7 +1063,8 @@ last one is created from the given <scheme-file> object." (cons f (search-path* module-path f)))))) modules))) (imported-files files #:name name #:system system - #:guile guile))) + #:guile guile + #:deprecation-warnings deprecation-warnings))) (define* (compiled-modules modules #:key (name "module-import-compiled") @@ -1058,7 +1081,9 @@ they can refer to each other." #:system system #:guile guile #:module-path - module-path))) + module-path + #:deprecation-warnings + deprecation-warnings))) (define build (gexp (begin diff --git a/guix/packages.scm b/guix/packages.scm index ab4b6278d6..a6f9936d63 100644 --- a/guix/packages.scm +++ b/guix/packages.scm @@ -388,10 +388,11 @@ object." (define-condition-type &package-cross-build-system-error &package-error package-cross-build-system-error?) - -(define (package-full-name package) - "Return the full name of PACKAGE--i.e., `NAME-VERSION'." - (string-append (package-name package) "-" (package-version package))) +(define* (package-full-name package #:optional (delimiter "@")) + "Return the full name of PACKAGE--i.e., `NAME@VERSION'. By specifying +DELIMITER (a string), you can customize what will appear between the name and +the version. By default, DELIMITER is \"@\"." + (string-append (package-name package) delimiter (package-version package))) (define (%standard-patch-inputs) (let* ((canonical (module-ref (resolve-interface '(gnu packages base)) @@ -945,6 +946,10 @@ and return it." (($ <package> name version source build-system args inputs propagated-inputs native-inputs self-native-input? outputs) + ;; Even though we prefer to use "@" to separate the package + ;; name from the package version in various user-facing parts + ;; of Guix, checkStoreName (in nix/libstore/store-api.cc) + ;; prohibits the use of "@", so use "-" instead. (or (make-bag build-system (string-append name "-" version) #:system system #:target target diff --git a/guix/profiles.scm b/guix/profiles.scm index 95dc9746bd..dca2479769 100644 --- a/guix/profiles.scm +++ b/guix/profiles.scm @@ -168,7 +168,7 @@ (version manifest-entry-version) ; string (output manifest-entry-output ; string (default "out")) - (item manifest-entry-item) ; package | store path + (item manifest-entry-item) ; package | file-like | store path (dependencies manifest-entry-dependencies ; <manifest-entry>* (default '())) (search-paths manifest-entry-search-paths ; search-path-specification* @@ -318,7 +318,7 @@ denoting a specific output of a package." (propagated-inputs #$(map entry->gexp deps)) (search-paths #$(map search-path-specification->sexp search-paths)))) - (($ <manifest-entry> name version output (? package? package) + (($ <manifest-entry> name version output package (deps ...) (search-paths ...)) #~(#$name #$version #$output (ungexp package (or output "out")) @@ -671,7 +671,13 @@ if not found." (return (find-among-inputs inputs))))) ((? string? item) (mlet %store-monad ((refs (references* item))) - (return (find-among-store-items refs))))))) + (return (find-among-store-items refs)))) + (item + ;; XXX: ITEM might be a 'computed-file' or anything like that, in + ;; which case we don't know what to do. The fix may be to check + ;; references once ITEM is compiled, as proposed at + ;; <https://bugs.gnu.org/29927>. + (return #f))))) (anym %store-monad entry-lookup-package (manifest-entries manifest))) @@ -1202,6 +1208,7 @@ the entries in MANIFEST." (hooks %default-profile-hooks) (locales? #t) (allow-collisions? #f) + (relative-symlinks? #f) system target) "Return a derivation that builds a profile (aka. 'user environment') with the given MANIFEST. The profile includes additional derivations returned by @@ -1213,6 +1220,9 @@ with a different version number.) When LOCALES? is true, the build is performed under a UTF-8 locale; this adds a dependency on the 'glibc-utf8-locales' package. +When RELATIVE-SYMLINKS? is true, use relative file names for symlink targets. +This is one of the things to do for the result to be relocatable. + When TARGET is true, it must be a GNU triplet, and the packages in MANIFEST are cross-built for TARGET." (mlet* %store-monad ((system (if system @@ -1275,6 +1285,9 @@ are cross-built for TARGET." (manifest-entries manifest)))))) (build-profile #$output '#$inputs + #:symlink #$(if relative-symlinks? + #~symlink-relative + #~symlink) #:manifest '#$(manifest->gexp manifest) #:search-paths search-paths)))) diff --git a/guix/scripts/lint.scm b/guix/scripts/lint.scm index 4ec3267007..cd802985dc 100644 --- a/guix/scripts/lint.scm +++ b/guix/scripts/lint.scm @@ -1037,7 +1037,7 @@ them for PACKAGE." (check check-inputs-should-be-native)) (lint-checker (name 'inputs-should-not-be-input) - (description "Identify inputs that should be inputs at all") + (description "Identify inputs that shouldn't be inputs at all") (check check-inputs-should-not-be-an-input-at-all)) (lint-checker (name 'patch-file-names) diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm index 0e09a01496..1e84459e78 100644 --- a/guix/scripts/pack.scm +++ b/guix/scripts/pack.scm @@ -32,6 +32,8 @@ #:use-module (guix packages) #:use-module (guix profiles) #:use-module (guix derivations) + #:use-module (guix search-paths) + #:use-module (guix build-system gnu) #:use-module (guix scripts build) #:use-module (gnu packages) #:use-module (gnu packages bootstrap) @@ -100,11 +102,14 @@ with a properly initialized store database. SYMLINKS must be a list of (SOURCE -> TARGET) tuples denoting symlinks to be added to the pack." (define build - (with-imported-modules '((guix build utils) - (guix build store-copy) - (gnu build install)) + (with-imported-modules (source-module-closure + '((guix build utils) + (guix build union) + (guix build store-copy) + (gnu build install))) #~(begin (use-modules (guix build utils) + ((guix build union) #:select (relative-file-name)) (gnu build install) (srfi srfi-1) (srfi srfi-26) @@ -117,9 +122,17 @@ added to the pack." ;; parent directories. (match-lambda ((source '-> target) - (let ((target (string-append #$profile "/" target))) - `((directory ,(dirname source)) - (,source -> ,target)))))) + (let ((target (string-append #$profile "/" target)) + (parent (dirname source))) + ;; Never add a 'directory' directive for "/" so as to + ;; preserve its ownnership when extracting the archive (see + ;; below), and also because this would lead to adding the + ;; same entries twice in the tarball. + `(,@(if (string=? parent "/") + '() + `((directory ,parent))) + (,source + -> ,(relative-file-name parent target))))))) (define directives ;; Fully-qualified symlinks. @@ -140,9 +153,11 @@ added to the pack." "") #$tar "/bin")) - ;; Note: there is not much to gain here with deduplication and - ;; there is the overhead of the '.links' directory, so turn it - ;; off. + ;; Note: there is not much to gain here with deduplication and there + ;; is the overhead of the '.links' directory, so turn it off. + ;; Furthermore GNU tar < 1.30 sometimes fails to extract tarballs + ;; with hard links: + ;; <http://lists.gnu.org/archive/html/bug-tar/2017-11/msg00009.html>. (populate-single-profile-directory %root #:profile #$profile #:closure "profile" @@ -189,6 +204,8 @@ added to the pack." (filter-map (match-lambda (('directory directory) (string-append "." directory)) + ((source '-> _) + (string-append "." source)) (_ #f)) directives))))))))) @@ -217,11 +234,13 @@ the image." (('gnu rest ...) #t) (rest #f))) + (define defmod 'define-module) ;trick Geiser + (define config ;; (guix config) module for consumption by (guix gcrypt). (scheme-file "gcrypt-config.scm" #~(begin - (define-module (guix config) + (#$defmod (guix config) #:export (%libgcrypt)) ;; XXX: Work around <http://bugs.gnu.org/15602>. @@ -267,6 +286,165 @@ the image." ;;; +;;; Compiling C programs. +;;; + +;; A C compiler. That lowers to a single program that can be passed typical C +;; compiler flags, and it makes sure the whole toolchain is available. +(define-record-type <c-compiler> + (%c-compiler toolchain guile) + c-compiler? + (toolchain c-compiler-toolchain) + (guile c-compiler-guile)) + +(define* (c-compiler #:optional inputs + #:key (guile (default-guile))) + (%c-compiler inputs guile)) + +(define (bootstrap-c-compiler) + "Return the C compiler that uses the bootstrap toolchain. This is used only +by '--bootstrap', for testing purposes." + (define bootstrap-toolchain + (list (first (assoc-ref %bootstrap-inputs "gcc")) + (first (assoc-ref %bootstrap-inputs "binutils")) + (first (assoc-ref %bootstrap-inputs "libc")))) + + (c-compiler bootstrap-toolchain + #:guile %bootstrap-guile)) + +(define-gexp-compiler (c-compiler-compiler (compiler <c-compiler>) system target) + "Lower COMPILER to a single script that does the right thing." + (define toolchain + (or (c-compiler-toolchain compiler) + (list (first (assoc-ref (standard-packages) "gcc")) + (first (assoc-ref (standard-packages) "ld-wrapper")) + (first (assoc-ref (standard-packages) "binutils")) + (first (assoc-ref (standard-packages) "libc")) + (gexp-input (first (assoc-ref (standard-packages) "libc")) + "static")))) + + (define inputs + (match (append-map package-propagated-inputs + (filter package? toolchain)) + (((labels things . _) ...) + (append toolchain things)))) + + (define search-paths + (cons $PATH + (append-map package-native-search-paths + (filter package? inputs)))) + + (define run + (with-imported-modules (source-module-closure + '((guix build utils) + (guix search-paths))) + #~(begin + (use-modules (guix build utils) (guix search-paths) + (ice-9 match)) + + (define (output-file args) + (let loop ((args args)) + (match args + (() "a.out") + (("-o" file _ ...) file) + ((head rest ...) (loop rest))))) + + (set-search-paths (map sexp->search-path-specification + '#$(map search-path-specification->sexp + search-paths)) + '#$inputs) + + (let ((output (output-file (command-line)))) + (apply invoke "gcc" (cdr (command-line))) + (invoke "strip" output))))) + + (when target + ;; TODO: Yep, we'll have to do it someday! + (leave (G_ "cross-compilation not implemented here; +please email '~a'~%") + (@ (guix config) %guix-bug-report-address))) + + (gexp->script "c-compiler" run + #:guile (c-compiler-guile compiler))) + + +;;; +;;; Wrapped package. +;;; + +(define* (wrapped-package package + #:optional (compiler (c-compiler))) + (define runner + (local-file (search-auxiliary-file "run-in-namespace.c"))) + + (define build + (with-imported-modules (source-module-closure + '((guix build utils) + (guix build union))) + #~(begin + (use-modules (guix build utils) + ((guix build union) #:select (relative-file-name)) + (ice-9 ftw) + (ice-9 match)) + + (define (strip-store-prefix file) + ;; Given a file name like "/gnu/store/…-foo-1.2/bin/foo", return + ;; "/bin/foo". + (let* ((len (string-length (%store-directory))) + (base (string-drop file (+ 1 len)))) + (match (string-index base #\/) + (#f base) + (index (string-drop base index))))) + + (define (build-wrapper program) + ;; Build a user-namespace wrapper for PROGRAM. + (format #t "building wrapper for '~a'...~%" program) + (copy-file #$runner "run.c") + + (substitute* "run.c" + (("@WRAPPED_PROGRAM@") program) + (("@STORE_DIRECTORY@") (%store-directory))) + + (let* ((base (strip-store-prefix program)) + (result (string-append #$output "/" base))) + (mkdir-p (dirname result)) + (invoke #$compiler "-std=gnu99" "-static" "-Os" "-g0" "-Wall" + "run.c" "-o" result) + (delete-file "run.c"))) + + (setvbuf (current-output-port) + (cond-expand (guile-2.2 'line) + (else _IOLBF))) + + ;; Link the top-level files of PACKAGE so that search paths are + ;; properly defined in PROFILE/etc/profile. + (mkdir #$output) + (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)) + + (for-each build-wrapper + (append (find-files #$(file-append package "/bin")) + (find-files #$(file-append package "/sbin")) + (find-files #$(file-append package "/libexec"))))))) + + (computed-file (string-append (package-full-name package "-") "R") + build)) + +(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)))) + + +;;; ;;; Command-line options. ;;; @@ -302,6 +480,9 @@ the image." (option '(#\f "format") #t #f (lambda (opt name arg result) (alist-cons 'format (string->symbol arg) result))) + (option '(#\R "relocatable") #f #f + (lambda (opt name arg result) + (alist-cons 'relocatable? #t result))) (option '(#\e "expression") #t #f (lambda (opt name arg result) (alist-cons 'expression arg result))) @@ -354,6 +535,8 @@ Create a bundle of PACKAGE.\n")) (display (G_ " -f, --format=FORMAT build a pack in the given FORMAT")) (display (G_ " + -R, --relocatable produce relocatable executables")) + (display (G_ " -e, --expression=EXPR consider the package EXPR evaluates to")) (display (G_ " -s, --system=SYSTEM attempt to build for SYSTEM--e.g., \"i686-linux\"")) @@ -417,6 +600,9 @@ Create a bundle of PACKAGE.\n")) (with-error-handling (with-store store + ;; Set the build options before we do anything else. + (set-build-options-from-command-line store opts) + (parameterize ((%graft? (assoc-ref opts 'graft?)) (%guile-for-build (package-derivation store @@ -425,7 +611,13 @@ Create a bundle of PACKAGE.\n")) (canonical-package guile-2.2)) #:graft? (assoc-ref opts 'graft?)))) (let* ((dry-run? (assoc-ref opts 'dry-run?)) - (manifest (manifest-from-args store opts)) + (relocatable? (assoc-ref opts 'relocatable?)) + (manifest (let ((manifest (manifest-from-args store opts))) + ;; Note: We cannot honor '--bootstrap' here because + ;; 'glibc-bootstrap' lacks 'libc.a'. + (if relocatable? + (map-manifest-entries wrapped-package manifest) + manifest))) (pack-format (assoc-ref opts 'format)) (name (string-append (symbol->string pack-format) "-pack")) @@ -444,12 +636,10 @@ Create a bundle of PACKAGE.\n")) (leave (G_ "~a: unknown pack format") format)))) (localstatedir? (assoc-ref opts 'localstatedir?))) - ;; Set the build options before we do anything else. - (set-build-options-from-command-line store opts) - (run-with-store store (mlet* %store-monad ((profile (profile-derivation manifest + #:relative-symlinks? relocatable? #:hooks (if bootstrap? '() %default-profile-hooks) diff --git a/guix/search-paths.scm b/guix/search-paths.scm index 4bf0e44389..002e6342bb 100644 --- a/guix/search-paths.scm +++ b/guix/search-paths.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013, 2014, 2015, 2017 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2013, 2014, 2015, 2017, 2018 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -38,7 +38,8 @@ string-tokenize* evaluate-search-paths environment-variable-definition - search-path-definition)) + search-path-definition + set-search-paths)) ;;; Commentary: ;;; @@ -196,4 +197,14 @@ prefix/suffix." #:kind kind #:separator separator)))) +(define* (set-search-paths search-paths directories + #:key (setenv setenv)) + "Set the search path environment variables specified by SEARCH-PATHS for the +given directories." + (for-each (match-lambda + ((spec . value) + (setenv (search-path-specification-variable spec) + value))) + (evaluate-search-paths search-paths directories))) + ;;; search-paths.scm ends here diff --git a/guix/utils.scm b/guix/utils.scm index 92e45de616..e9efea5866 100644 --- a/guix/utils.scm +++ b/guix/utils.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2013, 2014, 2015 Mark H Weaver <mhw@netris.org> ;;; Copyright © 2014 Eric Bavier <bavier@member.fsf.org> ;;; Copyright © 2014 Ian Denhardt <ian@zenhack.net> @@ -84,6 +84,7 @@ version-major+minor version-major guile-version>? + version-prefix? string-replace-substring arguments-from-environment-variable file-extension @@ -521,6 +522,27 @@ minor version numbers from version-string." (micro-version)) str)) +(define version-prefix? + (let ((not-dot (char-set-complement (char-set #\.)))) + (lambda (v1 v2) + "Return true if V1 is a version prefix of V2: + + (version-prefix? \"4.1\" \"4.16.2\") => #f + (version-prefix? \"4.1\" \"4.1.2\") => #t +" + (define (list-prefix? lst1 lst2) + (match lst1 + (() #t) + ((head1 tail1 ...) + (match lst2 + (() #f) + ((head2 tail2 ...) + (and (equal? head1 head2) + (list-prefix? tail1 tail2))))))) + + (list-prefix? (string-tokenize v1 not-dot) + (string-tokenize v2 not-dot))))) + (define (file-extension file) "Return the extension of FILE or #f if there is none." (let ((dot (string-rindex file #\.))) |