From: Sean Whitton Date: Fri, 9 May 2025 10:00:47 +0000 (+0100) Subject: Create new test/lisp/vc/vc-tests/ for vc.el tests X-Git-Url: http://git.eshelyaron.com/gitweb/?a=commitdiff_plain;h=3215d9f1cbbd892d225871ff1b089555d17842bf;p=emacs.git Create new test/lisp/vc/vc-tests/ for vc.el tests * test/lisp/vc/vc-tests.el: Move ... * test/lisp/vc/vc-tests/vc-tests.el: ... to here. * test/lisp/vc/vc-misc-tests.el: Move ... * test/lisp/vc/vc-tests/vc-test-misc.el: ... to here. (cherry picked from commit 295c38b03d065d00361ca07355b82bf279ebd6b1) --- diff --git a/test/lisp/vc/vc-misc-tests.el b/test/lisp/vc/vc-misc-tests.el deleted file mode 100644 index d19dda36d2f..00000000000 --- a/test/lisp/vc/vc-misc-tests.el +++ /dev/null @@ -1,67 +0,0 @@ -;;; vc-misc-tests.el --- backend-agnostic VC tests -*- lexical-binding:t -*- - -;; Copyright (C) 2025 Free Software Foundation, Inc. - -;; Author: 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: - -(require 'ert-x) -(require 'vc) - -(ert-deftest vc-test-buffer-sync-fileset () - "Test `vc-buffer-sync-fileset'." - (cl-flet ((test-it (&rest args) - (let (buffers) - (cl-letf (((symbol-function 'vc-buffer-sync) - (lambda (&rest _) - (push (current-buffer) buffers)))) - (apply #'vc-buffer-sync-fileset args) - (sort buffers))))) - (ert-with-temp-directory temp - (let* ((default-directory temp) - (present (find-file-noselect "present")) - (missing (find-file-noselect "missing")) - (only-present (list present)) - (only-missing (list missing)) - (missing+present (list missing present))) - (with-current-buffer present (basic-save-buffer)) - (with-temp-file "unvisited") - ;; Regular behavior for files. - (should (equal (test-it `(Git ("missing"))) - only-missing)) - (should (equal (test-it `(Git ("present" "missing"))) - missing+present)) - ;; Regular behavior for directories. - (should (equal (test-it `(Git (,temp))) - only-present)) - ;; Two ways to override regular behavior for directories. - (should (equal (test-it `(Git (,temp)) nil t) - missing+present)) - (should (equal (test-it `(Git (,temp "missing"))) - missing+present)) - ;; Doesn't sync PRESENT twice. - (should (equal (test-it `(Git ("present" ,temp))) - only-present)) - (should (equal (test-it `(Git ("missing" ,temp "present"))) - missing+present)))))) - -(provide 'vc-misc-tests) -;;; vc-misc-tests.el ends here diff --git a/test/lisp/vc/vc-tests.el b/test/lisp/vc/vc-tests.el deleted file mode 100644 index e7852d53f99..00000000000 --- a/test/lisp/vc/vc-tests.el +++ /dev/null @@ -1,792 +0,0 @@ -;;; vc-tests.el --- Tests of different backends of vc.el -*- lexical-binding:t -*- - -;; Copyright (C) 2014-2025 Free Software Foundation, Inc. - -;; Author: Michael Albinus - -;; 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: - -;; For every supported VC on the machine, different test cases are -;; generated automatically. - -;; Functions to be tested (see Commentary of vc.el). Mandatory -;; functions are marked with `*', optional functions are marked with `-': - -;; BACKEND PROPERTIES -;; -;; * revision-granularity DONE - -;; STATE-QUERYING FUNCTIONS -;; -;; * registered (file) DONE -;; * state (file) DONE -;; - dir-status (dir update-function) -;; - dir-status-files (dir files default-state update-function) -;; - dir-extra-headers (dir) -;; - dir-printer (fileinfo) -;; - status-fileinfo-extra (file) -;; * working-revision (file) DONE -;; - latest-on-branch-p (file) -;; * checkout-model (files) DONE -;; - mode-line-string (file) - -;; STATE-CHANGING FUNCTIONS -;; -;; * create-repo (backend) DONE -;; * register (files &optional comment) DONE -;; - responsible-p (file) -;; - receive-file (file rev) -;; - unregister (file) DONE -;; * checkin (files comment) DONE -;; * find-revision (file rev buffer) -;; * checkout (file &optional rev) -;; * revert (file &optional contents-done) -;; - rollback (files) -;; - merge-file (file rev1 rev2) -;; - merge-branch () -;; - merge-news (file) -;; - pull (prompt) -;; - steal-lock (file &optional revision) -;; - modify-change-comment (files rev comment) -;; - mark-resolved (files) -;; - find-admin-dir (file) - -;; HISTORY FUNCTIONS -;; -;; * print-log (files buffer &optional shortlog start-revision limit) -;; * log-outgoing (backend remote-location) -;; * log-incoming (backend remote-location) -;; - log-view-mode () -;; - show-log-entry (revision) -;; - comment-history (file) -;; - update-changelog (files) -;; * diff (files &optional async rev1 rev2 buffer) DONE -;; - revision-completion-table (files) -;; - annotate-command (file buf &optional rev) -;; - annotate-time () -;; - annotate-current-time () -;; - annotate-extract-revision-at-line () -;; - region-history (FILE BUFFER LFROM LTO) -;; - region-history-mode () - -;; TAG SYSTEM -;; -;; - create-tag (dir name branchp) -;; - retrieve-tag (dir name update) - -;; MISCELLANEOUS -;; -;; - make-version-backups-p (file) -;; - root (file) -;; - ignore (file &optional directory) -;; - ignore-completion-table -;; - previous-revision (file rev) -;; - next-revision (file rev) -;; - log-edit-mode () -;; - check-headers () -;; - delete-file (file) -;; - rename-file (old new) DONE -;; - find-file-hook () -;; - extra-menu () -;; - extra-dir-menu () -;; - conflicted-files (dir) - -;;; Code: - -(require 'ert) -(require 'ert-x) -(require 'vc) -(require 'log-edit) - -(declare-function w32-application-type "w32proc.c") - -;; The working horses. - -(defvar vc-test--cleanup-hook nil - "Functions for cleanup at the end of an ert test. -Don't set it globally, the functions should be let-bound.") - -(defun vc-test--revision-granularity-function (backend) - "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) - (push (format "BZR_HOME=%s" ,tempdir) process-environment) - (push (format "HOME=%s" ,tempdir) process-environment))) - -(defun vc-test--create-repo (backend) - "Create a test repository in `default-directory', a temporary directory." - (ert-with-temp-directory tempdir - (let ((vc-handled-backends `(,backend)) - (default-directory - (file-name-as-directory - (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) - (unwind-protect - (progn - ;; Cleanup. - (add-hook - 'vc-test--cleanup-hook - (let ((dir default-directory)) - (lambda () (delete-directory dir 'recursive)))) - - ;; Check the revision granularity. - (should (memq (vc-test--revision-granularity-function backend) - '(file repository))) - - ;; Create empty repository. - (make-directory default-directory) - (should (file-directory-p default-directory)) - (vc-test--create-repo-function backend) - (should (eq (vc-responsible-backend default-directory) backend))) - - ;; Save exit. - (ignore-errors - (run-hooks 'vc-test--cleanup-hook)))))) - -;; FIXME: Why isn't there `vc-unregister'? -(defun vc-test--unregister-function (backend file) - "Run the `vc-unregister' backend function. -For backends which don't support it, `vc-not-supported' is signaled." - ;; CVS, SVN, SCCS, SRC and Mtn are not supported, and will signal - ;; `vc-not-supported'. - (prog1 - (vc-call-backend backend 'unregister file) - (vc-file-clearprops file))) - -(defmacro vc-test--run-maybe-unsupported-function (func &rest args) - "Run FUNC with ARGS as arguments. -Catch the `vc-not-supported' error." - `(condition-case err - (funcall ,func ,@args) - (vc-not-supported 'vc-not-supported) - (t (signal (car err) (cdr err))))) - -(defun vc-test--register (backend) - "Register and unregister a file. -This checks also `vc-backend' and `vc-responsible-backend'." - (ert-with-temp-directory tempdir - (let ((vc-handled-backends `(,backend)) - (default-directory - (file-name-as-directory - (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) - (unwind-protect - (progn - ;; Cleanup. - (add-hook - 'vc-test--cleanup-hook - (let ((dir default-directory)) - (lambda () (delete-directory dir 'recursive)))) - - ;; Create empty repository. - (make-directory default-directory) - (vc-test--create-repo-function backend) - ;; For file oriented backends CVS, RCS and SVN the backend is - ;; returned, and the directory is registered already. - (should (if (vc-backend default-directory) - (vc-registered default-directory) - (not (vc-registered default-directory)))) - (should (eq (vc-responsible-backend default-directory) backend)) - - (let ((tmp-name1 (expand-file-name "foo" default-directory)) - (tmp-name2 "bla")) - ;; Register files. Check for it. - (write-region "foo" nil tmp-name1 nil 'nomessage) - (should (file-exists-p tmp-name1)) - (should-not (vc-backend tmp-name1)) - (should (eq (vc-responsible-backend tmp-name1) backend)) - (should-not (vc-registered tmp-name1)) - - (write-region "bla" nil tmp-name2 nil 'nomessage) - (should (file-exists-p tmp-name2)) - (should-not (vc-backend tmp-name2)) - (should (eq (vc-responsible-backend tmp-name2) backend)) - (should-not (vc-registered tmp-name2)) - - (vc-register (list backend (list tmp-name1 tmp-name2))) - (should (file-exists-p tmp-name1)) - (should (eq (vc-backend tmp-name1) backend)) - (should (eq (vc-responsible-backend tmp-name1) backend)) - (should (vc-registered tmp-name1)) - - (should (file-exists-p tmp-name2)) - (should (eq (vc-backend tmp-name2) backend)) - (should (eq (vc-responsible-backend tmp-name2) backend)) - (should (vc-registered tmp-name2)) - - ;; `vc-backend' accepts also a list of files, - ;; `vc-responsible-backend' doesn't. - (should (vc-backend (list tmp-name1 tmp-name2))) - - ;; Unregister the files. - (unless (eq (vc-test--run-maybe-unsupported-function - 'vc-test--unregister-function backend tmp-name1) - 'vc-not-supported) - (should-not (vc-backend tmp-name1)) - (should-not (vc-registered tmp-name1))) - (unless (eq (vc-test--run-maybe-unsupported-function - 'vc-test--unregister-function backend tmp-name2) - 'vc-not-supported) - (should-not (vc-backend tmp-name2)) - (should-not (vc-registered tmp-name2))) - - ;; The files should still exist. - (should (file-exists-p tmp-name1)) - (should (file-exists-p tmp-name2)))) - - ;; Save exit. - (ignore-errors - (run-hooks 'vc-test--cleanup-hook)))))) - -(defun vc-test--state (backend) - "Check the different states of a file." - (ert-with-temp-directory tempdir - (let ((vc-handled-backends `(,backend)) - (default-directory - (file-name-as-directory - (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) - (unwind-protect - (progn - ;; Cleanup. - (add-hook - 'vc-test--cleanup-hook - (let ((dir default-directory)) - (lambda () (delete-directory dir 'recursive)))) - - ;; Create empty repository. - (make-directory default-directory) - (vc-test--create-repo-function backend) - - (let ((tmp-name (expand-file-name "foo" default-directory))) - ;; Check state of a nonexistent file. - - (message "vc-state2 %s" (vc-state tmp-name)) - (should (null (vc-state tmp-name))) - - ;; Write a new file. Check state. - (write-region "foo" nil tmp-name nil 'nomessage) - - ;; nil: Mtn - ;; unregistered: Bzr CVS Git Hg SVN RCS - (message "vc-state3 %s %s" backend (vc-state tmp-name backend)) - (should (memq (vc-state tmp-name backend) '(nil unregistered))) - - ;; Register a file. Check state. - (vc-register - (list backend (list (file-name-nondirectory tmp-name)))) - - ;; FIXME: nil is definitely wrong. - ;; nil: SRC - ;; added: Bzr CVS Git Hg Mtn SVN - ;; up-to-date: RCS SCCS - (message "vc-state4 %s" (vc-state tmp-name)) - (should (memq (vc-state tmp-name) '(nil added up-to-date))) - - ;; Unregister the file. Check state. - (if (eq (vc-test--run-maybe-unsupported-function - 'vc-test--unregister-function backend tmp-name) - 'vc-not-supported) - (message "vc-state5 unsupported") - ;; unregistered: Bzr Git RCS Hg - ;; unsupported: CVS SCCS SRC SVN - (message "vc-state5 %s %s" backend (vc-state tmp-name backend)) - (should (memq (vc-state tmp-name backend) - '(nil unregistered)))))) - - ;; Save exit. - (ignore-errors - (run-hooks 'vc-test--cleanup-hook)))))) - -(defun vc-test--working-revision (backend) - "Check the working revision of a repository." - (ert-with-temp-directory tempdir - (let ((vc-handled-backends `(,backend)) - (default-directory - (file-name-as-directory - (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) - (unwind-protect - (progn - ;; Cleanup. - (add-hook - 'vc-test--cleanup-hook - (let ((dir default-directory)) - (lambda () (delete-directory dir 'recursive)))) - - ;; Create empty repository. Check working revision of - ;; repository, should be nil. - (make-directory default-directory) - (vc-test--create-repo-function backend) - - ;; FIXME: Is the value for SVN correct? - ;; nil: Bzr CVS Git Hg Mtn RCS SCCS SRC - ;; "0": SVN - (message - "vc-working-revision1 %s" (vc-working-revision default-directory)) - (should (member (vc-working-revision default-directory) '(nil "0"))) - - (let ((tmp-name (expand-file-name "foo" default-directory))) - ;; Check initial working revision, should be nil until - ;; it's registered. - - (message "vc-working-revision2 %s" (vc-working-revision tmp-name)) - (should-not (vc-working-revision tmp-name)) - - ;; Write a new file. Check working revision. - (write-region "foo" nil tmp-name nil 'nomessage) - - (message "vc-working-revision3 %s" (vc-working-revision tmp-name)) - (should-not (vc-working-revision tmp-name)) - - ;; Register a file. Check working revision. - (vc-register - (list backend (list (file-name-nondirectory tmp-name)))) - - ;; XXX: nil is fine, at least in Git's case, because - ;; `vc-register' only makes the file `added' in this case. - ;; nil: Git Mtn - ;; "0": Bzr CVS Hg SRC SVN - ;; "1.1": RCS SCCS - ;; "-1": Hg versions before 5 (probably) - (message "vc-working-revision4 %s" (vc-working-revision tmp-name)) - (should (member (vc-working-revision tmp-name) '(nil "0" "1.1" "-1"))) - - ;; TODO: Call `vc-checkin', and check the resulting - ;; working revision. None of the return values should be - ;; nil then. - - ;; Unregister the file. Check working revision. - (if (eq (vc-test--run-maybe-unsupported-function - 'vc-test--unregister-function backend tmp-name) - 'vc-not-supported) - (message "vc-working-revision5 unsupported") - ;; nil: Bzr Git Hg RCS - ;; unsupported: CVS Mtn SCCS SRC SVN - (message "vc-working-revision5 %s" (vc-working-revision tmp-name)) - (should-not (vc-working-revision tmp-name))))) - - ;; Save exit. - (ignore-errors - (run-hooks 'vc-test--cleanup-hook)))))) - -(defun vc-test--checkout-model (backend) - "Check the checkout model of a repository." - (ert-with-temp-directory tempdir - (let ((vc-handled-backends `(,backend)) - (default-directory - (file-name-as-directory - (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) - (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) - - ;; Surprisingly, none of the backends returns 'announce. - ;; implicit: Bzr CVS Git Hg Mtn SRC SVN - ;; locking: RCS SCCS - (message - "vc-checkout-model1 %s" - (vc-checkout-model backend default-directory)) - (should (memq (vc-checkout-model backend default-directory) - '(announce implicit locking))) - - (let ((tmp-name (expand-file-name "foo" default-directory))) - ;; Check checkout model of a nonexistent file. - - ;; implicit: Bzr CVS Git Hg Mtn SRC SVN - ;; locking: RCS SCCS - (message - "vc-checkout-model2 %s" (vc-checkout-model backend tmp-name)) - (should (memq (vc-checkout-model backend tmp-name) - '(announce implicit locking))) - - ;; Write a new file. Check checkout model. - (write-region "foo" nil tmp-name nil 'nomessage) - - ;; implicit: Bzr CVS Git Hg Mtn SRC SVN - ;; locking: RCS SCCS - (message - "vc-checkout-model3 %s" (vc-checkout-model backend tmp-name)) - (should (memq (vc-checkout-model backend tmp-name) - '(announce implicit locking))) - - ;; Register a file. Check checkout model. - (vc-register - (list backend (list (file-name-nondirectory tmp-name)))) - - ;; implicit: Bzr CVS Git Hg Mtn SRC SVN - ;; locking: RCS SCCS - (message - "vc-checkout-model4 %s" (vc-checkout-model backend tmp-name)) - (should (memq (vc-checkout-model backend tmp-name) - '(announce implicit locking))) - - ;; Unregister the file. Check checkout model. - (if (eq (vc-test--run-maybe-unsupported-function - 'vc-test--unregister-function backend tmp-name) - 'vc-not-supported) - (message "vc-checkout-model5 unsupported") - ;; implicit: Bzr Git Hg - ;; locking: RCS - ;; unsupported: CVS Mtn SCCS SRC SVN - (message - "vc-checkout-model5 %s" (vc-checkout-model backend tmp-name)) - (should (memq (vc-checkout-model backend tmp-name) - '(announce implicit locking)))))) - - ;; Save exit. - (ignore-errors - (run-hooks 'vc-test--cleanup-hook)))))) - -(defun vc-test--rename-file (backend) - "Check the rename-file action." - (ert-with-temp-directory tempdir - (let ((vc-handled-backends `(,backend)) - (default-directory - (file-name-as-directory - (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) - (unwind-protect - (progn - ;; Cleanup. - (add-hook - 'vc-test--cleanup-hook - (let ((dir default-directory)) - (lambda () (delete-directory dir 'recursive)))) - - ;; Create empty repository. - (make-directory default-directory) - (vc-test--create-repo-function backend) - - (let ((tmp-name (expand-file-name "foo" default-directory)) - (new-name (expand-file-name "bar" default-directory))) - ;; Write a new file. - (write-region "foo" nil tmp-name nil 'nomessage) - - ;; Register it. Renaming can fail otherwise. - (vc-register - (list backend (list (file-name-nondirectory tmp-name)))) - - (vc-rename-file tmp-name new-name) - - (should (not (file-exists-p tmp-name))) - (should (file-exists-p new-name)) - - (should (equal (vc-state new-name) - (if (memq backend '(RCS SCCS)) - 'up-to-date - 'added))))) - - ;; Save exit. - (ignore-errors - (run-hooks 'vc-test--cleanup-hook)))))) - -(declare-function log-edit-done "vc/log-edit") - -(defun vc-test--version-diff (backend) - "Check the diff version of a repository." - (ert-with-temp-directory tempdir - (let ((vc-handled-backends `(,backend)) - (default-directory - (file-name-as-directory - (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 - (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") - (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) - (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)))))) - -;; Create the test cases. - -(defun vc-test--rcs-enabled () - (executable-find "rcs")) - -(defun vc-test--cvs-enabled () - (executable-find "cvs")) - -(defvar vc-svn-program) -(defun vc-test--svn-enabled () - (and (executable-find "svnadmin") - (executable-find vc-svn-program))) - -(defun vc-test--sccs-enabled () - (executable-find "sccs")) - -(defvar vc-src-program) -(defun vc-test--src-enabled () - (executable-find vc-src-program)) - -(defvar vc-bzr-program) -(defun vc-test--bzr-enabled () - (executable-find vc-bzr-program)) - -(defvar vc-git-program) -(defun vc-test--git-enabled () - (executable-find vc-git-program)) - -(defvar vc-hg-program) -(defun vc-test--hg-enabled () - (executable-find vc-hg-program)) - -(defvar vc-mtn-program) -(defun vc-test--mtn-enabled () - (executable-find vc-mtn-program)) - -;; Obsoleted. -(defvar vc-arch-program) -(defun vc-test--arch-enabled () - (executable-find vc-arch-program)) - -;; Create the test cases. -(dolist (backend vc-handled-backends) - (let ((backend-string (downcase (symbol-name backend)))) - (require (intern (format "vc-%s" backend-string))) - (eval - ;; Check, whether the backend is supported. - `(when (funcall ',(intern (format "vc-test--%s-enabled" backend-string))) - - (ert-deftest - ,(intern (format "vc-test-%s00-create-repo" backend-string)) () - ,(format "Check `vc-create-repo' for the %s backend." - backend-string) - (vc-test--create-repo ',backend)) - - (ert-deftest - ,(intern (format "vc-test-%s01-register" backend-string)) () - ,(format - "Check `vc-register' and `vc-registered' for the %s backend." - backend-string) - (skip-unless - (ert-test-passed-p - (ert-test-most-recent-result - (ert-get-test - ',(intern - (format "vc-test-%s00-create-repo" backend-string)))))) - (vc-test--register ',backend)) - - (ert-deftest - ,(intern (format "vc-test-%s02-state" backend-string)) () - ,(format "Check `vc-state' for the %s backend." backend-string) - (skip-unless - (ert-test-passed-p - (ert-test-most-recent-result - (ert-get-test - ',(intern - (format "vc-test-%s01-register" backend-string)))))) - (vc-test--state ',backend)) - - (ert-deftest - ,(intern (format "vc-test-%s03-working-revision" backend-string)) () - ,(format "Check `vc-working-revision' for the %s backend." - backend-string) - (skip-unless - (ert-test-passed-p - (ert-test-most-recent-result - (ert-get-test - ',(intern - (format "vc-test-%s01-register" backend-string)))))) - (vc-test--working-revision ',backend)) - - (ert-deftest - ,(intern (format "vc-test-%s04-checkout-model" backend-string)) () - ,(format "Check `vc-checkout-model' for the %s backend." - backend-string) - (skip-unless - (ert-test-passed-p - (ert-test-most-recent-result - (ert-get-test - ',(intern - (format "vc-test-%s01-register" backend-string)))))) - (vc-test--checkout-model ',backend)) - - (ert-deftest - ,(intern (format "vc-test-%s05-rename-file" backend-string)) () - ,(format "Check `vc-rename-file' for the %s backend." - backend-string) - (skip-unless - (ert-test-passed-p - (ert-test-most-recent-result - (ert-get-test - ',(intern - (format "vc-test-%s01-register" backend-string)))))) - ;; CVS calls vc-delete-file, which insists on prompting - ;; "Really want to delete ...?", and `vc-mtn.el' does not implement - ;; `delete-file' at all. - (skip-when (memq ',backend '(CVS Mtn))) - (vc-test--rename-file ',backend)) - - (ert-deftest - ,(intern (format "vc-test-%s06-version-diff" backend-string)) () - ,(format "Check `vc-version-diff' for the %s backend." - backend-string) - (skip-unless - (ert-test-passed-p - (ert-test-most-recent-result - (ert-get-test - ',(intern - (format "vc-test-%s01-register" backend-string)))))) - ;; `vc-mtn.el' gives me: - ;; "Failed (status 1): mtn commit -m Testing vc-version-diff\n\n foo" - (skip-when (memq ',backend '(Mtn))) - (vc-test--version-diff ',backend)) - )))) - -(provide 'vc-tests) -;;; vc-tests.el ends here diff --git a/test/lisp/vc/vc-tests/vc-test-misc.el b/test/lisp/vc/vc-tests/vc-test-misc.el new file mode 100644 index 00000000000..22015358972 --- /dev/null +++ b/test/lisp/vc/vc-tests/vc-test-misc.el @@ -0,0 +1,67 @@ +;;; vc-test-misc.el --- backend-agnostic VC tests -*- lexical-binding:t -*- + +;; Copyright (C) 2025 Free Software Foundation, Inc. + +;; Author: 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: + +(require 'ert-x) +(require 'vc) + +(ert-deftest vc-test-buffer-sync-fileset () + "Test `vc-buffer-sync-fileset'." + (cl-flet ((test-it (&rest args) + (let (buffers) + (cl-letf (((symbol-function 'vc-buffer-sync) + (lambda (&rest _) + (push (current-buffer) buffers)))) + (apply #'vc-buffer-sync-fileset args) + (sort buffers))))) + (ert-with-temp-directory temp + (let* ((default-directory temp) + (present (find-file-noselect "present")) + (missing (find-file-noselect "missing")) + (only-present (list present)) + (only-missing (list missing)) + (missing+present (list missing present))) + (with-current-buffer present (basic-save-buffer)) + (with-temp-file "unvisited") + ;; Regular behavior for files. + (should (equal (test-it `(Git ("missing"))) + only-missing)) + (should (equal (test-it `(Git ("present" "missing"))) + missing+present)) + ;; Regular behavior for directories. + (should (equal (test-it `(Git (,temp))) + only-present)) + ;; Two ways to override regular behavior for directories. + (should (equal (test-it `(Git (,temp)) nil t) + missing+present)) + (should (equal (test-it `(Git (,temp "missing"))) + missing+present)) + ;; Doesn't sync PRESENT twice. + (should (equal (test-it `(Git ("present" ,temp))) + only-present)) + (should (equal (test-it `(Git ("missing" ,temp "present"))) + missing+present)))))) + +(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 new file mode 100644 index 00000000000..e7852d53f99 --- /dev/null +++ b/test/lisp/vc/vc-tests/vc-tests.el @@ -0,0 +1,792 @@ +;;; vc-tests.el --- Tests of different backends of vc.el -*- lexical-binding:t -*- + +;; Copyright (C) 2014-2025 Free Software Foundation, Inc. + +;; Author: Michael Albinus + +;; 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: + +;; For every supported VC on the machine, different test cases are +;; generated automatically. + +;; Functions to be tested (see Commentary of vc.el). Mandatory +;; functions are marked with `*', optional functions are marked with `-': + +;; BACKEND PROPERTIES +;; +;; * revision-granularity DONE + +;; STATE-QUERYING FUNCTIONS +;; +;; * registered (file) DONE +;; * state (file) DONE +;; - dir-status (dir update-function) +;; - dir-status-files (dir files default-state update-function) +;; - dir-extra-headers (dir) +;; - dir-printer (fileinfo) +;; - status-fileinfo-extra (file) +;; * working-revision (file) DONE +;; - latest-on-branch-p (file) +;; * checkout-model (files) DONE +;; - mode-line-string (file) + +;; STATE-CHANGING FUNCTIONS +;; +;; * create-repo (backend) DONE +;; * register (files &optional comment) DONE +;; - responsible-p (file) +;; - receive-file (file rev) +;; - unregister (file) DONE +;; * checkin (files comment) DONE +;; * find-revision (file rev buffer) +;; * checkout (file &optional rev) +;; * revert (file &optional contents-done) +;; - rollback (files) +;; - merge-file (file rev1 rev2) +;; - merge-branch () +;; - merge-news (file) +;; - pull (prompt) +;; - steal-lock (file &optional revision) +;; - modify-change-comment (files rev comment) +;; - mark-resolved (files) +;; - find-admin-dir (file) + +;; HISTORY FUNCTIONS +;; +;; * print-log (files buffer &optional shortlog start-revision limit) +;; * log-outgoing (backend remote-location) +;; * log-incoming (backend remote-location) +;; - log-view-mode () +;; - show-log-entry (revision) +;; - comment-history (file) +;; - update-changelog (files) +;; * diff (files &optional async rev1 rev2 buffer) DONE +;; - revision-completion-table (files) +;; - annotate-command (file buf &optional rev) +;; - annotate-time () +;; - annotate-current-time () +;; - annotate-extract-revision-at-line () +;; - region-history (FILE BUFFER LFROM LTO) +;; - region-history-mode () + +;; TAG SYSTEM +;; +;; - create-tag (dir name branchp) +;; - retrieve-tag (dir name update) + +;; MISCELLANEOUS +;; +;; - make-version-backups-p (file) +;; - root (file) +;; - ignore (file &optional directory) +;; - ignore-completion-table +;; - previous-revision (file rev) +;; - next-revision (file rev) +;; - log-edit-mode () +;; - check-headers () +;; - delete-file (file) +;; - rename-file (old new) DONE +;; - find-file-hook () +;; - extra-menu () +;; - extra-dir-menu () +;; - conflicted-files (dir) + +;;; Code: + +(require 'ert) +(require 'ert-x) +(require 'vc) +(require 'log-edit) + +(declare-function w32-application-type "w32proc.c") + +;; The working horses. + +(defvar vc-test--cleanup-hook nil + "Functions for cleanup at the end of an ert test. +Don't set it globally, the functions should be let-bound.") + +(defun vc-test--revision-granularity-function (backend) + "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) + (push (format "BZR_HOME=%s" ,tempdir) process-environment) + (push (format "HOME=%s" ,tempdir) process-environment))) + +(defun vc-test--create-repo (backend) + "Create a test repository in `default-directory', a temporary directory." + (ert-with-temp-directory tempdir + (let ((vc-handled-backends `(,backend)) + (default-directory + (file-name-as-directory + (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) + (unwind-protect + (progn + ;; Cleanup. + (add-hook + 'vc-test--cleanup-hook + (let ((dir default-directory)) + (lambda () (delete-directory dir 'recursive)))) + + ;; Check the revision granularity. + (should (memq (vc-test--revision-granularity-function backend) + '(file repository))) + + ;; Create empty repository. + (make-directory default-directory) + (should (file-directory-p default-directory)) + (vc-test--create-repo-function backend) + (should (eq (vc-responsible-backend default-directory) backend))) + + ;; Save exit. + (ignore-errors + (run-hooks 'vc-test--cleanup-hook)))))) + +;; FIXME: Why isn't there `vc-unregister'? +(defun vc-test--unregister-function (backend file) + "Run the `vc-unregister' backend function. +For backends which don't support it, `vc-not-supported' is signaled." + ;; CVS, SVN, SCCS, SRC and Mtn are not supported, and will signal + ;; `vc-not-supported'. + (prog1 + (vc-call-backend backend 'unregister file) + (vc-file-clearprops file))) + +(defmacro vc-test--run-maybe-unsupported-function (func &rest args) + "Run FUNC with ARGS as arguments. +Catch the `vc-not-supported' error." + `(condition-case err + (funcall ,func ,@args) + (vc-not-supported 'vc-not-supported) + (t (signal (car err) (cdr err))))) + +(defun vc-test--register (backend) + "Register and unregister a file. +This checks also `vc-backend' and `vc-responsible-backend'." + (ert-with-temp-directory tempdir + (let ((vc-handled-backends `(,backend)) + (default-directory + (file-name-as-directory + (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) + (unwind-protect + (progn + ;; Cleanup. + (add-hook + 'vc-test--cleanup-hook + (let ((dir default-directory)) + (lambda () (delete-directory dir 'recursive)))) + + ;; Create empty repository. + (make-directory default-directory) + (vc-test--create-repo-function backend) + ;; For file oriented backends CVS, RCS and SVN the backend is + ;; returned, and the directory is registered already. + (should (if (vc-backend default-directory) + (vc-registered default-directory) + (not (vc-registered default-directory)))) + (should (eq (vc-responsible-backend default-directory) backend)) + + (let ((tmp-name1 (expand-file-name "foo" default-directory)) + (tmp-name2 "bla")) + ;; Register files. Check for it. + (write-region "foo" nil tmp-name1 nil 'nomessage) + (should (file-exists-p tmp-name1)) + (should-not (vc-backend tmp-name1)) + (should (eq (vc-responsible-backend tmp-name1) backend)) + (should-not (vc-registered tmp-name1)) + + (write-region "bla" nil tmp-name2 nil 'nomessage) + (should (file-exists-p tmp-name2)) + (should-not (vc-backend tmp-name2)) + (should (eq (vc-responsible-backend tmp-name2) backend)) + (should-not (vc-registered tmp-name2)) + + (vc-register (list backend (list tmp-name1 tmp-name2))) + (should (file-exists-p tmp-name1)) + (should (eq (vc-backend tmp-name1) backend)) + (should (eq (vc-responsible-backend tmp-name1) backend)) + (should (vc-registered tmp-name1)) + + (should (file-exists-p tmp-name2)) + (should (eq (vc-backend tmp-name2) backend)) + (should (eq (vc-responsible-backend tmp-name2) backend)) + (should (vc-registered tmp-name2)) + + ;; `vc-backend' accepts also a list of files, + ;; `vc-responsible-backend' doesn't. + (should (vc-backend (list tmp-name1 tmp-name2))) + + ;; Unregister the files. + (unless (eq (vc-test--run-maybe-unsupported-function + 'vc-test--unregister-function backend tmp-name1) + 'vc-not-supported) + (should-not (vc-backend tmp-name1)) + (should-not (vc-registered tmp-name1))) + (unless (eq (vc-test--run-maybe-unsupported-function + 'vc-test--unregister-function backend tmp-name2) + 'vc-not-supported) + (should-not (vc-backend tmp-name2)) + (should-not (vc-registered tmp-name2))) + + ;; The files should still exist. + (should (file-exists-p tmp-name1)) + (should (file-exists-p tmp-name2)))) + + ;; Save exit. + (ignore-errors + (run-hooks 'vc-test--cleanup-hook)))))) + +(defun vc-test--state (backend) + "Check the different states of a file." + (ert-with-temp-directory tempdir + (let ((vc-handled-backends `(,backend)) + (default-directory + (file-name-as-directory + (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) + (unwind-protect + (progn + ;; Cleanup. + (add-hook + 'vc-test--cleanup-hook + (let ((dir default-directory)) + (lambda () (delete-directory dir 'recursive)))) + + ;; Create empty repository. + (make-directory default-directory) + (vc-test--create-repo-function backend) + + (let ((tmp-name (expand-file-name "foo" default-directory))) + ;; Check state of a nonexistent file. + + (message "vc-state2 %s" (vc-state tmp-name)) + (should (null (vc-state tmp-name))) + + ;; Write a new file. Check state. + (write-region "foo" nil tmp-name nil 'nomessage) + + ;; nil: Mtn + ;; unregistered: Bzr CVS Git Hg SVN RCS + (message "vc-state3 %s %s" backend (vc-state tmp-name backend)) + (should (memq (vc-state tmp-name backend) '(nil unregistered))) + + ;; Register a file. Check state. + (vc-register + (list backend (list (file-name-nondirectory tmp-name)))) + + ;; FIXME: nil is definitely wrong. + ;; nil: SRC + ;; added: Bzr CVS Git Hg Mtn SVN + ;; up-to-date: RCS SCCS + (message "vc-state4 %s" (vc-state tmp-name)) + (should (memq (vc-state tmp-name) '(nil added up-to-date))) + + ;; Unregister the file. Check state. + (if (eq (vc-test--run-maybe-unsupported-function + 'vc-test--unregister-function backend tmp-name) + 'vc-not-supported) + (message "vc-state5 unsupported") + ;; unregistered: Bzr Git RCS Hg + ;; unsupported: CVS SCCS SRC SVN + (message "vc-state5 %s %s" backend (vc-state tmp-name backend)) + (should (memq (vc-state tmp-name backend) + '(nil unregistered)))))) + + ;; Save exit. + (ignore-errors + (run-hooks 'vc-test--cleanup-hook)))))) + +(defun vc-test--working-revision (backend) + "Check the working revision of a repository." + (ert-with-temp-directory tempdir + (let ((vc-handled-backends `(,backend)) + (default-directory + (file-name-as-directory + (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) + (unwind-protect + (progn + ;; Cleanup. + (add-hook + 'vc-test--cleanup-hook + (let ((dir default-directory)) + (lambda () (delete-directory dir 'recursive)))) + + ;; Create empty repository. Check working revision of + ;; repository, should be nil. + (make-directory default-directory) + (vc-test--create-repo-function backend) + + ;; FIXME: Is the value for SVN correct? + ;; nil: Bzr CVS Git Hg Mtn RCS SCCS SRC + ;; "0": SVN + (message + "vc-working-revision1 %s" (vc-working-revision default-directory)) + (should (member (vc-working-revision default-directory) '(nil "0"))) + + (let ((tmp-name (expand-file-name "foo" default-directory))) + ;; Check initial working revision, should be nil until + ;; it's registered. + + (message "vc-working-revision2 %s" (vc-working-revision tmp-name)) + (should-not (vc-working-revision tmp-name)) + + ;; Write a new file. Check working revision. + (write-region "foo" nil tmp-name nil 'nomessage) + + (message "vc-working-revision3 %s" (vc-working-revision tmp-name)) + (should-not (vc-working-revision tmp-name)) + + ;; Register a file. Check working revision. + (vc-register + (list backend (list (file-name-nondirectory tmp-name)))) + + ;; XXX: nil is fine, at least in Git's case, because + ;; `vc-register' only makes the file `added' in this case. + ;; nil: Git Mtn + ;; "0": Bzr CVS Hg SRC SVN + ;; "1.1": RCS SCCS + ;; "-1": Hg versions before 5 (probably) + (message "vc-working-revision4 %s" (vc-working-revision tmp-name)) + (should (member (vc-working-revision tmp-name) '(nil "0" "1.1" "-1"))) + + ;; TODO: Call `vc-checkin', and check the resulting + ;; working revision. None of the return values should be + ;; nil then. + + ;; Unregister the file. Check working revision. + (if (eq (vc-test--run-maybe-unsupported-function + 'vc-test--unregister-function backend tmp-name) + 'vc-not-supported) + (message "vc-working-revision5 unsupported") + ;; nil: Bzr Git Hg RCS + ;; unsupported: CVS Mtn SCCS SRC SVN + (message "vc-working-revision5 %s" (vc-working-revision tmp-name)) + (should-not (vc-working-revision tmp-name))))) + + ;; Save exit. + (ignore-errors + (run-hooks 'vc-test--cleanup-hook)))))) + +(defun vc-test--checkout-model (backend) + "Check the checkout model of a repository." + (ert-with-temp-directory tempdir + (let ((vc-handled-backends `(,backend)) + (default-directory + (file-name-as-directory + (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) + (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) + + ;; Surprisingly, none of the backends returns 'announce. + ;; implicit: Bzr CVS Git Hg Mtn SRC SVN + ;; locking: RCS SCCS + (message + "vc-checkout-model1 %s" + (vc-checkout-model backend default-directory)) + (should (memq (vc-checkout-model backend default-directory) + '(announce implicit locking))) + + (let ((tmp-name (expand-file-name "foo" default-directory))) + ;; Check checkout model of a nonexistent file. + + ;; implicit: Bzr CVS Git Hg Mtn SRC SVN + ;; locking: RCS SCCS + (message + "vc-checkout-model2 %s" (vc-checkout-model backend tmp-name)) + (should (memq (vc-checkout-model backend tmp-name) + '(announce implicit locking))) + + ;; Write a new file. Check checkout model. + (write-region "foo" nil tmp-name nil 'nomessage) + + ;; implicit: Bzr CVS Git Hg Mtn SRC SVN + ;; locking: RCS SCCS + (message + "vc-checkout-model3 %s" (vc-checkout-model backend tmp-name)) + (should (memq (vc-checkout-model backend tmp-name) + '(announce implicit locking))) + + ;; Register a file. Check checkout model. + (vc-register + (list backend (list (file-name-nondirectory tmp-name)))) + + ;; implicit: Bzr CVS Git Hg Mtn SRC SVN + ;; locking: RCS SCCS + (message + "vc-checkout-model4 %s" (vc-checkout-model backend tmp-name)) + (should (memq (vc-checkout-model backend tmp-name) + '(announce implicit locking))) + + ;; Unregister the file. Check checkout model. + (if (eq (vc-test--run-maybe-unsupported-function + 'vc-test--unregister-function backend tmp-name) + 'vc-not-supported) + (message "vc-checkout-model5 unsupported") + ;; implicit: Bzr Git Hg + ;; locking: RCS + ;; unsupported: CVS Mtn SCCS SRC SVN + (message + "vc-checkout-model5 %s" (vc-checkout-model backend tmp-name)) + (should (memq (vc-checkout-model backend tmp-name) + '(announce implicit locking)))))) + + ;; Save exit. + (ignore-errors + (run-hooks 'vc-test--cleanup-hook)))))) + +(defun vc-test--rename-file (backend) + "Check the rename-file action." + (ert-with-temp-directory tempdir + (let ((vc-handled-backends `(,backend)) + (default-directory + (file-name-as-directory + (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) + (unwind-protect + (progn + ;; Cleanup. + (add-hook + 'vc-test--cleanup-hook + (let ((dir default-directory)) + (lambda () (delete-directory dir 'recursive)))) + + ;; Create empty repository. + (make-directory default-directory) + (vc-test--create-repo-function backend) + + (let ((tmp-name (expand-file-name "foo" default-directory)) + (new-name (expand-file-name "bar" default-directory))) + ;; Write a new file. + (write-region "foo" nil tmp-name nil 'nomessage) + + ;; Register it. Renaming can fail otherwise. + (vc-register + (list backend (list (file-name-nondirectory tmp-name)))) + + (vc-rename-file tmp-name new-name) + + (should (not (file-exists-p tmp-name))) + (should (file-exists-p new-name)) + + (should (equal (vc-state new-name) + (if (memq backend '(RCS SCCS)) + 'up-to-date + 'added))))) + + ;; Save exit. + (ignore-errors + (run-hooks 'vc-test--cleanup-hook)))))) + +(declare-function log-edit-done "vc/log-edit") + +(defun vc-test--version-diff (backend) + "Check the diff version of a repository." + (ert-with-temp-directory tempdir + (let ((vc-handled-backends `(,backend)) + (default-directory + (file-name-as-directory + (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 + (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") + (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) + (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)))))) + +;; Create the test cases. + +(defun vc-test--rcs-enabled () + (executable-find "rcs")) + +(defun vc-test--cvs-enabled () + (executable-find "cvs")) + +(defvar vc-svn-program) +(defun vc-test--svn-enabled () + (and (executable-find "svnadmin") + (executable-find vc-svn-program))) + +(defun vc-test--sccs-enabled () + (executable-find "sccs")) + +(defvar vc-src-program) +(defun vc-test--src-enabled () + (executable-find vc-src-program)) + +(defvar vc-bzr-program) +(defun vc-test--bzr-enabled () + (executable-find vc-bzr-program)) + +(defvar vc-git-program) +(defun vc-test--git-enabled () + (executable-find vc-git-program)) + +(defvar vc-hg-program) +(defun vc-test--hg-enabled () + (executable-find vc-hg-program)) + +(defvar vc-mtn-program) +(defun vc-test--mtn-enabled () + (executable-find vc-mtn-program)) + +;; Obsoleted. +(defvar vc-arch-program) +(defun vc-test--arch-enabled () + (executable-find vc-arch-program)) + +;; Create the test cases. +(dolist (backend vc-handled-backends) + (let ((backend-string (downcase (symbol-name backend)))) + (require (intern (format "vc-%s" backend-string))) + (eval + ;; Check, whether the backend is supported. + `(when (funcall ',(intern (format "vc-test--%s-enabled" backend-string))) + + (ert-deftest + ,(intern (format "vc-test-%s00-create-repo" backend-string)) () + ,(format "Check `vc-create-repo' for the %s backend." + backend-string) + (vc-test--create-repo ',backend)) + + (ert-deftest + ,(intern (format "vc-test-%s01-register" backend-string)) () + ,(format + "Check `vc-register' and `vc-registered' for the %s backend." + backend-string) + (skip-unless + (ert-test-passed-p + (ert-test-most-recent-result + (ert-get-test + ',(intern + (format "vc-test-%s00-create-repo" backend-string)))))) + (vc-test--register ',backend)) + + (ert-deftest + ,(intern (format "vc-test-%s02-state" backend-string)) () + ,(format "Check `vc-state' for the %s backend." backend-string) + (skip-unless + (ert-test-passed-p + (ert-test-most-recent-result + (ert-get-test + ',(intern + (format "vc-test-%s01-register" backend-string)))))) + (vc-test--state ',backend)) + + (ert-deftest + ,(intern (format "vc-test-%s03-working-revision" backend-string)) () + ,(format "Check `vc-working-revision' for the %s backend." + backend-string) + (skip-unless + (ert-test-passed-p + (ert-test-most-recent-result + (ert-get-test + ',(intern + (format "vc-test-%s01-register" backend-string)))))) + (vc-test--working-revision ',backend)) + + (ert-deftest + ,(intern (format "vc-test-%s04-checkout-model" backend-string)) () + ,(format "Check `vc-checkout-model' for the %s backend." + backend-string) + (skip-unless + (ert-test-passed-p + (ert-test-most-recent-result + (ert-get-test + ',(intern + (format "vc-test-%s01-register" backend-string)))))) + (vc-test--checkout-model ',backend)) + + (ert-deftest + ,(intern (format "vc-test-%s05-rename-file" backend-string)) () + ,(format "Check `vc-rename-file' for the %s backend." + backend-string) + (skip-unless + (ert-test-passed-p + (ert-test-most-recent-result + (ert-get-test + ',(intern + (format "vc-test-%s01-register" backend-string)))))) + ;; CVS calls vc-delete-file, which insists on prompting + ;; "Really want to delete ...?", and `vc-mtn.el' does not implement + ;; `delete-file' at all. + (skip-when (memq ',backend '(CVS Mtn))) + (vc-test--rename-file ',backend)) + + (ert-deftest + ,(intern (format "vc-test-%s06-version-diff" backend-string)) () + ,(format "Check `vc-version-diff' for the %s backend." + backend-string) + (skip-unless + (ert-test-passed-p + (ert-test-most-recent-result + (ert-get-test + ',(intern + (format "vc-test-%s01-register" backend-string)))))) + ;; `vc-mtn.el' gives me: + ;; "Failed (status 1): mtn commit -m Testing vc-version-diff\n\n foo" + (skip-when (memq ',backend '(Mtn))) + (vc-test--version-diff ',backend)) + )))) + +(provide 'vc-tests) +;;; vc-tests.el ends here