;;; vc-tests.el --- Tests of different backends of vc.el
-;; Copyright (C) 2014-2015 Free Software Foundation, Inc.
+;; Copyright (C) 2014-2016 Free Software Foundation, Inc.
;; Author: Michael Albinus <michael.albinus@gmx.de>
;; BACKEND PROPERTIES
;;
-;; * revision-granularity
+;; * revision-granularity DONE
;; STATE-QUERYING FUNCTIONS
;;
-;; * registered (file)
-;; * state (file)
+;; * 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)
+;; * working-revision (file) DONE
;; - latest-on-branch-p (file)
-;; * checkout-model (files)
+;; * checkout-model (files) DONE
;; - mode-line-string (file)
;; STATE-CHANGING FUNCTIONS
;;
-;; * create-repo (backend)
-;; * register (files &optional comment)
+;; * create-repo (backend) DONE
+;; * register (files &optional comment) DONE
;; - responsible-p (file)
;; - receive-file (file rev)
-;; - unregister (file)
+;; - unregister (file) DONE
;; * checkin (files comment)
;; * find-revision (file rev buffer)
;; * checkout (file &optional rev)
(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)
- (shell-command-to-string (format "cvs -Q -d:local:%s co module" tmp-dir))
+ (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.
;; Check the revision granularity.
(should (memq (vc-test--revision-granularity-function backend)
- '(file repository)))
+ '(file repository)))
;; Create empty repository.
(make-directory default-directory)
(should (file-directory-p default-directory))
- (vc-test--create-repo-function backend))
+ (vc-test--create-repo-function backend)
+ (should (eq (vc-responsible-backend default-directory) backend)))
;; Save exit.
(ignore-errors (run-hooks 'vc-test--cleanup-hook)))))
(write-region "bla" nil tmp-name2 nil 'nomessage)
(should (file-exists-p tmp-name2))
(should-not (vc-registered tmp-name2))
- (vc-register
- (list backend (list tmp-name1 tmp-name2)))
+ (vc-register (list backend (list tmp-name1 tmp-name2)))
(should (file-exists-p tmp-name1))
(should (vc-registered tmp-name1))
(should (file-exists-p tmp-name2))
(vc-test--unregister-function backend tmp-name2)
(should-not (vc-registered tmp-name2)))
;; CVS, SVN, SCCS, SRC and Mtn are not supported.
- (vc-not-supported (message "%s" (error-message-string err))))
+ (vc-not-supported t))
+ ;; The files shall still exist.
(should (file-exists-p tmp-name1))
(should (file-exists-p tmp-name2))))
;; Save exit.
(ignore-errors (run-hooks 'vc-test--cleanup-hook)))))
-;; `vc-state' returns different results for different backends. So we
-;; don't check with `should', but print the results for analysis.
(defun vc-test--state (backend)
"Check the different states of a file."
(file-name-as-directory
(expand-file-name
(make-temp-name "vc-test") temporary-file-directory)))
- vc-test--cleanup-hook errors)
+ vc-test--cleanup-hook)
(unwind-protect
(progn
'vc-test--cleanup-hook
`(lambda () (delete-directory ,default-directory 'recursive)))
- ;; Create empty repository.
+ ;; Create empty repository. Check repository state.
(make-directory default-directory)
(vc-test--create-repo-function backend)
- (message "%s" (vc-state default-directory backend))
- ;(should (eq (vc-state default-directory backend) 'up-to-date))
+ ;; nil: Hg Mtn RCS
+ ;; added: Git
+ ;; unregistered: CVS SCCS SRC
+ ;; up-to-date: Bzr SVN
+ (message "vc-state1 %s" (vc-state default-directory))
+ (should (eq (vc-state default-directory)
+ (vc-state default-directory backend)))
+ (should (memq (vc-state default-directory)
+ '(nil added unregistered up-to-date)))
(let ((tmp-name (expand-file-name "foo" default-directory)))
- ;; Check for initial state.
- (message "%s" (vc-state tmp-name backend))
- ;(should (eq (vc-state tmp-name backend) 'unregistered))
-
- ;; Write a new file. Check for state.
+ ;; Check state of an empty file.
+
+ ;; nil: Hg Mtn SRC SVN
+ ;; added: Git
+ ;; unregistered: RCS SCCS
+ ;; up-to-date: Bzr CVS
+ (message "vc-state2 %s" (vc-state tmp-name))
+ (should (eq (vc-state tmp-name) (vc-state tmp-name backend)))
+ (should (memq (vc-state tmp-name)
+ '(nil added unregistered up-to-date)))
+
+ ;; Write a new file. Check state.
(write-region "foo" nil tmp-name nil 'nomessage)
- (message "%s" (vc-state tmp-name backend))
- ;(should (eq (vc-state tmp-name backend) 'unregistered))
- ;; Register a file. Check for state.
+ ;; nil: Mtn
+ ;; added: Git
+ ;; unregistered: Hg RCS SCCS SRC SVN
+ ;; up-to-date: Bzr CVS
+ (message "vc-state3 %s" (vc-state tmp-name))
+ (should (eq (vc-state tmp-name) (vc-state tmp-name backend)))
+ (should (memq (vc-state tmp-name)
+ '(nil added unregistered up-to-date)))
+
+ ;; Register a file. Check state.
(vc-register
(list backend (list (file-name-nondirectory tmp-name))))
- (message "%s" (vc-state tmp-name backend))
- ;(should (eq (vc-state tmp-name backend) 'added))
- ;; Unregister the file. Check for state.
+ ;; added: Git Mtn
+ ;; unregistered: Hg RCS SCCS SRC SVN
+ ;; up-to-date: Bzr CVS
+ (message "vc-state4 %s" (vc-state tmp-name))
+ (should (eq (vc-state tmp-name) (vc-state tmp-name backend)))
+ (should (memq (vc-state tmp-name) '(added unregistered up-to-date)))
+
+ ;; Unregister the file. Check state.
(condition-case nil
(progn
(vc-test--unregister-function backend tmp-name)
- (message "%s" (vc-state tmp-name backend))
- );(should (eq (vc-state tmp-name backend) 'unregistered)))
- (vc-not-supported (message "%s" 'unsupported)))))
+
+ ;; added: Git
+ ;; unregistered: Hg RCS
+ ;; unsupported: CVS Mtn SCCS SRC SVN
+ ;; up-to-date: Bzr
+ (message "vc-state5 %s" (vc-state tmp-name))
+ (should (eq (vc-state tmp-name) (vc-state tmp-name backend)))
+ (should (memq (vc-state tmp-name)
+ '(added unregistered up-to-date))))
+ (vc-not-supported (message "vc-state5 unsupported")))))
;; Save exit.
(ignore-errors (run-hooks 'vc-test--cleanup-hook)))))
(file-name-as-directory
(expand-file-name
(make-temp-name "vc-test") temporary-file-directory)))
- vc-test--cleanup-hook errors)
+ vc-test--cleanup-hook)
(unwind-protect
(progn
'vc-test--cleanup-hook
`(lambda () (delete-directory ,default-directory 'recursive)))
- ;; Create empty repository.
+ ;; Create empty repository. Check working revision of
+ ;; repository, should be nil.
(make-directory default-directory)
(vc-test--create-repo-function backend)
- (should
- (member
- (vc-working-revision default-directory backend) '("0" "master")))
+ ;; nil: CVS Git Mtn RCS SCCS
+ ;; "0": Bzr Hg SRC SVN
+ (message
+ "vc-working-revision1 %s" (vc-working-revision default-directory))
+ (should (eq (vc-working-revision default-directory)
+ (vc-working-revision default-directory backend)))
+ (should (member (vc-working-revision default-directory) '(nil "0")))
(let ((tmp-name (expand-file-name "foo" default-directory)))
- ;; Check for initial state.
- (should
- (member (vc-working-revision tmp-name backend) '("0" "master")))
+ ;; Check initial working revision, should be nil until
+ ;; it's registered.
+
+ ;; nil: CVS Git Mtn RCS SCCS SVN
+ ;; "0": Bzr Hg SRC
+ (message "vc-working-revision2 %s" (vc-working-revision tmp-name))
+ (should (eq (vc-working-revision tmp-name)
+ (vc-working-revision tmp-name backend)))
+ (should (member (vc-working-revision tmp-name) '(nil "0")))
- ;; Write a new file. Check for state.
+ ;; Write a new file. Check working revision.
(write-region "foo" nil tmp-name nil 'nomessage)
- (should
- (member (vc-working-revision tmp-name backend) '("0" "master")))
- ;; Register a file. Check for state.
+ ;; nil: CVS Git Mtn RCS SCCS SVN
+ ;; "0": Bzr Hg SRC
+ (message "vc-working-revision3 %s" (vc-working-revision tmp-name))
+ (should (eq (vc-working-revision tmp-name)
+ (vc-working-revision tmp-name backend)))
+ (should (member (vc-working-revision tmp-name) '(nil "0")))
+
+ ;; Register a file. Check working revision.
(vc-register
(list backend (list (file-name-nondirectory tmp-name))))
- (should
- (member (vc-working-revision tmp-name backend) '("0" "master")))
- ;; Unregister the file. Check for working-revision.
+ ;; nil: Mtn Git RCS SCCS
+ ;; "0": Bzr CVS Hg SRC SVN
+ (message "vc-working-revision4 %s" (vc-working-revision tmp-name))
+ (should (eq (vc-working-revision tmp-name)
+ (vc-working-revision tmp-name backend)))
+ (should (member (vc-working-revision tmp-name) '(nil "0")))
+
+ ;; Unregister the file. Check working revision.
(condition-case nil
(progn
(vc-test--unregister-function backend tmp-name)
- (should
- (member
- (vc-working-revision tmp-name backend) '("0" "master"))))
- (vc-not-supported (message "%s" 'unsupported)))))
+
+ ;; nil: Git RCS
+ ;; "0": Bzr Hg
+ ;; unsupported: CVS Mtn SCCS SRC SVN
+ (message
+ "vc-working-revision5 %s" (vc-working-revision tmp-name))
+ (should (eq (vc-working-revision tmp-name)
+ (vc-working-revision tmp-name backend)))
+ (should (member (vc-working-revision tmp-name) '(nil "0"))))
+ (vc-not-supported (message "vc-working-revision5 unsupported")))))
+
+ ;; Save exit.
+ (ignore-errors (run-hooks 'vc-test--cleanup-hook)))))
+
+(defun vc-test--checkout-model (backend)
+ "Check the checkout model of a repository."
+
+ (let ((vc-handled-backends `(,backend))
+ (default-directory
+ (file-name-as-directory
+ (expand-file-name
+ (make-temp-name "vc-test") temporary-file-directory)))
+ vc-test--cleanup-hook)
+
+ (unwind-protect
+ (progn
+ ;; Cleanup.
+ (add-hook
+ 'vc-test--cleanup-hook
+ `(lambda () (delete-directory ,default-directory '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.
+ ;; nil: RCS
+ ;; implicit: Bzr CVS Git Hg Mtn SRC SVN
+ ;; locking: 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 an empty file.
+
+ ;; nil: RCS
+ ;; implicit: Bzr CVS Git Hg Mtn SRC SVN
+ ;; locking: 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)
+
+ ;; nil: RCS
+ ;; implicit: Bzr CVS Git Hg Mtn SRC SVN
+ ;; locking: 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))))
+
+ ;; nil: RCS
+ ;; implicit: Bzr CVS Git Hg Mtn SRC SVN
+ ;; locking: 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.
+ (condition-case nil
+ (progn
+ (vc-test--unregister-function backend tmp-name)
+
+ ;; nil: RCS
+ ;; implicit: Bzr Git Hg
+ ;; 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))))
+ (vc-not-supported (message "vc-checkout-model5 unsupported")))))
;; Save exit.
(ignore-errors (run-hooks 'vc-test--cleanup-hook)))))
(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))
-
-;; There are too many failed test cases yet. We suppress them on hydra.
-(if (getenv "NIX_STORE")
- (ert-deftest vc-test ()
- "Dummy test case for hydra."
- (ert-pass))
-
- ;; 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)))))))
+;; 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)
+ ;; FIXME make this pass.
+ :expected-result ,(if (equal backend 'RCS) :failed :passed)
+ (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))))))
(provide 'vc-tests)
;;; vc-tests.el ends here