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

vc-test-vc-dir-on-symlink: Use vc-test--with-author-identity

Browse source 
* 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.
This commit is contained in:
Sean Whitton 2026-06-09 11:21:33 +01:00
parent b8fa2243ea
commit 71ea4bbb6c
3 changed files with 151 additions and 113 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

100
test/lisp/vc/vc-tests/resources/vc-tests-helpers.el Normal file
View file

@ -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 <michael.albinus@gmx.de>
;; Sean Whitton <spwhitton@spwhitton.name>
;; 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 <https://www.gnu.org/licenses/>.
;;; 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)

86
test/lisp/vc/vc-tests/vc-test-misc.el
View file

@ -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

78
test/lisp/vc/vc-tests/vc-tests.el
View file

@ -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)