(require 'ert)
(require 'vc)
+(declare-function w32-application-type "w32proc")
+
;; The working horses.
(defvar vc-test--cleanup-hook nil
(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.
;; 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
;; 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))))
'vc-test--cleanup-hook
`(lambda () (delete-directory ,default-directory 'recursive)))
- ;; Create empty repository. Check repository state.
+ ;; Create empty repository.
(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
- (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)))
-
(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
(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 (null (vc-state tmp-name)))
;; 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
(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 (null (vc-state tmp-name)))
;; 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 is definitely 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")
+ ;; nil: Bzr Git Hg RCS
+ ;; unsupported: CVS Mtn SCCS SRC SVN
+ (message "vc-state5 %s" (vc-state tmp-name))
+ (should (null (vc-state tmp-name))))))
;; Save exit.
(ignore-errors (run-hooks 'vc-test--cleanup-hook)))))
(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)
- (vc-working-revision default-directory backend)))
- (should (member (vc-working-revision default-directory) '(nil "0")))
+ (should (member (vc-working-revision default-directory) '(nil "0")))
(let ((tmp-name (expand-file-name "foo" default-directory)))
;; Check initial working revision, should be nil until
;; it's registered.
- ;; nil: CVS Git Mtn RCS SCCS SVN
- ;; "0": Bzr Hg SRC
(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
(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
+ ;; XXX: nil is fine, at least in Git's case, because
+ ;; `vc-register' only makes the file `added' in this case.
+ ;; 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")))
+
+ ;; TODO: Call `vc-checkin', and check the resulting
+ ;; working revision. None of the return values should be
+ ;; nil then.
;; 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-not (vc-working-revision tmp-name)))))
;; Save exit.
(ignore-errors (run-hooks 'vc-test--cleanup-hook)))))
(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))
'(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)
;; 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)
(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)))))
,(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