diff options
author | Andrew Whatson <whatson@gmail.com> | 2021-05-28 00:18:27 +1000 |
---|---|---|
committer | Ludovic Courtès <ludo@gnu.org> | 2021-05-28 11:36:02 +0200 |
commit | ebbfee880c1def28b77aeb2eee640998b9fa7d5f (patch) | |
tree | fdfb912c6f8e49135f5db8c5f74d12338a9b2140 | |
parent | 50d5bb1f3e3f080212436db1b8666d061a8ae1d2 (diff) | |
download | guix-ebbfee880c1def28b77aeb2eee640998b9fa7d5f.tar.gz guix-ebbfee880c1def28b77aeb2eee640998b9fa7d5f.zip |
git-download: Support submodules in 'git-predicate'.
* guix/git-download.scm (git-file-list): Add prefix and recursive?
arguments. Recurse into submodules when requested.
(git-predicate): Add recursive? argument.
Signed-off-by: Ludovic Courtès <ludo@gnu.org>
-rw-r--r-- | guix/git-download.scm | 67 |
1 files changed, 53 insertions, 14 deletions
diff --git a/guix/git-download.scm b/guix/git-download.scm index 72084a2249..5e624b9ae9 100644 --- a/guix/git-download.scm +++ b/guix/git-download.scm @@ -33,6 +33,9 @@ repository-discover repository-head repository-working-directory) + #:autoload (git submodule) (repository-submodules + submodule-lookup + submodule-path) #:autoload (git commit) (commit-lookup commit-tree) #:autoload (git reference) (reference-target) #:autoload (git tree) (tree-list) @@ -194,11 +197,17 @@ HASH-ALGO (a symbol). Use NAME as the file name, or a generic name if #f." ;;; 'git-predicate'. ;;; -(define (git-file-list directory) +(define* (git-file-list directory #:optional prefix #:key (recursive? #t)) "Return the list of files checked in in the Git repository at DIRECTORY. The result is similar to that of the 'git ls-files' command, except that it -also includes directories, not just regular files. The returned file names -are relative to DIRECTORY, which is not necessarily the root of the checkout." +also includes directories, not just regular files. + +When RECURSIVE? is true, also list files in submodules, similar to the 'git +ls-files --recurse-submodules' command. This is enabled by default. + +The returned file names are relative to DIRECTORY, which is not necessarily +the root of the checkout. If a PREFIX is provided, it is prepended to each +file name." (let* (;; 'repository-working-directory' always returns a trailing "/", ;; so add one here to ease the comparisons below. (directory (string-append (canonicalize-path directory) "/")) @@ -209,27 +218,57 @@ are relative to DIRECTORY, which is not necessarily the root of the checkout." (oid (reference-target head)) (commit (commit-lookup repository oid)) (tree (commit-tree commit)) - (files (tree-list tree))) + (files (tree-list tree)) + (submodules (if recursive? + (map (lambda (name) + (submodule-path + (submodule-lookup repository name))) + (repository-submodules repository)) + '())) + (relative (and (not (string=? workdir directory)) + (string-drop directory (string-length workdir)))) + (included? (lambda (path) + (or (not relative) + (string-prefix? relative path)))) + (make-relative (lambda (path) + (if relative + (string-drop path (string-length relative)) + path))) + (add-prefix (lambda (path) + (if prefix + (string-append prefix "/" path) + path))) + (rectify (compose add-prefix make-relative))) (repository-close! repository) - (if (string=? workdir directory) - files - (let ((relative (string-drop directory (string-length workdir)))) - (filter-map (lambda (file) - (and (string-prefix? relative file) - (string-drop file (string-length relative)))) - files))))) - -(define (git-predicate directory) + (append + (if (or relative prefix) + (filter-map (lambda (file) + (and (included? file) + (rectify file))) + files) + files) + (append-map (lambda (submodule) + (if (included? submodule) + (git-file-list + (string-append workdir submodule) + (rectify submodule)) + '())) + submodules)))) + +(define* (git-predicate directory #:key (recursive? #t)) "Return a predicate that returns true if a file is part of the Git checkout living at DIRECTORY. If DIRECTORY does not lie within a Git checkout, and upon Git errors, return #f instead of a predicate. +When RECURSIVE? is true, the predicate also returns true if a file is part of +any Git submodule under DIRECTORY. This is enabled by default. + The returned predicate takes two arguments FILE and STAT where FILE is an absolute file name and STAT is the result of 'lstat'." (libgit2-init!) (catch 'git-error (lambda () - (let* ((files (git-file-list directory)) + (let* ((files (git-file-list directory #:recursive? recursive?)) (inodes (fold (lambda (file result) (let* ((file (string-append directory "/" file)) (stat (false-if-exception (lstat file)))) |