mirror of
git://git.sv.gnu.org/emacs.git
synced 2026-06-14 12:31:25 +00:00
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.
This commit is contained in:
Sean Whitton
parent
e48592ef3b
commit
bb1c737531
1 changed files with 158 additions and 152 deletions
|
|
@ -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.
|
||||
|
||||
|
|
|
|||
Loading…
Reference in a new issue