From 5e1c32e7916420a447b060a4ff2507364aff41a4 Mon Sep 17 00:00:00 2001 From: Michael Albinus Date: Sat, 9 Apr 2016 21:14:40 +0200 Subject: [PATCH] Add vc-backend and vc-responsible-backend tests * lisp/vc/vc-hooks.el (vc-file-setprop, vc-file-getprop) (vc-file-clearprops): Use properties on absolute files. * test/lisp/vc/vc-tests.el (vc-test--unregister-function): Clear file properties. (vc-test--register): Add tests for `vc-backend' and `vc-responsible-backend'. Catch other errors but `vc-not-supported'. (vc-test--state, vc-test--checkout-model): Catch other errors but `vc-not-supported'. (vc-test--working-revision): Fix test for RCS and SCCS. Catch other errors but `vc-not-supported'. (vc-test-src02-state): Mark as an expected failure. --- lisp/vc/vc-hooks.el | 6 ++-- test/lisp/vc/vc-tests.el | 73 ++++++++++++++++++++++++++++++---------- 2 files changed, 58 insertions(+), 21 deletions(-) diff --git a/lisp/vc/vc-hooks.el b/lisp/vc/vc-hooks.el index c6512e95e4..97ccec8455 100644 --- a/lisp/vc/vc-hooks.el +++ b/lisp/vc/vc-hooks.el @@ -206,17 +206,17 @@ VC commands are globally reachable under the prefix `\\[vc-prefix-map]': (not (memq property vc-touched-properties))) (setq vc-touched-properties (append (list property) vc-touched-properties))) - (put (intern file vc-file-prop-obarray) property value)) + (put (intern (expand-file-name file) vc-file-prop-obarray) property value)) (defun vc-file-getprop (file property) "Get per-file VC PROPERTY for FILE." - (get (intern file vc-file-prop-obarray) property)) + (get (intern (expand-file-name file) vc-file-prop-obarray) property)) (defun vc-file-clearprops (file) "Clear all VC properties of FILE." (if (boundp 'vc-parent-buffer) (kill-local-variable 'vc-parent-buffer)) - (setplist (intern file vc-file-prop-obarray) nil)) + (setplist (intern (expand-file-name file) vc-file-prop-obarray) nil)) ;; We keep properties on each symbol naming a backend as follows: diff --git a/test/lisp/vc/vc-tests.el b/test/lisp/vc/vc-tests.el index 2faa143652..2b3445aa56 100644 --- a/test/lisp/vc/vc-tests.el +++ b/test/lisp/vc/vc-tests.el @@ -137,7 +137,7 @@ For backends which dont support it, it is emulated." (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?) + ;; 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)))) @@ -201,19 +201,24 @@ For backends which dont support it, it is emulated." ;; Save exit. (ignore-errors (run-hooks 'vc-test--cleanup-hook))))) -;; Why isn't there `vc-unregister'? +;; FIXME Why isn't there `vc-unregister'? (defun vc-test--unregister-function (backend file) "Run the `vc-unregister' backend function. For backends which dont support it, `vc-not-supported' is signalled." - (let ((symbol (intern (downcase (format "vc-%s-unregister" backend))))) - (if (functionp symbol) - (funcall symbol file) - ;; CVS, SVN, SCCS, SRC and Mtn are not supported. - (signal 'vc-not-supported (list 'unregister backend))))) + (unwind-protect + (let ((symbol (intern (downcase (format "vc-%s-unregister" backend))))) + (if (functionp symbol) + (funcall symbol file) + ;; CVS, SVN, SCCS, SRC and Mtn are not supported. + (signal 'vc-not-supported (list 'unregister backend)))) + + ;; FIXME This shall be called in `vc-unregister'. + (vc-file-clearprops file))) (defun vc-test--register (backend) - "Register and unregister a file." + "Register and unregister a file. +This checks also `vc-backend' and `vc-reponsible-backend'." (let ((vc-handled-backends `(,backend)) (default-directory @@ -232,32 +237,58 @@ For backends which dont support it, `vc-not-supported' is signalled." ;; 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. + ;; FIXME is this correct? + (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)) + ;; FIXME `vc-backend' accepts also a list of files, + ;; `vc-responsible-backend' doesn't. Is this right? + (should (vc-backend (list tmp-name1 tmp-name2))) + ;; Unregister the files. (condition-case err (progn (vc-test--unregister-function backend tmp-name1) + (should-not (vc-backend tmp-name1)) (should-not (vc-registered tmp-name1)) (vc-test--unregister-function backend tmp-name2) + (should-not (vc-backend tmp-name2)) (should-not (vc-registered tmp-name2))) ;; CVS, SVN, SCCS, SRC and Mtn are not supported. - (vc-not-supported t)) - ;; The files shall still exist. + (vc-not-supported t) + (t (signal (car err) (cdr err)))) + + ;; The files shall still exist. (should (file-exists-p tmp-name1)) (should (file-exists-p tmp-name2)))) @@ -331,7 +362,7 @@ For backends which dont support it, `vc-not-supported' is signalled." (should (memq (vc-state tmp-name) '(added unregistered up-to-date))) ;; Unregister the file. Check state. - (condition-case nil + (condition-case err (progn (vc-test--unregister-function backend tmp-name) @@ -343,7 +374,8 @@ For backends which dont support it, `vc-not-supported' is signalled." (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"))))) + (vc-not-supported (message "vc-state5 unsupported")) + (t (signal (car err) (cdr err)))))) ;; Save exit. (ignore-errors (run-hooks 'vc-test--cleanup-hook))))) @@ -403,15 +435,16 @@ For backends which dont support it, `vc-not-supported' is signalled." (vc-register (list backend (list (file-name-nondirectory tmp-name)))) - ;; nil: Mtn Git RCS SCCS + ;; nil: Mtn Git ;; "0": Bzr CVS Hg SRC SVN + ;; "1.1" RCS SCCS (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"))) + (should (member (vc-working-revision tmp-name) '(nil "0" "1.1"))) ;; Unregister the file. Check working revision. - (condition-case nil + (condition-case err (progn (vc-test--unregister-function backend tmp-name) @@ -423,7 +456,8 @@ For backends which dont support it, `vc-not-supported' is signalled." (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"))))) + (vc-not-supported (message "vc-working-revision5 unsupported")) + (t (signal (car err) (cdr err)))))) ;; Save exit. (ignore-errors (run-hooks 'vc-test--cleanup-hook))))) @@ -494,7 +528,7 @@ For backends which dont support it, `vc-not-supported' is signalled." '(announce implicit locking))) ;; Unregister the file. Check checkout model. - (condition-case nil + (condition-case err (progn (vc-test--unregister-function backend tmp-name) @@ -505,7 +539,8 @@ For backends which dont support it, `vc-not-supported' is signalled." "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"))))) + (vc-not-supported (message "vc-checkout-model5 unsupported")) + (t (signal (car err) (cdr err)))))) ;; Save exit. (ignore-errors (run-hooks 'vc-test--cleanup-hook))))) @@ -580,6 +615,8 @@ For backends which dont support it, `vc-not-supported' is signalled." (ert-deftest ,(intern (format "vc-test-%s02-state" backend-string)) () ,(format "Check `vc-state' for the %s backend." backend-string) + ;; FIXME make this pass. + :expected-result ,(if (equal backend 'SRC) :failed :passed) (skip-unless (ert-test-passed-p (ert-test-most-recent-result -- 2.39.2