X-Git-Url: https://code.delx.au/gnu-emacs/blobdiff_plain/b4fbd69b66a927ad8ff479bee6ca57e977d7e649..5cb7620027f78a3a0f473972a0584c8ea1791398:/test/lisp/vc/vc-tests.el diff --git a/test/lisp/vc/vc-tests.el b/test/lisp/vc/vc-tests.el index 2faa143652..793ad82c74 100644 --- a/test/lisp/vc/vc-tests.el +++ b/test/lisp/vc/vc-tests.el @@ -109,6 +109,8 @@ (require 'ert) (require 'vc) +(declare-function w32-application-type "w32proc") + ;; The working horses. (defvar vc-test--cleanup-hook nil @@ -117,7 +119,7 @@ Don't set it globally, the functions shall be let-bound.") (defun vc-test--revision-granularity-function (backend) "Run the `vc-revision-granularity' backend function." - (funcall (intern (downcase (format "vc-%s-revision-granularity" backend))))) + (vc-call-backend backend 'revision-granularity)) (defun vc-test--create-repo-function (backend) "Run the `vc-create-repo' backend function. @@ -201,19 +203,28 @@ 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))))) +For backends which don't support it, `vc-not-supported' is signalled." + ;; 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 withs ARGS as arguments. +Catch the `vc-not-supported' error." + `(let (err) + (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." + "Register and unregister a file. +This checks also `vc-backend' and `vc-responsible-backend'." (let ((vc-handled-backends `(,backend)) (default-directory @@ -232,32 +243,56 @@ 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. + (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. - (condition-case err - (progn - (vc-test--unregister-function backend tmp-name1) - (should-not (vc-registered tmp-name1)) - (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 t)) - ;; The files shall still exist. + (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 shall still exist. (should (file-exists-p tmp-name1)) (should (file-exists-p tmp-name2)))) @@ -285,65 +320,54 @@ For backends which dont support it, `vc-not-supported' is signalled." (make-directory default-directory) (vc-test--create-repo-function backend) - ;; nil: Hg Mtn RCS - ;; added: Git - ;; unregistered: CVS SCCS SRC - ;; up-to-date: Bzr SVN + ;; FIXME: The state shall be unregistered only. + ;; nil: RCS + ;; unregistered: Bzr CVS Git Hg Mtn SCCS SRC + ;; up-to-date: 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))) + '(nil unregistered up-to-date))) (let ((tmp-name (expand-file-name "foo" default-directory))) - ;; Check state of an empty file. + ;; Check state of a nonexistent file. - ;; nil: Hg Mtn SRC SVN - ;; added: Git - ;; unregistered: RCS SCCS - ;; up-to-date: Bzr CVS + ;; unregistered: Bzr CVS Git Hg Mtn RCS SCCS SRC SVN (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))) + (should (eq (vc-state tmp-name) 'unregistered)) ;; Write a new file. Check state. (write-region "foo" nil tmp-name nil 'nomessage) - ;; nil: Mtn - ;; added: Git - ;; unregistered: Hg RCS SCCS SRC SVN - ;; up-to-date: Bzr CVS + ;; unregistered: Bzr CVS Git Hg Mtn RCS SCCS SRC SVN (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))) + (should (eq (vc-state tmp-name) 'unregistered)) ;; Register a file. Check state. (vc-register (list backend (list (file-name-nondirectory tmp-name)))) - ;; added: Git Mtn - ;; unregistered: Hg RCS SCCS SRC SVN - ;; up-to-date: Bzr CVS + ;; FIXME: nil seems to be wrong. + ;; nil: SRC + ;; added: Bzr CVS Git Hg Mtn SVN + ;; up-to-date: RCS SCCS (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))) + (should (memq (vc-state tmp-name) '(nil added up-to-date))) ;; Unregister the file. Check state. - (condition-case nil - (progn - (vc-test--unregister-function backend tmp-name) - - ;; 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"))))) + (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 Hg RCS + ;; unsupported: CVS Mtn SCCS SRC SVN + (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) '(unregistered)))))) ;; Save exit. (ignore-errors (run-hooks 'vc-test--cleanup-hook))))) @@ -370,8 +394,9 @@ For backends which dont support it, `vc-not-supported' is signalled." (make-directory default-directory) (vc-test--create-repo-function backend) - ;; nil: CVS Git Mtn RCS SCCS - ;; "0": Bzr Hg SRC SVN + ;; 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 (eq (vc-working-revision default-directory) @@ -382,48 +407,45 @@ For backends which dont support it, `vc-not-supported' is signalled." ;; Check initial working revision, should be nil until ;; it's registered. - ;; nil: CVS Git Mtn RCS SCCS SVN - ;; "0": Bzr Hg SRC + ;; nil: Bzr CVS Git Hg Mtn RCS SCCS SRC SVN (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"))) + (should-not (vc-working-revision tmp-name)) ;; Write a new file. Check working revision. (write-region "foo" nil tmp-name nil 'nomessage) - ;; nil: CVS Git Mtn RCS SCCS SVN - ;; "0": Bzr Hg SRC + ;; nil: Bzr CVS Git Hg Mtn RCS SCCS SRC SVN (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"))) + (should-not (vc-working-revision tmp-name)) ;; Register a file. Check working revision. (vc-register (list backend (list (file-name-nondirectory tmp-name)))) - ;; nil: Mtn Git RCS SCCS + ;; FIXME: nil doesn't seem to be proper. + ;; nil: Git Mtn ;; "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 - (progn - (vc-test--unregister-function backend tmp-name) - - ;; 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"))))) + (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 (eq (vc-working-revision tmp-name) + (vc-working-revision tmp-name backend))) + (should-not (vc-working-revision tmp-name))))) ;; Save exit. (ignore-errors (run-hooks 'vc-test--cleanup-hook))))) @@ -450,9 +472,8 @@ For backends which dont support it, `vc-not-supported' is signalled." (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 + ;; locking: RCS SCCS (message "vc-checkout-model1 %s" (vc-checkout-model backend default-directory)) @@ -460,11 +481,10 @@ For backends which dont support it, `vc-not-supported' is signalled." '(announce implicit locking))) (let ((tmp-name (expand-file-name "foo" default-directory))) - ;; Check checkout model of an empty file. + ;; Check checkout model of a nonexistent file. - ;; nil: RCS ;; implicit: Bzr CVS Git Hg Mtn SRC SVN - ;; locking: SCCS + ;; locking: RCS SCCS (message "vc-checkout-model2 %s" (vc-checkout-model backend tmp-name)) (should (memq (vc-checkout-model backend tmp-name) @@ -473,9 +493,8 @@ For backends which dont support it, `vc-not-supported' is signalled." ;; 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 + ;; locking: RCS SCCS (message "vc-checkout-model3 %s" (vc-checkout-model backend tmp-name)) (should (memq (vc-checkout-model backend tmp-name) @@ -485,27 +504,25 @@ For backends which dont support it, `vc-not-supported' is signalled." (vc-register (list backend (list (file-name-nondirectory tmp-name)))) - ;; nil: RCS ;; implicit: Bzr CVS Git Hg Mtn SRC SVN - ;; locking: SCCS + ;; 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. - (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"))))) + (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))))) @@ -604,8 +621,6 @@ For backends which dont support it, `vc-not-supported' is signalled." ,(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