GNU bug report logs - #48699
[PATCH] git-download: Support submodules in 'git-predicate'.

Previous Next

To add a comment to this bug, you must first unarchive it, by sending
a message to control AT debbugs.gnu.org, with unarchive 48699 in the body.
You can then email your comments to 48699 AT debbugs.gnu.org in the normal way.

Toggle the display of automated, internal messages from the tracker.

Message #5 received at submit <at> debbugs.gnu.org (full text, mbox):

From: Andrew Whatson <whatson <at> gmail.com>
To: guix-patches <at> gnu.org
Cc: Andrew Whatson <whatson <at> gmail.com>
Subject: [PATCH] git-download: Support submodules in 'git-predicate'.
Date: Fri, 28 May 2021 00:18:27 +1000

* guix/git-download.scm (git-file-list): Add prefix and recursive?
arguments.  Recurse into submodules when requested.
(git-predicate): Add recursive? argument.
---
 guix/git-download.scm | 67 ++++++++++++++++++++++++++++++++++---------
 1 file changed, 53 insertions(+), 14 deletions(-)

diff --git a/guix/git-download.scm b/guix/git-download.scm
index 8d8e1c865f..8094e5e5c7 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* ((path (string-append directory "/" file))
                                     (stat (and (file-exists? path)
-- 
2.31.1

Message #10 received at 48699-done <at> debbugs.gnu.org (full text, mbox):

From: Ludovic Courtès <ludo <at> gnu.org>
To: Andrew Whatson <whatson <at> gmail.com>
Cc: 48699-done <at> debbugs.gnu.org
Subject: Re: bug#48699: [PATCH] git-download: Support submodules in
 'git-predicate'.
Date: Fri, 28 May 2021 12:10:33 +0200

Andrew Whatson <whatson <at> gmail.com> skribis:

> * guix/git-download.scm (git-file-list): Add prefix and recursive?
> arguments.  Recurse into submodules when requested.
> (git-predicate): Add recursive? argument.

Pushed as ebbfee880c1def28b77aeb2eee640998b9fa7d5f, thanks!

Ludo’.

Previous Next

GNU bug tracking system
Copyright (C) 1999 Darren O. Benham, 1997,2003 nCipher Corporation Ltd, 1994-97 Ian Jackson.