TakeV
/
guix
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

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>
This commit is contained in:
Andrew Whatson 2021-05-28 00:18:27 +10:00 committed by Ludovic Courtès
parent 50d5bb1f3e
commit ebbfee880c
No known key found for this signature in database
GPG Key ID: 090B11993D9AEBB5
1 changed files with 52 additions and 13 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

65
guix/git-download.scm
View File

@ -33,6 +33,9 @@
repository-discover repository-discover
repository-head repository-head
repository-working-directory) repository-working-directory)
#:autoload (git submodule) (repository-submodules
submodule-lookup
submodule-path)
#:autoload (git commit) (commit-lookup commit-tree) #:autoload (git commit) (commit-lookup commit-tree)
#:autoload (git reference) (reference-target) #:autoload (git reference) (reference-target)
#:autoload (git tree) (tree-list) #: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'. ;;; '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. "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 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 also includes directories, not just regular files.
are relative to DIRECTORY, which is not necessarily the root of the checkout."
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 "/", (let* (;; 'repository-working-directory' always returns a trailing "/",
;; so add one here to ease the comparisons below. ;; so add one here to ease the comparisons below.
(directory (string-append (canonicalize-path directory) "/")) (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)) (oid (reference-target head))
(commit (commit-lookup repository oid)) (commit (commit-lookup repository oid))
(tree (commit-tree commit)) (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) (repository-close! repository)
(if (string=? workdir directory) (append
files (if (or relative prefix)
(let ((relative (string-drop directory (string-length workdir)))) (filter-map (lambda (file)
(filter-map (lambda (file) (and (included? file)
(and (string-prefix? relative file) (rectify file)))
(string-drop file (string-length relative)))) files)
files))))) files)
(append-map (lambda (submodule)
(if (included? submodule)
(git-file-list
(string-append workdir submodule)
(rectify submodule))
'()))
submodules))))
(define (git-predicate directory) (define* (git-predicate directory #:key (recursive? #t))
"Return a predicate that returns true if a file is part of the Git checkout "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 living at DIRECTORY. If DIRECTORY does not lie within a Git checkout, and
upon Git errors, return #f instead of a predicate. 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 The returned predicate takes two arguments FILE and STAT where FILE is an
absolute file name and STAT is the result of 'lstat'." absolute file name and STAT is the result of 'lstat'."
(libgit2-init!) (libgit2-init!)
(catch 'git-error (catch 'git-error
(lambda () (lambda ()
(let* ((files (git-file-list directory)) (let* ((files (git-file-list directory #:recursive? recursive?))
(inodes (fold (lambda (file result) (inodes (fold (lambda (file result)
(let* ((file (string-append directory "/" file)) (let* ((file (string-append directory "/" file))
(stat (false-if-exception (lstat file)))) (stat (false-if-exception (lstat file))))