From 71ea4bbb6c14c163bd14bb6faa511ff89939c69f Mon Sep 17 00:00:00 2001 From: Sean Whitton Date: Tue, 9 Jun 2026 11:21:33 +0100 Subject: [PATCH] vc-test-vc-dir-on-symlink: Use vc-test--with-author-identity * test/lisp/vc/vc-tests/vc-tests.el (vc-hg-global-switches): Declare. (vc-tests-helpers): Require. (vc-test--create-repo-function, vc-test--with-author-identity): Move these from here ... * test/lisp/vc/vc-tests/resources/vc-tests-helpers.el (vc-test--create-repo-function, vc-test--with-author-identity): ... to here. (vc-hg-global-switches): * test/lisp/vc/vc-tests/vc-test-misc.el (vc-hg-global-switches): Declare. (vc-dir, log-edit, vc-tests-helpers): Require. (vc-test-vc-dir-on-symlink): Use vc-test--with-author-identity and vc-test--create-repo-function. --- .../vc/vc-tests/resources/vc-tests-helpers.el | 100 ++++++++++++++++++ test/lisp/vc/vc-tests/vc-test-misc.el | 86 ++++++++------- test/lisp/vc/vc-tests/vc-tests.el | 78 +------------- 3 files changed, 151 insertions(+), 113 deletions(-) create mode 100644 test/lisp/vc/vc-tests/resources/vc-tests-helpers.el diff --git a/test/lisp/vc/vc-tests/resources/vc-tests-helpers.el b/test/lisp/vc/vc-tests/resources/vc-tests-helpers.el new file mode 100644 index 00000000000..73afef4075b --- /dev/null +++ b/test/lisp/vc/vc-tests/resources/vc-tests-helpers.el @@ -0,0 +1,100 @@ +;;; vc-test-helper.el --- VC test suite helpers -*- lexical-binding:t -*- + +;; Copyright (C) 2014-2026 Free Software Foundation, Inc. + +;; Author: Michael Albinus +;; Sean Whitton + +;; This file is part of GNU Emacs. +;; +;; GNU Emacs is free software: you can redistribute it and/or +;; modify it under the terms of the GNU General Public License as +;; published by the Free Software Foundation, either version 3 of the +;; License, or (at your option) any later version. +;; +;; GNU Emacs is distributed in the hope that it will be useful, but +;; WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: + +;;; Code: + +(defun vc-test--create-repo-function (backend) + "Run the `vc-create-repo' backend function. +For backends which don't support it, it is emulated." + (cond + ((eq backend 'CVS) + (let ((tmp-dir + (expand-file-name + (make-temp-name "vc-test") temporary-file-directory))) + (make-directory (expand-file-name "module" tmp-dir) 'parents) + (make-directory (expand-file-name "CVSROOT" tmp-dir) 'parents) + (if (not (fboundp 'w32-application-type)) + (shell-command-to-string (format "cvs -Q -d:local:%s co module" + tmp-dir)) + (let ((cvs-prog (executable-find "cvs")) + (tdir tmp-dir)) + ;; If CVS executable is an MSYS program, reformat the file + ;; name of TMP-DIR to have the /d/foo/bar form supported by + ;; MSYS programs. (FIXME: What about Cygwin cvs.exe?) + (if (eq (w32-application-type cvs-prog) 'msys) + (setq tdir + (concat "/" (substring tmp-dir 0 1) (substring tmp-dir 2)))) + (shell-command-to-string (format "cvs -Q -d:local:%s co module" + tdir)))) + (rename-file "module/CVS" default-directory) + (delete-directory "module" 'recursive) + ;; We must cleanup the "remote" CVS repo as well. + (add-hook 'vc-test--cleanup-hook + (lambda () (delete-directory tmp-dir 'recursive))))) + + ((eq backend 'Arch) + (let ((archive-name (format "%s--%s" user-mail-address (random)))) + (when (string-match + "no arch user id set" (shell-command-to-string "tla my-id")) + (shell-command-to-string + (format "tla my-id \"<%s>\"" user-mail-address))) + (shell-command-to-string + (format "tla make-archive %s %s" archive-name default-directory)) + (shell-command-to-string + (format "tla my-default-archive %s" archive-name)))) + + ((eq backend 'Mtn) + (let ((archive-name "foo.mtn")) + (shell-command-to-string + (format + "mtn db init --db=%s" + (expand-file-name archive-name default-directory))) + (shell-command-to-string + (format "mtn --db=%s --branch=foo setup ." archive-name)))) + + (t (vc-create-repo backend)))) + +(defvar vc-hg-global-switches) + +(defmacro vc-test--with-author-identity (backend &rest body) + (declare (indent 1) (debug t)) + `(let ((process-environment process-environment) + (vc-hg-global-switches (bound-and-true-p vc-hg-global-switches))) + ;; git tries various approaches to guess a user name and email, + ;; which can fail depending on how the system is configured. + ;; Eg if the user account has no GECOS, git commit can fail with + ;; status 128 "fatal: empty ident name". + (when (memq ,backend '(Bzr Git)) + (push "EMAIL=joh.doe@example.com" process-environment)) + (when (eq ,backend 'Git) + (setq process-environment (append '("GIT_AUTHOR_NAME=A" + "GIT_COMMITTER_NAME=C") + process-environment))) + + ;; Mercurial fails to autodetect an identity on MS-Windows. + (when (eq ,backend 'Hg) + (push "--config=ui.username=john@doe.ee" vc-hg-global-switches)) + ,@body)) + +(provide 'vc-tests-helpers) diff --git a/test/lisp/vc/vc-tests/vc-test-misc.el b/test/lisp/vc/vc-tests/vc-test-misc.el index 72a65df0fe6..bb2ee8af1f7 100644 --- a/test/lisp/vc/vc-tests/vc-test-misc.el +++ b/test/lisp/vc/vc-tests/vc-test-misc.el @@ -26,6 +26,13 @@ (require 'ert-x) (require 'vc) (require 'vc-git) +(require 'vc-dir) +(require 'log-edit) + +(require 'vc-tests-helpers + (ert-resource-file "vc-tests-helpers")) + +(defvar vc-hg-global-switches) (ert-deftest vc-test-buffer-sync-fileset () "Test `vc-buffer-sync-fileset'." @@ -247,45 +254,46 @@ "Test VC-Dir on a symlink to a repository. See bug#80803 and bug#80967." (skip-unless (executable-find vc-git-program)) - (let ((vc-handled-backends '(Git))) - (ert-with-temp-directory tempdir - (let* ((default-directory tempdir) - (src (expand-file-name "src/" tempdir)) - (dest (expand-file-name "dest/" tempdir)) - (file (expand-file-name "foo" dest)) - file-buf truename-dir symlink-dir) - (make-directory dest) - (let ((default-directory dest) - vc-async-checkin) - (vc-create-repo 'Git) - (write-region "foo\n" nil file nil 'nomessage) - (with-current-buffer (setq file-buf (find-file-noselect file)) - (vc-register `(Git (,file))) - (vc-checkin (list file) 'Git) - (insert "Initial commit") - (let (vc-async-checkin) - (log-edit-done)))) - (make-symbolic-link dest src) - ;; Emulate an interactive call to `vc-dir'. - (vc-dir (file-truename src) 'Git) - (while (vc-dir-busy) (sit-for 0.05)) - (should (equal default-directory dest)) - (setq truename-dir (current-buffer)) - ;; Now a `vc-dir' pointed at the symlink, which is unlike an - ;; interactive call to `vc-dir'. - (vc-dir src 'Git) - (while (vc-dir-busy) (sit-for 0.05)) - (should (equal default-directory src)) - (setq symlink-dir (current-buffer)) - (with-current-buffer file-buf - (insert "bar") - (basic-save-buffer)) - (dolist (buf (list truename-dir symlink-dir)) - (with-current-buffer buf - (should (equal (vc-dir-fileinfo->name - (ewoc-data - (ewoc-nth vc-ewoc 1))) - (file-name-nondirectory file))))))))) + (vc-test--with-author-identity 'Git + (let ((vc-handled-backends '(Git))) + (ert-with-temp-directory tempdir + (let* ((default-directory tempdir) + (src (expand-file-name "src/" tempdir)) + (dest (expand-file-name "dest/" tempdir)) + (file (expand-file-name "foo" dest)) + file-buf truename-dir symlink-dir) + (make-directory dest) + (let ((default-directory dest) + vc-async-checkin) + (vc-test--create-repo-function 'Git) + (write-region "foo\n" nil file nil 'nomessage) + (with-current-buffer (setq file-buf (find-file-noselect file)) + (vc-register `(Git (,file))) + (vc-checkin (list file) 'Git) + (insert "Initial commit") + (let (vc-async-checkin) + (log-edit-done)))) + (make-symbolic-link dest src) + ;; Emulate an interactive call to `vc-dir'. + (vc-dir (file-truename src) 'Git) + (while (vc-dir-busy) (sit-for 0.05)) + (should (equal default-directory dest)) + (setq truename-dir (current-buffer)) + ;; Now a `vc-dir' pointed at the symlink, which is unlike an + ;; interactive call to `vc-dir'. + (vc-dir src 'Git) + (while (vc-dir-busy) (sit-for 0.05)) + (should (equal default-directory src)) + (setq symlink-dir (current-buffer)) + (with-current-buffer file-buf + (insert "bar") + (basic-save-buffer)) + (dolist (buf (list truename-dir symlink-dir)) + (with-current-buffer buf + (should (equal (vc-dir-fileinfo->name + (ewoc-data + (ewoc-nth vc-ewoc 1))) + (file-name-nondirectory file)))))))))) (provide 'vc-test-misc) ;;; vc-test-misc.el ends here diff --git a/test/lisp/vc/vc-tests/vc-tests.el b/test/lisp/vc/vc-tests/vc-tests.el index 8e2ae2c4454..f190db103d5 100644 --- a/test/lisp/vc/vc-tests/vc-tests.el +++ b/test/lisp/vc/vc-tests/vc-tests.el @@ -120,6 +120,10 @@ (require 'project) (require 'cl-lib) +(require 'vc-tests-helpers + (ert-resource-file "vc-tests-helpers")) + +(defvar vc-hg-global-switches) (declare-function w32-application-type "w32proc.c") ;; The working horses. @@ -132,58 +136,6 @@ Don't set it globally, the functions should be let-bound.") "Run the `revision-granularity' backend function." (vc-call-backend backend 'revision-granularity)) -(defun vc-test--create-repo-function (backend) - "Run the `vc-create-repo' backend function. -For backends which don't support it, it is emulated." - - (cond - ((eq backend 'CVS) - (let ((tmp-dir - (expand-file-name - (make-temp-name "vc-test") temporary-file-directory))) - (make-directory (expand-file-name "module" tmp-dir) 'parents) - (make-directory (expand-file-name "CVSROOT" tmp-dir) 'parents) - (if (not (fboundp 'w32-application-type)) - (shell-command-to-string (format "cvs -Q -d:local:%s co module" - tmp-dir)) - (let ((cvs-prog (executable-find "cvs")) - (tdir tmp-dir)) - ;; If CVS executable is an MSYS program, reformat the file - ;; name of TMP-DIR to have the /d/foo/bar form supported by - ;; MSYS programs. (FIXME: What about Cygwin cvs.exe?) - (if (eq (w32-application-type cvs-prog) 'msys) - (setq tdir - (concat "/" (substring tmp-dir 0 1) (substring tmp-dir 2)))) - (shell-command-to-string (format "cvs -Q -d:local:%s co module" - tdir)))) - (rename-file "module/CVS" default-directory) - (delete-directory "module" 'recursive) - ;; We must cleanup the "remote" CVS repo as well. - (add-hook 'vc-test--cleanup-hook - (lambda () (delete-directory tmp-dir 'recursive))))) - - ((eq backend 'Arch) - (let ((archive-name (format "%s--%s" user-mail-address (random)))) - (when (string-match - "no arch user id set" (shell-command-to-string "tla my-id")) - (shell-command-to-string - (format "tla my-id \"<%s>\"" user-mail-address))) - (shell-command-to-string - (format "tla make-archive %s %s" archive-name default-directory)) - (shell-command-to-string - (format "tla my-default-archive %s" archive-name)))) - - ((eq backend 'Mtn) - (let ((archive-name "foo.mtn")) - (shell-command-to-string - (format - "mtn db init --db=%s" - (expand-file-name archive-name default-directory))) - (shell-command-to-string - (format "mtn --db=%s --branch=foo setup ." archive-name)))) - - (t (vc-create-repo backend)))) - (defmacro vc--fix-home-for-bzr (tempdir) ;; See the comment in `vc-bzr-test-bug9726'. `(when (eq backend 'Bzr) @@ -718,28 +670,6 @@ This checks also `vc-backend' and `vc-responsible-backend'." (ignore-errors (run-hooks 'vc-test--cleanup-hook)))))) -(defvar vc-hg-global-switches) - -(defmacro vc-test--with-author-identity (backend &rest body) - (declare (indent 1) (debug t)) - `(let ((process-environment process-environment) - (vc-hg-global-switches vc-hg-global-switches)) - ;; git tries various approaches to guess a user name and email, - ;; which can fail depending on how the system is configured. - ;; Eg if the user account has no GECOS, git commit can fail with - ;; status 128 "fatal: empty ident name". - (when (memq ,backend '(Bzr Git)) - (push "EMAIL=joh.doe@example.com" process-environment)) - (when (eq ,backend 'Git) - (setq process-environment (append '("GIT_AUTHOR_NAME=A" - "GIT_COMMITTER_NAME=C") - process-environment))) - - ;; Mercurial fails to autodetect an identity on MS-Windows. - (when (eq ,backend 'Hg) - (push "--config=ui.username=john@doe.ee" vc-hg-global-switches)) - ,@body)) - (declare-function log-edit-done "vc/log-edit") (defun vc-test--version-diff (backend)