From: Eshel Yaron Date: Sat, 26 Jul 2025 20:06:05 +0000 (+0200) Subject: vc: Tweak new worktree commands, avoid project.el dep X-Git-Url: http://git.eshelyaron.com/gitweb/?a=commitdiff_plain;h=2b1383d647402df2b539f69cf73a12c0717b00f3;p=emacs.git vc: Tweak new worktree commands, avoid project.el dep --- diff --git a/lisp/dired.el b/lisp/dired.el index b9dc8b0a031..82960971f06 100644 --- a/lisp/dired.el +++ b/lisp/dired.el @@ -2725,7 +2725,10 @@ Do so according to the former subdir alist OLD-SUBDIR-ALIST." ;; Dired mode is suitable only for specially formatted data. (put 'dired-mode 'mode-class 'special) +(defvar vc-switch-working-tree-function) + (defvar grep-read-files-function) + ;; Autoload cookie needed by desktop.el ;;;###autoload (defun dired-mode (&optional dirname switches) @@ -2811,6 +2814,7 @@ Keybindings: '(dired-font-lock-keywords t nil nil beginning-of-line)) (setq-local desktop-save-buffer 'dired-desktop-buffer-misc-data) (setq-local grep-read-files-function #'dired-grep-read-files) + (setq-local vc-switch-working-tree-function #'dired-switch-working-tree) (setq-local window-point-context-set-function (lambda (w) (with-current-buffer (window-buffer w) @@ -5404,5 +5408,11 @@ completes." (define-obsolete-variable-alias 'dired-move-to-filename-regexp 'directory-listing-before-filename-regexp "30.1") +(defun dired-switch-working-tree (worktree) + (dired-noselect + (expand-file-name + (file-relative-name (car (ensure-list dired-directory)) (vc-root-dir)) + worktree))) + (provide 'dired) ;;; dired.el ends here diff --git a/lisp/vc/vc-hg.el b/lisp/vc/vc-hg.el index 1e064a24e39..da02a216579 100644 --- a/lisp/vc/vc-hg.el +++ b/lisp/vc/vc-hg.el @@ -1686,32 +1686,12 @@ Intended for use via the `vc-hg--async-command' wrapper." ;; Mercurial doesn't maintain records of shared repositories. ;; The first repository knows nothing about shares created from it, ;; and each share only has a reference back to the first repository. - ;; - ;; Therefore, to support the VC API for other working trees, Emacs - ;; needs to maintain records of its own about other working trees. - ;; Rather than create something new our strategy is to rely on - ;; project.el's knowledge of existing projects. - ;; Note that this relies on code calling `vc-hg-add-working-tree' - ;; registering the resultant working tree with project.el. (let* ((our-root (vc-hg-root default-directory)) - (our-sp (expand-file-name ".hg/sharedpath" our-root)) - our-store shares) - (if (file-exists-p our-sp) - (with-temp-buffer - (insert-file-contents-literally our-sp) - (setq our-store (string-trim (buffer-string))) - (push (abbreviate-file-name (file-name-directory our-store)) - shares)) - (setq our-store (expand-file-name ".hg" our-root))) - (dolist (root (project-known-project-roots)) - (when-let* (((not (equal root our-root))) - (sp (expand-file-name ".hg/sharedpath" root)) - ((file-exists-p sp))) - (with-temp-buffer - (insert-file-contents-literally sp) - (when (equal our-store (buffer-string)) - (push root shares))))) - shares)) + (our-sp (expand-file-name ".hg/sharedpath" our-root))) + (when (file-exists-p our-sp) + (with-temp-buffer + (insert-file-contents-literally our-sp) + (list (abbreviate-file-name (file-name-directory (string-trim (buffer-string))))))))) (defun vc-hg-add-working-tree (directory) "Implementation of `add-working-tree' backend function for Mercurial." diff --git a/lisp/vc/vc.el b/lisp/vc/vc.el index ebf4cda8c22..500cb83fd25 100644 --- a/lisp/vc/vc.el +++ b/lisp/vc/vc.el @@ -4377,33 +4377,45 @@ yourself with a function like `vc-file-tree-walk'." (while morep (accept-process-output))) (nreverse results))) -;;;###autoload -(defun vc-add-working-tree (backend directory) - "Create working tree DIRECTORY with same backing repository as this tree. -Must be called from within an existing VC working tree. -When called interactively, prompts for DIRECTORY. -When called from Lisp, BACKEND is the VC backend." - (interactive - (list - (vc-responsible-backend default-directory) - (read-directory-name "Location for new working tree: " - (file-name-parent-directory - (or (vc-root-dir) - (error "File is not under version control")))))) - (vc-call-backend backend 'add-working-tree directory) - - ;; `vc-switch-working-tree' relies on project.el registration so try - ;; to ensure that both the old and new working trees are registered. - ;; `project-current' should not return nil in either case, but don't - ;; signal an error if it does. - (when-let* ((p (project-current))) - (project-remember-project p)) - (when-let* ((p (project-current nil directory))) - (project-remember-project p)) - - (vc-dir directory backend)) - -(defvar project-current-directory-override) +(defun vc-read-other-working-tree (prompt &optional force-prompt) + "Read the file name of another working tree of the current VC repository. + +If there are multiple other working trees, prompt with PROMPT for one of +them. If there is just other working tree, return it without prompting, +unless the optional argument FORCE-PROMPT is non-nil. + +If there are no known other working trees, throw a `user-error'." + (if-let* ((wts (vc-call-backend (vc-responsible-backend default-directory) + 'known-other-working-trees)) + (fst (car wts))) + (if (or (cdr wts) force-prompt) + (let ((wt (completing-read + (format-prompt prompt fst) + (completion-table-with-metadata + wts + '((category . vc-working-tree) + (affixation-function . completion-file-name-affixation))) + nil 'confirm nil nil fst))) + (when (string-empty-p wt) + (user-error "You didn't specify another working tree")) + wt) + fst) + (user-error "No known other working trees"))) + +(defun vc-switch-working-tree-find-file (worktree) + "Find the file in WORKTREE that corresponds to the currently visited file." + (unless buffer-file-name (error "Buffer is not associated with a file")) + (find-file-noselect + (expand-file-name + (file-relative-name buffer-file-name (vc-root-dir)) + worktree))) + +(defvar vc-switch-working-tree-function #'vc-switch-working-tree-find-file + "Function for switching to another VC working tree. + +The function takes one argument, the file name of the root directory of +the another working tree, and return a buffer that is an analog of the +current buffer in the other working tree.") ;;;###autoload (defun vc-switch-working-tree (directory) @@ -4413,71 +4425,69 @@ When called interactively, prompts for DIRECTORY. This command switches to the file which has the same file name relative to DIRECTORY that this buffer's file has relative to the root of this working tree." - ;; FIXME: Switch between directory analogues, too, in Dired buffers. + (interactive (list (vc-read-other-working-tree "Visit other working tree"))) + (switch-to-buffer (funcall vc-switch-working-tree-function directory))) + +(defvar vc-create-working-tree-hook '(vc-dir)) + +(defvar vc-delete-working-tree-hook nil) + +;;;###autoload +(defun vc-add-working-tree (directory) + "Create working tree DIRECTORY with same backing repository as this tree. +Must be called from within an existing VC working tree. +When called interactively, prompts for DIRECTORY." (interactive (list - ;; FIXME: This should respect `project-prompter'. See bug#79024. - (completing-read "Other working tree to visit: " - (vc-call-backend (vc-responsible-backend default-directory) - 'known-other-working-trees) - nil t))) - (let ((project-current-directory-override directory)) - (project-find-matching-file))) + (read-directory-name "Location for new working tree: " + (file-name-parent-directory + (or (vc-root-dir) + (error "File is not under version control")))))) + (vc-call-backend (vc-responsible-backend default-directory) + 'add-working-tree directory) + (run-hook-with-args 'vc-create-working-tree-hook directory)) ;;;###autoload -(defun vc-delete-working-tree (backend directory) +(defun vc-delete-working-tree (directory) "Delete working tree DIRECTORY with same backing repository as this tree. Must be called from within an existing VC working tree. -When called interactively, prompts for DIRECTORY. -BACKEND is the VC backend." - (interactive - (let ((backend (vc-responsible-backend default-directory))) - (list backend - ;; FIXME: This should respect `project-prompter'. See bug#79024. - (completing-read "Delete working tree: " - (vc-call-backend backend 'known-other-working-trees) - nil t)))) +When called interactively, prompts for DIRECTORY." + (interactive (list (vc-read-other-working-tree "Delete working tree" t))) ;; We could consider not prompting here, thus always failing when ;; there is uncommitted work, and requiring the user to review and ;; revert the uncommitted changes before invoking this command again. ;; But other working trees are often created as throwaways to quickly ;; test some changes, so it is more useful to offer to recursively ;; delete them on the user's behalf. - (when (and (vc-dir-status-files directory nil backend) - (not (yes-or-no-p (format "\ + (let ((backend (vc-responsible-backend default-directory))) + (when (and (vc-dir-status-files directory nil backend) + (not (yes-or-no-p (format "\ %s contains uncommitted work. Continue to recursively delete it?" directory)))) - (user-error "Aborted due to uncommitted work in %s" directory)) - - (project-forget-project directory) - (vc-call-backend backend 'delete-working-tree directory)) + (user-error "Aborted due to uncommitted work in %s" directory)) + (vc-call-backend backend 'delete-working-tree directory) + (run-hook-with-args 'vc-delete-working-tree-hook directory))) (autoload 'dired-rename-subdir "dired-aux") ;;;###autoload -(defun vc-move-working-tree (backend from to) +(defun vc-move-working-tree (from to) "Relocate a working tree from FROM to TO, two directory file names. Must be called from within an existing VC working tree. When called interactively, prompts the directory file names of each of -the other working trees FROM and TO. -BACKEND is the VC backend." +the other working trees FROM and TO." (interactive - (let ((backend (vc-responsible-backend default-directory))) - (list backend - ;; FIXME: This should respect `project-prompter'. See bug#79024. - (completing-read "Relocate working tree: " - (vc-call-backend backend 'known-other-working-trees) - nil t) - (read-directory-name "New location for working tree: " - (file-name-parent-directory (vc-root-dir)))))) - (let ((inhibit-message t)) - (project-forget-project from)) - (vc-call-backend backend 'move-working-tree from to) + (let ((from (vc-read-other-working-tree "Move working tree" t))) + (list + from + (read-directory-name (format "Move working tree %s to: " from) + (file-name-parent-directory (vc-root-dir)))))) + (vc-call-backend (vc-responsible-backend default-directory) + 'move-working-tree from to) ;; Update visited file names for buffers visiting files under FROM. ;; FIXME: Also update VC-Dir buffers. (dired-rename-subdir (expand-file-name from) (expand-file-name to)) - - (when-let* ((p (project-current nil to))) - (project-remember-project p))) + (run-hook-with-args 'vc-delete-working-tree-hook from) + (run-hook-with-args 'vc-create-working-tree-hook to))