emacs-29 785fa80159: New user option: project-vc-extra-root-markers

[Dmitry Gutov]

branch: emacs-29
commit 785fa801596ad7bb9f838cac865f00de29e253d1
Author: Dmitry Gutov <dgutov@yandex.ru>
Commit: Dmitry Gutov <dgutov@yandex.ru>

    New user option: project-vc-extra-root-markers
    
    * lisp/progmodes/project.el: Commentary update.
    (project-vc, project-vc-include-untracked, project-vc-name):
    Update docstrings.  Rename 'VC project' to 'VC-aware project'.
    (project-vc-extra-root-markers): New option (bug#41572).
    (project-try-vc): Use it.  Construct a single regexp from all and
    validate it using the MATCH argument of 'directory-files'.  Call
    'locate-dominating-file' directly.
    (project-ignores): Support VC-aware project instances with nil
    value of VC backend.
    
    * test/lisp/progmodes/project-tests.el (project-vc-recognizes-git)
    (project-vc-extra-root-markers-supports-wildcards)
    New tests.
    (project-tests--this-file): New variable.
---
 lisp/progmodes/project.el            | 132 +++++++++++++++++++++++++++--------
 test/lisp/progmodes/project-tests.el |  29 ++++++++
 2 files changed, 130 insertions(+), 31 deletions(-)

diff --git a/lisp/progmodes/project.el b/lisp/progmodes/project.el
index cc28bddff2..dfd3d5c7ab 100644
--- a/lisp/progmodes/project.el
+++ b/lisp/progmodes/project.el
@@ -1,7 +1,7 @@
 ;;; project.el --- Operations on the current project  -*- lexical-binding: t; 
-*-
 
 ;; Copyright (C) 2015-2022 Free Software Foundation, Inc.
-;; Version: 0.8.3
+;; Version: 0.9.0
 ;; Package-Requires: ((emacs "26.1") (xref "1.4.0"))
 
 ;; This is a GNU ELPA :core package.  Avoid using functionality that
@@ -58,13 +58,30 @@
 ;;
 ;; This list can change in future versions.
 ;;
-;; VC project:
+;; Transient project:
+;;
+;; An instance of this type can be returned by `project-current' if no
+;; project was detected automatically, and the user had to pick a
+;; directory manually.  The fileset it describes is the whole
+;; directory, with the exception of some standard ignored files and
+;; directories.  This type has little purpose otherwise, as the only
+;; generic function it provides an override for is `project-root'.
+;;
+;; VC-aware project:
 ;;
 ;; Originally conceived as an example implementation, now it's a
 ;; relatively fast backend that delegates to 'git ls-files' or 'hg
 ;; status' to list the project's files.  It honors the VC ignore
 ;; files, but supports additions to the list using the user option
-;; `project-vc-ignores' (usually through .dir-locals.el).
+;; `project-vc-ignores' (usually through .dir-locals.el).  See the
+;; customization group `project-vc' for other options that control its
+;; behavior.
+;;
+;; If the repository is using any other VCS than Git or Hg, the file
+;; listing uses the default mechanism based on `find-program'.
+;;
+;; This project type can also be used for non-VCS controlled
+;; directories, see the variable `project-vc-extra-root-markers'.
 ;;
 ;; Utils:
 ;;
@@ -377,7 +394,7 @@ the buffer's value of `default-directory'."
     (nreverse bufs)))
 
 (defgroup project-vc nil
-  "Project implementation based on the VC package."
+  "VC-aware project implementation."
   :version "25.1"
   :group 'project)
 
@@ -397,21 +414,50 @@ you might have to restart Emacs to see the effect."
   :safe #'booleanp)
 
 (defcustom project-vc-include-untracked t
-  "When non-nil, the VC project backend includes untracked files."
+  "When non-nil, the VC-aware project backend includes untracked files."
   :type 'boolean
   :version "29.1"
   :safe #'booleanp)
 
 (defcustom project-vc-name nil
-  "When non-nil, the name of the current VC project.
+  "When non-nil, the name of the current VC-aware project.
 
-The best way to change the value a VC project reports as its
-name, is by setting this in .dir-locals.el."
+The best way to change the value a VC-aware project reports as
+its name, is by setting this in .dir-locals.el."
   :type '(choice (const :tag "Default to the base name" nil)
                  (string :tag "Custom name"))
   :version "29.1"
+  :package-version '(project . "0.9.0")
   :safe #'stringp)
 
+;; Not using regexps because these wouldn't work in Git pathspecs, in
+;; case we decide we need to be able to list nested projects.
+(defcustom project-vc-extra-root-markers nil
+  "List of additional markers to signal project roots.
+
+A marker is either a base file name or a glob pattern for such.
+
+A directory containing such a marker file or a file matching a
+marker pattern will be recognized as the root of a VC-aware
+project.
+
+Example values: \".dir-locals.el\", \"package.json\", \"pom.xml\",
+\"requirements.txt\", \"Gemfile\", \"*.gemspec\", \"autogen.sh\".
+
+These will be used in addition to regular directory markers such
+as \".git\", \".hg\", and so on, depending on the value of
+`vc-handled-backends'.  It is most useful when a project has
+subdirectories inside it that need to be considered as separate
+projects.  It can also be used for projects outside of VC
+repositories.
+
+In either case, their behavior will still obey the relevant
+variables, such as `project-vc-ignores' or `project-vc-name'."
+  :type 'list
+  :version "29.1"
+  :package-version '(project . "0.9.0")
+  :safe (lambda (val) (and (listp val) (cl-every #'stringp val))))
+
 ;; FIXME: Using the current approach, major modes are supposed to set
 ;; this variable to a buffer-local value.  So we don't have access to
 ;; the "external roots" of language A from buffers of language B, which
@@ -420,7 +466,7 @@ name, is by setting this in .dir-locals.el."
 ;;
 ;; We could add a second argument to this function: a file extension,
 ;; or a language name.  Some projects will know the set of languages
-;; used in them; for others, like VC-based projects, we'll need
+;; used in them; for others, like the VC-aware type, we'll need
 ;; auto-detection.  I see two options:
 ;;
 ;; - That could be implemented as a separate second hook, with a
@@ -444,32 +490,55 @@ name, is by setting this in .dir-locals.el."
 It should return a list of directory roots that contain source
 files related to the current buffer.
 
-The directory names should be absolute.  Used in the VC project
-backend implementation of `project-external-roots'.")
+The directory names should be absolute.  Used in the VC-aware
+project backend implementation of `project-external-roots'.")
 
 (defun project-try-vc (dir)
+  (defvar vc-svn-admin-directory)
+  (require 'vc-svn)
+  ;; FIXME: Learn to invalidate when the value of
+  ;; `project-vc-merge-submodules' or `project-vc-extra-root-markers'
+  ;; changes.
   (or (vc-file-getprop dir 'project-vc)
-      (let* ((backend (ignore-errors (vc-responsible-backend dir)))
+      (let* ((backend-markers-alist `((Git . ".git")
+                                      (Hg . ".hg")
+                                      (Bzr . ".bzr")
+                                      (SVN . ,vc-svn-admin-directory)
+                                      (DARCS . "_darcs")
+                                      (Fossil . ".fslckout")))
+             (backend-markers
+              (delete
+               nil
+               (mapcar
+                (lambda (b) (assoc-default b backend-markers-alist))
+                vc-handled-backends)))
+             (marker-re
+              (mapconcat
+               (lambda (m) (format "\\(%s\\)" (wildcard-to-regexp m)))
+               (append backend-markers project-vc-extra-root-markers)
+               "\\|"))
+             (locate-dominating-stop-dir-regexp
+              (or vc-ignore-dir-regexp locate-dominating-stop-dir-regexp))
+             last-matches
              (root
-              (pcase backend
-                ('Git
-                 ;; Don't stop at submodule boundary.
-                 (or (vc-file-getprop dir 'project-git-root)
-                     (let ((root (vc-call-backend backend 'root dir)))
-                       (vc-file-setprop
-                        dir 'project-git-root
-                        (if (and
-                             ;; FIXME: Invalidate the cache when the value
-                             ;; of this variable changes.
-                             project-vc-merge-submodules
-                             (project--submodule-p root))
-                            (let* ((parent (file-name-directory
-                                            (directory-file-name root))))
-                              (vc-call-backend backend 'root parent))
-                          root)))))
-                ('nil nil)
-                (_ (ignore-errors (vc-call-backend backend 'root dir)))))
+              (locate-dominating-file
+               dir
+               (lambda (d)
+                 ;; Maybe limit count to 100 when we can drop Emacs < 28.
+                 (setq last-matches (directory-files d nil marker-re t)))))
+             (backend
+              (cl-find-if
+               (lambda (b)
+                 (member (assoc-default b backend-markers-alist)
+                         last-matches))
+               vc-handled-backends))
              project)
+        (when (and
+               (eq backend 'Git)
+               project-vc-merge-submodules
+               (project--submodule-p root))
+          (let* ((parent (file-name-directory (directory-file-name root))))
+            (setq root (vc-call-backend 'Git 'root parent))))
         (when root
           (setq project (list 'vc backend root))
           ;; FIXME: Cache for a shorter time.
@@ -627,7 +696,8 @@ backend implementation of `project-external-roots'.")
   (let* ((root (nth 2 project))
          backend)
     (append
-     (when (file-equal-p dir root)
+     (when (and backend
+                (file-equal-p dir root))
        (setq backend (cadr project))
        (delq
         nil
diff --git a/test/lisp/progmodes/project-tests.el 
b/test/lisp/progmodes/project-tests.el
index d4b6bca7e8..55f3f499b3 100644
--- a/test/lisp/progmodes/project-tests.el
+++ b/test/lisp/progmodes/project-tests.el
@@ -110,4 +110,33 @@ When `project-ignores' includes a name matching project 
dir."
                      (list
                       (expand-file-name "some-file" dir)))))))
 
+(defvar project-tests--this-file (or (bound-and-true-p 
byte-compile-current-file)
+                                     (and load-in-progress load-file-name)
+                                     buffer-file-name))
+
+(ert-deftest project-vc-recognizes-git ()
+  "Check that Git repository is detected."
+  (skip-unless (eq (vc-responsible-backend default-directory) 'Git))
+  (let* ((vc-handled-backends '(Git))
+         (dir (file-name-directory project-tests--this-file))
+         (_ (vc-file-clearprops dir))
+         (project-vc-extra-root-markers nil)
+         (project (project-current nil dir)))
+    (should-not (null project))
+    (should (equal
+             "test/lisp/progmodes/project-tests.el"
+             (file-relative-name
+              project-tests--this-file
+              (project-root project))))))
+
+(ert-deftest project-vc-extra-root-markers-supports-wildcards ()
+  "Check that one can add wildcard entries."
+  (skip-unless (eq (vc-responsible-backend default-directory) 'Git))
+  (let* ((dir (file-name-directory project-tests--this-file))
+         (_ (vc-file-clearprops dir))
+         (project-vc-extra-root-markers '("files-x-tests.*"))
+         (project (project-current nil dir)))
+    (should-not (null project))
+    (should (string-match-p "/test/lisp/\\'" (project-root project)))))
+
 ;;; project-tests.el ends here