1 ;;; vc-tests.el --- Tests of different backends of vc.el
3 ;; Copyright (C) 2014-2016 Free Software Foundation, Inc.
5 ;; Author: Michael Albinus <michael.albinus@gmx.de>
7 ;; This program is free software: you can redistribute it and/or
8 ;; modify it under the terms of the GNU General Public License as
9 ;; published by the Free Software Foundation, either version 3 of the
10 ;; License, or (at your option) any later version.
12 ;; This program is distributed in the hope that it will be useful, but
13 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
14 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
15 ;; General Public License for more details.
17 ;; You should have received a copy of the GNU General Public License
18 ;; along with this program. If not, see `http://www.gnu.org/licenses/'.
22 ;; For every supported VC on the machine, different test cases are
23 ;; generated automatically.
25 ;; Functions to be tested (see Commentary of vc.el). Mandatory
26 ;; functions are marked with `*', optional functions are marked with `-':
30 ;; * revision-granularity DONE
32 ;; STATE-QUERYING FUNCTIONS
34 ;; * registered (file) DONE
35 ;; * state (file) DONE
36 ;; - dir-status (dir update-function)
37 ;; - dir-status-files (dir files default-state update-function)
38 ;; - dir-extra-headers (dir)
39 ;; - dir-printer (fileinfo)
40 ;; - status-fileinfo-extra (file)
41 ;; * working-revision (file) DONE
42 ;; - latest-on-branch-p (file)
43 ;; * checkout-model (files) DONE
44 ;; - mode-line-string (file)
46 ;; STATE-CHANGING FUNCTIONS
48 ;; * create-repo (backend) DONE
49 ;; * register (files &optional comment) DONE
50 ;; - responsible-p (file)
51 ;; - receive-file (file rev)
52 ;; - unregister (file) DONE
53 ;; * checkin (files comment)
54 ;; * find-revision (file rev buffer)
55 ;; * checkout (file &optional rev)
56 ;; * revert (file &optional contents-done)
58 ;; - merge-file (file rev1 rev2)
60 ;; - merge-news (file)
62 ;; - steal-lock (file &optional revision)
63 ;; - modify-change-comment (files rev comment)
64 ;; - mark-resolved (files)
65 ;; - find-admin-dir (file)
69 ;; * print-log (files buffer &optional shortlog start-revision limit)
70 ;; * log-outgoing (backend remote-location)
71 ;; * log-incoming (backend remote-location)
73 ;; - show-log-entry (revision)
74 ;; - comment-history (file)
75 ;; - update-changelog (files)
76 ;; * diff (files &optional async rev1 rev2 buffer)
77 ;; - revision-completion-table (files)
78 ;; - annotate-command (file buf &optional rev)
80 ;; - annotate-current-time ()
81 ;; - annotate-extract-revision-at-line ()
82 ;; - region-history (FILE BUFFER LFROM LTO)
83 ;; - region-history-mode ()
87 ;; - create-tag (dir name branchp)
88 ;; - retrieve-tag (dir name update)
92 ;; - make-version-backups-p (file)
94 ;; - ignore (file &optional directory)
95 ;; - ignore-completion-table
96 ;; - previous-revision (file rev)
97 ;; - next-revision (file rev)
100 ;; - delete-file (file)
101 ;; - rename-file (old new)
102 ;; - find-file-hook ()
104 ;; - extra-dir-menu ()
105 ;; - conflicted-files (dir)
112 ;; The working horses.
114 (defvar vc-test--cleanup-hook nil
115 "Functions for cleanup at the end of an ert test.
116 Don't set it globally, the functions shall be let-bound.")
118 (defun vc-test--revision-granularity-function (backend)
119 "Run the `vc-revision-granularity' backend function."
120 (funcall (intern (downcase (format "vc-%s-revision-granularity" backend)))))
122 (defun vc-test--create-repo-function (backend)
123 "Run the `vc-create-repo' backend function.
124 For backends which dont support it, it is emulated."
130 (make-temp-name "vc-test") temporary-file-directory)))
131 (make-directory (expand-file-name "module" tmp-dir) 'parents)
132 (make-directory (expand-file-name "CVSROOT" tmp-dir) 'parents)
133 (if (not (fboundp 'w32-application-type))
134 (shell-command-to-string (format "cvs -Q -d:local:%s co module"
136 (let ((cvs-prog (executable-find "cvs"))
138 ;; If CVS executable is an MSYS program, reformat the file
139 ;; name of TMP-DIR to have the /d/foo/bar form supported by
140 ;; MSYS programs. (FIXME: What about Cygwin cvs.exe?)
141 (if (eq (w32-application-type cvs-prog) 'msys)
143 (concat "/" (substring tmp-dir 0 1) (substring tmp-dir 2))))
144 (shell-command-to-string (format "cvs -Q -d:local:%s co module"
146 (rename-file "module/CVS" default-directory)
147 (delete-directory "module" 'recursive)
148 ;; We must cleanup the "remote" CVS repo as well.
149 (add-hook 'vc-test--cleanup-hook
150 `(lambda () (delete-directory ,tmp-dir 'recursive)))))
153 (let ((archive-name (format "%s--%s" user-mail-address (random))))
155 "no arch user id set" (shell-command-to-string "tla my-id"))
156 (shell-command-to-string
157 (format "tla my-id \"<%s>\"" user-mail-address)))
158 (shell-command-to-string
159 (format "tla make-archive %s %s" archive-name default-directory))
160 (shell-command-to-string
161 (format "tla my-default-archive %s" archive-name))))
164 (let ((archive-name "foo.mtn"))
165 (shell-command-to-string
167 "mtn db init --db=%s"
168 (expand-file-name archive-name default-directory)))
169 (shell-command-to-string
170 (format "mtn --db=%s --branch=foo setup ." archive-name))))
172 (t (vc-create-repo backend))))
174 (defun vc-test--create-repo (backend)
175 "Create a test repository in `default-directory', a temporary directory."
177 (let ((vc-handled-backends `(,backend))
179 (file-name-as-directory
181 (make-temp-name "vc-test") temporary-file-directory)))
182 vc-test--cleanup-hook)
188 'vc-test--cleanup-hook
189 `(lambda () (delete-directory ,default-directory 'recursive)))
191 ;; Check the revision granularity.
192 (should (memq (vc-test--revision-granularity-function backend)
195 ;; Create empty repository.
196 (make-directory default-directory)
197 (should (file-directory-p default-directory))
198 (vc-test--create-repo-function backend)
199 (should (eq (vc-responsible-backend default-directory) backend)))
202 (ignore-errors (run-hooks 'vc-test--cleanup-hook)))))
204 ;; Why isn't there `vc-unregister'?
205 (defun vc-test--unregister-function (backend file)
206 "Run the `vc-unregister' backend function.
207 For backends which dont support it, `vc-not-supported' is signalled."
209 (let ((symbol (intern (downcase (format "vc-%s-unregister" backend)))))
210 (if (functionp symbol)
211 (funcall symbol file)
212 ;; CVS, SVN, SCCS, SRC and Mtn are not supported.
213 (signal 'vc-not-supported (list 'unregister backend)))))
215 (defun vc-test--register (backend)
216 "Register and unregister a file."
218 (let ((vc-handled-backends `(,backend))
220 (file-name-as-directory
222 (make-temp-name "vc-test") temporary-file-directory)))
223 vc-test--cleanup-hook)
229 'vc-test--cleanup-hook
230 `(lambda () (delete-directory ,default-directory 'recursive)))
232 ;; Create empty repository.
233 (make-directory default-directory)
234 (vc-test--create-repo-function backend)
236 (let ((tmp-name1 (expand-file-name "foo" default-directory))
238 ;; Register files. Check for it.
239 (write-region "foo" nil tmp-name1 nil 'nomessage)
240 (should (file-exists-p tmp-name1))
241 (should-not (vc-registered tmp-name1))
242 (write-region "bla" nil tmp-name2 nil 'nomessage)
243 (should (file-exists-p tmp-name2))
244 (should-not (vc-registered tmp-name2))
245 (vc-register (list backend (list tmp-name1 tmp-name2)))
246 (should (file-exists-p tmp-name1))
247 (should (vc-registered tmp-name1))
248 (should (file-exists-p tmp-name2))
249 (should (vc-registered tmp-name2))
251 ;; Unregister the files.
254 (vc-test--unregister-function backend tmp-name1)
255 (should-not (vc-registered tmp-name1))
256 (vc-test--unregister-function backend tmp-name2)
257 (should-not (vc-registered tmp-name2)))
258 ;; CVS, SVN, SCCS, SRC and Mtn are not supported.
259 (vc-not-supported t))
260 ;; The files shall still exist.
261 (should (file-exists-p tmp-name1))
262 (should (file-exists-p tmp-name2))))
265 (ignore-errors (run-hooks 'vc-test--cleanup-hook)))))
267 (defun vc-test--state (backend)
268 "Check the different states of a file."
270 (let ((vc-handled-backends `(,backend))
272 (file-name-as-directory
274 (make-temp-name "vc-test") temporary-file-directory)))
275 vc-test--cleanup-hook)
281 'vc-test--cleanup-hook
282 `(lambda () (delete-directory ,default-directory 'recursive)))
284 ;; Create empty repository. Check repository state.
285 (make-directory default-directory)
286 (vc-test--create-repo-function backend)
290 ;; unregistered: CVS SCCS SRC
291 ;; up-to-date: Bzr SVN
292 (message "vc-state1 %s" (vc-state default-directory))
293 ;;(should (eq (vc-state default-directory)
294 ;;(vc-state default-directory backend)))
295 (should (memq (vc-state default-directory)
296 '(nil added unregistered up-to-date)))
298 (let ((tmp-name (expand-file-name "foo" default-directory)))
299 ;; Check state of an empty file.
301 ;; nil: Hg Mtn SRC SVN
303 ;; unregistered: RCS SCCS
304 ;; up-to-date: Bzr CVS
305 (message "vc-state2 %s" (vc-state tmp-name))
306 ;;(should (eq (vc-state tmp-name) (vc-state tmp-name backend)))
307 (should (memq (vc-state tmp-name)
308 '(nil added unregistered up-to-date)))
310 ;; Write a new file. Check state.
311 (write-region "foo" nil tmp-name nil 'nomessage)
315 ;; unregistered: Hg RCS SCCS SRC SVN
316 ;; up-to-date: Bzr CVS
317 (message "vc-state3 %s" (vc-state tmp-name))
318 ;;(should (eq (vc-state tmp-name) (vc-state tmp-name backend)))
319 (should (memq (vc-state tmp-name)
320 '(nil added unregistered up-to-date)))
322 ;; Register a file. Check state.
324 (list backend (list (file-name-nondirectory tmp-name))))
327 ;; unregistered: Hg RCS SCCS SRC SVN
328 ;; up-to-date: Bzr CVS
329 (message "vc-state4 %s" (vc-state tmp-name))
330 ;;(should (eq (vc-state tmp-name) (vc-state tmp-name backend)))
331 (should (memq (vc-state tmp-name)
332 '(nil added unregistered up-to-date)))
334 ;; Unregister the file. Check state.
337 (vc-test--unregister-function backend tmp-name)
340 ;; unregistered: Hg RCS
341 ;; unsupported: CVS Mtn SCCS SRC SVN
343 (message "vc-state5 %s" (vc-state tmp-name))
344 ;;(should (eq (vc-state tmp-name) (vc-state tmp-name backend)))
345 (should (memq (vc-state tmp-name)
346 '(nil added unregistered up-to-date))))
347 (vc-not-supported (message "vc-state5 unsupported")))))
350 (ignore-errors (run-hooks 'vc-test--cleanup-hook)))))
352 (defun vc-test--working-revision (backend)
353 "Check the working revision of a repository."
355 (let ((vc-handled-backends `(,backend))
357 (file-name-as-directory
359 (make-temp-name "vc-test") temporary-file-directory)))
360 vc-test--cleanup-hook)
366 'vc-test--cleanup-hook
367 `(lambda () (delete-directory ,default-directory 'recursive)))
369 ;; Create empty repository. Check working revision of
370 ;; repository, should be nil.
371 (make-directory default-directory)
372 (vc-test--create-repo-function backend)
374 ;; nil: CVS Git Mtn RCS SCCS
375 ;; "0": Bzr Hg SRC SVN
377 "vc-working-revision1 %s" (vc-working-revision default-directory))
378 ;;(should (eq (vc-working-revision default-directory)
379 ;;(vc-working-revision default-directory backend)))
380 (should (member (vc-working-revision default-directory) '(nil "0")))
382 (let ((tmp-name (expand-file-name "foo" default-directory)))
383 ;; Check initial working revision, should be nil until
386 ;; nil: CVS Git Mtn RCS SCCS SVN
388 (message "vc-working-revision2 %s" (vc-working-revision tmp-name))
389 ;;(should (eq (vc-working-revision tmp-name)
390 ;;(vc-working-revision tmp-name backend)))
391 (should (member (vc-working-revision tmp-name) '(nil "0")))
393 ;; Write a new file. Check working revision.
394 (write-region "foo" nil tmp-name nil 'nomessage)
396 ;; nil: CVS Git Mtn RCS SCCS SVN
398 (message "vc-working-revision3 %s" (vc-working-revision tmp-name))
399 ;;(should (eq (vc-working-revision tmp-name)
400 ;;(vc-working-revision tmp-name backend)))
401 (should (member (vc-working-revision tmp-name) '(nil "0")))
403 ;; Register a file. Check working revision.
405 (list backend (list (file-name-nondirectory tmp-name))))
407 ;; nil: Mtn Git RCS SCCS
408 ;; "0": Bzr CVS Hg SRC SVN
409 (message "vc-working-revision4 %s" (vc-working-revision tmp-name))
410 ;;(should (eq (vc-working-revision tmp-name)
411 ;;(vc-working-revision tmp-name backend)))
412 (should (member (vc-working-revision tmp-name) '(nil "0")))
414 ;; Unregister the file. Check working revision.
417 (vc-test--unregister-function backend tmp-name)
421 ;; unsupported: CVS Mtn SCCS SRC SVN
423 "vc-working-revision5 %s" (vc-working-revision tmp-name))
424 ;;(should (eq (vc-working-revision tmp-name)
425 ;;(vc-working-revision tmp-name backend)))
426 (should (member (vc-working-revision tmp-name) '(nil "0"))))
427 (vc-not-supported (message "vc-working-revision5 unsupported")))))
430 (ignore-errors (run-hooks 'vc-test--cleanup-hook)))))
432 (defun vc-test--checkout-model (backend)
433 "Check the checkout model of a repository."
435 (let ((vc-handled-backends `(,backend))
437 (file-name-as-directory
439 (make-temp-name "vc-test") temporary-file-directory)))
440 vc-test--cleanup-hook)
446 'vc-test--cleanup-hook
447 `(lambda () (delete-directory ,default-directory 'recursive)))
449 ;; Create empty repository. Check repository checkout model.
450 (make-directory default-directory)
451 (vc-test--create-repo-function backend)
453 ;; Surprisingly, none of the backends returns 'announce.
455 ;; implicit: Bzr CVS Git Hg Mtn SRC SVN
458 "vc-checkout-model1 %s"
459 (vc-checkout-model backend default-directory))
460 (should (memq (vc-checkout-model backend default-directory)
461 '(announce implicit locking)))
463 (let ((tmp-name (expand-file-name "foo" default-directory)))
464 ;; Check checkout model of an empty file.
467 ;; implicit: Bzr CVS Git Hg Mtn SRC SVN
470 "vc-checkout-model2 %s" (vc-checkout-model backend tmp-name))
471 (should (memq (vc-checkout-model backend tmp-name)
472 '(announce implicit locking)))
474 ;; Write a new file. Check checkout model.
475 (write-region "foo" nil tmp-name nil 'nomessage)
478 ;; implicit: Bzr CVS Git Hg Mtn SRC SVN
481 "vc-checkout-model3 %s" (vc-checkout-model backend tmp-name))
482 (should (memq (vc-checkout-model backend tmp-name)
483 '(announce implicit locking)))
485 ;; Register a file. Check checkout model.
487 (list backend (list (file-name-nondirectory tmp-name))))
490 ;; implicit: Bzr CVS Git Hg Mtn SRC SVN
493 "vc-checkout-model4 %s" (vc-checkout-model backend tmp-name))
494 (should (memq (vc-checkout-model backend tmp-name)
495 '(announce implicit locking)))
497 ;; Unregister the file. Check checkout model.
500 (vc-test--unregister-function backend tmp-name)
503 ;; implicit: Bzr Git Hg
504 ;; unsupported: CVS Mtn SCCS SRC SVN
506 "vc-checkout-model5 %s" (vc-checkout-model backend tmp-name))
507 (should (memq (vc-checkout-model backend tmp-name)
508 '(announce implicit locking))))
509 (vc-not-supported (message "vc-checkout-model5 unsupported")))))
512 (ignore-errors (run-hooks 'vc-test--cleanup-hook)))))
514 ;; Create the test cases.
516 (defun vc-test--rcs-enabled ()
517 (executable-find "rcs"))
519 (defun vc-test--cvs-enabled ()
520 (executable-find "cvs"))
522 (defvar vc-svn-program)
523 (defun vc-test--svn-enabled ()
524 (executable-find vc-svn-program))
526 (defun vc-test--sccs-enabled ()
527 (executable-find "sccs"))
529 (defvar vc-src-program)
530 (defun vc-test--src-enabled ()
531 (executable-find vc-src-program))
533 (defvar vc-bzr-program)
534 (defun vc-test--bzr-enabled ()
535 (executable-find vc-bzr-program))
537 (defvar vc-git-program)
538 (defun vc-test--git-enabled ()
539 (executable-find vc-git-program))
541 (defvar vc-hg-program)
542 (defun vc-test--hg-enabled ()
543 (executable-find vc-hg-program))
545 (defvar vc-mtn-program)
546 (defun vc-test--mtn-enabled ()
547 (executable-find vc-mtn-program))
550 (defvar vc-arch-program)
551 (defun vc-test--arch-enabled ()
552 (executable-find vc-arch-program))
554 ;; Create the test cases.
555 (dolist (backend vc-handled-backends)
556 (let ((backend-string (downcase (symbol-name backend))))
557 (require (intern (format "vc-%s" backend-string)))
559 ;; Check, whether the backend is supported.
560 `(when (funcall ',(intern (format "vc-test--%s-enabled" backend-string)))
563 ,(intern (format "vc-test-%s00-create-repo" backend-string)) ()
564 ,(format "Check `vc-create-repo' for the %s backend."
566 (vc-test--create-repo ',backend))
569 ,(intern (format "vc-test-%s01-register" backend-string)) ()
571 "Check `vc-register' and `vc-registered' for the %s backend."
575 (ert-test-most-recent-result
578 (format "vc-test-%s00-create-repo" backend-string))))))
579 (vc-test--register ',backend))
582 ,(intern (format "vc-test-%s02-state" backend-string)) ()
583 ,(format "Check `vc-state' for the %s backend." backend-string)
586 (ert-test-most-recent-result
589 (format "vc-test-%s01-register" backend-string))))))
590 (vc-test--state ',backend))
593 ,(intern (format "vc-test-%s03-working-revision" backend-string)) ()
594 ,(format "Check `vc-working-revision' for the %s backend."
598 (ert-test-most-recent-result
601 (format "vc-test-%s01-register" backend-string))))))
602 (vc-test--working-revision ',backend))
605 ,(intern (format "vc-test-%s04-checkout-model" backend-string)) ()
606 ,(format "Check `vc-checkout-model' for the %s backend."
608 ;; FIXME make this pass.
609 :expected-result ,(if (equal backend 'RCS) :failed :passed)
612 (ert-test-most-recent-result
615 (format "vc-test-%s01-register" backend-string))))))
616 (vc-test--checkout-model ',backend))))))
619 ;;; vc-tests.el ends here