diff options
author | Liliana Marie Prikler <liliana.prikler@gmail.com> | 2023-11-19 10:02:15 +0100 |
---|---|---|
committer | Liliana Marie Prikler <liliana.prikler@gmail.com> | 2023-11-19 10:02:15 +0100 |
commit | 1cc3b7e80f60a2a5a6a1400ed0b025efeae7a523 (patch) | |
tree | 77cbf407563c8c4b1acc00fe0fdb8ac79b1fdd95 /guix | |
parent | f64ec2b15132c46bcdf0546196646237890832f6 (diff) | |
parent | b7abea0fd6a146563830db1dc4ddd0cceb6fcf1c (diff) |
Merge branch 'master' into gnome-team
Change-Id: I62da840b7600f2d3d8541e666d09e2f2a1b7d8c4
Diffstat (limited to 'guix')
-rw-r--r-- | guix/build-system/ant.scm | 2 | ||||
-rw-r--r-- | guix/build-system/vim.scm | 157 | ||||
-rw-r--r-- | guix/build/ant-build-system.scm | 31 | ||||
-rw-r--r-- | guix/build/git.scm | 19 | ||||
-rw-r--r-- | guix/build/guile-build-system.scm | 13 | ||||
-rw-r--r-- | guix/build/minetest-build-system.scm | 3 | ||||
-rw-r--r-- | guix/build/syscalls.scm | 15 | ||||
-rw-r--r-- | guix/build/vim-build-system.scm | 119 | ||||
-rw-r--r-- | guix/download.scm | 2 | ||||
-rw-r--r-- | guix/git-download.scm | 97 | ||||
-rw-r--r-- | guix/git.scm | 4 | ||||
-rw-r--r-- | guix/inferior.scm | 60 | ||||
-rw-r--r-- | guix/lint.scm | 3 | ||||
-rw-r--r-- | guix/progress.scm | 4 | ||||
-rw-r--r-- | guix/scripts/edit.scm | 6 | ||||
-rw-r--r-- | guix/scripts/locate.scm | 2 | ||||
-rw-r--r-- | guix/scripts/time-machine.scm | 91 |
17 files changed, 505 insertions, 123 deletions
diff --git a/guix/build-system/ant.scm b/guix/build-system/ant.scm index e191fd3c99..84bf951fab 100644 --- a/guix/build-system/ant.scm +++ b/guix/build-system/ant.scm @@ -103,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") @@ -131,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/vim.scm b/guix/build-system/vim.scm new file mode 100644 index 0000000000..fa874a1e3d --- /dev/null +++ b/guix/build-system/vim.scm @@ -0,0 +1,157 @@ +;;; 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")) + (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))))) + + (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/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/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/syscalls.scm b/guix/build/syscalls.scm index b845b8aab9..b29b6f78b6 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 @@ -2336,6 +2337,20 @@ 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 (syscall->procedure int "mbstowcs" (list '* '* size_t))) + (wcswidth (syscall->procedure int "wcswidth" (list '* size_t)))) + (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)))))) + (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/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 b7182305cf..4377b27e00 100644 --- a/guix/git.scm +++ b/guix/git.scm @@ -33,6 +33,8 @@ #: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?) @@ -154,7 +156,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 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/progress.scm b/guix/progress.scm index 33cf6f4a1a..13d3ddc171 100644 --- a/guix/progress.scm +++ b/guix/progress.scm @@ -21,6 +21,8 @@ (define-module (guix progress) #:use-module (guix records) + #:use-module ((guix build syscalls) + #:select (terminal-string-width)) #:use-module (srfi srfi-19) #:use-module (rnrs io ports) #:use-module (rnrs bytevectors) @@ -307,7 +309,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/scripts/edit.scm b/guix/scripts/edit.scm index ff2d529bcf..b7b4cd2514 100644 --- a/guix/scripts/edit.scm +++ b/guix/scripts/edit.scm @@ -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/locate.scm b/guix/scripts/locate.scm index ae64f46896..92af3509bf 100644 --- a/guix/scripts/locate.scm +++ b/guix/scripts/locate.scm @@ -657,7 +657,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/time-machine.scm b/guix/scripts/time-machine.scm index f31fae7435..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. @@ -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~%"))))))) |