1 ;;; vc-tests.el --- Tests of different backends of vc.el
3 ;; Copyright (C) 2014 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
32 ;; STATE-QUERYING FUNCTIONS
34 ;; * registered (file)
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)
42 ;; - latest-on-branch-p (file)
43 ;; * checkout-model (files)
44 ;; - mode-line-string (file)
46 ;; STATE-CHANGING FUNCTIONS
48 ;; * create-repo (backend)
49 ;; * register (files &optional comment)
50 ;; - responsible-p (file)
51 ;; - receive-file (file rev)
52 ;; - unregister (file)
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--create-repo-if-not-supported (backend)
119 "Create a local repository for backends which don't support `vc-create-repo'."
125 (make-temp-name "vc-test") temporary-file-directory
)))
126 (make-directory (expand-file-name "module" tmp-dir
) 'parents
)
127 (make-directory (expand-file-name "CVSROOT" tmp-dir
) 'parents
)
128 (shell-command-to-string (format "cvs -Q -d:local:%s co module" tmp-dir
))
129 (rename-file "module/CVS" default-directory
)
130 (delete-directory "module" 'recursive
)
131 ;; We must cleanup the "remote" CVS repo as well.
132 (add-hook 'vc-test--cleanup-hook
133 `(lambda () (delete-directory ,tmp-dir
'recursive
)))))
136 (let ((archive-name (format "%s--%s" user-mail-address
(random))))
138 "no arch user id set" (shell-command-to-string "tla my-id"))
139 (shell-command-to-string
140 (format "tla my-id \"<%s>\"" user-mail-address
)))
141 (shell-command-to-string
142 (format "tla make-archive %s %s" archive-name default-directory
))
143 (shell-command-to-string
144 (format "tla my-default-archive %s" archive-name
))))
147 (let ((archive-name "foo.mtn"))
148 (shell-command-to-string
150 "mtn db init --db=%s"
151 (expand-file-name archive-name default-directory
)))
152 (shell-command-to-string
153 (format "mtn --db=%s --branch=foo setup ." archive-name
))))
155 (t (signal 'vc-not-supported
(list 'create-repo backend
)))))
157 (defun vc-test--create-repo (backend)
158 "Create a test repository in `default-directory', a temporary directory."
160 (let ((vc-handled-backends `(,backend
))
162 (file-name-as-directory
164 (make-temp-name "vc-test") temporary-file-directory
)))
165 vc-test--cleanup-hook
)
171 'vc-test--cleanup-hook
172 `(lambda () (delete-directory ,default-directory
'recursive
)))
174 ;; Create empty repository.
175 (make-directory default-directory
)
176 (should (file-directory-p default-directory
))
178 (vc-create-repo backend
)
179 ;; CVS, Mtn and Arch need special handling.
180 (vc-not-supported (vc-test--create-repo-if-not-supported backend
))))
183 (ignore-errors (run-hooks 'vc-test--cleanup-hook
)))))
185 (defun vc-test--unregister-function (backend)
186 "Return the `vc-unregister' backend function."
188 (let ((symbol (intern (downcase (format "vc-%s-unregister" backend
)))))
189 (if (functionp symbol
)
191 (signal 'vc-not-supported
(list 'unregister backend
)))))
193 (defun vc-test--register (backend)
194 "Register and unregister a file."
196 (let ((vc-handled-backends `(,backend
))
198 (file-name-as-directory
200 (make-temp-name "vc-test") temporary-file-directory
)))
201 vc-test--cleanup-hook
)
207 'vc-test--cleanup-hook
208 `(lambda () (delete-directory ,default-directory
'recursive
)))
210 ;; Create empty repository.
211 (make-directory default-directory
)
213 (vc-create-repo backend
)
214 ;; CVS, Mtn and Arch need special handling.
215 (vc-not-supported (vc-test--create-repo-if-not-supported backend
)))
217 (let ((tmp-name1 (expand-file-name "foo" default-directory
))
219 ;; Register files. Check for it.
220 (write-region "foo" nil tmp-name1 nil
'nomessage
)
221 (should (file-exists-p tmp-name1
))
222 (should-not (vc-registered tmp-name1
))
223 (write-region "bla" nil tmp-name2 nil
'nomessage
)
224 (should (file-exists-p tmp-name2
))
225 (should-not (vc-registered tmp-name2
))
227 (list backend
(list tmp-name1 tmp-name2
)))
228 (should (vc-registered tmp-name1
))
229 (should (vc-registered tmp-name2
))
231 ;; Unregister the file2. Why isn't there `vc-unregister'?
234 (funcall (vc-test--unregister-function backend
) tmp-name1
)
235 (should-not (vc-registered tmp-name1
))
236 (funcall (vc-test--unregister-function backend
) tmp-name2
)
237 (should-not (vc-registered tmp-name2
)))
238 ;; CVS, SVN, SCCS, SRC and Mtn are not supported.
239 (vc-not-supported (message "%s" (error-message-string err
))))))
242 (ignore-errors (run-hooks 'vc-test--cleanup-hook
)))))
244 ;; `vc-state' returns different results for different backends. So we
245 ;; don't check with `should', but print the results for analysis.
246 (defun vc-test--state (backend)
247 "Check the different states of a file."
249 (let ((vc-handled-backends `(,backend
))
251 (file-name-as-directory
253 (make-temp-name "vc-test") temporary-file-directory
)))
254 vc-test--cleanup-hook errors
)
260 'vc-test--cleanup-hook
261 `(lambda () (delete-directory ,default-directory
'recursive
)))
263 ;; Create empty repository.
264 (make-directory default-directory
)
266 (vc-create-repo backend
)
267 ;; CVS, Mtn and Arch need special handling.
268 (vc-not-supported (vc-test--create-repo-if-not-supported backend
)))
270 (message "%s" (vc-state default-directory backend
))
271 ;(should (eq (vc-state default-directory backend) 'up-to-date))
273 (let ((tmp-name (expand-file-name "foo" default-directory
)))
274 ;; Check for initial state.
275 (message "%s" (vc-state tmp-name backend
))
276 ;(should (eq (vc-state tmp-name backend) 'unregistered))
278 ;; Write a new file. Check for state.
279 (write-region "foo" nil tmp-name nil
'nomessage
)
280 (message "%s" (vc-state tmp-name backend
))
281 ;(should (eq (vc-state tmp-name backend) 'unregistered))
283 ;; Register a file. Check for state.
285 (list backend
(list (file-name-nondirectory tmp-name
))))
286 (message "%s" (vc-state tmp-name backend
))
287 ;(should (eq (vc-state tmp-name backend) 'added))
289 ;; Unregister the file. Check for state.
292 (funcall (vc-test--unregister-function backend
) tmp-name
)
293 (message "%s" (vc-state tmp-name backend
))
294 );(should (eq (vc-state tmp-name backend) 'unregistered)))
295 ;; CVS, SVN, SCCS, SRC and Mtn are not supported.
296 (vc-not-supported (message "%s" 'unsupported
)))))
299 (ignore-errors (run-hooks 'vc-test--cleanup-hook
)))))
301 ;; Create the test cases.
303 (defun vc-test--rcs-enabled ()
304 (executable-find "rcs"))
306 (defun vc-test--cvs-enabled ()
307 (executable-find "cvs"))
309 (defvar vc-svn-program
)
310 (defun vc-test--svn-enabled ()
311 (executable-find vc-svn-program
))
313 (defun vc-test--sccs-enabled ()
314 (executable-find "sccs"))
316 (defvar vc-src-program
)
317 (defun vc-test--src-enabled ()
318 (executable-find vc-src-program
))
320 (defvar vc-bzr-program
)
321 (defun vc-test--bzr-enabled ()
322 (executable-find vc-bzr-program
))
324 (defvar vc-git-program
)
325 (defun vc-test--git-enabled ()
326 (executable-find vc-git-program
))
328 (defvar vc-hg-program
)
329 (defun vc-test--hg-enabled ()
330 (executable-find vc-hg-program
))
332 (defvar vc-mtn-program
)
333 (defun vc-test--mtn-enabled ()
334 (executable-find vc-mtn-program
))
336 (defvar vc-arch-program
)
337 (defun vc-test--arch-enabled ()
338 (executable-find vc-arch-program
))
341 ;; There are too many failed test cases yet. We suppress them on hydra.
342 (if (getenv "NIX_STORE")
343 (ert-deftest vc-test
()
344 "Dummy test case for hydra."
347 ;; Create the test cases.
348 (dolist (backend vc-handled-backends
)
349 (let ((backend-string (downcase (symbol-name backend
))))
350 (require (intern (format "vc-%s" backend-string
)))
352 ;; Check, whether the backend is supported.
353 `(when (funcall ',(intern (format "vc-test--%s-enabled" backend-string
)))
356 ,(intern (format "vc-test-%s00-create-repo" backend-string
)) ()
357 ,(format "Check `vc-create-repo' for the %s backend." backend-string
)
358 (vc-test--create-repo ',backend
))
361 ,(intern (format "vc-test-%s01-register" backend-string
)) ()
363 "Check `vc-register' and `vc-registered' for the %s backend."
367 (ert-test-most-recent-result
370 (format "vc-test-%s00-create-repo" backend-string
))))))
371 (vc-test--register ',backend
))
374 ,(intern (format "vc-test-%s02-state" backend-string
)) ()
375 ,(format "Check `vc-state' for the %s backend." backend-string
)
378 (ert-test-most-recent-result
381 (format "vc-test-%s01-register" backend-string
))))))
382 (vc-test--state ',backend
)))))))
385 ;;; vc-tests.el ends here