mirrors/emacs
1
Fork 0
mirror of git://git.sv.gnu.org/emacs.git synced 2025-12-23 06:00:41 -08:00
Code Issues Projects Releases Wiki Activity

project-try-vc: Fix the "sometimes wrong cache" issue

Browse source 
* lisp/progmodes/project.el (project-try-vc--search):
Extract from 'project-try-vc'.
(project-try-vc): Use it.
(project-try-vc--search): Call itself recursively directly, to
avoid creating invalid cache entry (bug#73801).

(cherry picked from commit 29b30eb49f)
This commit is contained in:
Dmitry Gutov 2024-10-28 05:53:16 +02:00
parent 8113b5c562
commit b4b0d5a853
1 changed files with 57 additions and 54 deletions
Download patch file Download diff file Expand all files Collapse all files

111
lisp/progmodes/project.el
View file

@ -543,61 +543,64 @@ project backend implementation of `project-external-roots'.")
See `project-vc-extra-root-markers' for the marker value format.") See `project-vc-extra-root-markers' for the marker value format.")
(defun project-try-vc (dir) (defun project-try-vc (dir)
;; FIXME: Learn to invalidate when the value of ;; FIXME: Learn to invalidate when the value changes:
;; `project-vc-merge-submodules' or `project-vc-extra-root-markers' ;; `project-vc-merge-submodules' or `project-vc-extra-root-markers'.
;; changes.
(or (vc-file-getprop dir 'project-vc) (or (vc-file-getprop dir 'project-vc)
(let* ((backend-markers ;; FIXME: Cache for a shorter time.
(delete (let ((res (project-try-vc--search dir)))
nil (and res (vc-file-setprop dir 'project-vc res))
(mapcar res)))
(lambda (b) (assoc-default b project-vc-backend-markers-alist))
vc-handled-backends))) (defun project-try-vc--search (dir)
(marker-re (let* ((backend-markers
(concat (delete
"\\`" nil
(mapconcat (mapcar
(lambda (m) (format "\\(%s\\)" (wildcard-to-regexp m))) (lambda (b) (assoc-default b project-vc-backend-markers-alist))
(append backend-markers vc-handled-backends)))
(project--value-in-dir 'project-vc-extra-root-markers dir)) (marker-re
"\\|") (concat
"\\'")) "\\`"
(locate-dominating-stop-dir-regexp (mapconcat
(or vc-ignore-dir-regexp locate-dominating-stop-dir-regexp)) (lambda (m) (format "\\(%s\\)" (wildcard-to-regexp m)))
last-matches (append backend-markers
(root (project--value-in-dir 'project-vc-extra-root-markers dir))
(locate-dominating-file "\\|")
dir "\\'"))
(lambda (d) (locate-dominating-stop-dir-regexp
;; Maybe limit count to 100 when we can drop Emacs < 28. (or vc-ignore-dir-regexp locate-dominating-stop-dir-regexp))
(setq last-matches last-matches
(condition-case nil (root
(directory-files d nil marker-re t) (locate-dominating-file
(file-missing nil)))))) dir
(backend (lambda (d)
(cl-find-if ;; Maybe limit count to 100 when we can drop Emacs < 28.
(lambda (b) (setq last-matches
(member (assoc-default b project-vc-backend-markers-alist) (condition-case nil
last-matches)) (directory-files d nil marker-re t)
vc-handled-backends)) (file-missing nil))))))
project) (backend
(when (and (cl-find-if
(eq backend 'Git) (lambda (b)
(project--vc-merge-submodules-p root) (member (assoc-default b project-vc-backend-markers-alist)
(project--submodule-p root)) last-matches))
(let* ((parent (file-name-directory (directory-file-name root)))) vc-handled-backends))
(setq root (vc-call-backend 'Git 'root parent)))) project)
(when root (when (and
(when (not backend) (eq backend 'Git)
(let* ((project-vc-extra-root-markers nil) (project--vc-merge-submodules-p root)
;; Avoid submodules scan. (project--submodule-p root))
(enable-dir-local-variables nil) (let* ((parent (file-name-directory (directory-file-name root))))
(parent (project-try-vc root))) (setq root (vc-call-backend 'Git 'root parent))))
(and parent (setq backend (nth 1 parent))))) (when root
(setq project (list 'vc backend root)) (when (not backend)
;; FIXME: Cache for a shorter time. (let* ((project-vc-extra-root-markers nil)
(vc-file-setprop dir 'project-vc project) ;; Avoid submodules scan.
project)))) (enable-dir-local-variables nil)
(parent (project-try-vc--search root)))
(and parent (setq backend (nth 1 parent)))))
(setq project (list 'vc backend root))
project)))
(defun project--submodule-p (root) (defun project--submodule-p (root)
;; XXX: We only support Git submodules for now. ;; XXX: We only support Git submodules for now.