code.delx.au - gnu-emacs/blob - test/automated/vc-tests.el

   1 ;;; vc-tests.el --- Tests of different backends of vc.el
   2
   3 ;; Copyright (C) 2014-2015 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 ;; 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--revision-granularity-function (backend)
 119   "Run the `vc-revision-granularity' backend function."
 120   (funcall (intern (downcase (format "vc-%s-revision-granularity" backend)))))
 121
 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."
 125
 126   (cond
 127    ((eq backend 'CVS)
 128     (let ((tmp-dir
 129            (expand-file-name
 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)))))
 139
 140    ((eq backend 'Arch)
 141     (let ((archive-name (format "%s--%s" user-mail-address (random))))
 142       (when (string-match
 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))))
 150
 151    ((eq backend 'Mtn)
 152     (let ((archive-name "foo.mtn"))
 153       (shell-command-to-string
 154        (format
 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))))
 159
 160    (t (vc-create-repo backend))))
 161
 162 (defun vc-test--create-repo (backend)
 163   "Create a test repository in `default-directory', a temporary directory."
 164
 165   (let ((vc-handled-backends `(,backend))
 166         (default-directory
 167           (file-name-as-directory
 168            (expand-file-name
 169             (make-temp-name "vc-test") temporary-file-directory)))
 170         vc-test--cleanup-hook)
 171
 172     (unwind-protect
 173         (progn
 174           ;; Cleanup.
 175           (add-hook
 176            'vc-test--cleanup-hook
 177            `(lambda () (delete-directory ,default-directory 'recursive)))
 178
 179           ;; Check the revision granularity.
 180           (should (memq (vc-test--revision-granularity-function backend)
 181                         '(file repository)))
 182
 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)))
 188
 189       ;; Save exit.
 190       (ignore-errors (run-hooks 'vc-test--cleanup-hook)))))
 191
 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."
 196
 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)))))
 202
 203 (defun vc-test--register (backend)
 204   "Register and unregister a file."
 205
 206   (let ((vc-handled-backends `(,backend))
 207         (default-directory
 208           (file-name-as-directory
 209            (expand-file-name
 210             (make-temp-name "vc-test") temporary-file-directory)))
 211         vc-test--cleanup-hook)
 212
 213     (unwind-protect
 214         (progn
 215           ;; Cleanup.
 216           (add-hook
 217            'vc-test--cleanup-hook
 218            `(lambda () (delete-directory ,default-directory 'recursive)))
 219
 220           ;; Create empty repository.
 221           (make-directory default-directory)
 222           (vc-test--create-repo-function backend)
 223
 224           (let ((tmp-name1 (expand-file-name "foo" default-directory))
 225                 (tmp-name2 "bla"))
 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))
 238
 239             ;; Unregister the files.
 240             (condition-case err
 241                 (progn
 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))))
 251
 252       ;; Save exit.
 253       (ignore-errors (run-hooks 'vc-test--cleanup-hook)))))
 254
 255 (defun vc-test--state (backend)
 256   "Check the different states of a file."
 257
 258   (let ((vc-handled-backends `(,backend))
 259         (default-directory
 260           (file-name-as-directory
 261            (expand-file-name
 262             (make-temp-name "vc-test") temporary-file-directory)))
 263         vc-test--cleanup-hook)
 264
 265     (unwind-protect
 266         (progn
 267           ;; Cleanup.
 268           (add-hook
 269            'vc-test--cleanup-hook
 270            `(lambda () (delete-directory ,default-directory 'recursive)))
 271
 272           ;; Create empty repository.  Check repository state.
 273           (make-directory default-directory)
 274           (vc-test--create-repo-function backend)
 275
 276           ;; nil: Hg Mtn RCS
 277           ;; added: Git
 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)))
 284
 285           (let ((tmp-name (expand-file-name "foo" default-directory)))
 286             ;; Check state of an empty file.
 287
 288             ;; nil: Hg Mtn SRC SVN
 289             ;; added: Git
 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)))
 295
 296             ;; Write a new file.  Check state.
 297             (write-region "foo" nil tmp-name nil 'nomessage)
 298
 299             ;; nil: Mtn
 300             ;; added: Git
 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)))
 306
 307             ;; Register a file.  Check state.
 308             (vc-register
 309              (list backend (list (file-name-nondirectory tmp-name))))
 310
 311             ;; added: Git Mtn
 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)))
 316
 317             ;; Unregister the file.  Check state.
 318             (condition-case nil
 319                 (progn
 320                   (vc-test--unregister-function backend tmp-name)
 321
 322                   ;; added: Git
 323                   ;; unregistered: Hg
 324                   ;; unsupported: CVS Mtn SCCS SRC SVN
 325                   ;; up-to-date: Bzr
 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))))
 330
 331       ;; Save exit.
 332       (ignore-errors (run-hooks 'vc-test--cleanup-hook)))))
 333
 334 (defun vc-test--working-revision (backend)
 335   "Check the working revision of a repository."
 336
 337   (let ((vc-handled-backends `(,backend))
 338         (default-directory
 339           (file-name-as-directory
 340            (expand-file-name
 341             (make-temp-name "vc-test") temporary-file-directory)))
 342         vc-test--cleanup-hook)
 343
 344     (unwind-protect
 345         (progn
 346           ;; Cleanup.
 347           (add-hook
 348            'vc-test--cleanup-hook
 349            `(lambda () (delete-directory ,default-directory 'recursive)))
 350
 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)
 355
 356           ;; nil: CVS Mtn RCS SCCS
 357           ;; "0": Bzr Hg SRC SVN
 358           ;; "master": Git
 359           (should (eq (vc-working-revision default-directory)
 360                       (vc-working-revision default-directory backend)))
 361           (should
 362            (member
 363             (vc-working-revision default-directory) '(nil "0" "master")))
 364
 365           (let ((tmp-name (expand-file-name "foo" default-directory)))
 366             ;; Check initial working revision, should be nil until
 367             ;; it's registered.
 368
 369             ;; nil: CVS Mtn RCS SCCS SVN
 370             ;; "0": Bzr Hg SRC
 371             ;; "master": Git
 372             (should (eq (vc-working-revision tmp-name)
 373                         (vc-working-revision tmp-name backend)))
 374             (should
 375              (member (vc-working-revision tmp-name) '(nil "0" "master")))
 376
 377             ;; Write a new file.  Check working revision.
 378             (write-region "foo" nil tmp-name nil 'nomessage)
 379
 380             ;; nil: CVS Mtn RCS SCCS SVN
 381             ;; "0": Bzr Hg SRC
 382             ;; "master": Git
 383             (should (eq (vc-working-revision tmp-name)
 384                         (vc-working-revision tmp-name backend)))
 385             (should
 386              (member (vc-working-revision tmp-name) '(nil "0" "master")))
 387
 388             ;; Register a file.  Check working revision.
 389             (vc-register
 390              (list backend (list (file-name-nondirectory tmp-name))))
 391
 392             ;; nil: Mtn RCS SCCS
 393             ;; "0": Bzr CVS Hg SRC SVN
 394             ;; "master": Git
 395             (should (eq (vc-working-revision tmp-name)
 396                         (vc-working-revision tmp-name backend)))
 397             (should
 398              (member (vc-working-revision tmp-name) '(nil "0" "master")))
 399
 400             ;; Unregister the file.  Check working revision.
 401             (condition-case nil
 402                 (progn
 403                   (vc-test--unregister-function backend tmp-name)
 404
 405                   ;; nil: RCS
 406                   ;; "0": Bzr Hg
 407                   ;; "master": Git
 408                   ;; unsupported: CVS Mtn SCCS SRC SVN
 409                   (should (eq (vc-working-revision tmp-name)
 410                               (vc-working-revision tmp-name backend)))
 411                   (should
 412                    (member
 413                     (vc-working-revision tmp-name) '(nil "0" "master"))))
 414               (vc-not-supported t))))
 415
 416       ;; Save exit.
 417       (ignore-errors (run-hooks 'vc-test--cleanup-hook)))))
 418
 419 (defun vc-test--checkout-model (backend)
 420   "Check the checkout model of a repository."
 421
 422   (let ((vc-handled-backends `(,backend))
 423         (default-directory
 424           (file-name-as-directory
 425            (expand-file-name
 426             (make-temp-name "vc-test") temporary-file-directory)))
 427         vc-test--cleanup-hook)
 428
 429     (unwind-protect
 430         (progn
 431           ;; Cleanup.
 432           (add-hook
 433            'vc-test--cleanup-hook
 434            `(lambda () (delete-directory ,default-directory 'recursive)))
 435
 436           ;; Create empty repository.  Check repository checkout model.
 437           (make-directory default-directory)
 438           (vc-test--create-repo-function backend)
 439
 440           ;; Surprisingly, none of the backends returns 'announce.
 441           ;; nil: RCS
 442           ;; implicit: Bzr CVS Git Hg Mtn SRC SVN
 443           ;; locking: SCCS
 444           (should (memq (vc-checkout-model backend default-directory)
 445                         '(announce implicit locking)))
 446
 447           (let ((tmp-name (expand-file-name "foo" default-directory)))
 448             ;; Check checkout model of an empty file.
 449
 450             ;; nil: RCS
 451             ;; implicit: Bzr CVS Git Hg Mtn SRC SVN
 452             ;; locking: SCCS
 453             (should (memq (vc-checkout-model backend tmp-name)
 454                           '(announce implicit locking)))
 455
 456             ;; Write a new file.  Check checkout model.
 457             (write-region "foo" nil tmp-name nil 'nomessage)
 458
 459             ;; nil: RCS
 460             ;; implicit: Bzr CVS Git Hg Mtn SRC SVN
 461             ;; locking: SCCS
 462             (should (memq (vc-checkout-model backend tmp-name)
 463                           '(announce implicit locking)))
 464
 465             ;; Register a file.  Check checkout model.
 466             (vc-register
 467              (list backend (list (file-name-nondirectory tmp-name))))
 468
 469             ;; nil: RCS
 470             ;; implicit: Bzr CVS Git Hg Mtn SRC SVN
 471             ;; locking: SCCS
 472             (should (memq (vc-checkout-model backend tmp-name)
 473                           '(announce implicit locking)))
 474
 475             ;; Unregister the file.  Check checkout model.
 476             (condition-case nil
 477                 (progn
 478                   (vc-test--unregister-function backend tmp-name)
 479
 480                   ;; nil: RCS
 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))))
 486
 487       ;; Save exit.
 488       (ignore-errors (run-hooks 'vc-test--cleanup-hook)))))
 489
 490 ;; Create the test cases.
 491
 492 (defun vc-test--rcs-enabled ()
 493   (executable-find "rcs"))
 494
 495 (defun vc-test--cvs-enabled ()
 496   (executable-find "cvs"))
 497
 498 (defvar vc-svn-program)
 499 (defun vc-test--svn-enabled ()
 500   (executable-find vc-svn-program))
 501
 502 (defun vc-test--sccs-enabled ()
 503   (executable-find "sccs"))
 504
 505 (defvar vc-src-program)
 506 (defun vc-test--src-enabled ()
 507   (executable-find vc-src-program))
 508
 509 (defvar vc-bzr-program)
 510 (defun vc-test--bzr-enabled ()
 511   (executable-find vc-bzr-program))
 512
 513 (defvar vc-git-program)
 514 (defun vc-test--git-enabled ()
 515   (executable-find vc-git-program))
 516
 517 (defvar vc-hg-program)
 518 (defun vc-test--hg-enabled ()
 519   (executable-find vc-hg-program))
 520
 521 (defvar vc-mtn-program)
 522 (defun vc-test--mtn-enabled ()
 523   (executable-find vc-mtn-program))
 524
 525 ;; Obsoleted.
 526 (defvar vc-arch-program)
 527 (defun vc-test--arch-enabled ()
 528   (executable-find vc-arch-program))
 529
 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."
 534       (ert-pass))
 535
 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)))
 540       (eval
 541        ;; Check, whether the backend is supported.
 542        `(when (funcall ',(intern (format "vc-test--%s-enabled" backend-string)))
 543
 544           (ert-deftest
 545               ,(intern (format "vc-test-%s00-create-repo" backend-string)) ()
 546             ,(format "Check `vc-create-repo' for the %s backend."
 547                      backend-string)
 548             (vc-test--create-repo ',backend))
 549
 550           (ert-deftest
 551               ,(intern (format "vc-test-%s01-register" backend-string)) ()
 552             ,(format
 553               "Check `vc-register' and `vc-registered' for the %s backend."
 554               backend-string)
 555             (skip-unless
 556              (ert-test-passed-p
 557               (ert-test-most-recent-result
 558                (ert-get-test
 559                 ',(intern
 560                    (format "vc-test-%s00-create-repo" backend-string))))))
 561             (vc-test--register ',backend))
 562
 563           (ert-deftest
 564               ,(intern (format "vc-test-%s02-state" backend-string)) ()
 565             ,(format "Check `vc-state' for the %s backend." 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-%s01-register" backend-string))))))
 572             (vc-test--state ',backend))
 573
 574           (ert-deftest
 575               ,(intern (format "vc-test-%s03-working-revision" backend-string)) ()
 576             ,(format "Check `vc-working-revision' for the %s backend."
 577                      backend-string)
 578             (skip-unless
 579              (ert-test-passed-p
 580               (ert-test-most-recent-result
 581                (ert-get-test
 582                 ',(intern
 583                    (format "vc-test-%s01-register" backend-string))))))
 584             (vc-test--working-revision ',backend))
 585
 586           (ert-deftest
 587               ,(intern (format "vc-test-%s04-checkout-model" backend-string)) ()
 588             ,(format "Check `vc-checkout-model' for the %s backend."
 589                      backend-string)
 590             (skip-unless
 591              (ert-test-passed-p
 592               (ert-test-most-recent-result
 593                (ert-get-test
 594                 ',(intern
 595                    (format "vc-test-%s01-register" backend-string))))))
 596             (vc-test--checkout-model ',backend)))))))
 597
 598 (provide 'vc-tests)
 599 ;;; vc-tests.el ends here