Some improvements in vc

* lisp/vc/vc-hooks.el (vc-state, vc-working-revision):
Check, whether FILE is registered.

* lisp/vc/vc-rcs.el (vc-rcs-checkout-model): Return `locking'
for nonexistent files.

* test/lisp/vc/vc-tests.el (w32-application-type): Declare.
(vc-test--revision-granularity-function)
(vc-test--unregister-function): Use `vc-call-backend'.
(vc-test--run-maybe-unsupported-function): New defmacro.
(vc-test--register, vc-test--state, vc-test--working-revision)
(vc-test--checkout-model): Use it.  Fix also expected results.
(vc-test-src02-state, vc-test-rcs04-checkout-model): They pass now.

1 files changed, 91 insertions, 113 deletions

diff --git a/test/lisp/vc/vc-tests.el b/test/lisp/vc/vc-tests.el
index 1a3e8e08b68..793ad82c74f 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.
@@ -137,7 +139,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,21 +203,25 @@ For backends which dont support it, it is emulated."
       ;; Save exit.
       (ignore-errors (run-hooks 'vc-test--cleanup-hook)))))
 
-;; FIXME 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."
-
-  (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'.
+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.
 This checks also `vc-backend' and `vc-responsible-backend'."
@@ -239,7 +245,6 @@ This checks also `vc-backend' and `vc-responsible-backend'."
           (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))))
@@ -271,22 +276,21 @@ This checks also `vc-backend' and `vc-responsible-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?
+            ;; `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-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)
-              (t (signal (car err) (cdr err))))
+            (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))
@@ -316,66 +320,54 @@ This checks also `vc-backend' and `vc-responsible-backend'."
           (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 err
-                (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"))
-              (t (signal (car err) (cdr err))))))
+            (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)))))
@@ -402,8 +394,9 @@ This checks also `vc-backend' and `vc-responsible-backend'."
           (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)
@@ -414,50 +407,45 @@ This checks also `vc-backend' and `vc-responsible-backend'."
             ;; 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
+            ;; FIXME: nil doesn't seem to be proper.
+            ;; nil: Git Mtn
             ;; "0": Bzr CVS Hg SRC SVN
-            ;; "1.1"  RCS SCCS
+            ;; "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" "1.1")))
 
             ;; Unregister the file.  Check working revision.
-            (condition-case err
-                (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"))
-              (t (signal (car err) (cdr err))))))
+            (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)))))
@@ -484,9 +472,8 @@ This checks also `vc-backend' and `vc-responsible-backend'."
           (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))
@@ -494,11 +481,10 @@ This checks also `vc-backend' and `vc-responsible-backend'."
                         '(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)
@@ -507,9 +493,8 @@ This checks also `vc-backend' and `vc-responsible-backend'."
             ;; 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)
@@ -519,28 +504,25 @@ This checks also `vc-backend' and `vc-responsible-backend'."
             (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 err
-                (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"))
-              (t (signal (car err) (cdr err))))))
+            (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)))))
@@ -615,8 +597,6 @@ This checks also `vc-backend' and `vc-responsible-backend'."
         (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
@@ -641,8 +621,6 @@ This checks also `vc-backend' and `vc-responsible-backend'."
             ,(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