From bb1c737531c8d2e78a77b29ddd2db5b89c9c6810 Mon Sep 17 00:00:00 2001 From: Sean Whitton Date: Tue, 12 Aug 2025 20:35:49 +0100 Subject: [PATCH] vc-test--other-working-trees: Export env vars so Git finds an author * test/lisp/vc/vc-tests/vc-tests.el (vc-test--with-author-identity): New macro, factored out of vc-test--version-diff. (vc-test--version-diff, vc-test--other-working-trees): Use it. --- test/lisp/vc/vc-tests/vc-tests.el | 310 +++++++++++++++--------------- 1 file changed, 158 insertions(+), 152 deletions(-) diff --git a/test/lisp/vc/vc-tests/vc-tests.el b/test/lisp/vc/vc-tests/vc-tests.el index ba131502b9b..81789814350 100644 --- a/test/lisp/vc/vc-tests/vc-tests.el +++ b/test/lisp/vc/vc-tests/vc-tests.el @@ -584,6 +584,22 @@ This checks also `vc-backend' and `vc-responsible-backend'." (ignore-errors (run-hooks 'vc-test--cleanup-hook)))))) +(defmacro vc-test--with-author-identity (backend &rest body) + (declare (indent 1) (debug t)) + `(let ((process-environment process-environment)) + ;; 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)) + (setq process-environment (cons "EMAIL=john@doe.ee" + process-environment))) + (when (eq ,backend 'Git) + (setq process-environment (append '("GIT_AUTHOR_NAME=A" + "GIT_COMMITTER_NAME=C") + process-environment))) + ,@body)) + (declare-function log-edit-done "vc/log-edit") (defun vc-test--version-diff (backend) @@ -595,72 +611,62 @@ This checks also `vc-backend' and `vc-responsible-backend'." (file-truename (expand-file-name (make-temp-name "vc-test") temporary-file-directory)))) - (process-environment process-environment) vc-test--cleanup-hook) (vc--fix-home-for-bzr tempdir) - ;; 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)) - (setq process-environment (cons "EMAIL=john@doe.ee" - process-environment))) - (if (eq backend 'Git) - (setq process-environment (append '("GIT_AUTHOR_NAME=A" - "GIT_COMMITTER_NAME=C") - process-environment))) - (unwind-protect - (progn - ;; Cleanup. - (add-hook - 'vc-test--cleanup-hook - (let ((dir default-directory)) - (lambda () (delete-directory dir 'recursive)))) + (vc-test--with-author-identity backend - ;; Create empty repository. Check repository checkout model. - (make-directory default-directory) - (vc-test--create-repo-function backend) + (unwind-protect + (progn + ;; Cleanup. + (add-hook + 'vc-test--cleanup-hook + (let ((dir default-directory)) + (lambda () (delete-directory dir 'recursive)))) - (let* ((tmp-name (expand-file-name "foo" default-directory)) - (files (list (file-name-nondirectory tmp-name)))) - ;; Write and register a new file. - (write-region "originaltext" nil tmp-name nil 'nomessage) - (vc-register (list backend files)) + ;; Create empty repository. Check repository checkout model. + (make-directory default-directory) + (vc-test--create-repo-function backend) - (let ((buff (find-file tmp-name))) - (with-current-buffer buff + (let* ((tmp-name (expand-file-name "foo" default-directory)) + (files (list (file-name-nondirectory tmp-name)))) + ;; Write and register a new file. + (write-region "originaltext" nil tmp-name nil 'nomessage) + (vc-register (list backend files)) + + (let ((buff (find-file tmp-name))) + (with-current-buffer buff + (progn + ;; Optionally checkout file. + (when (memq backend '(RCS CVS SCCS)) + (vc-checkout tmp-name)) + + ;; Checkin file. + (vc-checkin files backend) + (insert "Testing vc-version-diff") + (let (vc-async-checkin) + (log-edit-done))))) + + ;; Modify file content. + (when (memq backend '(RCS CVS SCCS)) + (vc-checkout tmp-name)) + (write-region "updatedtext" nil tmp-name nil 'nomessage) + + ;; Check version diff. + (vc-version-diff files nil nil) + (if (eq backend 'Bzr) + (sleep-for 1)) + (should (bufferp (get-buffer "*vc-diff*"))) + + (with-current-buffer "*vc-diff*" (progn - ;; Optionally checkout file. - (when (memq backend '(RCS CVS SCCS)) - (vc-checkout tmp-name)) + (let ((rawtext (buffer-substring-no-properties (point-min) + (point-max)))) + (should (string-search "-originaltext" rawtext)) + (should (string-search "+updatedtext" rawtext))))))) - ;; Checkin file. - (vc-checkin files backend) - (insert "Testing vc-version-diff") - (let (vc-async-checkin) - (log-edit-done))))) - - ;; Modify file content. - (when (memq backend '(RCS CVS SCCS)) - (vc-checkout tmp-name)) - (write-region "updatedtext" nil tmp-name nil 'nomessage) - - ;; Check version diff. - (vc-version-diff files nil nil) - (if (eq backend 'Bzr) - (sleep-for 1)) - (should (bufferp (get-buffer "*vc-diff*"))) - - (with-current-buffer "*vc-diff*" - (progn - (let ((rawtext (buffer-substring-no-properties (point-min) - (point-max)))) - (should (string-search "-originaltext" rawtext)) - (should (string-search "+updatedtext" rawtext))))))) - - ;; Save exit. - (ignore-errors - (run-hooks 'vc-test--cleanup-hook)))))) + ;; Save exit. + (ignore-errors + (run-hooks 'vc-test--cleanup-hook))))))) (declare-function vc-git--program-version "vc-git") @@ -672,104 +678,104 @@ This checks also `vc-backend' and `vc-responsible-backend'." (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)))))) + (vc-test--with-author-identity backend + (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-truename - (file-name-as-directory - (expand-file-name "first" default-directory)))) - (second (file-truename - (file-name-as-directory - (expand-file-name "second" default-directory)))) - (third (file-truename - (file-name-as-directory - (expand-file-name "third" default-directory)))) - (tmp-name (expand-file-name "foo" first)) - (project-list-file - (expand-file-name "projects.eld" default-directory))) + (let* ((first (file-truename + (file-name-as-directory + (expand-file-name "first" default-directory)))) + (second (file-truename + (file-name-as-directory + (expand-file-name "second" default-directory)))) + (third (file-truename + (file-name-as-directory + (expand-file-name "third" default-directory)))) + (tmp-name (expand-file-name "foo" first)) + (project-list-file + (expand-file-name "projects.eld" default-directory))) - ;; 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. - ;; Stub out `vc-dir' so that it doesn't start a - ;; background update process which won't like it when we - ;; start moving directories around. - ;; For the backends which do additional prompting (as - ;; specified in the API for this backend function) we - ;; need to stub that out. - (cl-letf (((symbol-function 'vc-dir) #'ignore)) - (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. - (cond ((and (eq backend 'Git) - (version<= "2.29" (vc-git--program-version))) - (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)) - ((eq backend 'Hg) - (let ((default-directory third)) - (should-error (vc-move-working-tree backend - first second))))) - (vc-move-working-tree backend third second) - - ;; Test `delete-working-tree'. + ;; Set up the first working tree. + (make-directory first t) (let ((default-directory first)) - (vc-delete-working-tree backend second) - (should-not (file-directory-p second)))))) + (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)) - ;; Save exit. - (ignore-errors - (run-hooks 'vc-test--cleanup-hook)))))) + ;; Set up the second working tree. + ;; Stub out `vc-dir' so that it doesn't start a + ;; background update process which won't like it when we + ;; start moving directories around. + ;; For the backends which do additional prompting (as + ;; specified in the API for this backend function) we + ;; need to stub that out. + (cl-letf (((symbol-function 'vc-dir) #'ignore)) + (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. + (cond ((and (eq backend 'Git) + (version<= "2.29" (vc-git--program-version))) + (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)) + ((eq backend 'Hg) + (let ((default-directory third)) + (should-error (vc-move-working-tree backend + first second))))) + (vc-move-working-tree backend third second) + + ;; Test `delete-working-tree'. + (let ((default-directory first)) + (vc-delete-working-tree backend second) + (should-not (file-directory-p second)))))) + + ;; Save exit. + (ignore-errors + (run-hooks 'vc-test--cleanup-hook))))))) ;; Create the test cases.