diff options
Diffstat (limited to 'guix')
82 files changed, 1277 insertions, 381 deletions
diff --git a/guix/build-system/android-ndk.scm b/guix/build-system/android-ndk.scm index 23e14c7801..b8cd56b871 100644 --- a/guix/build-system/android-ndk.scm +++ b/guix/build-system/android-ndk.scm @@ -31,7 +31,6 @@ (define %android-ndk-build-system-modules ;; Build-side modules imported by default. `((guix build android-ndk-build-system) - (guix build syscalls) ,@%default-gnu-imported-modules)) (define* (android-ndk-build name inputs diff --git a/guix/build-system/ant.scm b/guix/build-system/ant.scm index c8beea010c..9816cc061c 100644 --- a/guix/build-system/ant.scm +++ b/guix/build-system/ant.scm @@ -43,7 +43,6 @@ (guix build maven plugin) (guix build maven pom) (guix build java-utils) - (guix build syscalls) ,@%default-gnu-imported-modules)) (define (default-jdk) @@ -104,6 +103,7 @@ (build-target "jar") (jar-name #f) (main-class #f) + (use-java-modules? #f) (test-include (list "**/*Test.java")) (test-exclude (list "**/Abstract*.java")) (source-dir "src") @@ -132,6 +132,7 @@ #:build-target #$build-target #:jar-name #$jar-name #:main-class #$main-class + #:use-java-modules? #$use-java-modules? #:test-include (list #$@test-include) #:test-exclude (list #$@test-exclude) #:source-dir #$source-dir diff --git a/guix/build-system/clojure.scm b/guix/build-system/clojure.scm index fb897356bc..037fcaf21d 100644 --- a/guix/build-system/clojure.scm +++ b/guix/build-system/clojure.scm @@ -83,8 +83,8 @@ #:clojure #:jdk #:zip))) (if target - (error "No cross-compilation for clojure-build-system yet: LOWER" - target) ; FIXME + #f ; FIXME: No cross-compilation for + ; clojure-build-system yet (bag (name name) (system system) (host-inputs `(,@(if source diff --git a/guix/build-system/dub.scm b/guix/build-system/dub.scm index d53acd96e5..831a34af0d 100644 --- a/guix/build-system/dub.scm +++ b/guix/build-system/dub.scm @@ -59,7 +59,6 @@ (define %dub-build-system-modules ;; Build-side modules imported by default. `((guix build dub-build-system) - (guix build syscalls) ,@%default-gnu-imported-modules)) (define* (dub-build name inputs diff --git a/guix/build-system/go.scm b/guix/build-system/go.scm index b1d589e342..3883fac786 100644 --- a/guix/build-system/go.scm +++ b/guix/build-system/go.scm @@ -3,7 +3,7 @@ ;;; Copyright © 2017 Leo Famulari <leo@famulari.name> ;;; Copyright © 2020 Jakub Kądziołka <kuba@kadziolka.net> ;;; Copyright © 2021-2022 Ludovic Courtès <ludo@gnu.org> -;;; Copyright © 2021 Efraim Flashner <efraim@flashner.co.il> +;;; Copyright © 2021, 2023 Efraim Flashner <efraim@flashner.co.il> ;;; Copyright © 2021 Sarah Morgensen <iskarian@mgsn.dev> ;;; ;;; This file is part of GNU Guix. @@ -114,12 +114,19 @@ commit hash and its date rather than a proper release tag." (let ((go (resolve-interface '(gnu packages golang)))) (module-ref go 'go))) +(define (default-gccgo) + ;; Lazily resolve the binding to avoid a circular dependency. + (let ((gcc (resolve-interface '(gnu packages gcc)))) + (module-ref gcc 'gccgo-12))) + (define (make-go-std) (module-ref (resolve-interface '(gnu packages golang)) 'make-go-std)) (define* (lower name #:key source inputs native-inputs outputs system target - (go (default-go)) + (go (if (supported-package? (default-go)) + (default-go) + (default-gccgo))) #:allow-other-keys #:rest arguments) "Return a bag for NAME." diff --git a/guix/build-system/guile.scm b/guix/build-system/guile.scm index 7ac232bfca..0974fb5042 100644 --- a/guix/build-system/guile.scm +++ b/guix/build-system/guile.scm @@ -88,7 +88,8 @@ (compile-flags %compile-flags) (imported-modules %guile-build-system-modules) (modules '((guix build guile-build-system) - (guix build utils)))) + (guix build utils))) + (substitutable? #t)) "Build SOURCE using Guile taken from the native inputs, and with INPUTS." (define builder (with-imported-modules imported-modules @@ -114,6 +115,7 @@ #:system system #:target #f #:graft? #f + #:substitutable? substitutable? #:guile-for-build guile))) (define* (guile-cross-build name @@ -133,7 +135,8 @@ (compile-flags %compile-flags) (imported-modules %guile-build-system-modules) (modules '((guix build guile-build-system) - (guix build utils)))) + (guix build utils))) + (substitutable? #t)) (define builder (with-imported-modules imported-modules #~(begin @@ -173,6 +176,7 @@ #:system system #:target target #:graft? #f + #:substitutable? substitutable? #:guile-for-build guile))) (define guile-build-system diff --git a/guix/build-system/meson.scm b/guix/build-system/meson.scm index 7c617bffb0..2d14016b94 100644 --- a/guix/build-system/meson.scm +++ b/guix/build-system/meson.scm @@ -182,6 +182,7 @@ TRIPLET." (imported-modules %meson-build-system-modules) (modules '((guix build meson-build-system) (guix build utils))) + (substitutable? #t) allowed-references disallowed-references) "Build SOURCE using MESON, and with INPUTS, assuming that SOURCE @@ -266,6 +267,7 @@ has a 'meson.build' file." (imported-modules %meson-build-system-modules) (modules '((guix build meson-build-system) (guix build utils))) + (substitutable? #t) allowed-references disallowed-references) "Cross-build SOURCE for TARGET using MESON, and with INPUTS, assuming that diff --git a/guix/build-system/minify.scm b/guix/build-system/minify.scm index 21c17d1eb1..98c6e75980 100644 --- a/guix/build-system/minify.scm +++ b/guix/build-system/minify.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2017, 2018 Ricardo Wurmus <rekado@elephly.net> +;;; Copyright © 2017, 2018, 2023 Ricardo Wurmus <rekado@elephly.net> ;;; Copyright © 2021 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. @@ -41,15 +41,15 @@ `((guix build minify-build-system) ,@%default-gnu-imported-modules)) -(define (default-uglify-js) +(define (default-esbuild) "Return the default package to minify JavaScript source files." ;; Lazily resolve the binding to avoid a circular dependency. - (let ((mod (resolve-interface '(gnu packages uglifyjs)))) - (module-ref mod 'uglifyjs))) + (let ((mod (resolve-interface '(gnu packages web)))) + (module-ref mod 'esbuild))) (define* (lower name #:key source inputs native-inputs outputs system - (uglify-js (default-uglify-js)) + (esbuild (default-esbuild)) #:allow-other-keys #:rest arguments) "Return a bag for NAME." @@ -64,7 +64,7 @@ '()) ,@inputs ,@(standard-packages))) - (build-inputs `(("uglify-js" ,uglify-js) + (build-inputs `(("esbuild" ,esbuild) ,@native-inputs)) (outputs outputs) (build minify-build) diff --git a/guix/build-system/r.scm b/guix/build-system/r.scm index 93acb6ab49..0e6c1d8577 100644 --- a/guix/build-system/r.scm +++ b/guix/build-system/r.scm @@ -60,7 +60,7 @@ release corresponding to NAME and VERSION." "/src/contrib/" name "_" version ".tar.gz") ;; TODO: use %bioconductor-version from (guix import cran) - (string-append "https://bioconductor.org/packages/3.17" + (string-append "https://bioconductor.org/packages/3.18" type-url-part "/src/contrib/" name "_" version ".tar.gz")))) diff --git a/guix/build-system/vim.scm b/guix/build-system/vim.scm new file mode 100644 index 0000000000..dddf7ea14b --- /dev/null +++ b/guix/build-system/vim.scm @@ -0,0 +1,170 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2022 Jonathan Scoresby <me@jonscoresby.com> +;;; Copyright © 2023 Efraim Flashner <efraim@flashner.co.il> +;;; +;;; 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 vim) + #:use-module (guix store) + #:use-module (guix utils) + #:use-module (guix gexp) + #:use-module (guix monads) + #:use-module (guix packages) + #:use-module (guix search-paths) + #:use-module (guix build-system) + #:use-module (guix build-system copy) + #:use-module (guix build-system gnu) + #:export (%vim-build-system-modules vim-build vim-build-system)) + +;; Commentary: +;; +;; Standard package installer for vim and neovim plugins. +;; This is implemented as an extension of the `copy-build-system' +;; and takes advantage of vim and neovim's built-in package manager. +;; It extends the installation procedure from the copy-build-system +;; to put files in the correct place and then generates help tags. +;; +;; Code: + +(define %vim-build-system-modules + ;; Build-side modules imported by default. + `((guix build vim-build-system) + ,@%copy-build-system-modules)) + +(define (default-vim) + "Return the default Vim package." + ;; Lazily resolve the binding to avoid a circular dependency. + (let ((vim (resolve-interface '(gnu packages vim)))) + (module-ref vim 'vim))) + +(define (default-neovim) + "Return the default Neovim package." + (let ((vim (resolve-interface '(gnu packages vim)))) + (module-ref vim 'neovim))) + +(define* (lower name + #:key source + inputs + native-inputs + outputs + system + target + (vim? #f) + (neovim? #f) + (plugin-name name) + (vim (default-vim)) + (neovim (default-neovim)) + #:allow-other-keys #:rest arguments) + "Return a bag for NAME." + (let* ((private-keywords '(#:target #:vim #:neovim #:inputs #:native-inputs)) + (vim? (or (string-prefix? "vim-" name) + vim?)) + (neovim? (or (string-prefix? "neovim-" name) + neovim?)) + (vim-inputs (append (if vim? + `(("vim" ,vim)) + '()) + (if neovim? + `(("neovim" ,neovim)) + '()))) + (vim-arguments (append arguments + `(#:vim? ,vim? + #:neovim? ,neovim?)))) + (bag (name name) + (system system) + (host-inputs `(,@(if source + `(("source" ,source)) + '()) ,@inputs + + ;; Keep the standard inputs of 'gnu-build-system'. + ,@(standard-packages))) + (build-inputs `(,@vim-inputs ,@native-inputs)) + (outputs outputs) + (build vim-build) + (arguments (strip-keyword-arguments private-keywords vim-arguments))))) + +(define* (vim-build name inputs + #:key guile + source + (vim? #f) + (neovim? #f) + (mode "start") + (plugin-name name) + (install-plan ''()) + (phases '(@ (guix build vim-build-system) %standard-phases)) + (outputs '("out")) + (out-of-source? #t) + (tests? #t) + (validate-runpath? #t) + (patch-shebangs? #t) + (strip-binaries? #t) + (strip-flags %strip-flags) + (strip-directories %strip-directories) + (search-paths '()) + (system (%current-system)) + (substitutable? #t) + (imported-modules %vim-build-system-modules) + (modules '((guix build vim-build-system) + (guix build utils)))) + + (define build + (with-imported-modules imported-modules + #~(begin + (use-modules #$@modules) + #$(with-build-variables inputs outputs + #~(vim-build #:name #$name + #:vim? #$vim? + #:neovim? #$neovim? + #:mode #$mode + #:plugin-name #$plugin-name + #:install-plan #$(if (pair? install-plan) + (sexp->gexp install-plan) + install-plan) + #:source #+source + #:system #$system + #:phases #$(if (pair? phases) + (sexp->gexp phases) + phases) + #:outputs %outputs + #:search-paths '#$(sexp->gexp + (map search-path-specification->sexp + search-paths)) + #:inputs %build-inputs + #:out-of-source? #$out-of-source? + #:tests? #$tests? + #:validate-runpath? #$validate-runpath? + #:patch-shebangs? #$patch-shebangs? + #:strip-binaries? #$strip-binaries? + #:strip-flags #$strip-flags + #:strip-directories #$strip-directories))))) + + (mlet %store-monad + ((guile (package->derivation (or guile (default-guile)) + system #:graft? #f))) + (gexp->derivation name + build + #:system system + #:target #f + #:graft? #f + #:substitutable? substitutable? + #:guile-for-build guile))) + +(define vim-build-system + (build-system (name 'vim) + (description "The standard Vim build system") + (lower lower))) + +;;; vim.scm ends here diff --git a/guix/build-system/zig.scm b/guix/build-system/zig.scm new file mode 100644 index 0000000000..41751f9116 --- /dev/null +++ b/guix/build-system/zig.scm @@ -0,0 +1,124 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2023 Ekaitz Zarraga <ekaitz@elenq.tech> +;;; +;;; 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 zig) + #:use-module (guix search-paths) + #:use-module (guix store) + #:use-module (guix utils) + #:use-module (guix gexp) + #:use-module (guix monads) + #: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 (zig-build-system)) + + +(define (default-zig) + "Return the default zig package." + ;; Lazily resolve the binding to avoid a circular dependency. + (let ((zig (resolve-interface '(gnu packages zig)))) + (module-ref zig 'zig))) + +(define %zig-build-system-modules + ;; Build-side modules imported by default. + `((guix build zig-build-system) + (guix build syscalls) + ,@%default-gnu-imported-modules)) + +(define* (zig-build name inputs + #:key + source + (tests? #t) + (test-target #f) + (zig-build-flags ''()) + (zig-test-flags ''()) + (zig-release-type #f) + (phases '%standard-phases) + (outputs '("out")) + (search-paths '()) + (system (%current-system)) + (guile #f) + (imported-modules %zig-build-system-modules) + (modules '((guix build zig-build-system) + (guix build utils)))) + "Build SOURCE using Zig, and with INPUTS." + (define builder + (with-imported-modules imported-modules + #~(begin + (use-modules #$@(sexp->gexp modules)) + (zig-build #:name #$name + #:source #+source + #:system #$system + #:test-target #$test-target + #:zig-build-flags #$zig-build-flags + #:zig-test-flags #$zig-test-flags + #:zig-release-type #$zig-release-type + #:tests? #$tests? + #:phases #$phases + #:outputs #$(outputs->gexp outputs) + #:search-paths '#$(sexp->gexp + (map search-path-specification->sexp + search-paths)) + #:inputs #$(input-tuples->gexp inputs))))) + + (mlet %store-monad ((guile (package->derivation (or guile (default-guile)) + system #:graft? #f))) + (gexp->derivation name builder + #:system system + #:guile-for-build guile))) + +(define* (lower name + #:key source inputs native-inputs outputs system target + (zig (default-zig)) + #:allow-other-keys + #:rest arguments) + "Return a bag for NAME." + + (define private-keywords + '(#:target #:zig #:inputs #:native-inputs #:outputs)) + + ;; TODO: support cross-compilation + ;; It's as simple as adding some build flags to `zig-build-flags` + ;; -Dtarget=aarch64-linux-musl, for example. + (and (not target) + (bag + (name name) + (system system) + (target target) + (host-inputs `(,@(if source + `(("source" ,source)) + '()) + ,@inputs + + ;; Keep the standard inputs of 'gnu-build-system' + ;; TODO: do we need this? + ,@(standard-packages))) + (build-inputs `(("zig" ,zig) + ,@native-inputs)) + (outputs outputs) + (build zig-build) + (arguments (strip-keyword-arguments private-keywords arguments))))) + +(define zig-build-system + (build-system + (name 'zig) + (description + "Zig build system, to build Zig packages") + (lower lower))) diff --git a/guix/build/ant-build-system.scm b/guix/build/ant-build-system.scm index d29912bf59..ced34177f4 100644 --- a/guix/build/ant-build-system.scm +++ b/guix/build/ant-build-system.scm @@ -37,6 +37,7 @@ (define* (default-build.xml jar-name prefix #:optional (source-dir ".") (test-dir "./test") (main-class #f) + (use-java-modules? #f) (test-include '("**/*Test.java")) (test-exclude '("**/Abstract*Test.java"))) "Create a simple build.xml with standard targets for Ant." @@ -65,7 +66,7 @@ (value "first"))) (property (@ (environment "env"))) (path (@ (id "classpath")) - (pathelement (@ (location "${env.CLASSPATH}")))) + (pathelement (@ (path "${env.CLASSPATH}")))) (target (@ (name "manifest")) (mkdir (@ (dir "${manifest.dir}"))) @@ -79,18 +80,30 @@ (mkdir (@ (dir "${classes.dir}"))) (javac (@ (includeantruntime "false") (srcdir ,source-dir) - (destdir "${classes.dir}") - (classpath (@ (refid "classpath")))))) + (destdir "${classes.dir}")) + ,(if use-java-modules? + `((modulepath (@ (refid "classpath")))) + '()) + (classpath (@ (refid "classpath"))))) (target (@ (name "compile-tests")) (mkdir (@ (dir "${test.classes.dir}"))) (javac (@ (includeantruntime "false") (srcdir ,test-dir) (destdir "${test.classes.dir}")) - (classpath - (pathelement (@ (path "${env.CLASSPATH}"))) - (pathelement (@ (location "${classes.dir}"))) - (pathelement (@ (location "${test.classes.dir}")))))) + ,(if use-java-modules? + `((classpath + (pathelement + (@ (path "${env.CLASSPATH}"))) + (pathelement + (@ (location "${classes.dir}"))) + (pathelement + (@ (location "${test.classes.dir}"))))) + '()) + (classpath + (pathelement (@ (path "${env.CLASSPATH}"))) + (pathelement (@ (location "${classes.dir}"))) + (pathelement (@ (location "${test.classes.dir}")))))) (target (@ (name "check") (depends "compile-tests")) @@ -156,13 +169,15 @@ to the default GNU unpack strategy." (source-dir "src") (test-dir "src/test") (main-class #f) + (use-java-modules? #f) (test-include '("**/*Test.java")) (test-exclude '("**/Abstract*.java")) #:allow-other-keys) (when jar-name (default-build.xml jar-name (string-append (assoc-ref outputs "out") "/share/java") - source-dir test-dir main-class test-include test-exclude)) + source-dir test-dir main-class use-java-modules? + test-include test-exclude)) (setenv "JAVA_HOME" (assoc-ref inputs "jdk")) (setenv "CLASSPATH" (generate-classpath inputs)) #t) diff --git a/guix/build/cargo-build-system.scm b/guix/build/cargo-build-system.scm index fbba554e9b..505c0b4b01 100644 --- a/guix/build/cargo-build-system.scm +++ b/guix/build/cargo-build-system.scm @@ -111,6 +111,13 @@ Cargo.toml file present at its root." (define (rust-package? name) (string-prefix? "rust-" name)) +(define* (check-for-pregenerated-files #:rest _) + "Check the source code for files which are known to generally be bundled +libraries or executables." + (let ((pregenerated-files (find-files "." "\\.(a|dll|dylib|exe|lib)$"))) + (when (not (null-list? pregenerated-files)) + (error "Possible pre-generated files found:" pregenerated-files)))) + (define* (configure #:key inputs (vendor-dir "guix-vendor") #:allow-other-keys) @@ -224,10 +231,10 @@ directory = '" port) (for-each (lambda (file) (make-file-writable file) - ;; Strip the hash and replace '.tar.gz' with '.crate'. + ;; Strip the hash and rust prefix and replace '.tar.gz' with '.crate'. (rename-file file (string-append (string-drop-right - (string-drop file 35) + (string-drop file 40) (string-length ".tar.gz")) ".crate"))) (find-files "." "\\.tar\\.gz$")))) @@ -235,7 +242,32 @@ directory = '" port) ;;error: invalid inclusion of reserved file name Cargo.toml.orig in package source (when (file-exists? "Cargo.toml.orig") (delete-file "Cargo.toml.orig")) - (apply invoke `("cargo" "package" ,@cargo-package-flags)))) + (apply invoke `("cargo" "package" ,@cargo-package-flags)) + + ;; Then unpack the crate, reset the timestamp of all contained files, and + ;; repack them. This is necessary to ensure that they are reproducible. + (with-directory-excursion "target/package" + (for-each + (lambda (crate) + (invoke "tar" "xf" crate) + (delete-file crate) + ;; Some of the crate names have underscores, so we need to + ;; search the current directory to find the unpacked crate. + (let ((dir + (car (scandir "." + (lambda (file) + (and (not (member file '("." ".."))) + (not (string-suffix? ".crate" file)))))))) + ;; XXX: copied from (gnu build install) + (for-each (lambda (file) + (let ((s (lstat file))) + (unless (eq? (stat:type s) 'symlink) + (utime file 0 0 0 0)))) + (find-files dir #:directories? #t)) + (apply invoke "tar" "czf" (string-append dir ".crate") + (find-files dir #:directories? #t)) + (delete-file-recursively dir))) + (find-files "." "\\.crate$"))))) (format #t "Not installing cargo sources, skipping `cargo package`.~%")) #t) @@ -285,7 +317,8 @@ directory = '" port) (replace 'check check) (replace 'install install) (add-after 'build 'package package) - (add-after 'unpack 'unpack-rust-crates unpack-rust-crates) + (add-after 'unpack 'check-for-pregenerated-files check-for-pregenerated-files) + (add-after 'check-for-pregenerated-files 'unpack-rust-crates unpack-rust-crates) (add-after 'patch-generated-file-shebangs 'patch-cargo-checksums patch-cargo-checksums))) (define* (cargo-build #:key inputs (phases %standard-phases) diff --git a/guix/build/git.scm b/guix/build/git.scm index 0ff263c81b..867cade2c4 100644 --- a/guix/build/git.scm +++ b/guix/build/git.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2014, 2016, 2019, 2023 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2023 Maxim Cournoyer <maxim.cournoyer@gmail.com> ;;; ;;; This file is part of GNU Guix. ;;; @@ -33,10 +34,13 @@ ;;; Code: (define* (git-fetch url commit directory - #:key (git-command "git") recursive?) + #:key (git-command "git") + lfs? recursive?) "Fetch COMMIT from URL into DIRECTORY. COMMIT must be a valid Git commit -identifier. When RECURSIVE? is true, all the sub-modules of URL are fetched, -recursively. Return #t on success, #f otherwise." +identifier. When LFS? is true, configure Git to also fetch Large File +Storage (LFS) files; it assumes that the @code{git-lfs} extension is available +in the environment. When RECURSIVE? is true, all the sub-modules of URL are +fetched, recursively. Return #t on success, #f otherwise." ;; Disable TLS certificate verification. The hash of the checkout is known ;; in advance anyway. @@ -57,6 +61,11 @@ recursively. Return #t on success, #f otherwise." (with-directory-excursion directory (invoke git-command "init" "--initial-branch=main") (invoke git-command "remote" "add" "origin" url) + + (when lfs? + (setenv "HOME" "/tmp") + (invoke git-command "lfs" "install")) + (if (zero? (system* git-command "fetch" "--depth" "1" "origin" commit)) (invoke git-command "checkout" "FETCH_HEAD") (begin @@ -81,11 +90,13 @@ recursively. Return #t on success, #f otherwise." (define* (git-fetch-with-fallback url commit directory - #:key (git-command "git") recursive?) + #:key (git-command "git") + lfs? recursive?) "Like 'git-fetch', fetch COMMIT from URL into DIRECTORY, but fall back to alternative methods when fetching from URL fails: attempt to download a nar, and if that also fails, download from the Software Heritage archive." (or (git-fetch url commit directory + #:lfs? lfs? #:recursive? recursive? #:git-command git-command) (download-nar directory) diff --git a/guix/build/guile-build-system.scm b/guix/build/guile-build-system.scm index 32a431d347..e7e7f2d0be 100644 --- a/guix/build/guile-build-system.scm +++ b/guix/build/guile-build-system.scm @@ -28,6 +28,7 @@ #:use-module (ice-9 format) #:use-module (guix build utils) #:export (target-guile-effective-version + target-guile-scm+go %standard-phases guile-build)) @@ -44,7 +45,17 @@ Return #false if it cannot be determined." (string? line) line))) -(define (file-sans-extension file) ;TODO: factorize +(define* (target-guile-scm+go output #:optional guile) + "Return paths under `output' for scm and go files for effective version of +GUILE or whichever `guile' is in $PATH. Raises an error if they cannot be +determined." + (let* ((version (or (target-guile-effective-version guile) + (error "Cannot determine the effective target guile version."))) + (scm (string-append output "/share/guile/site/" version)) + (go (string-append output "/lib/guile/" version "/site-ccache"))) + (values scm go))) + +(define (file-sans-extension file) ;TODO: factorize "Return the substring of FILE without its extension, if any." (let ((dot (string-rindex file #\.))) (if dot diff --git a/guix/build/minetest-build-system.scm b/guix/build/minetest-build-system.scm index 4a7a87ab83..3bf083e004 100644 --- a/guix/build/minetest-build-system.scm +++ b/guix/build/minetest-build-system.scm @@ -126,7 +126,8 @@ If it is unknown, make an educated guess." (/ total-old-size (expt 1024 2)) (/ total-new-size (expt 1024 2))))))) -(define name-regexp (make-regexp "^name[ ]*=(.+)$")) +(define name-regexp + (make-regexp "^name[[:space:]]*=[[:space:]]*([[:graph:]]+)[[:space:]]*$")) (define* (read-mod-name mod.conf #:optional not-found) "Read the name of a mod from MOD.CONF. If MOD.CONF diff --git a/guix/build/minify-build-system.scm b/guix/build/minify-build-system.scm index 5789ca3f0f..ea2428fa76 100644 --- a/guix/build/minify-build-system.scm +++ b/guix/build/minify-build-system.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2016 Ricardo Wurmus <rekado@elephly.net> +;;; Copyright © 2016, 2023 Ricardo Wurmus <rekado@elephly.net> ;;; Copyright © 2020 Efraim Flashner <efraim@flashner.co.il> ;;; ;;; This file is part of GNU Guix. @@ -24,7 +24,6 @@ #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) #:use-module (ice-9 match) - #:use-module (ice-9 popen) #:export (%standard-phases minify-build minify)) @@ -39,14 +38,9 @@ (define* (minify file #:key target (directory "")) (format #t "minifying ~a\n" file) (let* ((base (basename file ".js")) - (installed (or target (string-append directory base ".min.js"))) - (minified (open-pipe* OPEN_READ "uglifyjs" file))) - (call-with-output-file installed - (cut dump-port minified <>)) - (match (close-pipe minified) - (0 #t) - (status - (error "uglify-js failed" status))))) + (installed (or target (string-append directory base ".min.js")))) + (invoke "esbuild" file "--minify" + (string-append "--outfile=" installed)))) (define* (build #:key javascript-files #:allow-other-keys) diff --git a/guix/build/syscalls.scm b/guix/build/syscalls.scm index d947b010d3..4afe6d2f87 100644 --- a/guix/build/syscalls.scm +++ b/guix/build/syscalls.scm @@ -192,6 +192,7 @@ terminal-window-size terminal-columns terminal-rows + terminal-string-width openpty login-tty @@ -836,7 +837,8 @@ fdatasync(2) on the underlying file descriptor." (define-syntax fsword ;fsword_t (identifier-syntax long)) -(define linux? (string-contains %host-type "linux-gnu")) +(define musl-libc? (string-contains %host-type "linux-musl")) +(define linux? (string-contains %host-type "linux-")) (define-syntax define-statfs-flags (syntax-rules (linux hurd) @@ -905,7 +907,7 @@ fdatasync(2) on the underlying file descriptor." (spare (array fsword 4))) (define statfs - (let ((proc (syscall->procedure int "statfs64" '(* *)))) + (let ((proc (syscall->procedure int (if musl-libc? "statfs" "statfs64") '(* *)))) (lambda (file) "Return a <file-system> data structure describing the file system mounted at FILE." @@ -1232,7 +1234,7 @@ system to PUT-OLD." (define (readdir-procedure name-field-offset sizeof-dirent-header read-dirent-header) - (let ((proc (syscall->procedure '* "readdir64" '(*)))) + (let ((proc (syscall->procedure '* (if musl-libc? "readdir" "readdir64") '(*)))) (lambda* (directory #:optional (pointer->string pointer->string/utf-8)) (let ((ptr (proc directory))) (and (not (null-pointer? ptr)) @@ -1244,7 +1246,7 @@ system to PUT-OLD." (define readdir* ;; Decide at run time which one must be used. - (if (string-contains %host-type "linux-gnu") + (if linux? (readdir-procedure (c-struct-field-offset %struct-dirent-header/linux name) sizeof-dirent-header/linux @@ -1664,7 +1666,7 @@ bytevector BV at INDEX." (error "unsupported socket address" sockaddr))))) (define write-socket-address! - (if (string-contains %host-type "linux-gnu") + (if linux? write-socket-address!/linux write-socket-address!/hurd)) @@ -1696,7 +1698,7 @@ bytevector BV at INDEX." (vector family))))) (define read-socket-address - (if (string-contains %host-type "linux-gnu") + (if linux? read-socket-address/linux read-socket-address/hurd)) @@ -2335,6 +2337,26 @@ PORT, trying to guess a reasonable value if all else fails. The result is always a positive integer." (terminal-dimension window-size-rows port (const 25))) +(define terminal-string-width + (let ((mbstowcs (and=> (false-if-exception + (dynamic-func "mbstowcs" (dynamic-link))) + (cute pointer->procedure int <> (list '* '* size_t)))) + (wcswidth (and=> (false-if-exception + (dynamic-func "wcswidth" (dynamic-link))) + (cute pointer->procedure int <> (list '* size_t))))) + (if (and mbstowcs wcswidth) + (lambda (str) + "Return the width of a string as it would be printed on the terminal. +This procedure accounts for characters that have a different width than 1, such +as CJK double-width characters." + (let ((wchar (make-bytevector (* (+ (string-length str) 1) 4)))) + (mbstowcs (bytevector->pointer wchar) + (string->pointer str) + (string-length str)) + (wcswidth (bytevector->pointer wchar) + (string-length str)))) + string-length))) ;using a statically-linked Guile + (define openpty (let ((proc (syscall->procedure int "openpty" '(* * * * *) #:library "libutil"))) diff --git a/guix/build/vim-build-system.scm b/guix/build/vim-build-system.scm new file mode 100644 index 0000000000..e11965cc27 --- /dev/null +++ b/guix/build/vim-build-system.scm @@ -0,0 +1,119 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2022 Jonathan Scoresby <me@jonscoresby.com> +;;; Copyright © 2023 Efraim Flashner <efraim@flashner.co.il> +;;; +;;; 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 vim-build-system) + #:use-module ((guix build copy-build-system) + #:prefix copy:) + #:use-module (guix build utils) + #:use-module (ice-9 match) + #:use-module (ice-9 ftw) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-26) + #:export (%standard-phases vim-build)) + +;; Commentary: +;; +;; System for installing vim and neovim plugins. It downloads +;; the source and copies the appropriate files to vim and nvim +;; packpaths. It then generates helptags. +;; +;; Code: + +(define copy:install + (assoc-ref copy:%standard-phases 'install)) + +(define vim-path + "/share/vim/vimfiles/pack/guix/") +(define nvim-path + "/share/nvim/site/pack/guix/") + +(define* (install #:key plugin-name + install-plan + neovim? + vim? + mode + outputs + #:allow-other-keys) + + (let* ((include-regexp '(".*\\/.*\\/.*")) + (exclude-regexp '("^scripts/.*" + "tests?/.*" "^t/.*" + "assets/.*" + ".*\\/\\..*")) + (vim-install + (if vim? + `(("." ,(string-append vim-path mode "/" plugin-name "/") + #:include-regexp ,include-regexp + #:exclude-regexp ,exclude-regexp)) + '())) + (neovim-install + (if neovim? + `(("." ,(string-append nvim-path mode "/" plugin-name "/") + #:include-regexp ,include-regexp + #:exclude-regexp ,exclude-regexp)) + '()))) + (copy:install #:outputs outputs + #:install-plan (append vim-install + neovim-install + install-plan)))) + +(define* (generate-helptags #:key plugin-name + neovim? + vim? + mode + outputs + #:allow-other-keys) + + (define (vim-generate-helptags output) + (invoke "vim" "--clean" "-en" "--cmd" + (string-append "helptags " + output vim-path mode "/" plugin-name "/doc") + "--cmd" "q")) + + (define (neovim-generate-helptags output) + (invoke "nvim" "--clean" "--headless" "-en" "--cmd" + (string-append "helptags " + output nvim-path mode "/" plugin-name "/doc") + "--cmd" "q")) + + (when (scandir "./doc") + (let ((out (assoc-ref outputs "out"))) + (when vim? + (vim-generate-helptags out)) + (when neovim? + (neovim-generate-helptags out))))) + +(define %standard-phases + ;; Everything is as with the Copy Build System except for + ;; the addition of the generate-helptags phase and a few + ;; custom actions are added to the install phase + (modify-phases copy:%standard-phases + (replace 'install install) + (add-after 'install 'generate-helptags generate-helptags))) + +(define* (vim-build #:key inputs + (phases %standard-phases) + #:allow-other-keys #:rest args) + "Build the given package, applying all of PHASES in order." + (apply copy:copy-build + #:inputs inputs + #:phases phases + args)) + +;;; vim-build-system.scm ends here diff --git a/guix/build/zig-build-system.scm b/guix/build/zig-build-system.scm new file mode 100644 index 0000000000..d414ebfb17 --- /dev/null +++ b/guix/build/zig-build-system.scm @@ -0,0 +1,100 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2023 Ekaitz Zarraga <ekaitz@elenq.tech> +;;; +;;; 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 zig-build-system) + #:use-module ((guix build gnu-build-system) #:prefix gnu:) + #: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 + zig-build)) + +;; Interesting guide here: +;; https://github.com/riverwm/river/blob/master/PACKAGING.md +(define global-cache-dir "zig-cache") + +(define* (set-cc #:rest args) + ;; TODO: Zig needs the gcc-toolchain in order to find the libc. + ;; we need to think about how to solve this in the build system + ;; directly: --libc + (setenv "CC" "gcc")) + +(define* (set-zig-global-cache-dir #:rest args) + (setenv "ZIG_GLOBAL_CACHE_DIR" global-cache-dir)) + +(define* (build #:key + zig-build-flags + zig-release-type ;; "safe", "fast" or "small" empty for a + ;; debug build" + #:allow-other-keys) + "Build a given Zig package." + + (setenv "DESTDIR" "out") + (let ((call `("zig" "build" + "--prefix" "" ;; Don't add /usr + "--prefix-lib-dir" "lib" + "--prefix-exe-dir" "bin" + "--prefix-include-dir" "include" + ,@(if zig-release-type + (list (string-append "-Drelease-" zig-release-type)) + '()) + ,@zig-build-flags))) + (format #t "running: ~s~%" call) + (apply invoke call))) + +(define* (check #:key tests? + zig-test-flags + #:allow-other-keys) + "Run all the tests" + (when tests? + (let ((old-destdir (getenv "DESTDIR"))) + (setenv "DESTDIR" "test-out") ;; Avoid colisions with the build output + (let ((call `("zig" "build" "test" + ,@zig-test-flags))) + (format #t "running: ~s~%" call) + (apply invoke call)) + (if old-destdir + (setenv "DESTDIR" old-destdir) + (unsetenv "DESTDIR"))))) + +(define* (install #:key inputs outputs #:allow-other-keys) + "Install a given Zig package." + (let ((out (assoc-ref outputs "out"))) + (copy-recursively "out" out))) + +(define %standard-phases + (modify-phases gnu:%standard-phases + (delete 'bootstrap) + (delete 'configure) + (add-before 'build 'set-zig-global-cache-dir set-zig-global-cache-dir) + (add-before 'build 'set-cc set-cc) + (replace 'build build) + (replace 'check check) + (replace 'install install))) + + +(define* (zig-build #:key inputs (phases %standard-phases) + #:allow-other-keys #:rest args) + "Build the given Zig package, applying all of PHASES in order." + (apply gnu:gnu-build #:inputs inputs #:phases phases args)) diff --git a/guix/channels.scm b/guix/channels.scm index 681adafc6c..f01903642d 100644 --- a/guix/channels.scm +++ b/guix/channels.scm @@ -926,7 +926,7 @@ specified." (entries -> (map instance->entry instances derivations))) (return (manifest entries)))) -(define (package-cache-file manifest) +(define* (package-cache-file manifest #:optional system) "Build a package cache file for the instance in MANIFEST. This is meant to be used as a profile hook." ;; Note: Emit a profile in format version 3, which was introduced in 2017 @@ -961,6 +961,7 @@ be used as a profile hook." (gexp->derivation-in-inferior "guix-package-cache" build profile + #:system system ;; If the Guix in PROFILE is too old and ;; lacks 'guix repl', don't build the cache diff --git a/guix/download.scm b/guix/download.scm index 31a41e8183..38f5141cb9 100644 --- a/guix/download.scm +++ b/guix/download.scm @@ -129,7 +129,7 @@ "ftp://ftp.hu.netfilter.org/" "ftp://www.lt.netfilter.org/pub/") (kernel.org - "http://linux-kernel.uio.no/pub/" + "https://cdn.kernel.org/pub/" "http://ftp.be.debian.org/pub/" "https://mirrors.edge.kernel.org/pub/" "ftp://ftp.funet.fi/pub/mirrors/ftp.kernel.org/pub/") diff --git a/guix/git-download.scm b/guix/git-download.scm index 5d5d73dc6b..3de6ae970d 100644 --- a/guix/git-download.scm +++ b/guix/git-download.scm @@ -4,6 +4,7 @@ ;;; Copyright © 2017 Christopher Baines <mail@cbaines.net> ;;; Copyright © 2020 Jakub Kądziołka <kuba@kadziolka.net> ;;; Copyright © 2023 Simon Tournier <zimon.toutoune@gmail.com> +;;; Copyright © 2023 Maxim Cournoyer <maxim.cournoyer@gmail.com> ;;; ;;; This file is part of GNU Guix. ;;; @@ -54,6 +55,7 @@ git-reference-recursive? git-fetch + git-fetch/lfs git-version git-file-name git-predicate)) @@ -79,30 +81,36 @@ (let ((distro (resolve-interface '(gnu packages version-control)))) (module-ref distro 'git-minimal))) -(define* (git-fetch/in-band ref hash-algo hash - #:optional name - #:key (system (%current-system)) - (guile (default-guile)) - (git (git-package))) - "Return a fixed-output derivation that performs a Git checkout of REF, using -GIT and GUILE (thus, said derivation depends on GIT and GUILE). +(define (git-lfs-package) + "Return the default 'git-lfs' package." + (let ((distro (resolve-interface '(gnu packages version-control)))) + (module-ref distro 'git-lfs))) -This method is deprecated in favor of the \"builtin:git-download\" builder. -It will be removed when versions of guix-daemon implementing -\"builtin:git-download\" will be sufficiently widespread." +(define* (git-fetch/in-band* ref hash-algo hash + #:optional name + #:key (system (%current-system)) + (guile (default-guile)) + (git (git-package)) + git-lfs) + "Shared implementation code for git-fetch/in-band & friends. Refer to their +respective documentation." (define inputs - `(("git" ,(or git (git-package))) - - ;; When doing 'git clone --recursive', we need sed, grep, etc. to be - ;; available so that 'git submodule' works. + `(,(or git (git-package)) + ,@(if git-lfs + (list git-lfs) + '()) ,@(if (git-reference-recursive? ref) - (standard-packages) + ;; TODO: remove (standard-packages) after + ;; 48e528a26f9c019eeaccf5e3de3126aa02c98d3b is merged into master; + ;; currently when doing 'git clone --recursive', we need sed, grep, + ;; etc. to be available so that 'git submodule' works. + (map second (standard-packages)) ;; The 'swh-download' procedure requires tar and gzip. - `(("gzip" ,(module-ref (resolve-interface '(gnu packages compression)) - 'gzip)) - ("tar" ,(module-ref (resolve-interface '(gnu packages base)) - 'tar)))))) + (list (module-ref (resolve-interface '(gnu packages compression)) + 'gzip) + (module-ref (resolve-interface '(gnu packages base)) + 'tar))))) (define guile-json (module-ref (resolve-interface '(gnu packages guile)) 'guile-json-4)) @@ -126,7 +134,7 @@ It will be removed when versions of guix-daemon implementing (define build (with-imported-modules modules - (with-extensions (list guile-json gnutls ;for (guix swh) + (with-extensions (list guile-json gnutls ;for (guix swh) guile-lzlib) #~(begin (use-modules (guix build git) @@ -134,6 +142,9 @@ It will be removed when versions of guix-daemon implementing #:select (set-path-environment-variable)) (ice-9 match)) + (define lfs? + (call-with-input-string (getenv "git lfs?") read)) + (define recursive? (call-with-input-string (getenv "git recursive?") read)) @@ -144,18 +155,17 @@ It will be removed when versions of guix-daemon implementing #+(file-append glibc-locales "/lib/locale")) (setlocale LC_ALL "en_US.utf8") - ;; The 'git submodule' commands expects Coreutils, sed, - ;; grep, etc. to be in $PATH. - (set-path-environment-variable "PATH" '("bin") - (match '#+inputs - (((names dirs outputs ...) ...) - dirs))) + ;; The 'git submodule' commands expects Coreutils, sed, grep, + ;; etc. to be in $PATH. This also ensures that git extensions are + ;; found. + (set-path-environment-variable "PATH" '("bin") '#+inputs) (setvbuf (current-output-port) 'line) (setvbuf (current-error-port) 'line) (git-fetch-with-fallback (getenv "git url") (getenv "git commit") #$output + #:lfs? lfs? #:recursive? recursive? #:git-command "git"))))) @@ -175,18 +185,49 @@ It will be removed when versions of guix-daemon implementing (git-reference-url ref)))) ("git commit" . ,(git-reference-commit ref)) ("git recursive?" . ,(object->string - (git-reference-recursive? ref)))) + (git-reference-recursive? ref))) + ("git lfs?" . ,(if git-lfs "#t" "#f"))) #:leaked-env-vars '("http_proxy" "https_proxy" "LC_ALL" "LC_MESSAGES" "LANG" "COLUMNS") #:system system - #:local-build? #t ;don't offload repo cloning + #:local-build? #t ;don't offload repo cloning #:hash-algo hash-algo #:hash hash #:recursive? #t #:guile-for-build guile))) +(define* (git-fetch/in-band ref hash-algo hash + #:optional name + #:key (system (%current-system)) + (guile (default-guile)) + (git (git-package))) + "Return a fixed-output derivation that performs a Git checkout of REF, using +GIT and GUILE (thus, said derivation depends on GIT and GUILE). + +This method is deprecated in favor of the \"builtin:git-download\" builder. +It will be removed when versions of guix-daemon implementing +\"builtin:git-download\" will be sufficiently widespread." + (git-fetch/in-band* ref hash-algo hash name + #:system system + #:guile guile + #:git git)) + +(define* (git-fetch/lfs ref hash-algo hash + #:optional name + #:key (system (%current-system)) + (guile (default-guile)) + (git (git-package)) + (git-lfs (git-lfs-package))) + "Like git-fetch/in-band, but with support for the Git Large File +Storage (LFS) extension." + (git-fetch/in-band* ref hash-algo hash name + #:system system + #:guile guile + #:git git + #:git-lfs git-lfs)) + (define* (git-fetch/built-in ref hash-algo hash #:optional name #:key (system (%current-system))) diff --git a/guix/git.scm b/guix/git.scm index a8f5144299..a041b2cf88 100644 --- a/guix/git.scm +++ b/guix/git.scm @@ -1,6 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2017, 2020 Mathieu Othacehe <m.othacehe@gmail.com> -;;; Copyright © 2018-2022 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2018-2023 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2021 Kyle Meyer <kyle@kyleam.com> ;;; Copyright © 2021 Marius Bakke <marius@gnu.org> ;;; Copyright © 2022 Maxime Devos <maximedevos@telenet.be> @@ -29,15 +29,18 @@ #:use-module (guix cache) #:use-module (gcrypt hash) #:use-module ((guix build utils) - #:select (mkdir-p delete-file-recursively)) + #:select (mkdir-p delete-file-recursively invoke/quiet)) #:use-module (guix store) #:use-module (guix utils) #:use-module (guix records) + #:use-module ((guix build syscalls) + #:select (terminal-string-width)) #:use-module (guix gexp) #:autoload (guix git-download) (git-reference-url git-reference-commit git-reference-recursive?) + #:autoload (guix config) (%git) #:use-module (guix sets) - #:use-module ((guix diagnostics) #:select (leave warning)) + #:use-module ((guix diagnostics) #:select (leave warning info)) #:use-module (guix progress) #:autoload (guix swh) (swh-download commit-id?) #:use-module (rnrs bytevectors) @@ -154,7 +157,7 @@ the 'SSL_CERT_FILE' and 'SSL_CERT_DIR' environment variables." ;; TODO: Both should be handled & exposed by the PROGRESS-BAR API instead. (define width (max (- (current-terminal-columns) - (string-length label) 7) + (terminal-string-width label) 7) 3)) (define grain @@ -433,6 +436,35 @@ could not be fetched from Software Heritage~%") (rename-file directory trashed) (delete-file-recursively trashed))) +(define (packs-in-git-repository directory) + "Return the number of pack files under DIRECTORY, a Git checkout." + (catch 'system-error + (lambda () + (let ((directory (opendir (in-vicinity directory ".git/objects/pack")))) + (let loop ((count 0)) + (match (readdir directory) + ((? eof-object?) + (closedir directory) + count) + (str + (loop (if (string-suffix? ".pack" str) + (+ 1 count) + count))))))) + (const 0))) + +(define (maybe-run-git-gc directory) + "Run 'git gc' in DIRECTORY if needed." + ;; XXX: As of libgit2 1.3.x (used by Guile-Git), there's no support for GC. + ;; Each time a checkout is pulled, a new pack is created, which eventually + ;; takes up a lot of space (lots of small, poorly-compressed packs). As a + ;; workaround, shell out to 'git gc' when the number of packs in a + ;; repository has become "too large", potentially wasting a lot of space. + ;; See <https://issues.guix.gnu.org/65720>. + (when (> (packs-in-git-repository directory) 25) + (info (G_ "compressing cached Git repository at '~a'...~%") + directory) + (invoke/quiet %git "-C" directory "gc"))) + (define* (update-cached-checkout url #:key (ref '()) @@ -520,6 +552,9 @@ it unchanged." seconds seconds nanoseconds nanoseconds)))) + ;; Run 'git gc' if needed. + (maybe-run-git-gc cache-directory) + ;; When CACHE-DIRECTORY is a sub-directory of the default cache ;; directory, remove expired checkouts that are next to it. (let ((parent (dirname cache-directory))) diff --git a/guix/grafts.scm b/guix/grafts.scm index f93da32981..f4df513daf 100644 --- a/guix/grafts.scm +++ b/guix/grafts.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2014-2022 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2014-2023 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -22,7 +22,7 @@ #:use-module (guix records) #:use-module (guix combinators) #:use-module (guix derivations) - #:use-module ((guix utils) #:select (%current-system)) + #:use-module ((guix utils) #:select (%current-system target-hurd?)) #:use-module (guix sets) #:use-module (guix gexp) #:use-module (srfi srfi-1) @@ -98,7 +98,9 @@ OUTPUTS of DRV. This procedure performs \"shallow\" grafting in that GRAFTS are not recursively applied to dependencies of DRV." (define glibc-locales (module-ref (resolve-interface '(gnu packages commencement)) - 'glibc-utf8-locales-final)) + (if (target-hurd? system) + 'glibc-utf8-locales-final/hurd + 'glibc-utf8-locales-final))) (define mapping ;; List of store item pairs. @@ -176,11 +178,8 @@ references." (append-map (cut references/cached store <>) items)))) (append-map (cut references/cached store <>) items))) - (let ((refs (references* (map (cut derivation->output-path drv <>) - outputs))) - (self (match (derivation->output-paths drv) - (((names . items) ...) - items)))) + (let* ((self (map (cut derivation->output-path drv <>) outputs)) + (refs (references* self))) (remove (cut member <> self) refs))) (define %graft-cache @@ -207,7 +206,7 @@ references." (return result))))))) (define (reference-origins drv items) - "Return the derivation/output pairs among the inputs of DRV, recursively, + "Return the derivation/output pairs among DRV and its inputs, recursively, that produce ITEMS. Elements of ITEMS not produced by a derivation (i.e., it's a content-addressed \"source\"), or not produced by a dependency of DRV, have no corresponding element in the resulting list." @@ -238,13 +237,10 @@ have no corresponding element in the resulting list." ((set-contains? visited drv) (loop rest items result visited)) (else - (let* ((inputs - (map derivation-input-derivation - (derivation-inputs drv))) - (result items - (fold2 lookup-derivers - result items inputs))) - (loop (append rest inputs) + (let ((result items (lookup-derivers drv result items))) + (loop (append rest + (map derivation-input-derivation + (derivation-inputs drv))) items result (set-insert drv visited))))))))) @@ -258,16 +254,17 @@ GRAFTS to the dependencies of DRV. Return the resulting list of grafts. This is a monadic procedure in %STATE-MONAD where the state is a vhash mapping derivations to the corresponding set of grafts." - (define (graft-origin? drv graft) - ;; Return true if DRV corresponds to the origin of GRAFT. + (define (graft-origin? drv output graft) + ;; Return true if DRV and OUTPUT correspond to the origin of GRAFT. (match graft - (($ <graft> (? derivation? origin) output) - (match (assoc-ref (derivation->output-paths drv) output) - ((? string? result) - (string=? result - (derivation->output-path origin output))) - (_ - #f))) + (($ <graft> (? derivation? origin) origin-output) + (and (string=? origin-output output) + (match (assoc-ref (derivation->output-paths drv) output) + ((? string? result) + (string=? result + (derivation->output-path origin output))) + (_ + #f)))) (_ #f))) @@ -278,7 +275,7 @@ derivations to the corresponding set of grafts." ((drv . output) ;; If GRAFTS already contains a graft from DRV, do not ;; override it. - (if (find (cut graft-origin? drv <>) grafts) + (if (find (cut graft-origin? drv output <>) grafts) (state-return grafts) (cumulative-grafts store drv grafts #:outputs (list output) diff --git a/guix/import/cabal.scm b/guix/import/cabal.scm index fe03c30254..d32c1c15fe 100644 --- a/guix/import/cabal.scm +++ b/guix/import/cabal.scm @@ -130,8 +130,17 @@ to the stack." (define (context-stack-clear!) ((context-stack) 'clear!)) -;; Indentation of the line being parsed. -(define current-indentation (make-parameter 0)) +;; Indentation of the line being parsed and that of the previous line. +(define current-indentation* (make-parameter 0)) + +(define previous-indentation (make-parameter 0)) + +(define* (current-indentation #:optional value) + (if value + (begin + (previous-indentation (current-indentation*)) + (current-indentation* value)) + (current-indentation*))) ;; Signal to reprocess the beginning of line, in case we need to close more ;; than one indentation level. @@ -196,27 +205,13 @@ to the stack." (exprs elif-else) : (append $1 (list ($2 '(())))) (elif-else) : (list ($1 '(())))) ;; LALR(1) parsers prefer to be left-recursive, which make if-statements slightly involved. - ;; XXX: This technically allows multiple else statements. - (elif-else (elif-else ELIF tests OCURLY exprs CCURLY) : (lambda (y) ($1 (list (append (list 'if $3 $5) y)))) - (elif-else ELIF tests open exprs close) : (lambda (y) ($1 (list (append (list 'if $3 $5) y)))) - (elif-else ELSE OCURLY exprs CCURLY) : (lambda (y) ($1 (list $4))) - ;; The 'open' token after 'tests' is shifted after an 'exprs' - ;; is found. This is because, instead of 'exprs' a 'OCURLY' - ;; token is a valid alternative. For this reason, 'open' - ;; pushes a <parse-context> with a line indentation equal to - ;; the indentation of 'exprs'. - ;; - ;; Differently from this, without the rule above this - ;; comment, when an 'ELSE' token is found, the 'open' token - ;; following the 'ELSE' would be shifted immediately, before - ;; the 'exprs' is found (because there are no other valid - ;; tokens). The 'open' would therefore create a - ;; <parse-context> with the indentation of 'ELSE' and not - ;; 'exprs', creating an inconsistency. We therefore allow - ;; mixed style conditionals. - (elif-else ELSE open exprs close) : (lambda (y) ($1 (list $4))) + (elif (elif ELIF tests OCURLY exprs CCURLY) : (lambda (y) ($1 (list (append (list 'if $3 $5) y)))) + (elif ELIF tests open exprs close) : (lambda (y) ($1 (list (append (list 'if $3 $5) y)))) ;; Terminating rule. (if-then) : (lambda (y) (append $1 y))) + (elif-else (elif ELSE OCURLY exprs CCURLY) : (lambda (y) ($1 (list $4))) + (elif ELSE open exprs close) : (lambda (y) ($1 (list $4))) + (elif) : $1) (if-then (IF tests OCURLY exprs CCURLY) : (list 'if $2 $4) (IF tests open exprs close) : (list 'if $2 $4)) (tests (TEST OPAREN ID CPAREN) : `(,$1 ,$3) @@ -237,7 +232,7 @@ to the stack." (OPAREN tests CPAREN) : $2) (open () : (context-stack-push! (make-parse-context (context layout) - (current-indentation)))) + (+ 1 (previous-indentation))))) (close (VCCURLY)))) (define (peek-next-line-indent port) @@ -655,7 +650,8 @@ If #f use the function 'port-filename' to obtain it." (let ((cabal-parser (make-cabal-parser))) (parameterize ((cabal-file-name (or file-name (port-filename port) "standard input")) - (current-indentation 0) + (current-indentation* 0) + (previous-indentation 0) (check-bol? #f) (context-stack (make-stack))) (cabal-parser (make-lexer port) (errorp))))) @@ -869,7 +865,16 @@ the ordering operation and the version." (((? string? name) values) (list name values)) ((("import" imports) rest ...) - (eval (append (append-map (cut assoc-ref common-stanzas <>) imports) + (eval (append (append-map + ;; The imports are (at least sometimes) a list with one string + ;; containing all the names separeted by commas. This splits + ;; those strings to a list of strings in the same format that is + ;; used in common-stanzas. + (cut assoc-ref common-stanzas <>) + (append-map (lambda (imports-string) + (map (compose string-downcase string-trim-both) + (string-split imports-string #\,))) + imports)) rest))) ((element rest ...) (cons (eval element) (eval rest))) diff --git a/guix/import/cran.scm b/guix/import/cran.scm index 59c65f9fa5..ca984cb49c 100644 --- a/guix/import/cran.scm +++ b/guix/import/cran.scm @@ -181,9 +181,9 @@ package definition." (define %cran-canonical-url "https://cran.r-project.org/package=") (define %bioconductor-url "https://bioconductor.org/packages/") -;; The latest Bioconductor release is 3.17. Bioconductor packages should be +;; The latest Bioconductor release is 3.18. Bioconductor packages should be ;; updated together. -(define %bioconductor-version "3.17") +(define %bioconductor-version "3.18") (define* (bioconductor-packages-list-url #:optional type) (string-append "https://bioconductor.org/packages/" diff --git a/guix/import/crate.scm b/guix/import/crate.scm index 6e10ebb5d4..43823d006e 100644 --- a/guix/import/crate.scm +++ b/guix/import/crate.scm @@ -5,6 +5,7 @@ ;;; Copyright © 2021 Nicolas Goaziou <mail@nicolasgoaziou.fr> ;;; Copyright © 2022 Hartmut Goebel <h.goebel@crazy-compilers.com> ;;; Copyright © 2023 Simon Tournier <zimon.toutoune@gmail.com> +;;; Copyright © 2023 Efraim Flashner <efraim@flashner.co.il> ;;; ;;; This file is part of GNU Guix. ;;; @@ -82,6 +83,7 @@ (match-lambda ('null #f) ((? string? str) str))) + (yanked? crate-version-yanked? "yanked") ;boolean (links crate-version-links)) ;alist ;; Crate dependency. Each dependency (each edge in the graph) is annotated as @@ -255,13 +257,16 @@ look up the development dependencs for the given crate." (and (not (null-list? versions)) (semver->string (last versions))))) - ;; find the highest version of a crate that fulfills the semver <range> + ;; Find the highest version of a crate that fulfills the semver <range> + ;; and hasn't been yanked. (define (find-crate-version crate range) (let* ((semver-range (string->semver-range range)) (versions (sort (filter (lambda (entry) - (semver-range-contains? semver-range (first entry))) + (and + (not (crate-version-yanked? (second entry))) + (semver-range-contains? semver-range (first entry)))) (map (lambda (ver) (list (string->semver (crate-version-number ver)) ver)) diff --git a/guix/import/hackage.scm b/guix/import/hackage.scm index 9333bedbbd..bbaee73a06 100644 --- a/guix/import/hackage.scm +++ b/guix/import/hackage.scm @@ -335,7 +335,7 @@ the hash of the Cabal file." (synopsis ,(cabal-package-synopsis cabal)) (description ,(beautify-description (cabal-package-description cabal))) (license ,(string->license (cabal-package-license cabal)))) - inputs))) + (map upstream-input-name inputs)))) (define* (hackage->guix-package package-name #:key (include-test-dependencies? #t) diff --git a/guix/import/opam.scm b/guix/import/opam.scm index e67146e593..86e82cde59 100644 --- a/guix/import/opam.scm +++ b/guix/import/opam.scm @@ -379,8 +379,10 @@ file names. Return a 'package' sexp or #f on failure." (synopsis ,(metadata-ref opam-content "synopsis")) (description ,(and=> (metadata-ref opam-content "description") beautify-description)) - (license ,(spdx-string->license - (metadata-ref opam-content "license")))) + (license ,(match (metadata-ref opam-content "license") + ((('string-pat strs) ...) + `(list ,@(map spdx-string->license strs))) + ((? string? str) (spdx-string->license str))))) (filter (lambda (name) (not (member name '("dune" "jbuilder")))) diff --git a/guix/import/stackage.scm b/guix/import/stackage.scm index 00814c7d46..f801835b33 100644 --- a/guix/import/stackage.scm +++ b/guix/import/stackage.scm @@ -92,7 +92,7 @@ "Return the version of the package with upstream NAME included in PACKAGES." (let ((pkg (find (lambda (pkg) (string=? (stackage-package-name pkg) name)) packages))) - (stackage-package-version pkg))) + (and=> pkg stackage-package-version))) ;;; diff --git a/guix/inferior.scm b/guix/inferior.scm index fca6fb4b22..190ba01b3c 100644 --- a/guix/inferior.scm +++ b/guix/inferior.scm @@ -872,14 +872,17 @@ prefix, resolve it; and if 'commit' is unset, fetch CHANNEL's branch tip." (authenticate? #t) (cache-directory (%inferior-cache-directory)) (ttl (* 3600 24 30)) - validate-channels) + (reference-channels '()) + (validate-channels (const #t))) "Return a directory containing a guix filetree defined by CHANNELS, a list of channels. The directory is a subdirectory of CACHE-DIRECTORY, where entries can be reclaimed after TTL seconds. This procedure opens a new connection to the build daemon. AUTHENTICATE? determines whether CHANNELS are authenticated. -VALIDATE-CHANNELS, if specified, must be a one argument procedure accepting a -list of channels that can be used to validate the channels; it should raise an -exception in case of problems." + +VALIDATE-CHANNELS must be a four-argument procedure used to validate channel +instances against REFERENCE-CHANNELS; it is passed as #:validate-pull to +'latest-channel-instances' and should raise an exception in case a target +channel commit is deemed \"invalid\"." (define commits ;; Since computing the instances of CHANNELS is I/O-intensive, use a ;; cheaper way to get the commit list of CHANNELS. This limits overhead @@ -927,30 +930,31 @@ exception in case of problems." (if (file-exists? cached) cached - (begin - (when (procedure? validate-channels) - (validate-channels channels)) - (run-with-store store - (mlet* %store-monad ((instances - -> (latest-channel-instances store channels - #:authenticate? - authenticate?)) - (profile - (channel-instances->derivation instances))) - (mbegin %store-monad - ;; It's up to the caller to install a build handler to report - ;; what's going to be built. - (built-derivations (list profile)) - - ;; Cache if and only if AUTHENTICATE? is true. - (if authenticate? - (mbegin %store-monad - (symlink* (derivation->output-path profile) cached) - (add-indirect-root* cached) - (return cached)) - (mbegin %store-monad - (add-temp-root* (derivation->output-path profile)) - (return (derivation->output-path profile)))))))))) + (run-with-store store + (mlet* %store-monad ((instances + -> (latest-channel-instances store channels + #:authenticate? + authenticate? + #:current-channels + reference-channels + #:validate-pull + validate-channels)) + (profile + (channel-instances->derivation instances))) + (mbegin %store-monad + ;; It's up to the caller to install a build handler to report + ;; what's going to be built. + (built-derivations (list profile)) + + ;; Cache if and only if AUTHENTICATE? is true. + (if authenticate? + (mbegin %store-monad + (symlink* (derivation->output-path profile) cached) + (add-indirect-root* cached) + (return cached)) + (mbegin %store-monad + (add-temp-root* (derivation->output-path profile)) + (return (derivation->output-path profile))))))))) (define* (inferior-for-channels channels #:key diff --git a/guix/lint.scm b/guix/lint.scm index 7ccf52dec1..861e352b93 100644 --- a/guix/lint.scm +++ b/guix/lint.scm @@ -1857,7 +1857,8 @@ them for PACKAGE." (call-with-input-file file (lambda (port) - (let loop ((line-number 1) + (go-to-location port starting-line 0) + (let loop ((line-number starting-line) (last-line #f) (warnings '())) (let ((line (read-line port))) diff --git a/guix/monad-repl.scm b/guix/monad-repl.scm index 8a6053edd5..d6b39112b7 100644 --- a/guix/monad-repl.scm +++ b/guix/monad-repl.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2014, 2015, 2016, 2022 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2014-2016, 2022-2023 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -21,13 +21,15 @@ #:use-module (guix monads) #:use-module (guix utils) #:use-module (guix packages) + #:autoload (guix build-system) (bag) #:use-module (guix status) - #:autoload (guix gexp) (lower-object) + #:autoload (guix gexp) (gexp gexp? lower-gexp lowered-gexp-sexp lower-object) #:use-module ((guix derivations) #:select (derivation? derivation->output-paths built-derivations)) + #:autoload (guix read-print) (pretty-print-with-comments) #:use-module (ice-9 match) - #:use-module (ice-9 pretty-print) + #:autoload (ice-9 pretty-print) (pretty-print) #:use-module (system repl repl) #:use-module (system repl common) #:use-module (system repl command) @@ -138,4 +140,68 @@ Enter a REPL for values in the store monad." (repl-option-set! new 'interp #t) (run-repl new)))) -;;; monad-repl.scm ends here + +;;; +;;; Viewing package arguments. +;;; + +(define (keyword-argument-value args keyword default) + "Return the value associated with KEYWORD in ARGS, a keyword/value sequence, +or DEFAULT if KEYWORD is missing from ARGS." + (let loop ((args args)) + (match args + (() + default) + ((kw value rest ...) + (if (eq? kw keyword) + value + (loop rest)))))) + +(define (package-argument-command repl form keyword default) + "Implement a command that display KEYWORD, a keyword such as #:phases, in +the arguments of the package FORM evaluates to. Return DEFAULT is KEYWORD is +missing from those arguments." + (match (repl-eval repl form) + ((? package? package) + (let* ((bag* (bag + (inherit (package->bag package)) + (build (lambda* (name inputs #:rest args) + (with-monad %store-monad + (return (keyword-argument-value args keyword + default)))))))) + (define phases + (parameterize ((%graft? #f)) + (with-store store + (set-build-options store + #:print-build-trace #t + #:print-extended-build-trace? #t + #:multiplexed-build-output? #t) + (run-with-store store + (mlet %store-monad ((exp (bag->derivation bag*))) + (if (gexp? exp) + (mlet %store-monad ((gexp (lower-gexp exp))) + (return (lowered-gexp-sexp gexp))) + (return exp))))))) + + (run-hook before-print-hook phases) + (let ((column (port-column (current-output-port)))) + (pretty-print-with-comments (current-output-port) phases + #:indent column) + (newline (current-output-port))))) + (_ + (format #t ";; ERROR: This command only accepts package records.~%")))) + +(define-meta-command ((phases guix) repl (form)) + "phases +Return the build phases of the package defined by FORM." + (package-argument-command repl form #:phases #~%standard-phases)) + +(define-meta-command ((configure-flags guix) repl (form)) + "configure-flags +Return the configure flags of the package defined by FORM." + (package-argument-command repl form #:configure-flags #~'())) + +(define-meta-command ((make-flags guix) repl (form)) + "make-flags +Return the make flags of the package defined by FORM." + (package-argument-command repl form #:make-flags #~'())) diff --git a/guix/packages.scm b/guix/packages.scm index f70fad695e..930b1a3b0e 100644 --- a/guix/packages.scm +++ b/guix/packages.scm @@ -849,14 +849,15 @@ identifiers. The result is inferred from the file names of patches." '())))) (append-map patch-vulnerabilities patches))) -(define (%standard-patch-inputs) +(define (%standard-patch-inputs system) (let* ((canonical (module-ref (resolve-interface '(gnu packages base)) 'canonical-package)) (ref (lambda (module var) ;; Make sure 'canonical-package' is not influenced by ;; '%current-target-system' since we're going to use the ;; native package anyway. - (parameterize ((%current-target-system #f)) + (parameterize ((%current-target-system #f) + (%current-system system)) (canonical (module-ref (resolve-interface module) var)))))) `(("tar" ,(ref '(gnu packages base) 'tar)) @@ -866,7 +867,12 @@ identifiers. The result is inferred from the file names of patches." ("lzip" ,(ref '(gnu packages compression) 'lzip)) ("unzip" ,(ref '(gnu packages compression) 'unzip)) ("patch" ,(ref '(gnu packages base) 'patch)) - ("locales" ,(ref '(gnu packages base) 'glibc-utf8-locales))))) + ("locales" + ,(parameterize ((%current-target-system #f) + (%current-system system)) + (canonical + ((module-ref (resolve-interface '(gnu packages base)) + 'libc-utf8-locales-for-target)))))))) (define (default-guile) "Return the default Guile package used to run the build code of @@ -909,7 +915,7 @@ specifies modules in scope when evaluating SNIPPET." (define lookup-input ;; The default value of the 'patch-inputs' field, and thus INPUTS is #f, ;; so deal with that. - (let ((inputs (or inputs (%standard-patch-inputs)))) + (let ((inputs (or inputs (%standard-patch-inputs system)))) (lambda (name) (match (assoc-ref inputs name) ((package) package) @@ -2022,11 +2028,12 @@ symbolic output name, such as \"out\". Note that this procedure calls ;;; Monadic interface. ;;; -(define (set-guile-for-build guile) +(define* (set-guile-for-build guile #:optional system) "This monadic procedure changes the Guile currently used to run the build -code of derivations to GUILE, a package object." +code of derivations to GUILE, a package object, compiled for SYSTEM." (lambda (store) - (let ((guile (package-derivation store guile))) + (let ((guile (package-derivation store guile + (or system (%current-system))))) (values (%guile-for-build guile) store)))) (define* (package-file package diff --git a/guix/profiles.scm b/guix/profiles.scm index fea766879d..ce2f8337bf 100644 --- a/guix/profiles.scm +++ b/guix/profiles.scm @@ -993,15 +993,16 @@ if not found." (anym %store-monad entry-lookup-package (manifest-entries manifest))) -(define (info-dir-file manifest) +(define* (info-dir-file manifest #:optional system) "Return a derivation that builds the 'dir' file for all the entries of MANIFEST." (define texinfo ;lazy reference (module-ref (resolve-interface '(gnu packages texinfo)) 'texinfo)) (define gzip ;lazy reference (module-ref (resolve-interface '(gnu packages compression)) 'gzip)) - (define glibc-utf8-locales ;lazy reference - (module-ref (resolve-interface '(gnu packages base)) 'glibc-utf8-locales)) + (define libc-utf8-locales-for-target ;lazy reference + (module-ref (resolve-interface '(gnu packages base)) + 'libc-utf8-locales-for-target)) (define build (with-imported-modules '((guix build utils)) @@ -1043,7 +1044,8 @@ MANIFEST." (setenv "PATH" (string-append #+gzip "/bin")) ;for info.gz files (setenv "GUIX_LOCPATH" - #+(file-append glibc-utf8-locales "/lib/locale")) + #+(file-append (libc-utf8-locales-for-target system) + "/lib/locale")) (mkdir-p (string-append #$output "/share/info")) (exit (every install-info @@ -1051,13 +1053,14 @@ MANIFEST." '#$(manifest-inputs manifest))))))) (gexp->derivation "info-dir" build + #:system system #:local-build? #t #:substitutable? #f #:properties `((type . profile-hook) (hook . info-dir)))) -(define (ghc-package-cache-file manifest) +(define* (ghc-package-cache-file manifest #:optional system) "Return a derivation that builds the GHC 'package.cache' file for all the entries of MANIFEST, or #f if MANIFEST does not have any GHC packages." (define ghc ;lazy reference @@ -1108,6 +1111,7 @@ entries of MANIFEST, or #f if MANIFEST does not have any GHC packages." (if (any (cut string-prefix? "ghc" <>) (map manifest-entry-name (manifest-entries manifest))) (gexp->derivation "ghc-package-cache" build + #:system system #:local-build? #t #:substitutable? #f #:properties @@ -1115,15 +1119,16 @@ entries of MANIFEST, or #f if MANIFEST does not have any GHC packages." (hook . ghc-package-cache))) (return #f)))) -(define (ca-certificate-bundle manifest) +(define* (ca-certificate-bundle manifest #:optional system) "Return a derivation that builds a single-file bundle containing the CA certificates in the /etc/ssl/certs sub-directories of the packages in MANIFEST. Single-file bundles are required by programs such as Git and Lynx." ;; See <http://lists.gnu.org/archive/html/guix-devel/2015-02/msg00429.html> ;; for a discussion. - (define glibc-utf8-locales ;lazy reference - (module-ref (resolve-interface '(gnu packages base)) 'glibc-utf8-locales)) + (define libc-utf8-locales-for-target ;lazy reference + (module-ref (resolve-interface '(gnu packages base)) + 'libc-utf8-locales-for-target)) (define build (with-imported-modules '((guix build utils)) @@ -1157,9 +1162,11 @@ MANIFEST. Single-file bundles are required by programs such as Git and Lynx." ;; Some file names in the NSS certificates are UTF-8 encoded so ;; install a UTF-8 locale. (setenv "LOCPATH" - (string-append #+glibc-utf8-locales "/lib/locale/" + (string-append #+(libc-utf8-locales-for-target system) + "/lib/locale/" #+(version-major+minor - (package-version glibc-utf8-locales)))) + (package-version + (libc-utf8-locales-for-target system))))) (setlocale LC_ALL "en_US.utf8") (match (append-map ca-files '#$(manifest-inputs manifest)) @@ -1179,13 +1186,14 @@ MANIFEST. Single-file bundles are required by programs such as Git and Lynx." #t)))))) (gexp->derivation "ca-certificate-bundle" build + #:system system #:local-build? #t #:substitutable? #f #:properties `((type . profile-hook) (hook . ca-certificate-bundle)))) -(define (emacs-subdirs manifest) +(define* (emacs-subdirs manifest #:optional system) (define build (with-imported-modules (source-module-closure '((guix build profiles) @@ -1219,13 +1227,14 @@ MANIFEST. Single-file bundles are required by programs such as Git and Lynx." (newline port) #t))))))) (gexp->derivation "emacs-subdirs" build + #:system system #:local-build? #t #:substitutable? #f #:properties `((type . profile-hook) (hook . emacs-subdirs)))) -(define (gdk-pixbuf-loaders-cache-file manifest) +(define* (gdk-pixbuf-loaders-cache-file manifest #:optional system) "Return a derivation that produces a loaders cache file for every gdk-pixbuf loaders discovered in MANIFEST." (define gdk-pixbuf ;lazy reference @@ -1264,6 +1273,7 @@ loaders discovered in MANIFEST." (if gdk-pixbuf (gexp->derivation "gdk-pixbuf-loaders-cache-file" build + #:system system #:local-build? #t #:substitutable? #f #:properties @@ -1271,7 +1281,7 @@ loaders discovered in MANIFEST." (hook . gdk-pixbuf-loaders-cache-file))) (return #f)))) -(define (glib-schemas manifest) +(define* (glib-schemas manifest #:optional system) "Return a derivation that unions all schemas from manifest entries and creates the Glib 'gschemas.compiled' file." (define glib ; lazy reference @@ -1318,6 +1328,7 @@ creates the Glib 'gschemas.compiled' file." ;; Don't run the hook when there's nothing to do. (if %glib (gexp->derivation "glib-schemas" build + #:system system #:local-build? #t #:substitutable? #f #:properties @@ -1325,7 +1336,7 @@ creates the Glib 'gschemas.compiled' file." (hook . glib-schemas))) (return #f)))) -(define (gtk-icon-themes manifest) +(define* (gtk-icon-themes manifest #:optional system) "Return a derivation that unions all icon themes from manifest entries and creates the GTK+ 'icon-theme.cache' file for each theme." (define gtk+ ; lazy reference @@ -1377,6 +1388,7 @@ creates the GTK+ 'icon-theme.cache' file for each theme." ;; Don't run the hook when there's nothing to do. (if %gtk+ (gexp->derivation "gtk-icon-themes" build + #:system system #:local-build? #t #:substitutable? #f #:properties @@ -1384,7 +1396,7 @@ creates the GTK+ 'icon-theme.cache' file for each theme." (hook . gtk-icon-themes))) (return #f)))) -(define (gtk-im-modules manifest) +(define* (gtk-im-modules manifest #:optional system) "Return a derivation that builds the cache files for input method modules for both major versions of GTK+." @@ -1454,6 +1466,7 @@ for both major versions of GTK+." #t)))) (if (or gtk+ gtk+-2) (gexp->derivation "gtk-im-modules" gexp + #:system system #:local-build? #t #:substitutable? #f #:properties @@ -1461,7 +1474,7 @@ for both major versions of GTK+." (hook . gtk-im-modules))) (return #f))))) -(define (linux-module-database manifest) +(define* (linux-module-database manifest #:optional system) "Return a derivation that unites all the kernel modules of the manifest and creates the dependency graph of all these kernel modules. @@ -1511,13 +1524,14 @@ This is meant to be used as a profile hook." (_ (error "Specified Linux kernel and Linux kernel modules are not all of the same version")))))))) (gexp->derivation "linux-module-database" build + #:system system #:local-build? #t #:substitutable? #f #:properties `((type . profile-hook) (hook . linux-module-database)))) -(define (xdg-desktop-database manifest) +(define* (xdg-desktop-database manifest #:optional system) "Return a derivation that builds the @file{mimeinfo.cache} database from desktop files. It's used to query what applications can handle a given MIME type." @@ -1551,6 +1565,7 @@ MIME type." ;; Don't run the hook when 'glib' is not referenced. (if glib (gexp->derivation "xdg-desktop-database" build + #:system system #:local-build? #t #:substitutable? #f #:properties @@ -1558,7 +1573,7 @@ MIME type." (hook . xdg-desktop-database))) (return #f)))) -(define (xdg-mime-database manifest) +(define* (xdg-mime-database manifest #:optional system) "Return a derivation that builds the @file{mime.cache} database from manifest entries. It's used to query the MIME type of a given file." (define shared-mime-info ; lazy reference @@ -1605,6 +1620,7 @@ entries. It's used to query the MIME type of a given file." ;; Don't run the hook when there are no GLib based applications. (if glib (gexp->derivation "xdg-mime-database" build + #:system system #:local-build? #t #:substitutable? #f #:properties @@ -1615,7 +1631,7 @@ entries. It's used to query the MIME type of a given file." ;; Several font packages may install font files into same directory, so ;; fonts.dir and fonts.scale file should be generated here, instead of in ;; packages. -(define (fonts-dir-file manifest) +(define* (fonts-dir-file manifest #:optional system) "Return a derivation that builds the @file{fonts.dir} and @file{fonts.scale} files for the fonts of the @var{manifest} entries." (define mkfontscale @@ -1676,6 +1692,7 @@ files for the fonts of the @var{manifest} entries." directories))))))) (gexp->derivation "fonts-dir" build + #:system system #:modules '((guix build utils) (guix build union) (srfi srfi-26)) @@ -1685,7 +1702,7 @@ files for the fonts of the @var{manifest} entries." `((type . profile-hook) (hook . fonts-dir)))) -(define (manual-database manifest) +(define* (manual-database manifest #:optional system) "Return a derivation that builds the manual page database (\"mandb\") for the entries in MANIFEST." (define gdbm-ffi @@ -1761,23 +1778,24 @@ the entries in MANIFEST." (force-output)))))) (gexp->derivation "manual-database" build + #:system system #:substitutable? #f #:local-build? #t #:properties `((type . profile-hook) (hook . manual-database)))) -(define (manual-database/optional manifest) +(define* (manual-database/optional manifest #:optional system) "Return a derivation to build the manual database of MANIFEST, but only if MANIFEST contains the \"man-db\" package. Otherwise, return #f." ;; Building the man database (for "man -k") is expensive and rarely used. ;; Build it only if the profile also contains "man-db". (mlet %store-monad ((man-db (manifest-lookup-package manifest "man-db"))) (if man-db - (manual-database manifest) + (manual-database manifest system) (return #f)))) -(define (texlive-font-maps manifest) +(define* (texlive-font-maps manifest #:optional system) "Return a derivation that builds the TeX Live font maps for the entries in MANIFEST." (define entry->texlive-input @@ -1898,6 +1916,7 @@ MANIFEST." ;; incomplete modular TeX Live installations to generate errors. (if (any texlive-scripts-entry? (manifest-entries manifest)) (gexp->derivation "texlive-font-maps" build + #:system system #:substitutable? #f #:local-build? #t #:properties @@ -1977,26 +1996,29 @@ are cross-built for TARGET." (extras (if (null? (manifest-entries manifest)) (return '()) (mapm/accumulate-builds (lambda (hook) - (hook manifest)) + (hook manifest + system)) hooks)))) (define extra-inputs (filter-map (lambda (drv) (and (derivation? drv) (gexp-input drv))) extras)) - (define glibc-utf8-locales ;lazy reference + (define libc-utf8-locales-for-target ;lazy reference (module-ref (resolve-interface '(gnu packages base)) - 'glibc-utf8-locales)) + 'libc-utf8-locales-for-target)) (define set-utf8-locale ;; Some file names (e.g., in 'nss-certs') are UTF-8 encoded so ;; install a UTF-8 locale. - #~(begin - (setenv "LOCPATH" - #$(file-append glibc-utf8-locales "/lib/locale/" - (version-major+minor - (package-version glibc-utf8-locales)))) - (setlocale LC_ALL "en_US.utf8"))) + (let ((locales (libc-utf8-locales-for-target + (or system (%current-system))))) + #~(begin + (setenv "LOCPATH" + #$(file-append locales "/lib/locale/" + (version-major+minor + (package-version locales)))) + (setlocale LC_ALL "en_US.utf8")))) (define builder (with-imported-modules '((guix build profiles) diff --git a/guix/progress.scm b/guix/progress.scm index 33cf6f4a1a..e1b35094e1 100644 --- a/guix/progress.scm +++ b/guix/progress.scm @@ -21,6 +21,7 @@ (define-module (guix progress) #:use-module (guix records) + #:autoload (guix build syscalls) (terminal-string-width) #:use-module (srfi srfi-19) #:use-module (rnrs io ports) #:use-module (rnrs bytevectors) @@ -307,7 +308,7 @@ tasks is performed. Write PREFIX at the beginning of the line." (if (string-null? prefix) (display (progress-bar ratio (current-terminal-columns)) port) (let ((width (- (current-terminal-columns) - (string-length prefix) 3))) + (terminal-string-width prefix) 3))) (display prefix port) (display " " port) (display (progress-bar ratio width) port))) diff --git a/guix/read-print.scm b/guix/read-print.scm index 7faad82c94..690f5dacdd 100644 --- a/guix/read-print.scm +++ b/guix/read-print.scm @@ -330,6 +330,7 @@ expressions and blanks that were read." ('add-after '(((modify-phases) . 3))) ('add-before '(((modify-phases) . 3))) ('replace '(((modify-phases) . 2))) ;different from 'modify-inputs' + ('parameterize 2) ('substitute* 2) ('substitute-keyword-arguments 2) ('call-with-input-file 2) diff --git a/guix/scripts/archive.scm b/guix/scripts/archive.scm index e32f22ec99..2b5a55a23f 100644 --- a/guix/scripts/archive.scm +++ b/guix/scripts/archive.scm @@ -119,7 +119,7 @@ Export/import one or more packages from/to the store.\n")) ;; Specifications of the command-line options. (cons* (option '(#\h "help") #f #f (lambda args - (show-help) + (leave-on-EPIPE (show-help)) (exit 0))) (option '(#\V "version") #f #f (lambda args diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm index 72a24f91ac..05f022a92e 100644 --- a/guix/scripts/build.scm +++ b/guix/scripts/build.scm @@ -477,7 +477,7 @@ Build the given PACKAGE-OR-DERIVATION and return their output paths.\n")) ;; Specifications of the command-line options. (cons* (option '(#\h "help") #f #f (lambda args - (show-help) + (leave-on-EPIPE (show-help)) (exit 0))) (option '(#\V "version") #f #f (lambda args diff --git a/guix/scripts/challenge.scm b/guix/scripts/challenge.scm index 4821e11bf6..01e2f9a2b2 100644 --- a/guix/scripts/challenge.scm +++ b/guix/scripts/challenge.scm @@ -467,7 +467,7 @@ Challenge the substitutes for PACKAGE... provided by one or more servers.\n")) (define %options (list (option '(#\h "help") #f #f (lambda args - (show-help) + (leave-on-EPIPE (show-help)) (exit 0))) (option '(#\V "version") #f #f (lambda args diff --git a/guix/scripts/container.scm b/guix/scripts/container.scm index 2369437043..70637bca29 100644 --- a/guix/scripts/container.scm +++ b/guix/scripts/container.scm @@ -57,7 +57,7 @@ Build and manipulate Linux containers.\n")) (format (current-error-port) (G_ "guix container: missing action~%"))) ((or ("-h") ("--help")) - (show-help) + (leave-on-EPIPE (show-help)) (exit 0)) ((or ("-V") ("--version")) (show-version-and-exit "guix container")) diff --git a/guix/scripts/copy.scm b/guix/scripts/copy.scm index 07357af420..67975ac1a9 100644 --- a/guix/scripts/copy.scm +++ b/guix/scripts/copy.scm @@ -150,7 +150,7 @@ Copy ITEMS to or from the specified host over SSH.\n")) (option '(#\h "help") #f #f (lambda args - (show-help) + (leave-on-EPIPE (show-help)) (exit 0))) (option '(#\V "version") #f #f (lambda args diff --git a/guix/scripts/deploy.scm b/guix/scripts/deploy.scm index 14ce736174..4b1a603049 100644 --- a/guix/scripts/deploy.scm +++ b/guix/scripts/deploy.scm @@ -68,7 +68,7 @@ Perform the deployment specified by FILE.\n")) (define %options (cons* (option '(#\h "help") #f #f (lambda args - (show-help) + (leave-on-EPIPE (show-help)) (exit 0))) (option '(#\V "version") #f #f (lambda args diff --git a/guix/scripts/describe.scm b/guix/scripts/describe.scm index 5523aa0ec2..6d451dc902 100644 --- a/guix/scripts/describe.scm +++ b/guix/scripts/describe.scm @@ -74,7 +74,7 @@ result))) (option '(#\h "help") #f #f (lambda args - (show-help) + (leave-on-EPIPE (show-help)) (exit 0))) (option '(#\V "version") #f #f (lambda args diff --git a/guix/scripts/discover.scm b/guix/scripts/discover.scm index 8970f835c9..32bf6085a5 100644 --- a/guix/scripts/discover.scm +++ b/guix/scripts/discover.scm @@ -50,7 +50,7 @@ Discover Guix related services using Avahi.\n")) (alist-cons 'cache arg result))) (option '(#\h "help") #f #f (lambda _ - (show-help) + (leave-on-EPIPE (show-help)) (exit 0))) (option '(#\V "version") #f #f (lambda _ diff --git a/guix/scripts/download.scm b/guix/scripts/download.scm index 0ab5c8c39c..0441d3fead 100644 --- a/guix/scripts/download.scm +++ b/guix/scripts/download.scm @@ -143,7 +143,7 @@ and 'base16' ('hex' and 'hexadecimal' can be used as well).\n")) (option '(#\h "help") #f #f (lambda args - (show-help) + (leave-on-EPIPE (show-help)) (exit 0))) (option '(#\V "version") #f #f (lambda args diff --git a/guix/scripts/edit.scm b/guix/scripts/edit.scm index 5ce2870c5a..b7b4cd2514 100644 --- a/guix/scripts/edit.scm +++ b/guix/scripts/edit.scm @@ -37,7 +37,7 @@ %standard-build-options) (option '(#\h "help") #f #f (lambda args - (show-help) + (leave-on-EPIPE (show-help)) (exit 0))) (option '(#\V "version") #f #f (lambda args @@ -64,7 +64,11 @@ Start $VISUAL or $EDITOR to edit the definitions of PACKAGE...\n")) (define (search-path* path file) "Like 'search-path' but exit if FILE is not found." - (let ((absolute-file-name (search-path path file))) + (let ((absolute-file-name (or (search-path path file) + ;; It could be that FILE is a relative name + ;; i.e., not relative to an element of PATH. + (and (file-exists? file) + file)))) (unless absolute-file-name ;; Shouldn't happen unless somebody fiddled with the 'location' field. (leave (G_ "file '~a' not found in search path ~s~%") diff --git a/guix/scripts/environment.scm b/guix/scripts/environment.scm index 9712389842..1d7a6e198d 100644 --- a/guix/scripts/environment.scm +++ b/guix/scripts/environment.scm @@ -311,6 +311,9 @@ use '--preserve' instead~%")) (define (options/resolve-packages store opts) "Return OPTS with package specification strings replaced by manifest entries for the corresponding packages." + (define system + (assoc-ref opts 'system)) + (define (manifest-entry=? e1 e2) (and (eq? (manifest-entry-item e1) (manifest-entry-item e2)) (string=? (manifest-entry-output e1) @@ -327,11 +330,11 @@ for the corresponding packages." ((? package? package) (if (eq? mode 'ad-hoc-package) (list (package->manifest-entry* package)) - (manifest-entries (package->development-manifest package)))) + (manifest-entries (package->development-manifest package system)))) (((? package? package) (? string? output)) (if (eq? mode 'ad-hoc-package) (list (package->manifest-entry* package output)) - (manifest-entries (package->development-manifest package)))) + (manifest-entries (package->development-manifest package system)))) ((lst ...) (append-map (cut packages->outputs <> mode) lst)))) @@ -345,7 +348,8 @@ for the corresponding packages." (('package 'package (? string? spec)) (manifest-entries (package->development-manifest - (transform (specification->package+output spec))))) + (transform (specification->package+output spec)) + system))) (('expression mode str) ;; Add all the outputs of the package STR evaluates to. (packages->outputs (read/eval str) mode)) @@ -1100,17 +1104,18 @@ command-line option processing with 'parse-command-line'." ;; Evaluate EXP... with STORE bound to a connection, unless ;; STORE-NEEDED? is false, in which case STORE is bound to #f. (let ((proc (lambda (store) exp ...))) - (if store-needed? - (with-store s - (set-build-options-from-command-line s opts) - (with-build-handler (build-notifier #:use-substitutes? - (assoc-ref opts 'substitutes?) - #:verbosity - (assoc-ref opts 'verbosity) - #:dry-run? - (assoc-ref opts 'dry-run?)) - (proc s))) - (proc #f)))) + (parameterize ((%graft? (assoc-ref opts 'graft?))) + (if store-needed? + (with-store s + (set-build-options-from-command-line s opts) + (with-build-handler (build-notifier #:use-substitutes? + (assoc-ref opts 'substitutes?) + #:verbosity + (assoc-ref opts 'verbosity) + #:dry-run? + (assoc-ref opts 'dry-run?)) + (proc s))) + (proc #f))))) (when container? (assert-container-features)) @@ -1122,11 +1127,11 @@ command-line option processing with 'parse-command-line'." (when no-cwd? (leave (G_ "--no-cwd cannot be used without '--container'~%"))) (when emulate-fhs? - (leave (G_ "'--emulate-fhs' cannot be used without '--container~%'"))) + (leave (G_ "'--emulate-fhs' cannot be used without '--container'~%"))) (when nesting? - (leave (G_ "'--nesting' cannot be used without '--container~%'"))) + (leave (G_ "'--nesting' cannot be used without '--container'~%"))) (when (pair? symlinks) - (leave (G_ "'--symlink' cannot be used without '--container~%'")))) + (leave (G_ "'--symlink' cannot be used without '--container'~%")))) (with-store/maybe store (with-status-verbosity (assoc-ref opts 'verbosity) @@ -1146,14 +1151,14 @@ command-line option processing with 'parse-command-line'." (warning (G_ "no packages specified; creating an empty environment~%"))) ;; Use the bootstrap Guile when requested. - (parameterize ((%graft? (assoc-ref opts 'graft?)) - (%guile-for-build + (parameterize ((%guile-for-build (and store-needed? (package-derivation store (if bootstrap? %bootstrap-guile - (default-guile)))))) + (default-guile)) + system)))) (run-with-store store ;; Containers need a Bourne shell at /bin/sh. (mlet* %store-monad ((bash (environment-bash container? diff --git a/guix/scripts/gc.scm b/guix/scripts/gc.scm index 6068f5fe3f..58af827617 100644 --- a/guix/scripts/gc.scm +++ b/guix/scripts/gc.scm @@ -132,7 +132,7 @@ current one." ;; Specification of the command-line options. (list (option '(#\h "help") #f #f (lambda args - (show-help) + (leave-on-EPIPE (show-help)) (exit 0))) (option '(#\V "version") #f #f (lambda args diff --git a/guix/scripts/git.scm b/guix/scripts/git.scm index 4436d8a6e0..abbad076cd 100644 --- a/guix/scripts/git.scm +++ b/guix/scripts/git.scm @@ -56,7 +56,7 @@ Operate on Git repositories.\n")) (format (current-error-port) (G_ "guix git: missing sub-command~%"))) ((or ("-h") ("--help")) - (show-help) + (leave-on-EPIPE (show-help)) (exit 0)) ((or ("-V") ("--version")) (show-version-and-exit "guix git")) diff --git a/guix/scripts/graph.scm b/guix/scripts/graph.scm index c075e0ec29..6740858d8b 100644 --- a/guix/scripts/graph.scm +++ b/guix/scripts/graph.scm @@ -510,7 +510,7 @@ package modules, while attempting to retain user package modules." %standard-build-options) (option '(#\h "help") #f #f (lambda args - (show-help) + (leave-on-EPIPE (show-help)) (exit 0))) (option '(#\V "version") #f #f (lambda args diff --git a/guix/scripts/hash.scm b/guix/scripts/hash.scm index 6dc67a2416..7197d3965c 100644 --- a/guix/scripts/hash.scm +++ b/guix/scripts/hash.scm @@ -153,7 +153,7 @@ use '--serializer=nar' instead~%"))) (alist-delete 'serializer result)))) (option '(#\h "help") #f #f (lambda args - (show-help) + (leave-on-EPIPE (show-help)) (exit 0))) (option '(#\V "version") #f #f (lambda args diff --git a/guix/scripts/home.scm b/guix/scripts/home.scm index e0800bc062..b4c82d275f 100644 --- a/guix/scripts/home.scm +++ b/guix/scripts/home.scm @@ -164,7 +164,7 @@ Some ACTIONS support additional ARGS.\n")) ;; Specification of the command-line options. (cons* (option '(#\h "help") #f #f (lambda args - (show-help) + (leave-on-EPIPE (show-help)) (exit 0))) (option '(#\n "dry-run") #f #f (lambda (opt name arg result) diff --git a/guix/scripts/import.scm b/guix/scripts/import.scm index 4ddd8d46a1..1e8ffd25ec 100644 --- a/guix/scripts/import.scm +++ b/guix/scripts/import.scm @@ -78,7 +78,7 @@ Run IMPORTER with ARGS.\n")) (format (current-error-port) (G_ "guix import: missing importer name~%"))) ((or ("-h") ("--help")) - (show-help) + (leave-on-EPIPE (show-help)) (exit 0)) ((or ("-V") ("--version")) (show-version-and-exit "guix import")) diff --git a/guix/scripts/install.scm b/guix/scripts/install.scm index 63e625f266..504dbc9a6f 100644 --- a/guix/scripts/install.scm +++ b/guix/scripts/install.scm @@ -52,7 +52,7 @@ This is an alias for 'guix package -i'.\n")) ;; Specification of the command-line options. (cons* (option '(#\h "help") #f #f (lambda args - (show-help) + (leave-on-EPIPE (show-help)) (exit 0))) (option '(#\V "version") #f #f (lambda args diff --git a/guix/scripts/lint.scm b/guix/scripts/lint.scm index 9920c3ee62..ee3de51fb1 100644 --- a/guix/scripts/lint.scm +++ b/guix/scripts/lint.scm @@ -159,7 +159,7 @@ run the checkers on all packages.\n")) %standard-build-options) (option '(#\h "help") #f #f (lambda args - (show-help) + (leave-on-EPIPE (show-help)) (exit 0))) (option '(#\l "list-checkers") #f #f (lambda (opt name arg result) diff --git a/guix/scripts/locate.scm b/guix/scripts/locate.scm index 79af533fd9..963ff2bf57 100644 --- a/guix/scripts/locate.scm +++ b/guix/scripts/locate.scm @@ -114,14 +114,24 @@ alter table Packages add column output text; "))) +;; XXX: missing in guile-sqlite3@0.1.3 +(define SQLITE_BUSY 5) + (define (call-with-database file proc) - (let ((db (sqlite-open file))) - (dynamic-wind - (lambda () #t) - (lambda () - (ensure-latest-database-schema db) - (proc db)) - (lambda () (sqlite-close db))))) + (catch 'sqlite-error + (lambda () + (let ((db (sqlite-open file))) + (dynamic-wind + (lambda () #t) + (lambda () + (ensure-latest-database-schema db) + (proc db)) + (lambda () (sqlite-close db))))) + (lambda (key who code errmsg) + (if (= code SQLITE_BUSY) + (leave (G_ "~a: database is locked by another process~%") + file) + (throw key who code errmsg))))) (define (ensure-latest-database-schema db) "Ensure DB follows the latest known version of the schema." @@ -196,10 +206,15 @@ SELECT version FROM SchemaVersion ORDER BY version DESC LIMIT 1;" ;; System-wide database file name. (string-append %localstatedir "/cache/guix/locate/db.sqlite")) -(define (suitable-database create?) +(define (file-age stat) + "Return the age of the file denoted by STAT in seconds." + (- (current-time) (stat:mtime stat))) + +(define (suitable-database create? age-update-threshold) "Return a suitable database file. When CREATE? is true, the returned database will be opened for writing; otherwise, return the most recent one, -user or system." +user or system. Do not return the system database if it is older than +AGE-UPDATE-THRESHOLD seconds." (if (zero? (getuid)) system-database-file (if create? @@ -207,10 +222,13 @@ user or system." (let ((system (stat system-database-file #f)) (user (stat user-database-file #f))) (if user - (if (and system (> (stat:mtime system) (stat:mtime user))) + (if (and system + (> (stat:mtime system) (stat:mtime user)) + (< (file-age system) age-update-threshold)) system-database-file user-database-file) - (if system + (if (and system + (< (file-age system) age-update-threshold)) system-database-file user-database-file)))))) @@ -543,7 +561,7 @@ Locate FILE and return the list of packages that contain it.\n")) (define %options (list (option '(#\h "help") #f #f - (lambda args (show-help) (exit 0))) + (lambda args (leave-on-EPIPE (show-help)) (exit 0))) (option '(#\V "version") #f #f (lambda (opt name arg result) (show-version-and-exit "guix locate"))) @@ -595,10 +613,6 @@ Locate FILE and return the list of packages that contain it.\n")) ;; database. (* 9 30 (* 24 60 60))) - (define (file-age stat) - ;; Return true if TIME denotes an "old" time. - (- (current-time) (stat:mtime stat))) - (with-error-handling (let* ((opts (parse-command-line args %options (list %default-options) @@ -610,7 +624,7 @@ Locate FILE and return the list of packages that contain it.\n")) (clear? (assoc-ref opts 'clear?)) (update? (assoc-ref opts 'update?)) (glob? (assoc-ref opts 'glob?)) - (database ((assoc-ref opts 'database) update?)) + (database ((assoc-ref opts 'database) update? age-update-threshold)) (method (assoc-ref opts 'method)) (files (reverse (filter-map (match-lambda (('argument . arg) arg) @@ -653,7 +667,7 @@ Locate FILE and return the list of packages that contain it.\n")) files))) (() (if (null? files) - (unless update? + (unless (or update? (assoc-ref opts 'clear?)) (leave (G_ "no files to search for~%"))) (leave (N_ "file~{ '~a'~} not found in database '~a'~%" "files~{ '~a'~} not found in database '~a'~%" diff --git a/guix/scripts/offload.scm b/guix/scripts/offload.scm index 7b76126d35..137e3b5fe3 100644 --- a/guix/scripts/offload.scm +++ b/guix/scripts/offload.scm @@ -868,11 +868,12 @@ machine." (("--version") (show-version-and-exit "guix offload")) (("--help") - (format #t (G_ "Usage: guix offload SYSTEM MAX-SILENT-TIME \ + (leave-on-EPIPE + (format #t (G_ "Usage: guix offload SYSTEM MAX-SILENT-TIME \ PRINT-BUILD-TRACE? BUILD-TIMEOUT Process build offload requests written on the standard input, possibly offloading builds to the machines listed in '~a'.~%") - %machine-file) + %machine-file)) (display (G_ " This tool is meant to be used internally by 'guix-daemon'.\n")) (show-bug-report-information)) diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm index 01995c48b7..8071840de1 100644 --- a/guix/scripts/pack.scm +++ b/guix/scripts/pack.scm @@ -137,7 +137,8 @@ dependencies are registered." ;; Make sure non-ASCII file names are properly handled. (setenv "GUIX_LOCPATH" - #+(file-append glibc-utf8-locales "/lib/locale")) + #+(file-append (libc-utf8-locales-for-target (%current-system)) + "/lib/locale")) (setlocale LC_ALL "en_US.utf8") (sql-schema #$schema) @@ -209,7 +210,10 @@ GLIBC-UT8-LOCALES package." (profile-locales? profile)) #~(begin (setenv "GUIX_LOCPATH" - #+(file-append glibc-utf8-locales "/lib/locale")) + #+(file-append (let-system (system target) + (libc-utf8-locales-for-target + (or target system))) + "/lib/locale")) (setlocale LC_ALL "en_US.utf8")) #~(setenv "GUIX_LOCPATH" "unset for tests"))) @@ -507,7 +511,7 @@ added to the pack." image is a tarball conforming to the Docker Image Specification, compressed with COMPRESSOR. It can be passed to 'docker load'. If TARGET is true, it must a be a GNU triplet and it is used to derive the architecture metadata in -the image." +the image. EXTRA-OPTIONS may contain the IMAGE-TAG keyword argument." (define database (and localstatedir? (file-append (store-database (list profile)) @@ -531,7 +535,7 @@ the image." (guix build utils) (guix profiles) (guix search-paths) (srfi srfi-1) (srfi srfi-19) - (ice-9 match)) + (ice-9 match) (ice-9 optargs)) #$(procedure-source manifest->friendly-name) @@ -560,23 +564,30 @@ the image." (setenv "PATH" #+(file-append archiver "/bin")) - (build-docker-image #$output - (map store-info-item - (call-with-input-file "profile" - read-reference-graph)) - #$profile - #:repository (manifest->friendly-name - (profile-manifest #$profile)) - #:database #+database - #:system (or #$target %host-type) - #:environment environment - #:entry-point - #$(and entry-point - #~(list (string-append #$profile "/" - #$entry-point))) - #:extra-files directives - #:compressor #+(compressor-command compressor) - #:creation-time (make-time time-utc 0 1)))))) + (let-keywords '#$extra-options #f + ((image-tag #f)) + (build-docker-image #$output + (map store-info-item + (call-with-input-file "profile" + read-reference-graph)) + #$profile + #:repository + (or image-tag + (manifest->friendly-name + (profile-manifest #$profile))) + #:database #+database + #:system (or #$target %host-type) + #:environment environment + #:entry-point + #$(and entry-point + #~(list + (string-append #$profile "/" + #$entry-point))) + #:extra-files directives + #:compressor + #+(compressor-command compressor) + #:creation-time + (make-time time-utc 0 1))))))) (gexp->derivation (string-append name ".tar" (compressor-extension compressor)) @@ -1287,6 +1298,20 @@ last resort for relocation." (alist-cons symbol arg result) rest)))) +(define %docker-format-options + (list (required-option 'image-tag))) + +(define (show-docker-format-options) + (display (G_ " + --help-docker-format list options specific to the docker format"))) + +(define (show-docker-format-options/detailed) + (display (G_ " + --image-tag=NAME + Use the given NAME for the Docker image repository")) + (newline) + (exit 0)) + (define %deb-format-options (list (required-option 'control-file) (required-option 'postinst-file) @@ -1339,7 +1364,7 @@ last resort for relocation." ;; Specifications of the command-line options. (cons* (option '(#\h "help") #f #f (lambda args - (show-help) + (leave-on-EPIPE (show-help)) (exit 0))) (option '(#\V "version") #f #f (lambda args @@ -1407,6 +1432,10 @@ last resort for relocation." (lambda (opt name arg result) (alist-cons 'bootstrap? #t result))) + (option '("help-docker-format") #f #f + (lambda args + (show-docker-format-options/detailed))) + (option '("help-deb-format") #f #f (lambda args (show-deb-format-options/detailed))) @@ -1415,7 +1444,8 @@ last resort for relocation." (lambda args (show-rpm-format-options/detailed))) - (append %deb-format-options + (append %docker-format-options + %deb-format-options %rpm-format-options %transformation-options %standard-build-options @@ -1433,6 +1463,7 @@ Create a bundle of PACKAGE.\n")) (newline) (show-transformation-options-help) (newline) + (show-docker-format-options) (show-deb-format-options) (show-rpm-format-options) (newline) @@ -1586,6 +1617,9 @@ Create a bundle of PACKAGE.\n")) manifest))) (pack-format (assoc-ref opts 'format)) (extra-options (match pack-format + ('docker + (list #:image-tag + (assoc-ref opts 'image-tag))) ('deb (list #:control-file (process-file-arg opts 'control-file) diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index ab1968b62d..a489e06e73 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -504,7 +504,7 @@ Install, remove, or upgrade packages in a single transaction.\n")) ;; Specification of the command-line options. (cons* (option '(#\h "help") #f #f (lambda args - (show-help) + (leave-on-EPIPE (show-help)) (exit 0))) (option '(#\V "version") #f #f (lambda args diff --git a/guix/scripts/perform-download.scm b/guix/scripts/perform-download.scm index 045dd84ad6..9aa0e61e9d 100644 --- a/guix/scripts/perform-download.scm +++ b/guix/scripts/perform-download.scm @@ -108,6 +108,12 @@ Note: OUTPUT may differ from the 'out' value of DRV, notably for 'bmCheck' or (drv-output (assoc-ref (derivation-outputs drv) "out")) (algo (derivation-output-hash-algo drv-output)) (hash (derivation-output-hash drv-output))) + ;; Commands such as 'git submodule' expect Coreutils and sed (among + ;; others) to be in $PATH. The 'git' package in Guix should address it + ;; with wrappers but packages on other distros such as Debian may rely + ;; on ambient authority, hence the PATH value below. + (setenv "PATH" "/run/current-system/profile/bin:/bin:/usr/bin") + (git-fetch-with-fallback url commit output #:recursive? recursive? #:git-command %git)))) diff --git a/guix/scripts/processes.scm b/guix/scripts/processes.scm index 3db5603286..4a855c8c7c 100644 --- a/guix/scripts/processes.scm +++ b/guix/scripts/processes.scm @@ -313,7 +313,7 @@ List the current Guix sessions and their processes.")) (define %options (list (option '(#\h "help") #f #f (lambda args - (show-help) + (leave-on-EPIPE (show-help)) (exit 0))) (option '(#\V "version") #f #f (lambda args diff --git a/guix/scripts/publish.scm b/guix/scripts/publish.scm index ada81838ac..4457be1fce 100644 --- a/guix/scripts/publish.scm +++ b/guix/scripts/publish.scm @@ -160,7 +160,7 @@ usage." (define %options (list (option '(#\h "help") #f #f (lambda _ - (show-help) + (leave-on-EPIPE (show-help)) (exit 0))) (option '(#\V "version") #f #f (lambda _ diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm index 1904a6913a..58d3cd7e83 100644 --- a/guix/scripts/pull.scm +++ b/guix/scripts/pull.scm @@ -201,7 +201,7 @@ Download and deploy the latest version of Guix.\n")) (option '(#\h "help") #f #f (lambda args - (show-help) + (leave-on-EPIPE (show-help)) (exit 0))) (option '(#\V "version") #f #f (lambda args diff --git a/guix/scripts/refresh.scm b/guix/scripts/refresh.scm index 46bf310d5f..d858ed07cb 100644 --- a/guix/scripts/refresh.scm +++ b/guix/scripts/refresh.scm @@ -144,7 +144,7 @@ (option '(#\h "help") #f #f (lambda args - (show-help) + (leave-on-EPIPE (show-help)) (exit 0))) (option '(#\V "version") #f #f (lambda args diff --git a/guix/scripts/remove.scm b/guix/scripts/remove.scm index a46ad04d56..be073878c5 100644 --- a/guix/scripts/remove.scm +++ b/guix/scripts/remove.scm @@ -49,7 +49,7 @@ This is an alias for 'guix package -r'.\n")) ;; Specification of the command-line options. (cons* (option '(#\h "help") #f #f (lambda args - (show-help) + (leave-on-EPIPE (show-help)) (exit 0))) (option '(#\V "version") #f #f (lambda args diff --git a/guix/scripts/repl.scm b/guix/scripts/repl.scm index fd23a2b982..cb71e59b05 100644 --- a/guix/scripts/repl.scm +++ b/guix/scripts/repl.scm @@ -42,7 +42,7 @@ (define %options (list (option '(#\h "help") #f #f (lambda args - (show-help) + (leave-on-EPIPE (show-help)) (exit 0))) (option '(#\V "version") #f #f (lambda args diff --git a/guix/scripts/search.scm b/guix/scripts/search.scm index 307ea410b9..e6deb710b1 100644 --- a/guix/scripts/search.scm +++ b/guix/scripts/search.scm @@ -47,7 +47,7 @@ This is an alias for 'guix package -s'.\n")) ;; Specification of the command-line options. (list (option '(#\h "help") #f #f (lambda args - (show-help) + (leave-on-EPIPE (show-help)) (exit 0))) (option '(#\V "version") #f #f (lambda args diff --git a/guix/scripts/shell.scm b/guix/scripts/shell.scm index 83888eee1d..0584a7e018 100644 --- a/guix/scripts/shell.scm +++ b/guix/scripts/shell.scm @@ -26,6 +26,7 @@ #:autoload (guix transformations) (options->transformation transformation-option-key? show-transformation-options-help) + #:autoload (guix grafts) (%graft?) #:use-module (guix scripts) #:use-module (guix packages) #:use-module (guix profiles) @@ -115,7 +116,7 @@ interactive shell in that environment.\n")) (append (list (option '(#\h "help") #f #f (lambda args - (show-help) + (leave-on-EPIPE (show-help)) (exit 0))) (option '(#\V "version") #f #f (lambda args @@ -354,6 +355,7 @@ performed--e.g., because the package cache is not authoritative." ;; be insufficient: <https://lwn.net/Articles/866582/>. (sha256 (string->utf8 (string-append primary-key ":" system ":" + (if (%graft?) "" "ungrafted:") (number->string (stat:dev stat)) ":" (number->string (stat:ino stat)))))))))) @@ -366,6 +368,7 @@ is a list of package specs. Return #f if caching is not possible." (bytevector->base32-string (sha256 (string->utf8 (string-append primary-key ":" system ":" + (if (%graft?) "" "ungrafted:") (object->string specs)))))))) (define (profile-cached-gc-root opts) @@ -396,9 +399,16 @@ return #f and #f." ((('nesting? . #t) . rest) (loop rest system file (append specs '("nested guix")))) ((('load . ('package candidate)) . rest) + ;; This is 'guix shell -D -f guix.scm'. (if (and (not file) (null? specs)) (loop rest system candidate specs) (values #f #f))) + ((('load . ('ad-hoc-package candidate)) . rest) + ;; When running 'guix shell -f guix.scm', one typically expects + ;; 'guix.scm' to be evaluated every time because it may contain + ;; references like (local-file "." #:recursive? #t). Thus, disable + ;; caching. + (values #f #f)) ((('manifest . candidate) . rest) (if (and (not file) (null? specs)) (loop rest system candidate specs) diff --git a/guix/scripts/show.scm b/guix/scripts/show.scm index f6d8256951..14b72cb75a 100644 --- a/guix/scripts/show.scm +++ b/guix/scripts/show.scm @@ -46,7 +46,7 @@ This is an alias for 'guix package --show='.\n")) ;; Specification of the command-line options. (list (option '(#\h "help") #f #f (lambda args - (show-help) + (leave-on-EPIPE (show-help)) (exit 0))) (option '(#\V "version") #f #f (lambda args diff --git a/guix/scripts/size.scm b/guix/scripts/size.scm index 48b8ecc881..d26ed98388 100644 --- a/guix/scripts/size.scm +++ b/guix/scripts/size.scm @@ -278,7 +278,7 @@ Report the size of the PACKAGE or STORE-ITEM, with its dependencies.\n")) %standard-build-options) (option '(#\h "help") #f #f (lambda args - (show-help) + (leave-on-EPIPE (show-help)) (exit 0))) (option '(#\V "version") #f #f (lambda args diff --git a/guix/scripts/style.scm b/guix/scripts/style.scm index 4920a8d969..211980dc1c 100644 --- a/guix/scripts/style.scm +++ b/guix/scripts/style.scm @@ -547,7 +547,7 @@ bailing out~%")) (option '(#\h "help") #f #f (lambda args - (show-help) + (leave-on-EPIPE (show-help)) (exit 0))) (option '(#\l "list-stylings") #f #f (lambda args @@ -625,6 +625,8 @@ Update package definitions to the latest style.\n")) opts))) (unless (eq? format-package-definition style) (warning (G_ "'--styling' option has no effect in whole-file mode~%"))) + (when (null? files) + (warning (G_ "no files specified, nothing to do~%"))) (for-each format-whole-file files)) (let ((packages (filter-map (match-lambda (('argument . spec) diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm index 8b1f7d6fda..37cd08e289 100755 --- a/guix/scripts/substitute.scm +++ b/guix/scripts/substitute.scm @@ -635,8 +635,9 @@ way to download the nar." (let loop ((cache-urls cache-urls)) (match cache-urls (() - (leave (G_ "failed to find alternative substitute for '~a'~%") - (narinfo-path narinfo))) + (report-error (G_ "failed to find alternative substitute for '~a'~%") + (narinfo-path narinfo)) + (display "not-found\n" port)) ((cache-url rest ...) (match (lookup-narinfos cache-url (list (narinfo-path narinfo)) @@ -813,7 +814,7 @@ default value." ((or ("-V") ("--version")) (show-version-and-exit "guix substitute")) ((or ("-h") ("--help") ()) - (show-help) + (leave-on-EPIPE (show-help)) (exit 0)) (_ #t)) diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index 547387d5e1..f85b663d64 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -1064,7 +1064,7 @@ Some ACTIONS support additional ARGS.\n")) ;; Specifications of the command-line options. (cons* (option '(#\h "help") #f #f (lambda args - (show-help) + (leave-on-EPIPE (show-help)) (exit 0))) (option '(#\V "version") #f #f (lambda args diff --git a/guix/scripts/time-machine.scm b/guix/scripts/time-machine.scm index 3ecf735acb..2c30fe7cfd 100644 --- a/guix/scripts/time-machine.scm +++ b/guix/scripts/time-machine.scm @@ -46,12 +46,6 @@ #:use-module (srfi srfi-71) #:export (guix-time-machine)) -;;; The required inferiors mechanism relied on by 'guix time-machine' was -;;; firmed up in v1.0.0; it is the oldest, safest commit that can be travelled -;;; to. -(define %oldest-possible-commit - "6298c3ffd9654d3231a6f25390b056483e8f407c") ;v1.0.0 - ;;; ;;; Command-line options. @@ -107,7 +101,7 @@ Execute COMMAND ARGS... in an older version of Guix.\n")) (alist-cons 'authenticate-channels? #f result))) (option '(#\h "help") #f #f (lambda args - (show-help) + (leave-on-EPIPE (show-help)) (exit 0))) (option '(#\V "version") #f #f (lambda args @@ -146,6 +140,31 @@ Execute COMMAND ARGS... in an older version of Guix.\n")) ;;; +;;; Avoiding traveling too far back. +;;; + +;;; The required inferiors mechanism relied on by 'guix time-machine' was +;;; firmed up in v1.0.0; it is the oldest, safest commit that can be travelled +;;; to. +(define %oldest-possible-commit + "6298c3ffd9654d3231a6f25390b056483e8f407c") ;v1.0.0 + +(define %reference-channels + (list (channel (inherit %default-guix-channel) + (commit %oldest-possible-commit)))) + +(define (validate-guix-channel channel start commit relation) + "Raise an error if CHANNEL is the 'guix' channel and the RELATION of COMMIT +to %OLDEST-POSSIBLE-COMMIT is not that of an ancestor." + (unless (or (not (guix-channel? channel)) + (memq relation '(ancestor self))) + (raise (formatted-message + (G_ "cannot travel past commit `~a' from May 1st, 2019") + (string-take %oldest-possible-commit 12))))) + + + +;;; ;;; Entry point. ;;; @@ -160,44 +179,22 @@ Execute COMMAND ARGS... in an older version of Guix.\n")) (ref (assoc-ref opts 'ref)) (substitutes? (assoc-ref opts 'substitutes?)) (authenticate? (assoc-ref opts 'authenticate-channels?))) - - (define (validate-guix-channel channels) - "Finds the Guix channel among CHANNELS, and validates that REF as -captured from the closure, a git reference specification such as a commit hash -or tag associated to the channel, is valid and new enough to satisfy the 'guix -time-machine' requirements. If the captured REF variable is #f, the reference -validate is the one of the Guix channel found in CHANNELS. A -`formatted-message' condition is raised otherwise." - (let* ((guix-channel (find guix-channel? channels)) - (guix-channel-commit (channel-commit guix-channel)) - (guix-channel-branch (channel-branch guix-channel)) - (guix-channel-ref (if guix-channel-commit - `(tag-or-commit . ,guix-channel-commit) - `(branch . ,guix-channel-branch))) - (reference (or ref guix-channel-ref)) - (checkout commit relation (update-cached-checkout - (channel-url guix-channel) - #:ref reference - #:starting-commit - %oldest-possible-commit))) - (unless (memq relation '(ancestor self)) - (raise (formatted-message - (G_ "cannot travel past commit `~a' from May 1st, 2019") - (string-take %oldest-possible-commit 12)))))) - - (when command-line - (let* ((directory - (with-store store - (with-status-verbosity (assoc-ref opts 'verbosity) - (with-build-handler (build-notifier #:use-substitutes? - substitutes? - #:verbosity - (assoc-ref opts 'verbosity) - #:dry-run? #f) - (set-build-options-from-command-line store opts) - (cached-channel-instance store channels - #:authenticate? authenticate? - #:validate-channels - validate-guix-channel))))) - (executable (string-append directory "/bin/guix"))) - (apply execl (cons* executable executable command-line)))))))) + (if command-line + (let* ((directory + (with-store store + (with-status-verbosity (assoc-ref opts 'verbosity) + (with-build-handler (build-notifier #:use-substitutes? + substitutes? + #:verbosity + (assoc-ref opts 'verbosity) + #:dry-run? #f) + (set-build-options-from-command-line store opts) + (cached-channel-instance store channels + #:authenticate? authenticate? + #:reference-channels + %reference-channels + #:validate-channels + validate-guix-channel))))) + (executable (string-append directory "/bin/guix"))) + (apply execl (cons* executable executable command-line))) + (warning (G_ "no command specified; nothing to do~%"))))))) diff --git a/guix/scripts/upgrade.scm b/guix/scripts/upgrade.scm index beb59cbe6f..1a5e8088cb 100644 --- a/guix/scripts/upgrade.scm +++ b/guix/scripts/upgrade.scm @@ -56,7 +56,7 @@ This is an alias for 'guix package -u'.\n")) ;; Specification of the command-line options. (cons* (option '(#\h "help") #f #f (lambda args - (show-help) + (leave-on-EPIPE (show-help)) (exit 0))) (option '(#\V "version") #f #f (lambda args diff --git a/guix/scripts/weather.scm b/guix/scripts/weather.scm index dc27f81984..140df3435f 100644 --- a/guix/scripts/weather.scm +++ b/guix/scripts/weather.scm @@ -360,7 +360,7 @@ Report the availability of substitutes.\n")) (define %options (cons* (option '(#\h "help") #f #f (lambda args - (show-help) + (leave-on-EPIPE (show-help)) (exit 0))) (option '(#\V "version") #f #f (lambda args diff --git a/guix/self.scm b/guix/self.scm index a1f235659d..f378548959 100644 --- a/guix/self.scm +++ b/guix/self.scm @@ -73,7 +73,10 @@ ("po4a" . ,(ref 'gettext 'po4a)) ("gettext-minimal" . ,(ref 'gettext 'gettext-minimal)) ("gcc-toolchain" . ,(ref 'commencement 'gcc-toolchain)) - ("glibc-utf8-locales" . ,(ref 'base 'glibc-utf8-locales)) + ("glibc-utf8-locales" . ,(delay + ((module-ref (resolve-interface + '(gnu packages base)) + 'libc-utf8-locales-for-target)))) ("graphviz" . ,(ref 'graphviz 'graphviz-minimal)) ("font-ghostscript" . ,(ref 'ghostscript 'font-ghostscript)) ("texinfo" . ,(ref 'texinfo 'texinfo))))) diff --git a/guix/transformations.scm b/guix/transformations.scm index 9cba6bedab..132ccd957a 100644 --- a/guix/transformations.scm +++ b/guix/transformations.scm @@ -3,6 +3,7 @@ ;;; Copyright © 2021 Marius Bakke <marius@gnu.org> ;;; Copyright © 2023 Sarthak Shah <shahsarthakw@gmail.com> ;;; Copyright © 2023 Efraim Flashner <efraim@flashner.co.il> +;;; Copyright © 2023 Ekaitz Zarraga <ekaitz@elenq.tech> ;;; ;;; This file is part of GNU Guix. ;;; @@ -439,7 +440,8 @@ the equal sign." actual compiler." (define wrapper #~(begin - (use-modules (ice-9 match)) + (use-modules (ice-9 match) + (ice-9 string-fun)) (define psabi #$(gcc-architecture->micro-architecture-level micro-architecture)) @@ -486,11 +488,20 @@ actual compiler." (apply execl next (append (cons next arguments) - (if (and (search-next "go") - (string=? next (search-next "go"))) - '() - (list (string-append "-march=" - #$micro-architecture))))))))))) + (cond + ((and (search-next "go") + (string=? next (search-next "go"))) + '()) + ((and (search-next "zig") + (string=? next (search-next "zig"))) + `(,(string-append + ;; https://issues.guix.gnu.org/67075#3 + "-Dcpu=" + (string-replace-substring + #$micro-architecture "-" "_")))) + (else + (list (string-append "-march=" + #$micro-architecture)))))))))))) (define program (program-file (string-append "tuning-compiler-wrapper-" micro-architecture) @@ -508,7 +519,7 @@ actual compiler." (symlink #$program (string-append bin "/" program))) '("cc" "gcc" "clang" "g++" "c++" "clang++" - "go"))))))) + "go" "zig"))))))) (define (build-system-with-tuning-compiler bs micro-architecture) "Return a variant of BS, a build system, that ensures that the compiler that diff --git a/guix/ui.scm b/guix/ui.scm index 6f2d4fe245..e3bf07212f 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -552,19 +552,20 @@ See the \"Application Setup\" section in the manual, for more info.\n")) (define* (show-version-and-exit #:optional (command (car (command-line)))) "Display version information for COMMAND and `(exit 0)'." - (simple-format #t "~a (~a) ~a~%" - command %guix-package-name %guix-version) - (format #t "Copyright ~a 2023 ~a" - ;; TRANSLATORS: Translate "(C)" to the copyright symbol - ;; (C-in-a-circle), if this symbol is available in the user's - ;; locale. Otherwise, do not translate "(C)"; leave it as-is. */ - (G_ "(C)") - (G_ "the Guix authors\n")) - (display (G_"\ + (leave-on-EPIPE + (simple-format #t "~a (~a) ~a~%" + command %guix-package-name %guix-version) + (format #t "Copyright ~a 2023 ~a" + ;; TRANSLATORS: Translate "(C)" to the copyright symbol + ;; (C-in-a-circle), if this symbol is available in the user's + ;; locale. Otherwise, do not translate "(C)"; leave it as-is. */ + (G_ "(C)") + (G_ "the Guix authors\n")) + (display (G_"\ License GPLv3+: GNU GPL version 3 or later <http://gnu.org/licenses/gpl.html> This is free software: you are free to change and redistribute it. There is NO WARRANTY, to the extent permitted by law. -")) +"))) (exit 0)) (define (show-bug-report-information) diff --git a/guix/utils.scm b/guix/utils.scm index e9af33bdeb..7a42b49df2 100644 --- a/guix/utils.scm +++ b/guix/utils.scm @@ -18,6 +18,7 @@ ;;; Copyright © 2022 Antero Mejr <antero@mailbox.org> ;;; Copyright © 2023 Philip McGrath <philip@philipmcgrath.com> ;;; Copyright © 2023 Janneke Nieuwenhuizen <janneke@gnu.org> +;;; Copyright © 2023 Zheng Junjie <873216071@qq.com> ;;; ;;; This file is part of GNU Guix. ;;; @@ -111,6 +112,7 @@ cxx-for-target ld-for-target pkg-config-for-target + strip-for-target version-compare version>? @@ -784,6 +786,11 @@ architecture (x86_64)?" (string-append target "-pkg-config") "pkg-config")) +(define* (strip-for-target #:optional (target (%current-target-system))) + (if target + (string-append target "-strip") + "strip")) + (define version-compare (let ((strverscmp (let ((sym (or (dynamic-func "strverscmp" (dynamic-link)) |