1 ;;; vc-tests.el --- Tests of different backends of vc.el
3 ;; Copyright (C) 2014-2015 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 (shell-command-to-string (format "cvs -Q -d:local:%s co module" tmp-dir
))
134 (rename-file "module/CVS" default-directory
)
135 (delete-directory "module" 'recursive
)
136 ;; We must cleanup the "remote" CVS repo as well.
137 (add-hook 'vc-test--cleanup-hook
138 `(lambda () (delete-directory ,tmp-dir
'recursive
)))))
141 (let ((archive-name (format "%s--%s" user-mail-address
(random))))
143 "no arch user id set" (shell-command-to-string "tla my-id"))
144 (shell-command-to-string
145 (format "tla my-id \"<%s>\"" user-mail-address
)))
146 (shell-command-to-string
147 (format "tla make-archive %s %s" archive-name default-directory
))
148 (shell-command-to-string
149 (format "tla my-default-archive %s" archive-name
))))
152 (let ((archive-name "foo.mtn"))
153 (shell-command-to-string
155 "mtn db init --db=%s"
156 (expand-file-name archive-name default-directory
)))
157 (shell-command-to-string
158 (format "mtn --db=%s --branch=foo setup ." archive-name
))))
160 (t (vc-create-repo backend
))))
162 (defun vc-test--create-repo (backend)
163 "Create a test repository in `default-directory', a temporary directory."
165 (let ((vc-handled-backends `(,backend
))
167 (file-name-as-directory
169 (make-temp-name "vc-test") temporary-file-directory
)))
170 vc-test--cleanup-hook
)
176 'vc-test--cleanup-hook
177 `(lambda () (delete-directory ,default-directory
'recursive
)))
179 ;; Check the revision granularity.
180 (should (memq (vc-test--revision-granularity-function backend
)
183 ;; Create empty repository.
184 (make-directory default-directory
)
185 (should (file-directory-p default-directory
))
186 (vc-test--create-repo-function backend
)
187 (should (eq (vc-responsible-backend default-directory
) backend
)))
190 (ignore-errors (run-hooks 'vc-test--cleanup-hook
)))))
192 ;; Why isn't there `vc-unregister'?
193 (defun vc-test--unregister-function (backend file
)
194 "Run the `vc-unregister' backend function.
195 For backends which dont support it, `vc-not-supported' is signalled."
197 (let ((symbol (intern (downcase (format "vc-%s-unregister" backend
)))))
198 (if (functionp symbol
)
199 (funcall symbol file
)
200 ;; CVS, SVN, SCCS, SRC and Mtn are not supported.
201 (signal 'vc-not-supported
(list 'unregister backend
)))))
203 (defun vc-test--register (backend)
204 "Register and unregister a file."
206 (let ((vc-handled-backends `(,backend
))
208 (file-name-as-directory
210 (make-temp-name "vc-test") temporary-file-directory
)))
211 vc-test--cleanup-hook
)
217 'vc-test--cleanup-hook
218 `(lambda () (delete-directory ,default-directory
'recursive
)))
220 ;; Create empty repository.
221 (make-directory default-directory
)
222 (vc-test--create-repo-function backend
)
224 (let ((tmp-name1 (expand-file-name "foo" default-directory
))
226 ;; Register files. Check for it.
227 (write-region "foo" nil tmp-name1 nil
'nomessage
)
228 (should (file-exists-p tmp-name1
))
229 (should-not (vc-registered tmp-name1
))
230 (write-region "bla" nil tmp-name2 nil
'nomessage
)
231 (should (file-exists-p tmp-name2
))
232 (should-not (vc-registered tmp-name2
))
233 (vc-register (list backend
(list tmp-name1 tmp-name2
)))
234 (should (file-exists-p tmp-name1
))
235 (should (vc-registered tmp-name1
))
236 (should (file-exists-p tmp-name2
))
237 (should (vc-registered tmp-name2
))
239 ;; Unregister the files.
242 (vc-test--unregister-function backend tmp-name1
)
243 (should-not (vc-registered tmp-name1
))
244 (vc-test--unregister-function backend tmp-name2
)
245 (should-not (vc-registered tmp-name2
)))
246 ;; CVS, SVN, SCCS, SRC and Mtn are not supported.
247 (vc-not-supported t
))
248 ;; The files shall still exist.
249 (should (file-exists-p tmp-name1
))
250 (should (file-exists-p tmp-name2
))))
253 (ignore-errors (run-hooks 'vc-test--cleanup-hook
)))))
255 (defun vc-test--state (backend)
256 "Check the different states of a file."
258 (let ((vc-handled-backends `(,backend
))
260 (file-name-as-directory
262 (make-temp-name "vc-test") temporary-file-directory
)))
263 vc-test--cleanup-hook
)
269 'vc-test--cleanup-hook
270 `(lambda () (delete-directory ,default-directory
'recursive
)))
272 ;; Create empty repository. Check repository state.
273 (make-directory default-directory
)
274 (vc-test--create-repo-function backend
)
278 ;; unregistered: CVS SCCS SRC
279 ;; up-to-date: Bzr SVN
280 (should (eq (vc-state default-directory
)
281 (vc-state default-directory backend
)))
282 (should (memq (vc-state default-directory
)
283 '(nil added unregistered up-to-date
)))
285 (let ((tmp-name (expand-file-name "foo" default-directory
)))
286 ;; Check state of an empty file.
288 ;; nil: Hg Mtn SRC SVN
290 ;; unregistered: RCS SCCS
291 ;; up-to-date: Bzr CVS
292 (should (eq (vc-state tmp-name
) (vc-state tmp-name backend
)))
293 (should (memq (vc-state tmp-name
)
294 '(nil added unregistered up-to-date
)))
296 ;; Write a new file. Check state.
297 (write-region "foo" nil tmp-name nil
'nomessage
)
301 ;; unregistered: Hg RCS SCCS SRC SVN
302 ;; up-to-date: Bzr CVS
303 (should (eq (vc-state tmp-name
) (vc-state tmp-name backend
)))
304 (should (memq (vc-state tmp-name
)
305 '(nil added unregistered up-to-date
)))
307 ;; Register a file. Check state.
309 (list backend
(list (file-name-nondirectory tmp-name
))))
312 ;; unregistered: Hg RCS SCCS SRC SVN
313 ;; up-to-date: Bzr CVS
314 (should (eq (vc-state tmp-name
) (vc-state tmp-name backend
)))
315 (should (memq (vc-state tmp-name
) '(added unregistered up-to-date
)))
317 ;; Unregister the file. Check state.
320 (vc-test--unregister-function backend tmp-name
)
324 ;; unsupported: CVS Mtn SCCS SRC SVN
326 (should (eq (vc-state tmp-name
) (vc-state tmp-name backend
)))
327 (should (memq (vc-state tmp-name
)
328 '(added unregistered up-to-date
))))
329 (vc-not-supported t
))))
332 (ignore-errors (run-hooks 'vc-test--cleanup-hook
)))))
334 (defun vc-test--working-revision (backend)
335 "Check the working revision of a repository."
337 (let ((vc-handled-backends `(,backend
))
339 (file-name-as-directory
341 (make-temp-name "vc-test") temporary-file-directory
)))
342 vc-test--cleanup-hook
)
348 'vc-test--cleanup-hook
349 `(lambda () (delete-directory ,default-directory
'recursive
)))
351 ;; Create empty repository. Check working revision of
352 ;; repository, should be nil.
353 (make-directory default-directory
)
354 (vc-test--create-repo-function backend
)
356 ;; nil: CVS Mtn RCS SCCS
357 ;; "0": Bzr Hg SRC SVN
359 (should (eq (vc-working-revision default-directory
)
360 (vc-working-revision default-directory backend
)))
363 (vc-working-revision default-directory
) '(nil "0" "master")))
365 (let ((tmp-name (expand-file-name "foo" default-directory
)))
366 ;; Check initial working revision, should be nil until
369 ;; nil: CVS Mtn RCS SCCS SVN
372 (should (eq (vc-working-revision tmp-name
)
373 (vc-working-revision tmp-name backend
)))
375 (member (vc-working-revision tmp-name
) '(nil "0" "master")))
377 ;; Write a new file. Check working revision.
378 (write-region "foo" nil tmp-name nil
'nomessage
)
380 ;; nil: CVS Mtn RCS SCCS SVN
383 (should (eq (vc-working-revision tmp-name
)
384 (vc-working-revision tmp-name backend
)))
386 (member (vc-working-revision tmp-name
) '(nil "0" "master")))
388 ;; Register a file. Check working revision.
390 (list backend
(list (file-name-nondirectory tmp-name
))))
393 ;; "0": Bzr CVS Hg SRC SVN
395 (should (eq (vc-working-revision tmp-name
)
396 (vc-working-revision tmp-name backend
)))
398 (member (vc-working-revision tmp-name
) '(nil "0" "master")))
400 ;; Unregister the file. Check working revision.
403 (vc-test--unregister-function backend tmp-name
)
408 ;; unsupported: CVS Mtn SCCS SRC SVN
409 (should (eq (vc-working-revision tmp-name
)
410 (vc-working-revision tmp-name backend
)))
413 (vc-working-revision tmp-name
) '(nil "0" "master"))))
414 (vc-not-supported t
))))
417 (ignore-errors (run-hooks 'vc-test--cleanup-hook
)))))
419 (defun vc-test--checkout-model (backend)
420 "Check the checkout model of a repository."
422 (let ((vc-handled-backends `(,backend
))
424 (file-name-as-directory
426 (make-temp-name "vc-test") temporary-file-directory
)))
427 vc-test--cleanup-hook
)
433 'vc-test--cleanup-hook
434 `(lambda () (delete-directory ,default-directory
'recursive
)))
436 ;; Create empty repository. Check repository checkout model.
437 (make-directory default-directory
)
438 (vc-test--create-repo-function backend
)
440 ;; Surprisingly, none of the backends returns 'announce.
442 ;; implicit: Bzr CVS Git Hg Mtn SRC SVN
444 (should (memq (vc-checkout-model backend default-directory
)
445 '(announce implicit locking
)))
447 (let ((tmp-name (expand-file-name "foo" default-directory
)))
448 ;; Check checkout model of an empty file.
451 ;; implicit: Bzr CVS Git Hg Mtn SRC SVN
453 (should (memq (vc-checkout-model backend tmp-name
)
454 '(announce implicit locking
)))
456 ;; Write a new file. Check checkout model.
457 (write-region "foo" nil tmp-name nil
'nomessage
)
460 ;; implicit: Bzr CVS Git Hg Mtn SRC SVN
462 (should (memq (vc-checkout-model backend tmp-name
)
463 '(announce implicit locking
)))
465 ;; Register a file. Check checkout model.
467 (list backend
(list (file-name-nondirectory tmp-name
))))
470 ;; implicit: Bzr CVS Git Hg Mtn SRC SVN
472 (should (memq (vc-checkout-model backend tmp-name
)
473 '(announce implicit locking
)))
475 ;; Unregister the file. Check checkout model.
478 (vc-test--unregister-function backend tmp-name
)
481 ;; implicit: Bzr Git Hg
482 ;; unsupported: CVS Mtn SCCS SRC SVN
483 (should (memq (vc-checkout-model backend tmp-name
)
484 '(announce implicit locking
))))
485 (vc-not-supported t
))))
488 (ignore-errors (run-hooks 'vc-test--cleanup-hook
)))))
490 ;; Create the test cases.
492 (defun vc-test--rcs-enabled ()
493 (executable-find "rcs"))
495 (defun vc-test--cvs-enabled ()
496 (executable-find "cvs"))
498 (defvar vc-svn-program
)
499 (defun vc-test--svn-enabled ()
500 (executable-find vc-svn-program
))
502 (defun vc-test--sccs-enabled ()
503 (executable-find "sccs"))
505 (defvar vc-src-program
)
506 (defun vc-test--src-enabled ()
507 (executable-find vc-src-program
))
509 (defvar vc-bzr-program
)
510 (defun vc-test--bzr-enabled ()
511 (executable-find vc-bzr-program
))
513 (defvar vc-git-program
)
514 (defun vc-test--git-enabled ()
515 (executable-find vc-git-program
))
517 (defvar vc-hg-program
)
518 (defun vc-test--hg-enabled ()
519 (executable-find vc-hg-program
))
521 (defvar vc-mtn-program
)
522 (defun vc-test--mtn-enabled ()
523 (executable-find vc-mtn-program
))
526 (defvar vc-arch-program
)
527 (defun vc-test--arch-enabled ()
528 (executable-find vc-arch-program
))
530 ;; There are too many failed test cases yet. We suppress them on hydra.
531 (if (getenv "NIX_STORE")
532 (ert-deftest vc-test
()
533 "Dummy test case for hydra."
536 ;; Create the test cases.
537 (dolist (backend vc-handled-backends
)
538 (let ((backend-string (downcase (symbol-name backend
))))
539 (require (intern (format "vc-%s" backend-string
)))
541 ;; Check, whether the backend is supported.
542 `(when (funcall ',(intern (format "vc-test--%s-enabled" backend-string
)))
545 ,(intern (format "vc-test-%s00-create-repo" backend-string
)) ()
546 ,(format "Check `vc-create-repo' for the %s backend."
548 (vc-test--create-repo ',backend
))
551 ,(intern (format "vc-test-%s01-register" backend-string
)) ()
553 "Check `vc-register' and `vc-registered' for the %s backend."
557 (ert-test-most-recent-result
560 (format "vc-test-%s00-create-repo" backend-string
))))))
561 (vc-test--register ',backend
))
564 ,(intern (format "vc-test-%s02-state" backend-string
)) ()
565 ,(format "Check `vc-state' for the %s backend." backend-string
)
568 (ert-test-most-recent-result
571 (format "vc-test-%s01-register" backend-string
))))))
572 (vc-test--state ',backend
))
575 ,(intern (format "vc-test-%s03-working-revision" backend-string
)) ()
576 ,(format "Check `vc-working-revision' for the %s backend."
580 (ert-test-most-recent-result
583 (format "vc-test-%s01-register" backend-string
))))))
584 (vc-test--working-revision ',backend
))
587 ,(intern (format "vc-test-%s04-checkout-model" backend-string
)) ()
588 ,(format "Check `vc-checkout-model' for the %s backend."
592 (ert-test-most-recent-result
595 (format "vc-test-%s01-register" backend-string
))))))
596 (vc-test--checkout-model ',backend
)))))))
599 ;;; vc-tests.el ends here