Github/emacs
2
0
Fork 1
mirror of git://git.sv.gnu.org/emacs.git synced 2026-06-14 12:31:25 +00:00
Code Issues Projects Releases Packages Wiki Activity

New project-find-matching-buffer-function for VC-Dir

Browse source 
* lisp/vc/vc-dir.el (vc-dir-find-matching-buffer): New function.
(vc-dir-mode): Use it as project-find-matching-buffer-function.
This commit is contained in:
Sean Whitton 2025-08-10 11:06:28 +01:00
parent 3aab8a72dc
commit e79f38b662
1 changed files with 30 additions and 0 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

30
lisp/vc/vc-dir.el
View file

@ -1295,6 +1295,7 @@ the *vc-dir* buffer.
(setq-local vc-dir-backend use-vc-backend)
(setq-local desktop-save-buffer 'vc-dir-desktop-buffer-misc-data)
(setq-local bookmark-make-record-function #'vc-dir-bookmark-make-record)
(setq-local project-find-matching-buffer-function #'vc-dir-find-matching-buffer)
(setq buffer-read-only t)
(when (boundp 'tool-bar-map)
(setq-local tool-bar-map vc-dir-tool-bar-map))
@ -1695,6 +1696,35 @@ type returned by `vc-dir-bookmark-make-record'."
(put 'vc-dir-bookmark-jump 'bookmark-handler-type "VC")
(declare-function project-root "project")
(defun vc-dir-find-matching-buffer (current-project mirror-project)
"Visit VC-Dir buffer for matching directory in another project.
CURRENT-PROJECT is the project instance for the current project.
MIRROR-PROJECT is the project instance for the project to visit.
The matching directory has the same name relative to the project root.
If a matching directory does not exist in the other project, try going
up the directory tree until encountering a directory that exists.
This function is intended to be used as the value of
`project-find-matching-buffer-function' in VC-Dir buffers."
(let* ((mirror-root (project-root mirror-project))
(relative-name (file-relative-name default-directory
(project-root current-project)))
(mirror-name (expand-file-name relative-name mirror-root))
(orig-mirror-name mirror-name))
(while (not (file-directory-p mirror-name))
(setq mirror-name (directory-file-name
(file-name-parent-directory mirror-name)))
(unless (file-in-directory-p mirror-name mirror-root)
(user-error "`%s' not found in `%s'" relative-name mirror-root)))
(vc-dir mirror-name)
(unless (equal mirror-name orig-mirror-name)
(message "`%s' not found; visiting VC-Dir for `%s' instead"
(abbreviate-file-name orig-mirror-name)
(abbreviate-file-name (file-name-as-directory mirror-name))))))
(provide 'vc-dir)