vc: Tweak new worktree commands, avoid project.el dep

diff --git a/lisp/dired.el b/lisp/dired.el
index b9dc8b0a0316f5f8d78f57ae98c6ef5173976077..82960971f067f0d18bf0d22cf6ca2775badc6416 100644 (file)
--- 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 1e064a24e3989e78607ca8b7fedf830b20f20511..da02a2165796970ac002462d1cb8f380e0dd7493 100644 (file)
--- 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 ebf4cda8c225434bef2db0347b10cbeade01b2e2..500cb83fd257acc1a735138efcc5700e498a889a 100644 (file)
--- 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))
 
 \f