[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Emacs-diffs] master 5cb7620: Some improvements in vc
|
From: |
Michael Albinus |
|
Subject: |
[Emacs-diffs] master 5cb7620: Some improvements in vc |
|
Date: |
Sun, 24 Apr 2016 12:59:17 +0000 |
branch: master
commit 5cb7620027f78a3a0f473972a0584c8ea1791398
Author: Michael Albinus <address@hidden>
Commit: Michael Albinus <address@hidden>
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.
---
lisp/vc/vc-hooks.el | 15 ++--
lisp/vc/vc-rcs.el | 4 +-
test/lisp/vc/vc-tests.el | 204 +++++++++++++++++++++-------------------------
3 files changed, 103 insertions(+), 120 deletions(-)
diff --git a/lisp/vc/vc-hooks.el b/lisp/vc/vc-hooks.el
index 4c0161d..0535565 100644
--- a/lisp/vc/vc-hooks.el
+++ b/lisp/vc/vc-hooks.el
@@ -475,10 +475,11 @@ status of this file. Otherwise, the value returned is
one of:
;; FIXME: New (sub)states needed (?):
;; - `copied' and `moved' (might be handled by `removed' and `added')
(or (vc-file-getprop file 'vc-state)
+ (and (not (vc-registered file)) 'unregistered)
(when (> (length file) 0) ;Why?? --Stef
(setq backend (or backend (vc-responsible-backend file)))
(when backend
- (vc-state-refresh file backend)))))
+ (vc-state-refresh file backend)))))
(defun vc-state-refresh (file backend)
"Quickly recompute the `state' of FILE."
@@ -494,11 +495,13 @@ status of this file. Otherwise, the value returned is
one of:
"Return the repository version from which FILE was checked out.
If FILE is not registered, this function always returns nil."
(or (vc-file-getprop file 'vc-working-revision)
- (progn
- (setq backend (or backend (vc-responsible-backend file)))
- (when backend
- (vc-file-setprop file 'vc-working-revision
- (vc-call-backend backend 'working-revision file))))))
+ (and (vc-registered file)
+ (progn
+ (setq backend (or backend (vc-responsible-backend file)))
+ (when backend
+ (vc-file-setprop file 'vc-working-revision
+ (vc-call-backend
+ backend 'working-revision file)))))))
;; Backward compatibility.
(define-obsolete-function-alias
diff --git a/lisp/vc/vc-rcs.el b/lisp/vc/vc-rcs.el
index 8d58611..b972956 100644
--- a/lisp/vc/vc-rcs.el
+++ b/lisp/vc/vc-rcs.el
@@ -120,7 +120,9 @@ For a description of possible values, see
`vc-check-master-templates'."
(setq result (vc-file-getprop file 'vc-checkout-model)))
(or result
(progn (vc-rcs-fetch-master-state file)
- (vc-file-getprop file 'vc-checkout-model)))))
+ (vc-file-getprop file 'vc-checkout-model))
+ ;; For non-existing files we assume strict locking.
+ 'locking)))
;;;
;;; State-querying functions
diff --git a/test/lisp/vc/vc-tests.el b/test/lisp/vc/vc-tests.el
index 1a3e8e0..793ad82 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
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Emacs-diffs] master 5cb7620: Some improvements in vc,
Michael Albinus <=