[Emacs-diffs] master 5e1c32e: Add vc-backend and vc-responsible-backend tests

[Michael Albinus]

branch: master
commit 5e1c32e7916420a447b060a4ff2507364aff41a4
Author: Michael Albinus <address@hidden>
Commit: Michael Albinus <address@hidden>

    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 c6512e9..97ccec8 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 2faa143..2b3445a 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