From: Sean Whitton Date: Fri, 25 Jul 2025 18:34:04 +0000 (+0100) Subject: VC: New support for other working trees X-Git-Url: http://git.eshelyaron.com/gitweb/?a=commitdiff_plain;h=e9083ef46c4474ca7938b29317d7c69c5d585f02;p=emacs.git VC: New support for other working trees * lisp/vc/vc-git.el (vc-git--read-start-point): New function, factored out of vc-git-create-tag. (vc-git-create-tag): Use it. (vc-git--worktrees, vc-git-known-other-working-trees) (vc-git-add-working-tree, vc-git-delete-working-tree) (vc-git-move-working-tree): * lisp/vc/vc-hg.el (vc-hg-known-other-working-trees) (vc-hg-add-working-tree, vc-hg--shared-p) (vc-hg-delete-working-tree, vc-hg-move-working-tree): New functions. * lisp/vc/vc.el: Define API for known-other-working-tree, add-working-tree, delete-working-tree and move-working-tree backend functions. (vc-dir-status-files): New function. (project-current-directory-override): Declare. (dired-rename-subdir): Autoload. (vc-add-working-tree, vc-switch-working-tree) (vc-delete-working-tree, vc-move-working-tree): New commands. * lisp/vc/vc-hooks.el (vc-prefix-map): Bind them under C-x v. * doc/emacs/vc1-xtra.texi (Other Working Trees): New node. * etc/NEWS: Announce the new commands. * test/lisp/vc/vc-tests/vc-tests.el (vc-test--other-working-trees): New function. (vc-test-git07-other-working-trees) (vc-test-hg07-other-working-trees): New tests. * lisp/ldefs-boot.el: Regenerate. (cherry picked from commit 50ffb29d0bbb92a7c6569c83d2e3e4868c4e867b) --- diff --git a/doc/emacs/emacs.texi b/doc/emacs/emacs.texi index 3ded7c30e95..ebdff7af376 100644 --- a/doc/emacs/emacs.texi +++ b/doc/emacs/emacs.texi @@ -863,6 +863,7 @@ Miscellaneous Commands and Features of VC * Change Logs and VC:: Generating a change log file from log entries. * VC Delete/Rename:: Deleting and renaming version-controlled files. * Revision Tags:: Symbolic names for revisions. +* Other Working Trees:: Multiple sets of workfiles. * Version Headers:: Inserting version control headers into working files. * Editing VC Commands:: Editing the VC shell commands that Emacs will run. * Preparing Patches:: Preparing and composing patches from within VC. diff --git a/doc/emacs/vc1-xtra.texi b/doc/emacs/vc1-xtra.texi index cfa80db2b0b..f2a561eccf8 100644 --- a/doc/emacs/vc1-xtra.texi +++ b/doc/emacs/vc1-xtra.texi @@ -14,6 +14,7 @@ * Change Logs and VC:: Generating a change log file from log entries. * VC Delete/Rename:: Deleting and renaming version-controlled files. * Revision Tags:: Symbolic names for revisions. +* Other Working Trees:: Multiple sets of workfiles. * Version Headers:: Inserting version control headers into working files. * Editing VC Commands:: Editing the VC shell commands that Emacs will run. * Preparing Patches:: Preparing and composing patches from within VC. @@ -226,6 +227,70 @@ an old tag, the renamed file is retrieved under its new name, which is not the name that the makefile expects. So the program won't really work as retrieved. +@node Other Working Trees +@subsubsection Multiple Working Trees for One Repository + +@cindex other working trees +@cindex multiple working trees +Some VCS support more than one working tree with the same backing +repository or revisions store. This means that you can have different +revisions or branches (@pxref{Branches}) checked out simultaneously, in +different working trees, but with all revision history, branches, tags +and other metadata shared. The following commands let you switch +between and modify different working trees. + +@table @kbd +@item C-x v w c +Add a new working tree. + +@item C-x v w w +Visit this file in another working tree. + +@item C-x v w x +Delete a working tree you no longer need. + +@item C-x v w R +Relocate a working tree to another file name. +@end table + +@kindex C-x v w c +@findex vc-add-working-tree +You can start using multiple working trees by using the command +@w{@kbd{C-x v w c}} (@code{vc-add-working-tree}) to create a new working +tree. This prompts you to specify a destination directory, which +identifies the working tree, and which will hold the new set of +workfiles. + +Different VCS have different rules about what may and must be checked +out in other working trees, so there may be additional prompts depending +on the VCS in use. For example, Git requires that each branch be +checked out in only one working tree at a time, so when using Git, Emacs +will also prompt you for the name of the branch to be checked out in the +new working tree. + +@kindex C-x v w w +@findex vc-switch-working-tree +Once your repository has other working trees, you can use the command +@kbd{C-x v w w} (@code{vc-switch-working-tree}) to switch between them. +It tries to find the analogue of the current buffer's file +under another working tree. Typically the sets of workfiles +under different working trees differ more in file contents than in which +files do and do not exist. In other words, the file the +current buffer visits probably exists in other working trees too, and +this command lets you switch to those versions of the file. + +@kindex C-x v w x +@kindex C-x v w R +@findex vc-delete-working-tree +@findex vc-move-working-tree +The commands @kbd{C-x v w x} (@code{vc-delete-working-tree}) and +@kbd{C-x v w R} (@code{vc-move-working-tree}) are for performing +maintenance tasks on other working trees, letting you delete, move and +rename them. Deleting other working trees is particular useful because +a common use for multiple working trees is to create throwaway copies of +the repository to quickly test changes, without interfering with any +work-in-progress you may have in your primary working trees. + @node Version Headers @subsubsection Inserting Version Control Headers diff --git a/etc/NEWS b/etc/NEWS index b1d6908ad7e..a713fb5646b 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -781,6 +781,22 @@ appearance of the list with the new faces 'mpc-song-viewer-tag', ** VC ++++ +*** New commands to handle repositories with multiple working trees. +Some VCS support more than one working tree with the same backing +revisions store, such as with Git's 'worktree' subcommand and +Mercurial's 'share' extension. Emacs now has some commands to manage +other working trees: + +- 'C-x v w c': Add a new working tree. +- 'C-x v w w': Visit this file in another working tree. +- 'C-x v w x': Delete a working tree you no longer need. +- 'C-x v w R': Relocate a working tree to another file name. + +In addition, Lisp programs that extend VC can invoke the new backend +functions to obtain a list of other working trees, and to add, remove +and relocate them. + --- *** Using 'e' from Log View mode to modify change comments now works for Git. diff --git a/lisp/vc/vc-dir.el b/lisp/vc/vc-dir.el index d40a2bc71c7..e9520ee7549 100644 --- a/lisp/vc/vc-dir.el +++ b/lisp/vc/vc-dir.el @@ -1415,7 +1415,7 @@ Throw an error if another update process is in progress." (vc-call-backend backend 'dir-status-files def-dir nil (lambda (entries &optional more-to-come) - ;; ENTRIES is a list of (FILE VC_STATE EXTRA) items. + ;; ENTRIES is a list of (FILE VC-STATE EXTRA) items. ;; If MORE-TO-COME is true, then more updates will come from ;; the asynchronous process. (with-current-buffer buffer @@ -1520,7 +1520,7 @@ not under version control, prompt for a directory." (interactive) (let ((root-dir (vc-root-dir))) (if root-dir (vc-dir root-dir) - (call-interactively 'vc-dir)))) + (call-interactively #'vc-dir)))) ;;;###autoload (defun vc-dir (dir &optional backend) diff --git a/lisp/vc/vc-git.el b/lisp/vc/vc-git.el index dd536c5674f..48d8e7cd76a 100644 --- a/lisp/vc/vc-git.el +++ b/lisp/vc/vc-git.el @@ -1913,12 +1913,15 @@ This requires git 1.8.4 or later, for the \"-L\" option of \"git log\"." (declare-function vc-read-revision "vc" (prompt &optional files backend default initial-input)) +(defun vc-git--read-start-point (&optional dir) + (let ((branch (car (vc-git-branches)))) + (vc-read-revision (format-prompt "Start point" branch) + (list (or dir (vc-git-root default-directory))) + 'Git branch))) + (defun vc-git-create-tag (dir name branchp) (let ((default-directory dir) - (start-point (when branchp (vc-read-revision - (format-prompt "Start point" - (car (vc-git-branches))) - (list dir) 'Git (car (vc-git-branches)))))) + (start-point (and branchp (vc-git--read-start-point dir)))) (and (or (zerop (vc-git-command nil t nil "update-index" "--refresh")) (y-or-n-p "Modified files exist. Proceed? ") (user-error (format "Can't create %s with modified files" @@ -2340,7 +2343,7 @@ In other modes, call `vc-deduce-fileset' to determine files to stash." (vc-resynch-buffer (vc-git-root default-directory) t t)) (defun vc-git-stash-list () - (when-let ((out (vc-git--run-command-string nil "stash" "list"))) + (and-let* ((out (vc-git--run-command-string nil "stash" "list"))) (split-string (replace-regexp-in-string "^stash@" " " out) @@ -2389,6 +2392,63 @@ In other modes, call `vc-deduce-fileset' to determine files to stash." (interactive "e") (vc-dir-at-event e (popup-menu vc-git-stash-menu-map e))) +(defun vc-git--worktrees () + "Return an alist of alists regarding this repository's worktrees." + (with-temp-buffer + (vc-git-command nil 0 nil "worktree" "prune") + (vc-git-command t 0 nil "worktree" "list" "--porcelain" "-z") + (let (worktrees current-root current-rest) + (goto-char (point-min)) + (while + (re-search-forward "\\=\\(\\([a-zA-Z]+\\)\\(?: \\([^\0]+\\)\\)?\\)?\0" + nil t) + (if (match-string 1) + (let ((k (intern (match-string 2))) + (v (or (match-string 3) t))) + (cond ((and (not current-root) (eq k 'worktree)) + (setq current-root (file-name-as-directory v))) + ((not (eq k 'worktree)) + (push (cons k v) current-rest)) + (t + (error "'git worktree' output parse error")))) + (push (cons current-root current-rest) worktrees) + (setq current-root nil current-rest nil))) + (or worktrees + (error "'git worktree' output parse error"))))) + +(defun vc-git-known-other-working-trees () + (cl-loop with root = (expand-file-name (vc-git-root default-directory)) + for (worktree) in (vc-git--worktrees) + unless (equal worktree root) + collect (abbreviate-file-name worktree))) + +(defun vc-git-add-working-tree (directory) + (letrec ((dir (expand-file-name directory)) + (vc-filter-command-function #'list) ; see `vc-read-revision' + (revs (vc-git-revision-table nil)) + (table (lazy-completion-table table (lambda () revs))) + (branch (completing-read (format-prompt "New or existing branch" + "latest revision, detached") + table nil nil nil 'vc-revision-history)) + (args (cond ((string-empty-p branch) + (list "--detach" dir)) + ((member branch revs) + (list dir branch)) + (t + (list "-b" branch dir (vc-git--read-start-point)))))) + (apply #'vc-git-command nil 0 nil "worktree" "add" args))) + +(defun vc-git-delete-working-tree (directory) + (vc-git-command nil 0 nil "worktree" "remove" "-f" + (expand-file-name directory))) + +(defun vc-git-move-working-tree (from to) + ;; 'git worktree move' can't move the main worktree, but moving and + ;; then repairing like this can. + (rename-file from (directory-file-name to) 1) + (let ((default-directory to)) + (vc-git-command nil 0 nil "worktree" "repair"))) + ;;; Internal commands diff --git a/lisp/vc/vc-hg.el b/lisp/vc/vc-hg.el index 4e9057db4f9..976c8183efe 100644 --- a/lisp/vc/vc-hg.el +++ b/lisp/vc/vc-hg.el @@ -1217,7 +1217,7 @@ It is based on `log-edit-mode', and has Hg-specific extensions.") (defalias 'vc-hg-async-checkins #'always) (defun vc-hg-checkin (files comment &optional _rev) - "Hg-specific version of `vc-backend-checkin'. + "Hg-specific version of `vc-BACKEND-checkin'. REV is ignored." (let ((args (nconc (list "commit" "-m") (vc-hg--extract-headers comment)))) @@ -1681,6 +1681,57 @@ Intended for use via the `vc-hg--async-command' wrapper." (concat "paths." (or remote-name "default"))) (buffer-substring-no-properties (point-min) (1- (point-max)))))) +(defun vc-hg-known-other-working-trees () + ;; 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)) + +(defun vc-hg-add-working-tree (directory) + (vc-hg-command nil 0 nil "share" + (vc-hg-root default-directory) + (expand-file-name directory))) + +(defun vc-hg--shared-p (directory) + (file-exists-p (expand-file-name ".hg/sharedpath" directory))) + +(defun vc-hg-delete-working-tree (directory) + (if (vc-hg--shared-p directory) + (delete-directory directory t t) + (user-error "\ +Cannot delete first working tree because this would break other working trees"))) + +(defun vc-hg-move-working-tree (from to) + (if (vc-hg--shared-p from) + (rename-file from (directory-file-name to) 1) + (user-error "\ +Cannot relocate first working tree because this would break other working trees"))) + (provide 'vc-hg) ;;; vc-hg.el ends here diff --git a/lisp/vc/vc-hooks.el b/lisp/vc/vc-hooks.el index 7907519346a..4b09a8b06db 100644 --- a/lisp/vc/vc-hooks.el +++ b/lisp/vc/vc-hooks.el @@ -970,7 +970,11 @@ In the latter case, VC mode is deactivated for this buffer." "~" #'vc-revision-other-window "R" #'vc-rename-file "x" #'vc-delete-file - "!" #'vc-edit-next-command) + "!" #'vc-edit-next-command + "w c" #'vc-add-working-tree + "w w" #'vc-switch-working-tree + "w x" #'vc-delete-working-tree + "w R" #'vc-move-working-tree) (fset 'vc-prefix-map vc-prefix-map) (define-key ctl-x-map "v" 'vc-prefix-map) diff --git a/lisp/vc/vc.el b/lisp/vc/vc.el index dc18c048ffb..d46a2c589f1 100644 --- a/lisp/vc/vc.el +++ b/lisp/vc/vc.el @@ -204,6 +204,17 @@ ;; The default implementation deals well with all states that ;; `vc-state' can return. ;; +;; - known-other-working-trees () +;; +;; Return a list of all other working trees known to use the same +;; backing repository as this working tree. The members of the list +;; are the abbreviated (with `abbreviate-file-name') absolute file +;; names of the root directories of the other working trees. +;; For some VCS, the known working trees will not be all the other +;; working trees, because other working trees can share the same +;; backing repository in a way that's transparent to the original +;; working tree (Mercurial is like this). +;; ;; STATE-CHANGING FUNCTIONS ;; ;; * create-repo () @@ -339,6 +350,31 @@ ;; - find-admin-dir (file) ;; ;; Return the administrative directory of FILE. +;; +;; - add-working-tree (directory) +;; +;; Create a new working tree at DIRECTORY that uses the same backing +;; repository as this working tree. +;; What gets checked out in DIRECTORY is left to the backend because +;; while some VCS can check out the same branch in multiple working +;; trees (e.g. Mercurial), others allow each branch to be checked out +;; in only one working tree (e.g. Git). +;; If a new branch should be created then the backend should handle +;; prompting for this, including prompting for a branch or tag from +;; which to start/fork the new branch, like `vc-create-branch'. +;; +;; - delete-working-tree (directory) +;; +;; Remove the working tree, assumed to be one that uses the same +;; backing repository as this working tree, at DIRECTORY. +;; This removal should be unconditional with respect to the state of +;; the working tree: the caller is responsible for checking for +;; uncommitted work in DIRECTORY. +;; +;; - move-working-tree (from to) +;; +;; Relocate the working tree, assumed to be one that uses the same +;; backing repository as this working tree, at FROM to TO. ;; HISTORY FUNCTIONS ;; @@ -4173,24 +4209,24 @@ to provide the `find-revision' operation instead." t) (defun vc-default-retrieve-tag (backend dir name update) - (if (string= name "") - (progn - (vc-file-tree-walk - dir - (lambda (f) (and - (vc-up-to-date-p f) - (vc-error-occurred - (vc-call-backend backend 'checkout f nil "") - (when update (vc-resynch-buffer f t t))))))) + (if (string-empty-p name) + (vc-file-tree-walk dir + (lambda (f) + (and (vc-up-to-date-p f) + (vc-error-occurred + (vc-call-backend backend 'checkout f nil "") + (when update + (vc-resynch-buffer f t t)))))) (let ((result (vc-tag-precondition dir))) (if (stringp result) (error "File %s is locked" result) (setq update (and (eq result 'visited) update)) - (vc-file-tree-walk - dir - (lambda (f) (vc-error-occurred - (vc-call-backend backend 'checkout f nil name) - (when update (vc-resynch-buffer f t t))))))))) + (vc-file-tree-walk dir + (lambda (f) + (vc-error-occurred + (vc-call-backend backend 'checkout f nil name) + (when update + (vc-resynch-buffer f t t))))))))) (defun vc-default-revert (backend file contents-done) (unless contents-done @@ -4296,6 +4332,136 @@ It returns the last revision that changed LINE number in FILE." (let ((rev (vc-call annotate-extract-revision-at-line file))) (if (consp rev) (car rev) rev)))) +(defun vc-dir-status-files (directory &optional files backend) + "Synchronously run `dir-status-files' VC backend function for DIRECTORY. +FILES is passed to the VC backend function. +BACKEND is defaulted by calling `vc-responsible-backend' on DIRECTORY." + ;; The `dir-status-files' API was designed for asynchronous use to + ;; populate *vc-dir* buffers; see `vc-dir-refresh'. + ;; This function provides Lisp programs with synchronous access to the + ;; same information without touching the user's *vc-dir* buffers and + ;; without having to add a new VC backend function. + ;; It is considerably faster than using `vc-file-tree-walk' + ;; (like `vc-tag-precondition' does). + ;; This function is in this file despite its `vc-dir-' prefix to avoid + ;; having to load `vc-dir' just to get access to this simple wrapper. + (let ((morep t) results) + (with-temp-buffer + (setq default-directory directory) + (vc-call-backend (or backend (vc-responsible-backend directory)) + 'dir-status-files directory files + (lambda (entries &optional more-to-come) + (let (entry) + (while (setq entry (pop entries)) + ;; We shouldn't actually get any + ;; `up-to-date' or `ignored' entries back, + ;; but just in case, pass through a filter. + (unless (memq (cadr entry) + '(up-to-date ignored)) + (push entry results)))) + (setq morep more-to-come))) + (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. +See Info node `(emacs)Other Working Trees' regarding VCS repositories +with multiple working trees." + (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) + +;;;###autoload +(defun vc-switch-working-tree (directory) + "Switch to this file's analogue in working tree DIRECTORY. +This command switches to the file which has the same path +relative to DIRECTORY that this buffer's file has relative +to the root of this working tree. +DIRECTORY names another working tree with the same backing repository as +this tree; see Info node `(emacs)Other Working Trees' for general +information regarding VCS repositories with multiple working trees." + ;; FIXME: Switch between directory analogues, too, in Dired buffers. + (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))) + +;;;###autoload +(defun vc-delete-working-tree (backend directory) + "Delete working tree DIRECTORY with same backing repository as this tree. +See Info node `(emacs)Other Working Trees' regarding VCS repositories +with multiple working trees." + (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)))) + ;; 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 "\ +%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)) + +(autoload 'dired-rename-subdir "dired-aux") +;;;###autoload +(defun vc-move-working-tree (backend from to) + "Relocate a working tree from FROM to TO. +See Info node `(emacs)Other Working Trees' regarding VCS repositories +with multiple working trees." + (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) + + ;; 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))) + ;; These things should probably be generally available diff --git a/test/lisp/vc/vc-tests/vc-tests.el b/test/lisp/vc/vc-tests/vc-tests.el index 82f28cdad3a..9f570ca0dd1 100644 --- a/test/lisp/vc/vc-tests/vc-tests.el +++ b/test/lisp/vc/vc-tests/vc-tests.el @@ -44,6 +44,7 @@ ;; - latest-on-branch-p (file) ;; * checkout-model (files) DONE ;; - mode-line-string (file) +;; - other-working-trees () DONE ;; STATE-CHANGING FUNCTIONS ;; @@ -65,6 +66,9 @@ ;; - modify-change-comment (files rev comment) ;; - mark-resolved (files) ;; - find-admin-dir (file) +;; - add-working-tree (directory) DONE +;; - delete-working-tree (directory) DONE +;; - move-working-tree (from to) DONE ;; HISTORY FUNCTIONS ;; @@ -656,6 +660,103 @@ This checks also `vc-backend' and `vc-responsible-backend'." (ignore-errors (run-hooks 'vc-test--cleanup-hook)))))) +(defun vc-test--other-working-trees (backend) + "Test other working trees actions." + (ert-with-temp-directory tempdir + (let ((vc-handled-backends `(,backend)) + (default-directory + (file-name-as-directory + (expand-file-name + (make-temp-name "vc-test") temporary-file-directory))) + (process-environment process-environment) + vc-test--cleanup-hook) + (unwind-protect + (progn + ;; Cleanup. + (add-hook + 'vc-test--cleanup-hook + (let ((dir default-directory)) + (lambda () + (delete-directory dir 'recursive) + (dolist (name '("first" "second" "first")) + (project-forget-project + (expand-file-name name default-directory)))))) + + (let* ((first (file-name-as-directory + (expand-file-name "first" default-directory))) + (second (file-name-as-directory + (expand-file-name "second" default-directory))) + (third (file-name-as-directory + (expand-file-name "third" default-directory))) + (tmp-name (expand-file-name "foo" first))) + + ;; Set up the first working tree. + (make-directory first t) + (let ((default-directory first)) + (vc-test--create-repo-function backend) + (write-region "foo" nil tmp-name nil 'nomessage) + (vc-register `(,backend (,(file-name-nondirectory tmp-name))))) + (with-current-buffer (find-file-noselect tmp-name) + (vc-checkin (list (file-name-nondirectory tmp-name)) backend) + (insert "Testing other working trees") + (let (vc-async-checkin) + (log-edit-done)) + + ;; Set up the second working tree. + ;; For the backends which do additional prompting (as + ;; specified in the API for this backend function) we + ;; need to stub that out. + (cl-ecase backend + (Git (cl-letf (((symbol-function 'completing-read) + (lambda (&rest _ignore) ""))) + (vc-add-working-tree backend second))) + (Hg (vc-add-working-tree backend second)))) + + ;; Test `known-other-working-trees'. + (with-current-buffer (find-file-noselect tmp-name) + (should + (equal (list second) + (vc-call-backend backend 'known-other-working-trees))) + (let ((default-directory second)) + (should + (equal (list first) + (vc-call-backend backend 'known-other-working-trees)))) + + ;; Test `move-working-tree'. + (vc-move-working-tree backend second third) + (should + (equal (list third) + (vc-call-backend backend 'known-other-working-trees))) + (should-not (file-directory-p second)) + (should (file-directory-p third)) + ;; Moving the first working tree is only supported + ;; for some backends. + (cl-ecase backend + (Git + (let ((default-directory third)) + (vc-move-working-tree backend first second)) + (let ((default-directory third)) + (should + (equal (list second) + (vc-call-backend backend + 'known-other-working-trees)))) + (should-not (file-directory-p first)) + (should (file-directory-p second)) + (vc-move-working-tree backend second first)) + (Hg + (let ((default-directory third)) + (should-error (vc-move-working-tree backend + first second))))) + + ;; Test `delete-working-tree'. + (let ((default-directory first)) + (vc-delete-working-tree backend third) + (should-not (file-directory-p third)))))) + + ;; Save exit. + (ignore-errors + (run-hooks 'vc-test--cleanup-hook)))))) + ;; Create the test cases. (defun vc-test--rcs-enabled () @@ -794,7 +895,23 @@ This checks also `vc-backend' and `vc-responsible-backend'." (eq system-type 'windows-nt) noninteractive)) (vc-test--version-diff ',backend)) - )))) + + (ert-deftest + ,(intern (format "vc-test-%s07-other-working-trees" backend-string)) () + ,(format "Check other working trees functions for the %s backend." + backend-string) + (skip-unless + (ert-test-passed-p + (ert-test-most-recent-result + (ert-get-test + ',(intern + (format "vc-test-%s01-register" backend-string)))))) + (skip-unless (memq ',backend '(Git Hg))) + (skip-when + (and (eq ',backend 'Hg) + (equal (car (process-lines-ignore-status "hg" "share")) + "hg: unknown command 'share'"))) + (vc-test--other-working-trees ',backend)))))) (provide 'vc-tests) ;;; vc-tests.el ends here