test/automated/vc-tests.el

   1 ;;; vc-tests.el --- Tests of different backends of vc.el
   2
   3 ;; Copyright (C) 2014 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
  31
  32 ;; STATE-QUERYING FUNCTIONS
  33 ;;
  34 ;; * registered (file)
  35 ;; * state (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)
  45
  46 ;; STATE-CHANGING FUNCTIONS
  47 ;;
  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)
  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 ;; The working horses.
 113
 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.")
 117
 118 (defun vc-test--create-repo-if-not-supported (backend)
 119   "Create a local repository for backends which don't support `vc-create-repo'."
 120
 121   (cond
 122    ((eq backend 'CVS)
 123     (let ((tmp-dir
 124            (expand-file-name
 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)))))
 134
 135    ((eq backend 'Arch)
 136     (let ((archive-name (format "%s--%s" user-mail-address (random))))
 137       (when (string-match
 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))))
 145
 146    ((eq backend 'Mtn)
 147     (let ((archive-name "foo.mtn"))
 148       (shell-command-to-string
 149        (format
 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))))
 154
 155    (t (signal 'vc-not-supported (list 'create-repo backend)))))
 156
 157 (defun vc-test--create-repo (backend)
 158   "Create a test repository in `default-directory', a temporary directory."
 159
 160   (let ((vc-handled-backends `(,backend))
 161         (default-directory
 162           (file-name-as-directory
 163            (expand-file-name
 164             (make-temp-name "vc-test") temporary-file-directory)))
 165         vc-test--cleanup-hook)
 166
 167     (unwind-protect
 168         (progn
 169           ;; Cleanup.
 170           (add-hook
 171            'vc-test--cleanup-hook
 172            `(lambda () (delete-directory ,default-directory 'recursive)))
 173
 174           ;; Create empty repository.
 175           (make-directory default-directory)
 176           (should (file-directory-p default-directory))
 177           (condition-case err
 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))))
 181
 182       ;; Save exit.
 183       (ignore-errors (run-hooks 'vc-test--cleanup-hook)))))
 184
 185 (defun vc-test--unregister-function (backend)
 186   "Return the `vc-unregister' backend function."
 187
 188   (let ((symbol (intern (downcase (format "vc-%s-unregister" backend)))))
 189     (if (functionp symbol)
 190         symbol
 191       (signal 'vc-not-supported (list 'unregister backend)))))
 192
 193 (defun vc-test--register (backend)
 194   "Register and unregister a file."
 195
 196   (let ((vc-handled-backends `(,backend))
 197         (default-directory
 198           (file-name-as-directory
 199            (expand-file-name
 200             (make-temp-name "vc-test") temporary-file-directory)))
 201         vc-test--cleanup-hook)
 202
 203     (unwind-protect
 204         (progn
 205           ;; Cleanup.
 206           (add-hook
 207            'vc-test--cleanup-hook
 208            `(lambda () (delete-directory ,default-directory 'recursive)))
 209
 210           ;; Create empty repository.
 211           (make-directory default-directory)
 212           (condition-case err
 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)))
 216
 217           (let ((tmp-name1 (expand-file-name "foo" default-directory))
 218                 (tmp-name2 "bla"))
 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))
 226             (vc-register
 227              (list backend (list tmp-name1 tmp-name2)))
 228             (should (vc-registered tmp-name1))
 229             (should (vc-registered tmp-name2))
 230
 231             ;; Unregister the file2.  Why isn't there `vc-unregister'?
 232             (condition-case err
 233                 (progn
 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))))))
 240
 241       ;; Save exit.
 242       (ignore-errors (run-hooks 'vc-test--cleanup-hook)))))
 243
 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."
 248
 249   (let ((vc-handled-backends `(,backend))
 250         (default-directory
 251           (file-name-as-directory
 252            (expand-file-name
 253             (make-temp-name "vc-test") temporary-file-directory)))
 254         vc-test--cleanup-hook errors)
 255
 256     (unwind-protect
 257         (progn
 258           ;; Cleanup.
 259           (add-hook
 260            'vc-test--cleanup-hook
 261            `(lambda () (delete-directory ,default-directory 'recursive)))
 262
 263           ;; Create empty repository.
 264           (make-directory default-directory)
 265           (condition-case err
 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)))
 269
 270           (message "%s" (vc-state default-directory backend))
 271           ;(should (eq (vc-state default-directory backend) 'up-to-date))
 272
 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))
 277
 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))
 282
 283             ;; Register a file.  Check for state.
 284             (vc-register
 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))
 288
 289             ;; Unregister the file.  Check for state.
 290             (condition-case nil
 291                 (progn
 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)))))
 297
 298       ;; Save exit.
 299       (ignore-errors (run-hooks 'vc-test--cleanup-hook)))))
 300
 301 ;; Create the test cases.
 302
 303 (defun vc-test--rcs-enabled ()
 304   (executable-find "rcs"))
 305
 306 (defun vc-test--cvs-enabled ()
 307   (executable-find "cvs"))
 308
 309 (defvar vc-svn-program)
 310 (defun vc-test--svn-enabled ()
 311   (executable-find vc-svn-program))
 312
 313 (defun vc-test--sccs-enabled ()
 314   (executable-find "sccs"))
 315
 316 (defvar vc-src-program)
 317 (defun vc-test--src-enabled ()
 318   (executable-find vc-src-program))
 319
 320 (defvar vc-bzr-program)
 321 (defun vc-test--bzr-enabled ()
 322   (executable-find vc-bzr-program))
 323
 324 (defvar vc-git-program)
 325 (defun vc-test--git-enabled ()
 326   (executable-find vc-git-program))
 327
 328 (defvar vc-hg-program)
 329 (defun vc-test--hg-enabled ()
 330   (executable-find vc-hg-program))
 331
 332 (defvar vc-mtn-program)
 333 (defun vc-test--mtn-enabled ()
 334   (executable-find vc-mtn-program))
 335
 336 (defvar vc-arch-program)
 337 (defun vc-test--arch-enabled ()
 338   (executable-find vc-arch-program))
 339
 340
 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."
 345       (ert-pass))
 346
 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)))
 351       (eval
 352        ;; Check, whether the backend is supported.
 353        `(when (funcall ',(intern (format "vc-test--%s-enabled" backend-string)))
 354
 355           (ert-deftest
 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))
 359
 360           (ert-deftest
 361               ,(intern (format "vc-test-%s01-register" backend-string)) ()
 362             ,(format
 363               "Check `vc-register' and `vc-registered' for the %s backend."
 364               backend-string)
 365             (skip-unless
 366              (ert-test-passed-p
 367               (ert-test-most-recent-result
 368                (ert-get-test
 369                 ',(intern
 370                    (format "vc-test-%s00-create-repo" backend-string))))))
 371             (vc-test--register ',backend))
 372
 373           (ert-deftest
 374               ,(intern (format "vc-test-%s02-state" backend-string)) ()
 375             ,(format "Check `vc-state' for the %s backend." backend-string)
 376             (skip-unless
 377              (ert-test-passed-p
 378               (ert-test-most-recent-result
 379                (ert-get-test
 380                 ',(intern
 381                    (format "vc-test-%s01-register" backend-string))))))
 382             (vc-test--state ',backend)))))))
 383
 384 (provide 'vc-tests)
 385 ;;; vc-tests.el ends here