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.

1 files changed, 164 insertions, 158 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))))
-
-            ;; Create empty repository.  Check repository checkout model.
-            (make-directory default-directory)
-            (vc-test--create-repo-function backend)
-
-            (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
+      (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))))
+
+              ;; Create empty repository.  Check repository checkout model.
+              (make-directory default-directory)
+              (vc-test--create-repo-function backend)
+
+              (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))
-
-                    ;; 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)))))))
+                    (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))))))
-
-            (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'.
+      (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)))
+
+                ;; 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))))))
-
-        ;; Save exit.
-        (ignore-errors
-          (run-hooks 'vc-test--cleanup-hook))))))
+                  (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'.
+                  (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.