X-Git-Url: https://code.delx.au/gnu-emacs/blobdiff_plain/d7a89815b6d69c3b1793d34bcad8bf0aa21d48c8..0e963201d03d9229bb8ac4323291d2b0119526ed:/test/automated/vc-tests.el diff --git a/test/automated/vc-tests.el b/test/automated/vc-tests.el index 5b7b3cce03..2faa143652 100644 --- a/test/automated/vc-tests.el +++ b/test/automated/vc-tests.el @@ -1,6 +1,6 @@ ;;; 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 @@ -27,29 +27,29 @@ ;; 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) @@ -130,7 +130,19 @@ For backends which dont support it, it is emulated." (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. @@ -178,12 +190,13 @@ For backends which dont support it, it is emulated." ;; 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))))) @@ -229,8 +242,7 @@ For backends which dont support it, `vc-not-supported' is signalled." (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)) @@ -244,15 +256,14 @@ For backends which dont support it, `vc-not-supported' is signalled." (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." @@ -261,7 +272,7 @@ For backends which dont support it, `vc-not-supported' is signalled." (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 @@ -270,36 +281,69 @@ For backends which dont support it, `vc-not-supported' is signalled." '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))))) @@ -312,7 +356,7 @@ For backends which dont support it, `vc-not-supported' is signalled." (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 @@ -321,38 +365,147 @@ For backends which dont support it, `vc-not-supported' is signalled." '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))))) @@ -392,64 +545,74 @@ For backends which dont support it, `vc-not-supported' is signalled." (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