]> code.delx.au - gnu-emacs/blob - test/lisp/vc/vc-tests.el
; Merge from origin/emacs-25
[gnu-emacs] / test / lisp / vc / vc-tests.el
1 ;;; vc-tests.el --- Tests of different backends of vc.el
2
3 ;; Copyright (C) 2014-2016 Free Software Foundation, Inc.
4
5 ;; Author: Michael Albinus <michael.albinus@gmx.de>
6
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.
11 ;;
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.
16 ;;
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/'.
19
20 ;;; Commentary:
21
22 ;; For every supported VC on the machine, different test cases are
23 ;; generated automatically.
24
25 ;; Functions to be tested (see Commentary of vc.el). Mandatory
26 ;; functions are marked with `*', optional functions are marked with `-':
27
28 ;; BACKEND PROPERTIES
29 ;;
30 ;; * revision-granularity DONE
31
32 ;; STATE-QUERYING FUNCTIONS
33 ;;
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)
45
46 ;; STATE-CHANGING FUNCTIONS
47 ;;
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)
57 ;; - rollback (files)
58 ;; - merge-file (file rev1 rev2)
59 ;; - merge-branch ()
60 ;; - merge-news (file)
61 ;; - pull (prompt)
62 ;; - steal-lock (file &optional revision)
63 ;; - modify-change-comment (files rev comment)
64 ;; - mark-resolved (files)
65 ;; - find-admin-dir (file)
66
67 ;; HISTORY FUNCTIONS
68 ;;
69 ;; * print-log (files buffer &optional shortlog start-revision limit)
70 ;; * log-outgoing (backend remote-location)
71 ;; * log-incoming (backend remote-location)
72 ;; - log-view-mode ()
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)
79 ;; - annotate-time ()
80 ;; - annotate-current-time ()
81 ;; - annotate-extract-revision-at-line ()
82 ;; - region-history (FILE BUFFER LFROM LTO)
83 ;; - region-history-mode ()
84
85 ;; TAG SYSTEM
86 ;;
87 ;; - create-tag (dir name branchp)
88 ;; - retrieve-tag (dir name update)
89
90 ;; MISCELLANEOUS
91 ;;
92 ;; - make-version-backups-p (file)
93 ;; - root (file)
94 ;; - ignore (file &optional directory)
95 ;; - ignore-completion-table
96 ;; - previous-revision (file rev)
97 ;; - next-revision (file rev)
98 ;; - log-edit-mode ()
99 ;; - check-headers ()
100 ;; - delete-file (file)
101 ;; - rename-file (old new)
102 ;; - find-file-hook ()
103 ;; - extra-menu ()
104 ;; - extra-dir-menu ()
105 ;; - conflicted-files (dir)
106
107 ;;; Code:
108
109 (require 'ert)
110 (require 'vc)
111
112 (declare-function w32-application-type "w32proc")
113
114 ;; The working horses.
115
116 (defvar vc-test--cleanup-hook nil
117 "Functions for cleanup at the end of an ert test.
118 Don't set it globally, the functions shall be let-bound.")
119
120 (defun vc-test--revision-granularity-function (backend)
121 "Run the `vc-revision-granularity' backend function."
122 (vc-call-backend backend 'revision-granularity))
123
124 (defun vc-test--create-repo-function (backend)
125 "Run the `vc-create-repo' backend function.
126 For backends which dont support it, it is emulated."
127
128 (cond
129 ((eq backend 'CVS)
130 (let ((tmp-dir
131 (expand-file-name
132 (make-temp-name "vc-test") temporary-file-directory)))
133 (make-directory (expand-file-name "module" tmp-dir) 'parents)
134 (make-directory (expand-file-name "CVSROOT" tmp-dir) 'parents)
135 (if (not (fboundp 'w32-application-type))
136 (shell-command-to-string (format "cvs -Q -d:local:%s co module"
137 tmp-dir))
138 (let ((cvs-prog (executable-find "cvs"))
139 (tdir tmp-dir))
140 ;; If CVS executable is an MSYS program, reformat the file
141 ;; name of TMP-DIR to have the /d/foo/bar form supported by
142 ;; MSYS programs. (FIXME: What about Cygwin cvs.exe?)
143 (if (eq (w32-application-type cvs-prog) 'msys)
144 (setq tdir
145 (concat "/" (substring tmp-dir 0 1) (substring tmp-dir 2))))
146 (shell-command-to-string (format "cvs -Q -d:local:%s co module"
147 tdir))))
148 (rename-file "module/CVS" default-directory)
149 (delete-directory "module" 'recursive)
150 ;; We must cleanup the "remote" CVS repo as well.
151 (add-hook 'vc-test--cleanup-hook
152 `(lambda () (delete-directory ,tmp-dir 'recursive)))))
153
154 ((eq backend 'Arch)
155 (let ((archive-name (format "%s--%s" user-mail-address (random))))
156 (when (string-match
157 "no arch user id set" (shell-command-to-string "tla my-id"))
158 (shell-command-to-string
159 (format "tla my-id \"<%s>\"" user-mail-address)))
160 (shell-command-to-string
161 (format "tla make-archive %s %s" archive-name default-directory))
162 (shell-command-to-string
163 (format "tla my-default-archive %s" archive-name))))
164
165 ((eq backend 'Mtn)
166 (let ((archive-name "foo.mtn"))
167 (shell-command-to-string
168 (format
169 "mtn db init --db=%s"
170 (expand-file-name archive-name default-directory)))
171 (shell-command-to-string
172 (format "mtn --db=%s --branch=foo setup ." archive-name))))
173
174 (t (vc-create-repo backend))))
175
176 (defun vc-test--create-repo (backend)
177 "Create a test repository in `default-directory', a temporary directory."
178
179 (let ((vc-handled-backends `(,backend))
180 (default-directory
181 (file-name-as-directory
182 (expand-file-name
183 (make-temp-name "vc-test") temporary-file-directory)))
184 vc-test--cleanup-hook)
185
186 (unwind-protect
187 (progn
188 ;; Cleanup.
189 (add-hook
190 'vc-test--cleanup-hook
191 `(lambda () (delete-directory ,default-directory 'recursive)))
192
193 ;; Check the revision granularity.
194 (should (memq (vc-test--revision-granularity-function backend)
195 '(file repository)))
196
197 ;; Create empty repository.
198 (make-directory default-directory)
199 (should (file-directory-p default-directory))
200 (vc-test--create-repo-function backend)
201 (should (eq (vc-responsible-backend default-directory) backend)))
202
203 ;; Save exit.
204 (ignore-errors (run-hooks 'vc-test--cleanup-hook)))))
205
206 ;; FIXME: Why isn't there `vc-unregister'?
207 (defun vc-test--unregister-function (backend file)
208 "Run the `vc-unregister' backend function.
209 For backends which don't support it, `vc-not-supported' is signalled."
210 ;; CVS, SVN, SCCS, SRC and Mtn are not supported, and will signal
211 ;; `vc-not-supported'.
212 (prog1
213 (vc-call-backend backend 'unregister file)
214 (vc-file-clearprops file)))
215
216 (defmacro vc-test--run-maybe-unsupported-function (func &rest args)
217 "Run FUNC withs ARGS as arguments.
218 Catch the `vc-not-supported' error."
219 `(let (err)
220 (condition-case err
221 (funcall ,func ,@args)
222 (vc-not-supported 'vc-not-supported)
223 (t (signal (car err) (cdr err))))))
224
225 (defun vc-test--register (backend)
226 "Register and unregister a file.
227 This checks also `vc-backend' and `vc-responsible-backend'."
228
229 (let ((vc-handled-backends `(,backend))
230 (default-directory
231 (file-name-as-directory
232 (expand-file-name
233 (make-temp-name "vc-test") temporary-file-directory)))
234 vc-test--cleanup-hook)
235
236 (unwind-protect
237 (progn
238 ;; Cleanup.
239 (add-hook
240 'vc-test--cleanup-hook
241 `(lambda () (delete-directory ,default-directory 'recursive)))
242
243 ;; Create empty repository.
244 (make-directory default-directory)
245 (vc-test--create-repo-function backend)
246 ;; For file oriented backends CVS, RCS and SVN the backend is
247 ;; returned, and the directory is registered already.
248 (should (if (vc-backend default-directory)
249 (vc-registered default-directory)
250 (not (vc-registered default-directory))))
251 (should (eq (vc-responsible-backend default-directory) backend))
252
253 (let ((tmp-name1 (expand-file-name "foo" default-directory))
254 (tmp-name2 "bla"))
255 ;; Register files. Check for it.
256 (write-region "foo" nil tmp-name1 nil 'nomessage)
257 (should (file-exists-p tmp-name1))
258 (should-not (vc-backend tmp-name1))
259 (should (eq (vc-responsible-backend tmp-name1) backend))
260 (should-not (vc-registered tmp-name1))
261
262 (write-region "bla" nil tmp-name2 nil 'nomessage)
263 (should (file-exists-p tmp-name2))
264 (should-not (vc-backend tmp-name2))
265 (should (eq (vc-responsible-backend tmp-name2) backend))
266 (should-not (vc-registered tmp-name2))
267
268 (vc-register (list backend (list tmp-name1 tmp-name2)))
269 (should (file-exists-p tmp-name1))
270 (should (eq (vc-backend tmp-name1) backend))
271 (should (eq (vc-responsible-backend tmp-name1) backend))
272 (should (vc-registered tmp-name1))
273
274 (should (file-exists-p tmp-name2))
275 (should (eq (vc-backend tmp-name2) backend))
276 (should (eq (vc-responsible-backend tmp-name2) backend))
277 (should (vc-registered tmp-name2))
278
279 ;; `vc-backend' accepts also a list of files,
280 ;; `vc-responsible-backend' doesn't.
281 (should (vc-backend (list tmp-name1 tmp-name2)))
282
283 ;; Unregister the files.
284 (unless (eq (vc-test--run-maybe-unsupported-function
285 'vc-test--unregister-function backend tmp-name1)
286 'vc-not-supported)
287 (should-not (vc-backend tmp-name1))
288 (should-not (vc-registered tmp-name1)))
289 (unless (eq (vc-test--run-maybe-unsupported-function
290 'vc-test--unregister-function backend tmp-name2)
291 'vc-not-supported)
292 (should-not (vc-backend tmp-name2))
293 (should-not (vc-registered tmp-name2)))
294
295 ;; The files shall still exist.
296 (should (file-exists-p tmp-name1))
297 (should (file-exists-p tmp-name2))))
298
299 ;; Save exit.
300 (ignore-errors (run-hooks 'vc-test--cleanup-hook)))))
301
302 (defun vc-test--state (backend)
303 "Check the different states of a file."
304
305 (let ((vc-handled-backends `(,backend))
306 (default-directory
307 (file-name-as-directory
308 (expand-file-name
309 (make-temp-name "vc-test") temporary-file-directory)))
310 vc-test--cleanup-hook)
311
312 (unwind-protect
313 (progn
314 ;; Cleanup.
315 (add-hook
316 'vc-test--cleanup-hook
317 `(lambda () (delete-directory ,default-directory 'recursive)))
318
319 ;; Create empty repository.
320 (make-directory default-directory)
321 (vc-test--create-repo-function backend)
322
323 (let ((tmp-name (expand-file-name "foo" default-directory)))
324 ;; Check state of a nonexistent file.
325
326 (message "vc-state2 %s" (vc-state tmp-name))
327 (should (null (vc-state tmp-name)))
328
329 ;; Write a new file. Check state.
330 (write-region "foo" nil tmp-name nil 'nomessage)
331
332 (message "vc-state3 %s" (vc-state tmp-name))
333 (should (null (vc-state tmp-name)))
334
335 ;; Register a file. Check state.
336 (vc-register
337 (list backend (list (file-name-nondirectory tmp-name))))
338
339 ;; FIXME: nil is definitely wrong.
340 ;; nil: SRC
341 ;; added: Bzr CVS Git Hg Mtn SVN
342 ;; up-to-date: RCS SCCS
343 (message "vc-state4 %s" (vc-state tmp-name))
344 (should (memq (vc-state tmp-name) '(nil added up-to-date)))
345
346 ;; Unregister the file. Check state.
347 (if (eq (vc-test--run-maybe-unsupported-function
348 'vc-test--unregister-function backend tmp-name)
349 'vc-not-supported)
350 (message "vc-state5 unsupported")
351 ;; nil: Bzr Git Hg RCS
352 ;; unsupported: CVS Mtn SCCS SRC SVN
353 (message "vc-state5 %s" (vc-state tmp-name))
354 (should (null (vc-state tmp-name))))))
355
356 ;; Save exit.
357 (ignore-errors (run-hooks 'vc-test--cleanup-hook)))))
358
359 (defun vc-test--working-revision (backend)
360 "Check the working revision of a repository."
361
362 (let ((vc-handled-backends `(,backend))
363 (default-directory
364 (file-name-as-directory
365 (expand-file-name
366 (make-temp-name "vc-test") temporary-file-directory)))
367 vc-test--cleanup-hook)
368
369 (unwind-protect
370 (progn
371 ;; Cleanup.
372 (add-hook
373 'vc-test--cleanup-hook
374 `(lambda () (delete-directory ,default-directory 'recursive)))
375
376 ;; Create empty repository. Check working revision of
377 ;; repository, should be nil.
378 (make-directory default-directory)
379 (vc-test--create-repo-function backend)
380
381 ;; FIXME: Is the value for SVN correct?
382 ;; nil: Bzr CVS Git Hg Mtn RCS SCCS SRC
383 ;; "0": SVN
384 (message
385 "vc-working-revision1 %s" (vc-working-revision default-directory))
386 (should (member (vc-working-revision default-directory) '(nil "0")))
387
388 (let ((tmp-name (expand-file-name "foo" default-directory)))
389 ;; Check initial working revision, should be nil until
390 ;; it's registered.
391
392 (message "vc-working-revision2 %s" (vc-working-revision tmp-name))
393 (should-not (vc-working-revision tmp-name))
394
395 ;; Write a new file. Check working revision.
396 (write-region "foo" nil tmp-name nil 'nomessage)
397
398 (message "vc-working-revision3 %s" (vc-working-revision tmp-name))
399 (should-not (vc-working-revision tmp-name))
400
401 ;; Register a file. Check working revision.
402 (vc-register
403 (list backend (list (file-name-nondirectory tmp-name))))
404
405 ;; XXX: nil is fine, at least in Git's case, because
406 ;; `vc-register' only makes the file `added' in this case.
407 ;; nil: Git Mtn
408 ;; "0": Bzr CVS Hg SRC SVN
409 ;; "1.1": RCS SCCS
410 (message "vc-working-revision4 %s" (vc-working-revision tmp-name))
411 (should (member (vc-working-revision tmp-name) '(nil "0" "1.1")))
412
413 ;; TODO: Call `vc-checkin', and check the resulting
414 ;; working revision. None of the return values should be
415 ;; nil then.
416
417 ;; Unregister the file. Check working revision.
418 (if (eq (vc-test--run-maybe-unsupported-function
419 'vc-test--unregister-function backend tmp-name)
420 'vc-not-supported)
421 (message "vc-working-revision5 unsupported")
422 ;; nil: Bzr Git Hg RCS
423 ;; unsupported: CVS Mtn SCCS SRC SVN
424 (message "vc-working-revision5 %s" (vc-working-revision tmp-name))
425 (should-not (vc-working-revision tmp-name)))))
426
427 ;; Save exit.
428 (ignore-errors (run-hooks 'vc-test--cleanup-hook)))))
429
430 (defun vc-test--checkout-model (backend)
431 "Check the checkout model of a repository."
432
433 (let ((vc-handled-backends `(,backend))
434 (default-directory
435 (file-name-as-directory
436 (expand-file-name
437 (make-temp-name "vc-test") temporary-file-directory)))
438 vc-test--cleanup-hook)
439
440 (unwind-protect
441 (progn
442 ;; Cleanup.
443 (add-hook
444 'vc-test--cleanup-hook
445 `(lambda () (delete-directory ,default-directory 'recursive)))
446
447 ;; Create empty repository. Check repository checkout model.
448 (make-directory default-directory)
449 (vc-test--create-repo-function backend)
450
451 ;; Surprisingly, none of the backends returns 'announce.
452 ;; implicit: Bzr CVS Git Hg Mtn SRC SVN
453 ;; locking: RCS SCCS
454 (message
455 "vc-checkout-model1 %s"
456 (vc-checkout-model backend default-directory))
457 (should (memq (vc-checkout-model backend default-directory)
458 '(announce implicit locking)))
459
460 (let ((tmp-name (expand-file-name "foo" default-directory)))
461 ;; Check checkout model of a nonexistent file.
462
463 ;; implicit: Bzr CVS Git Hg Mtn SRC SVN
464 ;; locking: RCS SCCS
465 (message
466 "vc-checkout-model2 %s" (vc-checkout-model backend tmp-name))
467 (should (memq (vc-checkout-model backend tmp-name)
468 '(announce implicit locking)))
469
470 ;; Write a new file. Check checkout model.
471 (write-region "foo" nil tmp-name nil 'nomessage)
472
473 ;; implicit: Bzr CVS Git Hg Mtn SRC SVN
474 ;; locking: RCS SCCS
475 (message
476 "vc-checkout-model3 %s" (vc-checkout-model backend tmp-name))
477 (should (memq (vc-checkout-model backend tmp-name)
478 '(announce implicit locking)))
479
480 ;; Register a file. Check checkout model.
481 (vc-register
482 (list backend (list (file-name-nondirectory tmp-name))))
483
484 ;; implicit: Bzr CVS Git Hg Mtn SRC SVN
485 ;; locking: RCS SCCS
486 (message
487 "vc-checkout-model4 %s" (vc-checkout-model backend tmp-name))
488 (should (memq (vc-checkout-model backend tmp-name)
489 '(announce implicit locking)))
490
491 ;; Unregister the file. Check checkout model.
492 (if (eq (vc-test--run-maybe-unsupported-function
493 'vc-test--unregister-function backend tmp-name)
494 'vc-not-supported)
495 (message "vc-checkout-model5 unsupported")
496 ;; implicit: Bzr Git Hg
497 ;; locking: RCS
498 ;; unsupported: CVS Mtn SCCS SRC SVN
499 (message
500 "vc-checkout-model5 %s" (vc-checkout-model backend tmp-name))
501 (should (memq (vc-checkout-model backend tmp-name)
502 '(announce implicit locking))))))
503
504 ;; Save exit.
505 (ignore-errors (run-hooks 'vc-test--cleanup-hook)))))
506
507 ;; Create the test cases.
508
509 (defun vc-test--rcs-enabled ()
510 (executable-find "rcs"))
511
512 (defun vc-test--cvs-enabled ()
513 (executable-find "cvs"))
514
515 (defvar vc-svn-program)
516 (defun vc-test--svn-enabled ()
517 (executable-find vc-svn-program))
518
519 (defun vc-test--sccs-enabled ()
520 (executable-find "sccs"))
521
522 (defvar vc-src-program)
523 (defun vc-test--src-enabled ()
524 (executable-find vc-src-program))
525
526 (defvar vc-bzr-program)
527 (defun vc-test--bzr-enabled ()
528 (executable-find vc-bzr-program))
529
530 (defvar vc-git-program)
531 (defun vc-test--git-enabled ()
532 (executable-find vc-git-program))
533
534 (defvar vc-hg-program)
535 (defun vc-test--hg-enabled ()
536 (executable-find vc-hg-program))
537
538 (defvar vc-mtn-program)
539 (defun vc-test--mtn-enabled ()
540 (executable-find vc-mtn-program))
541
542 ;; Obsoleted.
543 (defvar vc-arch-program)
544 (defun vc-test--arch-enabled ()
545 (executable-find vc-arch-program))
546
547 ;; Create the test cases.
548 (dolist (backend vc-handled-backends)
549 (let ((backend-string (downcase (symbol-name backend))))
550 (require (intern (format "vc-%s" backend-string)))
551 (eval
552 ;; Check, whether the backend is supported.
553 `(when (funcall ',(intern (format "vc-test--%s-enabled" backend-string)))
554
555 (ert-deftest
556 ,(intern (format "vc-test-%s00-create-repo" backend-string)) ()
557 ,(format "Check `vc-create-repo' for the %s backend."
558 backend-string)
559 (vc-test--create-repo ',backend))
560
561 (ert-deftest
562 ,(intern (format "vc-test-%s01-register" backend-string)) ()
563 ,(format
564 "Check `vc-register' and `vc-registered' for the %s backend."
565 backend-string)
566 (skip-unless
567 (ert-test-passed-p
568 (ert-test-most-recent-result
569 (ert-get-test
570 ',(intern
571 (format "vc-test-%s00-create-repo" backend-string))))))
572 (vc-test--register ',backend))
573
574 (ert-deftest
575 ,(intern (format "vc-test-%s02-state" backend-string)) ()
576 ,(format "Check `vc-state' for the %s backend." backend-string)
577 (skip-unless
578 (ert-test-passed-p
579 (ert-test-most-recent-result
580 (ert-get-test
581 ',(intern
582 (format "vc-test-%s01-register" backend-string))))))
583 (vc-test--state ',backend))
584
585 (ert-deftest
586 ,(intern (format "vc-test-%s03-working-revision" backend-string)) ()
587 ,(format "Check `vc-working-revision' for the %s backend."
588 backend-string)
589 (skip-unless
590 (ert-test-passed-p
591 (ert-test-most-recent-result
592 (ert-get-test
593 ',(intern
594 (format "vc-test-%s01-register" backend-string))))))
595 (vc-test--working-revision ',backend))
596
597 (ert-deftest
598 ,(intern (format "vc-test-%s04-checkout-model" backend-string)) ()
599 ,(format "Check `vc-checkout-model' for the %s backend."
600 backend-string)
601 (skip-unless
602 (ert-test-passed-p
603 (ert-test-most-recent-result
604 (ert-get-test
605 ',(intern
606 (format "vc-test-%s01-register" backend-string))))))
607 (vc-test--checkout-model ',backend))))))
608
609 (provide 'vc-tests)
610 ;;; vc-tests.el ends here