From 785fa801596ad7bb9f838cac865f00de29e253d1 Mon Sep 17 00:00:00 2001 From: Dmitry Gutov Date: Thu, 1 Dec 2022 04:05:49 +0200 Subject: [PATCH] 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 cc28bddff22..dfd3d5c7ab3 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 d4b6bca7e8f..55f3f499b39 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 -- 2.39.2