nxhtml/tests/ert.el

   1 ;;; ert.el --- Emacs Lisp Regression Testing
   2
   3 ;; Modified by Lennart Borgman 2008-07-13 to make all global symbols
   4 ;; use the "ert-" prefix.
   5
   6 ;; Copyright (C) 2007, 2008 Christian M. Ohler
   7
   8 ;; Author: Christian M. Ohler
   9 ;; Version: 0.2
  10 ;; Keywords: lisp, tools
  11
  12 ;; This file is NOT part of GNU Emacs.
  13
  14 ;; This program is free software: you can redistribute it and/or
  15 ;; modify it under the terms of the GNU General Public License as
  16 ;; published by the Free Software Foundation, either version 3 of the
  17 ;; License, or (at your option) any later version.
  18 ;;
  19 ;; This program is distributed in the hope that it will be useful, but
  20 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  21 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  22 ;; General Public License for more details.
  23 ;;
  24 ;; You should have received a copy of the GNU General Public License
  25 ;; along with this program.  If not, see `http://www.gnu.org/licenses/'.
  26
  27 ;;; Commentary:
  28
  29 ;; ERT is a tool for automated testing in Emacs Lisp.  Its main
  30 ;; features are facilities for defining and running test cases and
  31 ;; reporting the results as well as for debugging test failures
  32 ;; interactively.
  33 ;;
  34 ;; The main entry points are `ert-deftest', which is similar to
  35 ;; `defun' but defines a test, and `ert-run-tests-interactively',
  36 ;; which runs tests and offers an interactive interface for inspecting
  37 ;; results and debugging.  There is also `ert-run-tests-batch' for
  38 ;; non-interactive use.
  39 ;;
  40 ;; The body of `ert-deftest' forms resembles a function body, but the
  41 ;; additional operators `should', `should-not' and `should-error' are
  42 ;; available.  `should' is similar to cl's `assert', but signals a
  43 ;; different error when its condition is violated that is caught and
  44 ;; processed by ERT.  In addition, it analyzes its argument form and
  45 ;; records information that helps debugging (`assert' tries to do
  46 ;; something similar when its second argument SHOW-ARGS is true, but
  47 ;; `should' is more sophisticated).  For information on `should-not'
  48 ;; and `should-error', see their docstrings.
  49 ;;
  50 ;; For example,
  51 ;;
  52 ;;     ;; Define a test named `foo'.
  53 ;;     (ert-deftest foo ()
  54 ;;       (ert-should (= (+ 1 2) 4)))
  55 ;;
  56 ;;     ;; Run it.
  57 ;;     (ert-run-tests-interactively 'foo)
  58 ;;
  59 ;; generates the following output (in addition to some statistics) in
  60 ;; the *ert* results buffer:
  61 ;;
  62 ;;     F foo
  63 ;;         (ert-test-failed
  64 ;;          ((ert-should
  65 ;;            (=
  66 ;;             (+ 1 2)
  67 ;;             4))
  68 ;;           :form
  69 ;;           (= 3 4)
  70 ;;           :value nil))
  71 ;;
  72 ;; This indicates that the test failed.  The `should' form that failed
  73 ;; was (ert-should (= (+ 1 2) 4)), because its inner form, after
  74 ;; evaluation of its arguments, was the function call (= 3 4), which
  75 ;; returned nil.
  76 ;;
  77 ;; Obviously, this is a bug in the test case, not in the functions `+'
  78 ;; or `='.  In the results buffer, with point on the test result, the
  79 ;; key "." can be used to jump to the definition of the test to modify
  80 ;; it to correct the bug.  After evaluating the modified definition
  81 ;; and switching back to the results buffer, the key "r" will re-run
  82 ;; the test and show the new result.
  83
  84
  85 ;; Test selectors
  86 ;;
  87 ;; Functions like `ert-run-tests-interactively' accept a test
  88 ;; selector, which is a Lisp expression specifying a set of tests.
  89 ;; Each test name is a selector that refers to that test, the selector
  90 ;; `t' refers to all tests, and the selector `:failed' refers to all
  91 ;; tests that failed; but more complex selectors are available.  Test
  92 ;; selector syntax is similar to cl's type specifier syntax.  See the
  93 ;; docstring of `ert-select-tests' for details.
  94
  95
  96 ;; Comparison with other testing tools
  97 ;;
  98 ;; ERT allows test-driven development similar to *Unit frameworks for
  99 ;; other languages.  However, two common *Unit features are notably
 100 ;; absent from ERT: fixtures and test suites.
 101 ;;
 102 ;; Fixtures, as used e.g. in SUnit or JUnit, have two main purposes:
 103 ;; Setting up (and tearing down) an environment for a set of test
 104 ;; cases, and making that environment accessible through object
 105 ;; attributes that can be used like local variables.
 106 ;;
 107 ;; While fixtures are a great syntactic simplification in other
 108 ;; languages, they are not very useful in Lisp, where higher-order
 109 ;; functions and `unwind-protect' are available.  One way to implement
 110 ;; and use a fixture in ERT is
 111 ;;
 112 ;;    (defun my-fixture (body)
 113 ;;      (unwind-protect
 114 ;;          (progn ...set up...
 115 ;;                 (funcall body))
 116 ;;        ...tear down...))
 117 ;;
 118 ;;    (ert-deftest my-test ()
 119 ;;      (my-fixture
 120 ;;       (lambda ()
 121 ;;         ...test code...)))
 122 ;;
 123 ;; (Another way would be a `with-my-fixture' macro.)  This solves the
 124 ;; set-up and tear-down part, and additionally allows any test case to
 125 ;; use any combination of fixtures, so it is more general than what
 126 ;; other tools typically allow.
 127 ;;
 128 ;; If the test case needs access to the environment the fixture sets
 129 ;; up, the fixture can be modified to pass arguments to the body.
 130 ;;
 131 ;; These are standard Lisp idioms.  Special syntax for them could be
 132 ;; added easily enough, but would provide only a minor simplification.
 133 ;;
 134 ;; (Note that splitting set-up and tear-down into separate functions,
 135 ;; like *Unit tools usually do, makes it impossible to establish
 136 ;; dynamic `let' bindings as part of the fixture.  So, blindly
 137 ;; imitating the way fixtures are implemented in other languages would
 138 ;; be counter-productive in Lisp.)
 139 ;;
 140 ;;
 141 ;; The purpose of test suites is to group related test cases together.
 142 ;; The most common use of this is to run just the tests for one
 143 ;; particular module.  Since symbol prefixes are the usual way of
 144 ;; separating module namespaces in Emacs Lisp, test selectors already
 145 ;; solve this by allowing regexp matching on test names; e.g., the
 146 ;; selector "^ert-" selects ERT's self-tests.
 147 ;;
 148 ;; If test suites containing arbitrary sets of tests are found to be
 149 ;; desirable, it would be easy to add a `define-test-selector'
 150 ;; mechanism that introduces a new selector, defined in terms of
 151 ;; existing ones; e.g.
 152 ;;
 153 ;;     ;; Note that `define-test-selector' does not exist yet.
 154 ;;     (define-test-selector my-test-suite () `(member foo-test bar-test))
 155 ;;
 156 ;; would define a test suite named `my-test-suite' consisting of
 157 ;; `foo-test' and `bar-test'.  See also `deftype' in Common Lisp.
 158
 159
 160 ;; TODO: Add `skip' feature for tests that can't run in current environment.
 161
 162
 163 ;;; Code:
 164
 165 (eval-when-compile (require 'cl))
 166 (require 'ewoc)
 167 (require 'find-func)
 168 (require 'debug)
 169
 170 (defvar ert-debug-on-error nil
 171   "Non-nil means enter debugger when a test fails or terminates with an error.")
 172
 173
 174 ;;; Defining and locating tests.
 175
 176 ;; The data structure that represents a test case.
 177 (defstruct ert-test
 178   (name nil)
 179   (documentation nil)
 180   (body (assert nil))
 181   (most-recent-result nil)
 182   (expected-result-type 'ert-test-passed))
 183
 184 (defun ert-test-boundp (symbol)
 185   "Return non-nil if SYMBOL names a test."
 186   (and (get symbol 'ert-test) t))
 187
 188 (defun ert-get-test (symbol)
 189   "If SYMBOL names a test, return that.  Signal an error otherwise."
 190   (assert (ert-test-boundp symbol) t)
 191   (get symbol 'ert-test))
 192
 193 (defun ert-set-test (symbol doc definition)
 194   "Make SYMBOL name the test DEFINITION, and return DEFINITION."
 195   (when doc
 196     (put symbol 'ert-test-documentation doc))
 197   (put symbol 'ert-test definition)
 198   definition)
 199
 200 (defun ert-make-test-unbound (symbol)
 201   "Make SYMBOL name no test.  Return SYMBOL."
 202   (remprop symbol 'ert-test)
 203   symbol)
 204
 205 (defun ert-test-result-expected-p (test result)
 206   "Return non-nil if RESULT matches the expected result type for TEST."
 207   (typep result (ert-test-expected-result-type test)))
 208
 209 (defvar ert-find-test-regexp
 210   (concat "^\\s-*(ert-deftest"
 211           find-function-space-re
 212           "%s\\(\\s-\\|$\\)")
 213   "The regexp the `find-function' mechanisms use for locating test definitions.")
 214
 215 (eval-and-compile
 216   (defun ert-parse-keys-and-body (docstr keys-and-body)
 217     "Split KEYS-AND-BODY into keyword-and-value pairs and the remaining body.
 218
 219 KEYS-AND-BODY should have the form of a property list, with the
 220 exception that only keywords are permitted as keys and that the
 221 tail -- the body -- is a list of forms that does not start with a
 222 keyword.
 223
 224 Returns a two-element list containing the keys-and-values plist
 225 and the body."
 226     (unless (stringp docstr)
 227       (when docstr
 228         (setq keys-and-body (cons docstr keys-and-body))
 229         (setq docstr nil)))
 230     (let ((extracted-key-accu '())
 231           (remaining keys-and-body))
 232       (while (and (consp remaining) (keywordp (first remaining)))
 233         (let ((keyword (pop remaining)))
 234           (unless (consp remaining)
 235             (error "Value expected after keyword %S in %S"
 236                    keyword keys-and-body))
 237           (when (assoc keyword extracted-key-accu)
 238             (warn "Keyword %S appears more than once in %S" keyword
 239                   keys-and-body))
 240           (push (cons keyword (pop remaining)) extracted-key-accu)))
 241       (setq extracted-key-accu (nreverse extracted-key-accu))
 242       (list (loop for (key . value) in extracted-key-accu
 243                   collect key
 244                   collect value)
 245             docstr
 246             remaining))))
 247
 248 (defvar ert-error-on-test-redefinition nil)
 249
 250 ;;;###autoload
 251 (defmacro* ert-deftest (name ()
 252                              &optional docstr
 253                              &body keys-and-body)
 254   "Define NAME (a symbol) as a test.
 255
 256 \(fn NAME () [:documentation DOCSTRING] [:expected-result TYPE] BODY...)"
 257   ;; The :documentation would be unreadable.  I have therefore added
 258   ;; docstr that will look like documentation use to in Emacs.  Maybe
 259   ;; add function ert-describe-test?
 260   (declare (indent 2)
 261            (debug (&define :name test name sexp
 262                            [&optional [":documentation" stringp]]
 263                            [&optional [":expected-result" sexp]]
 264                            def-body)))
 265   (destructuring-bind ((&key (expected-result nil expected-result-supplied-p)
 266                              (documentation nil documentation-supplied-p))
 267                        doc
 268                        body)
 269       (ert-parse-keys-and-body docstr keys-and-body)
 270     `(progn
 271        ;; Guard against missing/badly named tests:
 272        (when (and ert-error-on-test-redefinition
 273                   (symbolp ',name)
 274                   (get ',name 'ert-test))
 275          (with-output-to-temp-buffer "*Ert Error*"
 276            (with-current-buffer "*Ert Error*"
 277              (insert "Test "
 278                      (format "%s" ',name)
 279                      " is already defined in "
 280                      (format "%s" (find-definition-noselect ',name 'ert-deftest))
 281                      "\n\n"
 282                      "Tip: Use `ert-delete-all-tests' or `ert-delete-test' before redefining tests."
 283                      )))
 284          (if (y-or-n-p "Do you want to call ert-delete-all-tests and then continue? ")
 285              ;; Fix-me: This does not work, why?
 286              (ert-delete-all-tests)
 287            (error "Test %s is already defined in %s"
 288                   ',name
 289                   (find-definition-noselect ',name 'ert-deftest))))
 290        (ert-set-test ',name
 291                      nil ;;doc
 292                      (make-ert-test
 293                       :name ',name
 294                       :body (lambda () ,@body)
 295                       ,@(when expected-result-supplied-p
 296                           `(:expected-result-type ,expected-result))
 297                       ,@(when documentation-supplied-p
 298                           `(:documentation ,documentation))))
 299        ;; This hack allows `symbol-file' to associate `ert-deftest'
 300        ;; forms with files, and therefore enables `find-function' to
 301        ;; work with tests.  However, it leads to warnings in
 302        ;; `unload-feature', which doesn't know how to undefine tests
 303        ;; and has no mechanism for extension.
 304        (push '(ert-deftest . ,name) current-load-list)
 305        ',name)))
 306
 307 (defun ert-read-test-name (prompt &optional default-value history)
 308   "Read the name of a test and return it as a symbol.
 309 Prompt with PROMPT.  By default, return DEFAULT-VALUE."
 310   (when (symbolp default-value) (setq default-value (symbol-name default-value)))
 311   (intern (completing-read prompt obarray #'ert-test-boundp
 312                            t nil history default-value nil)))
 313
 314 (defun ert-find-test-other-window (test-name)
 315   "Find, in another window, the definition of TEST-NAME."
 316   (interactive (list (ert-read-test-name "Find test definition: ")))
 317   (find-function-do-it test-name 'ert-deftest 'switch-to-buffer-other-window))
 318
 319 (defun ert-delete-test (test-name)
 320   "An interactive interface to `ert-make-test-unbound'."
 321   (interactive (list (let ((default (thing-at-point 'symbol)))
 322                        (when default
 323                          (set-text-properties 0 (length default) nil default)
 324                          (when (or (string= default "nil") (intern-soft default))
 325                            (setq default (intern default)))
 326                          (unless (ert-test-boundp default)
 327                            (setq default nil)))
 328                        (completing-read (if (null default)
 329                                             "Delete test: "
 330                                           (format "Delete test (default %s): "
 331                                                   default))
 332                                         obarray #'ert-test-boundp
 333                                         'really-require-match
 334                                         nil nil default nil))))
 335   (ert-make-test-unbound test-name))
 336
 337 (defun ert-delete-all-tests ()
 338   "Make all symbols in `obarray' name no test."
 339   (interactive)
 340   (when (interactive-p)
 341     (unless (y-or-n-p "Delete all tests? ")
 342       (error "Aborted")))
 343   (mapc #'ert-delete-test (mapcar #'ert-test-name (ert-select-tests t t)))
 344   t)
 345
 346
 347 (defun ert-make-end-marker (buffer must-exist)
 348   "Return a marker to the end of buffer BUFFER.
 349 BUFFER may be a string or a buffer. If BUFFER does not exist
 350 return nil.
 351
 352 The buffer must exist if MUST-EXIST is non-nil.
 353
 354 See also:
 355  `ert-end-of-messages'
 356  `ert-end-of-warnings'"
 357   (let ((buf (if must-exist
 358                  (get-buffer buffer)
 359                (get-buffer-create buffer))))
 360     (when (and buf
 361                (bufferp buf)
 362                (buffer-live-p buf))
 363       (with-current-buffer buf
 364         (save-restriction
 365           (widen)
 366           (point-max-marker))))))
 367
 368 (defun ert-end-of-messages ()
 369   "Return a marker to the end of *Messages* buffer."
 370   (ert-make-end-marker "*Messages*" nil))
 371
 372 (defun ert-end-of-warnings ()
 373   "Return a marker to the end of *Warnings* buffer."
 374   (ert-make-end-marker "*Warnings*" nil))
 375
 376 (defun ert-search-after (after regexp)
 377   "Search after marker in AFTER for regular expression REGEXP.
 378 Return a alist of position and matches.  AFTER should have been
 379 created with `ert-make-end-marker'.
 380
 381 This is supposed to be used for messages and trace buffers.
 382
 383 See also
 384  `ert-get-messages'"
 385   (let ((buf (marker-buffer after)))
 386     (with-current-buffer buf
 387       (let ((here (point))
 388             res)
 389         (goto-char after)
 390         (save-match-data
 391           (while (re-search-forward regexp nil t)
 392             (setq res (cons (match-data) res))))
 393         (goto-char here)
 394         (reverse res)))))
 395 ;; fix-me: add a conventient way to look at the result of
 396 ;; `ert-search-after'. Probably this means adding something more to
 397 ;; the returned result.
 398
 399 (defvar ert-messages-mark)
 400 (defun ert-get-messages (regexp)
 401   "Search *Messages* buffer for regular expression REGEXP.
 402 This should be used within `ert-deftest'.  Search begins where
 403 the buffer ended when test started.
 404
 405 See also:
 406  `ert-get-warnings'
 407  `ert-search-after'"
 408   (ert-search-after ert-messages-mark regexp))
 409
 410 (defvar ert-warnings-mark)
 411 (defun ert-get-warnings (regexp)
 412   "Search *Warnings* buffer for regular expression REGEXP.
 413 See `ert-get-messages' for more information."
 414   (ert-search-after ert-warnings-mark regexp))
 415
 416
 417 ;;; Test selectors.
 418
 419 (defun ert-select-tests (selector universe)
 420   "Select, from UNIVERSE, a set of tests according to SELECTOR.
 421
 422 UNIVERSE should be a list of tests, or t, which refers to all
 423 tests named by symbols in `obarray'.
 424
 425 Returns the set of tests as a list.
 426
 427 Valid selectors:
 428
 429 nil -- Selects the empty set.
 430 t -- Selects UNIVERSE.
 431 :new -- Selects all tests that have not been run yet.
 432 :failed, :passed, :error -- Select tests according to their most recent result.
 433 :expected, :unexpected -- Select tests according to their most recent result.
 434 a string -- Selects all tests that have a name that matches the string, a regexp.
 435 a test -- Selects that test.
 436 a symbol -- Selects the test that the symbol names, errors if none.
 437 \(member TESTS...\) -- Selects TESTS, a list of tests or symbols naming tests.
 438 \(eql TEST\) -- Selects TEST, a test or a symbol naming a test.
 439 \(and SELECTORS...\) -- Selects the tests that match all SELECTORS.
 440 \(or SELECTORS...\) -- Selects the tests that match any SELECTOR.
 441 \(not SELECTOR\) -- Selects all tests that do not match SELECTOR.
 442 \(satisfies PREDICATE\) -- Selects all tests that satisfy PREDICATE.
 443
 444 Only selectors that require a superset of tests, such
 445 as (satisfies ...), strings, :new, etc. make use of UNIVERSE.
 446 Selectors that do not, such as \(member ...\), just return the
 447 set implied by them without checking whether it is really
 448 contained in UNIVERSE."
 449   ;; This code needs to match the etypecase in
 450   ;; `ert-insert-human-readable-selector'.
 451   (etypecase selector
 452     ((member nil) nil)
 453     ((member t) (etypecase universe
 454                   (list universe)
 455                   ((member t) (ert-select-tests "" universe))))
 456     ((member :new) (ert-select-tests
 457                     `(satisfies ,(lambda (test)
 458                                    (typep (ert-test-most-recent-result test)
 459                                           'null)))
 460                     universe))
 461     ((member :failed) (ert-select-tests
 462                        `(satisfies ,(lambda (test)
 463                                       (typep (ert-test-most-recent-result test)
 464                                              'ert-test-failed)))
 465                        universe))
 466     ((member :passed) (ert-select-tests
 467                        `(satisfies ,(lambda (test)
 468                                       (typep (ert-test-most-recent-result test)
 469                                              'ert-test-passed)))
 470                        universe))
 471     ((member :error) (ert-select-tests
 472                       `(satisfies ,(lambda (test)
 473                                      (typep (ert-test-most-recent-result test)
 474                                             'ert-test-error)))
 475                       universe))
 476     ((member :expected) (ert-select-tests
 477                          `(satisfies
 478                            ,(lambda (test)
 479                               (ert-test-result-expected-p
 480                                test
 481                                (ert-test-most-recent-result test))))
 482                          universe))
 483     ((member :unexpected) (ert-select-tests `(not :expected) universe))
 484     (string
 485      (etypecase universe
 486        ((member t) (mapcar #'ert-get-test
 487                            (apropos-internal selector #'ert-test-boundp)))
 488        (list (remove-if-not (lambda (test)
 489                               (and (ert-test-name test)
 490                                    (string-match selector (ert-test-name test))))
 491                             universe))))
 492     (ert-test (list selector))
 493     (symbol
 494      (assert (ert-test-boundp selector))
 495      (list (ert-get-test selector)))
 496     (cons
 497      (destructuring-bind (operator &rest operands) selector
 498        (ecase operator
 499          (member
 500           (mapcar (lambda (purported-test)
 501                     (etypecase purported-test
 502                       (symbol (assert (ert-test-boundp purported-test))
 503                               (ert-get-test purported-test))
 504                       (ert-test purported-test)))
 505                   operands))
 506          (eql
 507           (assert (eql (length operands) 1))
 508           (ert-select-tests `(member ,@operands) universe))
 509          (and
 510           ;; Do these definitions of AND, NOT and OR satisfy de
 511           ;; Morgan's rules?  Should they?
 512           (case (length operands)
 513             (0 (ert-select-tests 't universe))
 514             (t (ert-select-tests `(and ,@(rest operands))
 515                                  (ert-select-tests (first operands) universe)))))
 516          (not
 517           (assert (eql (length operands) 1))
 518           (set-difference (ert-select-tests 't universe)
 519                           (ert-select-tests (first operands) universe)))
 520          (or
 521           (case (length operands)
 522             (0 (ert-select-tests 'nil universe))
 523             (t (union (ert-select-tests (first operands) universe)
 524                       (ert-select-tests `(or ,@(rest operands)) universe)))))
 525          (satisfies
 526           (assert (eql (length operands) 1))
 527           (remove-if-not (first operands) (ert-select-tests 't universe))))))))
 528
 529 (defun ert-insert-human-readable-selector (selector)
 530   "Insert a human-readable presentation of SELECTOR into the current buffer."
 531   ;; This is needed to avoid printing the (huge) contents of the
 532   ;; `backtrace' slot of the result objects in the
 533   ;; `most-recent-result' slots of test case objects in (eql ...) or
 534   ;; (member ...) selectors.
 535   (labels ((rec (selector)
 536              ;; This code needs to match the etypecase in `ert-select-tests'.
 537              (etypecase selector
 538                ((or (member nil t
 539                             :new :failed :passed :error
 540                             :expected :unexpected)
 541                     string
 542                     symbol)
 543                 selector)
 544                (ert-test
 545                 (if (ert-test-name selector)
 546                     (make-symbol (format "<%S>" (ert-test-name selector)))
 547                   (make-symbol "<unnamed test>")))
 548                (cons
 549                 (destructuring-bind (operator &rest operands) selector
 550                   (ecase operator
 551                     ((member eql and not or)
 552                      `(,operator ,@(mapcar #'rec operands)))
 553                     (satisfies
 554                      selector)))))))
 555     (insert (format "%S" (rec selector)))))
 556
 557
 558 ;;; Running tests.
 559
 560 (put 'ert-test-failed 'error-conditions '(error ert-test-failed))
 561 (put 'ert-test-failed 'error-message "Test failed")
 562
 563 (defun ert-pass ()
 564   "Terminate the current test and mark it passed.  Does not return."
 565   (throw 'ert-pass nil))
 566
 567 (defun ert-fail (data)
 568   "Terminate the current test and mark it failed.  Does not return.
 569 DATA is displayed to the user and should state the reason of the failure."
 570   (signal 'ert-test-failed (list data)))
 571
 572 ;; The data structures that represent the result of running a test.
 573 (defstruct ert-test-result
 574   (messages nil)
 575   )
 576 (defstruct (ert-test-passed (:include ert-test-result)))
 577 (defstruct (ert-test-result-with-condition (:include ert-test-result))
 578   (condition (assert nil))
 579   (backtrace (assert nil)))
 580 (defstruct (ert-test-error (:include ert-test-result-with-condition)))
 581 (defstruct (ert-test-quit (:include ert-test-result-with-condition)))
 582 (defstruct (ert-test-failed (:include ert-test-result-with-condition)))
 583 (defstruct (ert-test-aborted-with-non-local-exit (:include ert-test-result)))
 584
 585
 586 (defun ert-record-backtrace ()
 587   "Record the current backtrace (as a list) and return it."
 588   ;; Since the backtrace is stored in the result object, result
 589   ;; objects must only be printed with appropriate limits
 590   ;; (`print-level' and `print-length') in place.  For interactive
 591   ;; use, the cost of ensuring this possibly outweighs the advantage
 592   ;; of storing the backtrace for
 593   ;; `ert-results-pop-to-backtrace-for-test-at-point' given that we
 594   ;; already have `ert-results-rerun-test-debugging-errors-at-point'.
 595   ;; For batch use, however, printing the backtrace may be useful.
 596   (loop
 597    ;; 6 is the number of frames our own debugger adds (when
 598    ;; compiled; more when interpreted).  FIXME: Need to describe a
 599    ;; procedure for determining this constant.
 600    for i from 6
 601    for frame = (backtrace-frame i)
 602    while frame
 603    collect frame))
 604
 605 ;; A container for the state of the execution of a single test and
 606 ;; environment data needed during its execution.
 607 (defstruct ert-test-execution-info
 608   (test (assert nil))
 609   (result (assert nil))
 610   ;; A thunk that may be called when RESULT has been set to its final
 611   ;; value and test execution should be terminated.  Should not
 612   ;; return.
 613   (exit-continuation (assert nil))
 614   ;; The binding of `debugger' outside of the execution of the test.
 615   next-debugger
 616   ;; The binding of `ert-debug-on-error' that is in effect for the
 617   ;; execution of the current test.  We store it to avoid being
 618   ;; affected by any new bindings the test itself may establish.  (I
 619   ;; don't remember whether this feature is important.)
 620   ert-debug-on-error)
 621
 622 (defun ert-run-test-debugger (info debugger-args)
 623   "The function that `debugger' is bound to during the execution of tests.
 624
 625 Records failures and errors and either terminates the test
 626 silently or calls the interactive debugger, as appropriate."
 627   (destructuring-bind (first-debugger-arg &rest more-debugger-args) debugger-args
 628     (ecase first-debugger-arg
 629       ((lambda debug t exit nil)
 630        (apply (ert-test-execution-info-next-debugger info) debugger-args))
 631       (error
 632        (let* ((condition (first more-debugger-args))
 633               (type (case (car condition)
 634                       ((quit) 'quit)
 635                       ((ert-test-failed) 'failed)
 636                       (otherwise 'error)))
 637               (backtrace (ert-record-backtrace)))
 638          (setf (ert-test-execution-info-result info)
 639                (ecase type
 640                  (quit
 641                   (make-ert-test-quit :condition condition
 642                                       :backtrace backtrace))
 643                  (failed
 644                   (make-ert-test-failed :condition condition
 645                                         :backtrace backtrace))
 646                  (error
 647                   (make-ert-test-error :condition condition
 648                                        :backtrace backtrace))))
 649          ;; Work around Emacs' heuristic (in eval.c) for detecting
 650          ;; errors in the debugger.
 651          (incf num-nonmacro-input-events)
 652          ;; FIXME: We should probably implement more fine-grained
 653          ;; control a la non-t `debug-on-error' here.
 654          (cond
 655           ((ert-test-execution-info-ert-debug-on-error info)
 656            (apply (ert-test-execution-info-next-debugger info) debugger-args))
 657           (t))
 658          (funcall (ert-test-execution-info-exit-continuation info)))))))
 659
 660 (defun ert-run-test-internal (ert-test-execution-info)
 661   (lexical-let ((info ert-test-execution-info))
 662     (setf (ert-test-execution-info-next-debugger info) debugger
 663           (ert-test-execution-info-ert-debug-on-error info) ert-debug-on-error)
 664     (catch 'ert-pass
 665       ;; For now, each test gets its own temp buffer and its own
 666       ;; window excursion, just to be safe.  If this turns out to be
 667       ;; too expensive, we can remove it.
 668       (with-temp-buffer
 669         (save-window-excursion
 670           (let ((debugger (lambda (&rest debugger-args)
 671                             (ert-run-test-debugger info debugger-args)))
 672                 (debug-on-error t)
 673                 (debug-on-quit t)
 674                 ;; FIXME: Do we need to store the old binding of this
 675                 ;; and consider it in `ert-run-test-debugger'?
 676                 (debug-ignored-errors nil)
 677                 (ert-messages-mark (ert-end-of-messages))
 678                 (ert-warnings-mark (ert-end-of-warnings)))
 679             (funcall (ert-test-body (ert-test-execution-info-test info))))))
 680       (ert-pass))
 681     (setf (ert-test-execution-info-result info) (make-ert-test-passed)))
 682   nil)
 683
 684 (defun ert-make-marker-in-messages-buffer ()
 685   (with-current-buffer (get-buffer-create "*Messages*")
 686     (set-marker (make-marker) (point-max))))
 687
 688 (defun ert-force-message-log-buffer-truncation ()
 689   (with-current-buffer (get-buffer-create "*Messages*")
 690     ;; This is a reimplementation of this part of message_dolog() in xdisp.c:
 691     ;; if (NATNUMP (Vmessage_log_max))
 692     ;;   {
 693     ;;     scan_newline (Z, Z_BYTE, BEG, BEG_BYTE,
 694     ;;                   -XFASTINT (Vmessage_log_max) - 1, 0);
 695     ;;     del_range_both (BEG, BEG_BYTE, PT, PT_BYTE, 0);
 696     ;;   }
 697     (when (and (integerp message-log-max) (>= message-log-max 0))
 698       (let ((begin (point-min))
 699             (end (save-excursion
 700                    (goto-char (point-max))
 701                    (forward-line (- message-log-max))
 702                    (point))))
 703         (delete-region begin end)))))
 704
 705 (defun ert-run-test (test)
 706   "Run TEST.  Return the result and store it in TEST's `most-recent-result' slot."
 707   (setf (ert-test-most-recent-result test) nil)
 708   (block error
 709     (lexical-let* ((begin-marker (ert-make-marker-in-messages-buffer))
 710                    (info (make-ert-test-execution-info
 711                          :test test
 712                          :result (make-ert-test-aborted-with-non-local-exit)
 713                          :exit-continuation (lambda ()
 714                                               (return-from error nil)))))
 715       (unwind-protect
 716           (let ((message-log-max t))
 717             (ert-run-test-internal info))
 718         (let ((result (ert-test-execution-info-result info)))
 719           (setf (ert-test-result-messages result)
 720                 (with-current-buffer (get-buffer-create "*Messages*")
 721                   (buffer-substring begin-marker (point-max))))
 722           (ert-force-message-log-buffer-truncation)
 723           (setf (ert-test-most-recent-result test) result)))))
 724   (ert-test-most-recent-result test))
 725
 726
 727 ;;; The `should' macros.
 728
 729 (eval-and-compile
 730   (defun ert-special-operator-p (thing)
 731     "Return non-nil if THING is a symbol naming a special operator."
 732     (and (symbolp thing)
 733          (let ((definition (indirect-function thing t)))
 734            (and (subrp definition)
 735                 (eql (cdr (subr-arity definition)) 'unevalled)))))
 736   (defun ert-expand-should (whole form env inner-expander)
 737     "Helper function for the `should' macro and its variants.
 738
 739 Analyzes FORM and produces an expression that has the same
 740 semantics under evaluation but records additional debugging
 741 information.  INNER-EXPANDER adds the actual checks specific to
 742 the particular variant of `should'."
 743     (let ((form (macroexpand form env)))
 744       ;; It's sort of a wart that `inner-expander' can't influence the
 745       ;; value the expansion returns.
 746       (cond
 747        ((atom form)
 748         (funcall inner-expander form `(list ',whole :form ',form :value ,form)))
 749        ((ert-special-operator-p (car form))
 750         (let ((value (gensym "value-")))
 751           `(let ((,value (make-symbol "ert-form-evaluation-aborted")))
 752              ,(funcall inner-expander
 753                        `(setq ,value ,form)
 754                        `(list ',whole :form ',form :value ,value))
 755              ,value)))
 756        (t
 757         (let ((fn-name (car form))
 758               (arg-forms (cdr form)))
 759           (assert (or (symbolp fn-name)
 760                       (and (consp fn-name)
 761                            (eql (car fn-name) 'lambda)
 762                            (listp (cdr fn-name)))))
 763           (let ((fn (gensym "fn-"))
 764                 (args (gensym "args-"))
 765                 (value (gensym "value-"))
 766                 (default-value (gensym "ert-form-evaluation-aborted-")))
 767             `(let ((,fn (function ,fn-name))
 768                    (,args (list ,@arg-forms)))
 769                (let ((,value ',default-value))
 770                  ,(funcall inner-expander
 771                            `(setq ,value (apply ,fn ,args))
 772                            `(nconc (list ',whole)
 773                                    (list :form `(,,fn ,@,args))
 774                                    (unless (eql ,value ',default-value)
 775                                      (list :value ,value))
 776                                    (let ((-explainer-
 777                                           (and (symbolp ',fn-name)
 778                                                (get ',fn-name
 779                                                     'ert-explainer))))
 780                                      (when -explainer-
 781                                        (list :explanation
 782                                              (apply -explainer- ,args))))))
 783                  ,value)))))))))
 784
 785 (defmacro* ert-should (form &environment env)
 786   "Evaluate FORM.  If it returns nil, abort the current test as failed.
 787
 788 Returns the value of FORM."
 789   (ert-expand-should `(ert-should ,form) form env
 790                      (lambda (inner-form form-description-form)
 791                        `(unless ,inner-form
 792                           (ert-fail ,form-description-form)))))
 793
 794 (defmacro* ert-should-not (form &environment env)
 795   "Evaluate FORM.  If it returns non-nil, abort the current test as failed.
 796
 797 Returns nil."
 798   (ert-expand-should `(ert-should-not ,form) form env
 799                      (lambda (inner-form form-description-form)
 800                        `(unless (not ,inner-form)
 801                           (ert-fail ,form-description-form)))))
 802
 803 (defun ert-should-error-handle-error (form-description-fn
 804                                       condition type exclude-subtypes test)
 805   "Helper function for `should-error'.
 806
 807 Determines whether CONDITION matches TYPE, EXCLUDE-SUBTYPES and
 808 TEST, and aborts the current test as failed if it doesn't."
 809   (let ((signalled-conditions (get (car condition) 'error-conditions))
 810         (handled-conditions (etypecase type
 811                               (list type)
 812                               (symbol (list type)))))
 813     (assert signalled-conditions)
 814     (unless (intersection signalled-conditions handled-conditions)
 815       (ert-fail (append
 816                  (funcall form-description-fn)
 817                  (list
 818                   :condition condition
 819                   :fail-reason (concat "the error signalled did not"
 820                                        " have the expected type")))))
 821     (when exclude-subtypes
 822       (unless (member (car condition) handled-conditions)
 823         (ert-fail (append
 824                    (funcall form-description-fn)
 825                    (list
 826                     :condition condition
 827                     :fail-reason (concat "the error signalled was a subtype"
 828                                          " of the expected type"))))))
 829     (unless (funcall test condition)
 830       (ert-fail (append
 831                  (funcall form-description-fn)
 832                  (list
 833                   :condition condition
 834                   :fail-reason "the error signalled did not pass the test"))))))
 835
 836 ;; FIXME: The expansion will evaluate the keyword args (if any) in
 837 ;; nonstandard order.
 838 (defmacro* ert-should-error (form &rest keys &key type exclude-subtypes test
 839                               &environment env)
 840   "Evaluate FORM.  Unless it signals an error, abort the current test as failed.
 841
 842 The error signalled additionally needs to match TYPE and satisfy
 843 TEST.  TYPE should be a condition name or a list of condition
 844 names.  If EXCLUDE-SUBTYPES is nil, the error matches TYPE if one
 845 of its condition names is an element of TYPE.  If
 846 EXCLUDE-SUBTYPES is non-nil, the error matches TYPE if it is an
 847 element of TYPE.  TEST should be a predicate."
 848   ;; Returns a gensym named `ert-form-evaluation-aborted-XXX', but
 849   ;; that's a wart, so let's not document it.
 850   (unless type (setq type ''error))
 851   (unless test (setq test '(lambda (condition) t)))
 852   (ert-expand-should
 853    `(ert-should-error ,form ,@keys)
 854    form env
 855    (lambda (inner-form form-description-form)
 856      (let ((errorp (gensym "errorp"))
 857            (form-description-fn (gensym "form-description-fn-")))
 858        `(let ((,errorp nil)
 859               (,form-description-fn (lambda () ,form-description-form)))
 860           (condition-case -condition-
 861               ,inner-form
 862             ;; We can't use ,type here because we want to evaluate it.
 863             (error
 864              (setq ,errorp t)
 865              (ert-should-error-handle-error ,form-description-fn
 866                                             -condition-
 867                                             ,type ,exclude-subtypes ,test)
 868              ;; It would make sense to have the `should-error' form
 869              ;; return the error in this case, but `ert-expand-should'
 870              ;; doesn't allow that at the moment.
 871              ))
 872           (unless ,errorp
 873             (ert-fail (append
 874                        (funcall ,form-description-fn)
 875                        (list
 876                         :fail-reason "did not signal an error")))))))))
 877
 878
 879 ;;; Explanation of `should' failures.
 880
 881 (defun ert-proper-list-p (x)
 882   "Return non-nil if X is a proper list, nil otherwise."
 883   (loop
 884    for firstp = t then nil
 885    for fast = x then (cddr fast)
 886    for slow = x then (cdr slow) do
 887    (when (null fast) (return t))
 888    (when (not (consp fast)) (return nil))
 889    (when (null (cdr fast)) (return t))
 890    (when (not (consp (cdr fast))) (return nil))
 891    (when (and (not firstp) (eq fast slow)) (return nil))))
 892
 893 (defun ert-explain-not-equal (a b)
 894   "Return a programmer-readable explanation of why A and B are not `equal'.
 895
 896 Returns nil if they are equal."
 897   (if (not (equal (type-of a) (type-of b)))
 898       `(different-types ,a ,b)
 899     (etypecase a
 900       (cons
 901        (let ((a-proper-p (ert-proper-list-p a))
 902              (b-proper-p (ert-proper-list-p b)))
 903          (if (not (eql (not a-proper-p) (not b-proper-p)))
 904              `(one-list-proper-one-improper ,a ,b)
 905            (if a-proper-p
 906                (if (not (equal (length a) (length b)))
 907                    ;; This would be even more helpful if it showed
 908                    ;; something like what `set-difference' would
 909                    ;; return.
 910                    `(proper-lists-of-different-length ,a ,b)
 911                  (loop for i from 0
 912                        for ai in a
 913                        for bi in b
 914                        for xi = (ert-explain-not-equal ai bi)
 915                        do (when xi (return `(list-elt ,i ,xi)))))
 916              (let ((car-x (ert-explain-not-equal (car a) (car b))))
 917                (if car-x
 918                    `(car ,car-x)
 919                  (let ((cdr-x (ert-explain-not-equal (cdr a) (cdr b))))
 920                    (if cdr-x
 921                        `(cdr ,cdr-x))
 922                    nil)))))))
 923       (array (if (not (equal (length a) (length b)))
 924                  `(arrays-of-different-length ,a ,b)
 925                (loop for i from 0
 926                      for ai across a
 927                      for bi across b
 928                      for xi = (ert-explain-not-equal ai bi)
 929                      do (when xi (return `(array-elt ,i ,xi))))))
 930       (atom (if (not (equal a b))
 931                 `(different-atoms ,a ,b)
 932               nil)))))
 933 (put 'equal 'ert-explainer 'ert-explain-not-equal)
 934
 935
 936 ;;; Results display.
 937
 938 ;; The data structure that contains the set of tests being executed
 939 ;; during one particular test run, their results, the state of the
 940 ;; execution, and some statistics.
 941 ;;
 942 ;; The data about results and expected results of tests may seem
 943 ;; redundant here, since the test objects also carry such information.
 944 ;; However, the information in the test objects may be more recent, it
 945 ;; may correspond to a different test run.  We need the information
 946 ;; that corresponds to this run in order to be able to update the
 947 ;; statistics correctly when a test is re-run interactively and has a
 948 ;; different result than before.
 949 (defstruct ert-stats
 950   (selector (assert nil))
 951   ;; The tests, in order.
 952   (tests (assert nil) :type vector)
 953   ;; A map of test names (or the test objects themselves for unnamed
 954   ;; tests) to indices into the `tests' vector.
 955   (test-map (assert nil) :type hash-table)
 956   ;; The results of the tests during this run, in order.
 957   (test-results (assert nil) :type vector)
 958   ;; The expected result types of the tests, in order.
 959   (test-results-expected (assert nil) :type vector)
 960   (total (assert nil))
 961   (passed-expected 0)
 962   (passed-unexpected 0)
 963   (failed-expected 0)
 964   (failed-unexpected 0)
 965   (error-expected 0)
 966   (error-unexpected 0)
 967   (start-time (assert nil))
 968   (end-time nil)
 969   (aborted-p nil)
 970   (current-test nil))
 971
 972 ;; An entry in the results buffer ewoc.  There is one entry per test.
 973 (defstruct ert-ewoc-entry
 974   (test (assert nil))
 975   (result nil)
 976   ;; If the result of this test was expected, its ewoc entry is hidden
 977   ;; initially.
 978   (hidden-p (assert nil))
 979   ;; An ewoc entry may be collapsed to hide details such as the error
 980   ;; condition.
 981   ;;
 982   ;; I'm not sure the ability to expand and collapse entries is still
 983   ;; a useful feature.
 984   (expanded-p t)
 985   ;; By default, the ewoc entry presents the error condition with
 986   ;; certain limits on how much to print (`print-level',
 987   ;; `print-length').  The user can interactively switch to a set of
 988   ;; higher limits.
 989   (extended-printer-limits-p nil))
 990
 991 ;; Variables local to the results buffer.
 992
 993 ;; The ewoc.
 994 (defvar ert-results-ewoc)
 995 ;; The stats object.
 996 (defvar ert-results-stats)
 997 ;; A string with one character per test.  Each character represents
 998 ;; the result of the corresponding test.  The string is displayed near
 999 ;; the top of the buffer and serves as a progress bar.
1000 (defvar ert-results-progress-bar-string)
1001 ;; The position where the progress bar button begins.
1002 (defvar ert-results-progress-bar-button-begin)
1003 ;; The test result listener that updates the buffer when tests are run.
1004 (defvar ert-results-listener)
1005
1006 ;; The same as `ert-results-stats', but dynamically bound.  Used for
1007 ;; the mode line progress indicator.
1008 (defvar ert-current-run-stats nil)
1009
1010 (defun ert-format-time-iso8601 (time)
1011   "Format TIME in the particular variant of ISO 8601 used for timestamps in ERT."
1012   (format-time-string "%Y-%m-%d %T%z" time))
1013
1014 (defun ert-insert-test-name-button (test-name)
1015   (insert-text-button (format "%S" test-name)
1016                       :type 'ert-test-name-button
1017                       'ert-test-name test-name))
1018
1019 (defun ert-results-update-ewoc-hf (ewoc stats)
1020   "Update the header and footer of EWOC to show certain information from STATS.
1021
1022 Also sets `ert-results-progress-bar-button-begin'."
1023   (let ((run-count (+ (ert-stats-passed-expected stats)
1024                       (ert-stats-passed-unexpected stats)
1025                       (ert-stats-failed-expected stats)
1026                       (ert-stats-failed-unexpected stats)
1027                       (ert-stats-error-expected stats)
1028                       (ert-stats-error-unexpected stats)))
1029         (results-buffer (current-buffer)))
1030     (ewoc-set-hf
1031      ewoc
1032      ;; header
1033      (with-temp-buffer
1034        (insert "Selector: ")
1035        (ert-insert-human-readable-selector (ert-stats-selector stats))
1036        (insert "\n")
1037        (insert
1038         (format (concat "Passed: %s (%s unexpected)\n"
1039                         "Failed: %s (%s unexpected)\n"
1040                         "Error:  %s (%s unexpected)\n"
1041                         "Total:  %s/%s\n\n")
1042                 (+ (ert-stats-passed-expected stats)
1043                    (ert-stats-passed-unexpected stats))
1044                 (ert-stats-passed-unexpected stats)
1045                 (+ (ert-stats-failed-expected stats)
1046                    (ert-stats-failed-unexpected stats))
1047                 (ert-stats-failed-unexpected stats)
1048                 (+ (ert-stats-error-expected stats)
1049                    (ert-stats-error-unexpected stats))
1050                 (ert-stats-error-unexpected stats)
1051                 run-count
1052                 (ert-stats-total stats)))
1053        (insert
1054         (format "Started at:   %s\n"
1055                 (ert-format-time-iso8601 (ert-stats-start-time stats))))
1056        ;; FIXME: This is ugly.  Need to properly define invariants of
1057        ;; the `stats' data structure.
1058        (let ((state (cond ((ert-stats-aborted-p stats)
1059                            'aborted)
1060                           ((ert-stats-current-test stats)
1061                            'running)
1062                           ((ert-stats-end-time stats)
1063                            'finished)
1064                           (t
1065                            'preparing))))
1066          (ecase state
1067            (preparing
1068             (insert ""))
1069            (aborted
1070             (cond ((ert-stats-current-test stats)
1071                    (insert "Aborted during test: ")
1072                    (ert-insert-test-name-button
1073                     (ert-test-name (ert-stats-current-test stats))))
1074                   (t
1075                    (insert "Aborted."))))
1076            (running
1077             (assert (ert-stats-current-test stats))
1078             (insert "Running test: ")
1079             (ert-insert-test-name-button (ert-test-name
1080                                           (ert-stats-current-test stats))))
1081            (finished
1082             (assert (not (ert-stats-current-test stats)))
1083             (insert "Finished.")))
1084          (insert "\n")
1085          (if (ert-stats-end-time stats)
1086              (insert
1087               (format "%s%s\n"
1088                       (if (ert-stats-aborted-p stats)
1089                           "Aborted at:   "
1090                         "Finished at:  ")
1091                       (ert-format-time-iso8601 (ert-stats-end-time stats))))
1092            (insert "\n"))
1093          (insert "\n"))
1094        (let ((progress-bar-string (with-current-buffer results-buffer
1095                                     ert-results-progress-bar-string)))
1096          (let ((progress-bar-button-begin
1097                 (insert-text-button (substring progress-bar-string 0 run-count)
1098                                     :type 'ert-results-progress-bar-button)))
1099            (with-current-buffer results-buffer
1100              (set (make-local-variable 'ert-results-progress-bar-button-begin)
1101                   progress-bar-button-begin)))
1102          (insert (substring progress-bar-string run-count)))
1103        (insert "\n\n")
1104        (buffer-string))
1105      ;; footer
1106      ;;
1107      ;; We actually want an empty footer, but that would trigger a bug
1108      ;; in ewoc, sometimes clearing the entire buffer.
1109      "\n")))
1110
1111 (defun ert-results-update-stats-display (ewoc stats)
1112   "Update EWOC and the mode line to show data from STATS."
1113   (ert-results-update-ewoc-hf ewoc stats)
1114   (force-mode-line-update)
1115   (redisplay t))
1116
1117 (defun ert-char-for-test-result (result expectedp)
1118   "Return a character that represents the test result RESULT."
1119   (let ((char
1120          (etypecase result
1121            (ert-test-passed ?.)
1122            (ert-test-failed ?f)
1123            (ert-test-error ?e)
1124            (null ?-)
1125            (ert-test-aborted-with-non-local-exit ?a))))
1126     (if expectedp
1127         char
1128       (upcase char))))
1129
1130 (defun ert-string-for-test-result (result expectedp)
1131   "Return a string that represents the test result RESULT."
1132   (etypecase result
1133     (ert-test-passed "passed")
1134     (ert-test-failed "failed")
1135     (ert-test-error "error")
1136     (null "unknown")
1137     (ert-test-aborted-with-non-local-exit "aborted")))
1138
1139 (defun ert-tests-running-mode-line-indicator ()
1140   (let* ((stats ert-current-run-stats)
1141          (tests-total (ert-stats-total stats))
1142          (tests-completed (+ (ert-stats-passed-expected stats)
1143                              (ert-stats-passed-unexpected stats)
1144                              (ert-stats-failed-expected stats)
1145                              (ert-stats-failed-unexpected stats)
1146                              (ert-stats-error-expected stats)
1147                              (ert-stats-error-unexpected stats))))
1148     (if (>= tests-completed tests-total)
1149         (format " ERT(%s/%s,finished)" tests-completed tests-total)
1150       (format " ERT(%s/%s):%s"
1151               (1+ tests-completed)
1152               tests-total
1153               (if (null (ert-stats-current-test stats))
1154                   "?"
1155                 (format "%S"
1156                         (ert-test-name (ert-stats-current-test stats))))))))
1157
1158 (defun ert-pp-with-indentation-and-newline (object)
1159   "Pretty-print OBJECT, indenting it to the current column of point.
1160 Ensures a final newline is inserted."
1161   (let ((begin (point)))
1162     (pp object (current-buffer))
1163     (unless (bolp) (insert "\n"))
1164     (save-excursion
1165       (goto-char begin)
1166       (indent-sexp))))
1167
1168 (defun ert-print-test-for-ewoc (entry)
1169   "The ewoc print function for ewoc test entries."
1170   (let* ((test (ert-ewoc-entry-test entry))
1171          (result (ert-ewoc-entry-result entry))
1172          (hiddenp (ert-ewoc-entry-hidden-p entry))
1173          (expandedp (ert-ewoc-entry-expanded-p entry))
1174          (extended-printer-limits-p (ert-ewoc-entry-extended-printer-limits-p
1175                                      entry)))
1176     (cond (hiddenp)
1177           (t
1178            (insert-text-button (format "%c"
1179                                        (ert-char-for-test-result
1180                                         result
1181                                         (ert-test-result-expected-p test
1182                                                                     result)))
1183                                :type 'ert-results-expand-collapse-button)
1184            (insert " ")
1185            (ert-insert-test-name-button (ert-test-name test))
1186            (insert "\n")
1187            (when (and expandedp (not (eql result 'nil)))
1188              (etypecase result
1189                (ert-test-passed
1190                 (insert "    passed\n")
1191                 (insert ""))
1192                (ert-test-result-with-condition
1193                 (insert "    ")
1194                 (let ((print-escape-newlines t)
1195                       (print-level (if extended-printer-limits-p 10 5))
1196                       (print-length (if extended-printer-limits-p 100 10)))
1197                   (let ((begin (point)))
1198                     (ert-pp-with-indentation-and-newline
1199                      (ert-test-result-with-condition-condition result))
1200                     (save-restriction
1201                       (narrow-to-region begin (point))
1202                       ;; Inhibit optimization in `debugger-make-xrefs'
1203                       ;; that sometimes inserts unrelated backtrace
1204                       ;; info into our buffer.
1205                       (let ((debugger-previous-backtrace nil))
1206                         (debugger-make-xrefs))))))
1207                (ert-test-aborted-with-non-local-exit
1208                 (insert "    aborted\n")))
1209              (insert "\n")))))
1210   nil)
1211
1212 (defun ert-setup-results-buffer (stats listener buffer-name)
1213   "Set up a test results buffer."
1214   (unless buffer-name (setq buffer-name "*ert*"))
1215   (let ((buffer (let ((default-major-mode 'fundamental-mode))
1216                   (get-buffer-create buffer-name))))
1217     (with-current-buffer buffer
1218       (setq buffer-read-only t)
1219       (let ((inhibit-read-only t))
1220         (buffer-disable-undo)
1221         (erase-buffer)
1222         (ert-results-mode)
1223         (set (make-local-variable 'ert-results-ewoc)
1224              (ewoc-create 'ert-print-test-for-ewoc nil nil t))
1225         (set (make-local-variable 'ert-results-stats) stats)
1226         (set (make-local-variable 'ert-results-progress-bar-string)
1227              (make-string (ert-stats-total stats)
1228                           (ert-char-for-test-result nil t)))
1229         (set (make-local-variable 'ert-results-listener) listener)
1230         (ert-results-update-ewoc-hf ert-results-ewoc ert-results-stats)
1231         (goto-char (1- (point-max)))
1232         buffer))))
1233
1234 (defun ert-run-or-rerun-test (stats test listener)
1235   "Run the single test TEST and record the result using STATS and LISTENER."
1236   (let ((ert-current-run-stats stats)
1237         (pos (ert-stats-test-index stats test))
1238         (results (ert-stats-test-results stats))
1239         (expected (ert-stats-test-results-expected stats)))
1240     ;; Adjust stats to remove previous result.
1241     (if (aref expected pos)
1242         (etypecase (aref results pos)
1243           (ert-test-passed (decf (ert-stats-passed-expected stats)))
1244           (ert-test-failed (decf (ert-stats-failed-expected stats)))
1245           (ert-test-error (decf (ert-stats-error-expected stats)))
1246           (null)
1247           (ert-test-aborted-with-non-local-exit))
1248       (etypecase (aref results pos)
1249         (ert-test-passed (decf (ert-stats-passed-unexpected stats)))
1250         (ert-test-failed (decf (ert-stats-failed-unexpected stats)))
1251         (ert-test-error (decf (ert-stats-error-unexpected stats)))
1252         (null)
1253         (ert-test-aborted-with-non-local-exit)))
1254     (setf (aref results pos) nil)
1255     ;; Call listener after setting/before resetting
1256     ;; (ert-stats-current-test stats); the listener might refresh the
1257     ;; mode line display, and if the value is not set yet/any more
1258     ;; during this refresh, the mode line will flicker unnecessarily.
1259     (setf (ert-stats-current-test stats) test)
1260     (funcall listener 'test-started stats test)
1261     (setf (ert-test-most-recent-result test) nil)
1262     (unwind-protect
1263         (ert-run-test test)
1264       (let* ((result (ert-test-most-recent-result test))
1265              (expectedp (typep result (ert-test-expected-result-type test))))
1266         ;; Adjust stats to add new result.
1267         (if expectedp
1268             (etypecase result
1269               (ert-test-passed (incf (ert-stats-passed-expected stats)))
1270               (ert-test-failed (incf (ert-stats-failed-expected stats)))
1271               (ert-test-error (incf (ert-stats-error-expected stats)))
1272               (null)
1273               (ert-test-aborted-with-non-local-exit))
1274           (etypecase result
1275             (ert-test-passed (incf (ert-stats-passed-unexpected stats)))
1276             (ert-test-failed (incf (ert-stats-failed-unexpected stats)))
1277             (ert-test-error (incf (ert-stats-error-unexpected stats)))
1278             (null)
1279             (ert-test-aborted-with-non-local-exit)))
1280         (setf (aref results pos) result
1281               (aref expected pos) expectedp)
1282         (funcall listener 'test-ended stats test result))
1283       (setf (ert-stats-current-test stats) nil))))
1284
1285 (defun ert-run-tests (selector listener)
1286   "Run the tests specified by SELECTOR, sending progress updates to LISTENER."
1287   (let* ((tests (coerce (ert-select-tests selector t) 'vector))
1288          (map (let ((map (make-hash-table :size (length tests))))
1289                 (loop for i from 0
1290                       for test across tests
1291                       for key = (or (ert-test-name test) test) do
1292                       (assert (not (gethash key map)))
1293                       (setf (gethash key map) i))
1294                 map))
1295          (stats (make-ert-stats :selector selector
1296                                 :tests tests
1297                                 :test-map map
1298                                 :test-results (make-vector (length tests) nil)
1299                                 :test-results-expected (make-vector
1300                                                         (length tests) nil)
1301                                 :total (length tests)
1302                                 :start-time (current-time))))
1303     (funcall listener 'run-started stats)
1304     (let ((abortedp t))
1305       (let ((ert-current-run-stats stats))
1306         (force-mode-line-update)
1307         (unwind-protect
1308             (progn
1309               (loop for test across tests do
1310                     (ert-run-or-rerun-test stats test listener))
1311               (setq abortedp nil))
1312           (setf (ert-stats-aborted-p stats) abortedp)
1313           (setf (ert-stats-end-time stats) (current-time))
1314           (funcall listener 'run-ended stats abortedp)))
1315       stats)))
1316
1317 (defun ert-stats-test-index (stats test)
1318   "Return the index of TEST in the run represented by STATS."
1319   (gethash (or (ert-test-name test) test) (ert-stats-test-map stats)))
1320
1321 (defvar ert-selector-history nil
1322   "List of recent test selectors read from terminal.")
1323
1324 ;; Fix-me: return (regep (list of matches))?
1325 ;; Fix-me: Add prompt parameter?
1326 (defun ert-read-test-selector ()
1327   "Read a regexp for test selection from minibuffer.
1328 The user can use TAB to see which tests match."
1329   (let* ((all-tests
1330           (mapcar (lambda (rec) (format "%s" (elt rec 1)))
1331                   (ert-select-tests "" t))
1332           ;;'("ert-group1-1" "ert-group1-2" "ert-other")
1333           )
1334          regexp
1335          ret
1336          (get-completions
1337           (lambda ()
1338             (let* ((ret (save-match-data
1339                           (mapcar (lambda (alt)
1340                                     (when (string-match regexp alt)
1341                                       alt))
1342                                   all-tests))))
1343               (setq ret (delq nil ret))
1344               ret))))
1345     (setq all-tests (append all-tests
1346                             '(":new"
1347                               ":failed" ":passed" ":error"
1348                               )
1349                             nil))
1350     (let ((mini-map (copy-keymap minibuffer-local-map)))
1351       (define-key mini-map [?\t]
1352         (lambda () (interactive)
1353           (with-output-to-temp-buffer "*Completions*"
1354             (display-completion-list
1355              (progn
1356                (setq regexp (minibuffer-contents))
1357                (set-text-properties 0 (length regexp) nil regexp)
1358                (funcall get-completions))))))
1359       (setq regexp
1360             (let* ((sym-here (thing-at-point 'symbol))
1361                    (test-here (when (and sym-here
1362                                          (memq sym-here all-tests))
1363                                 sym-here))
1364                    (default (if sym-here
1365                                 (substring-no-properties sym-here)
1366                               (if ert-selector-history
1367                                   (first ert-selector-history)
1368                                 "t"))))
1369               (read-from-minibuffer
1370                (if (null default)
1371                    "Run tests, use TAB to see matches: "
1372                  (format "Run tests, use TAB to see matches (default %s): "
1373                          default))
1374                nil ;; initial-contents
1375                mini-map ;; keymap
1376                nil ;; read
1377                'ert-selector-history
1378                default nil))))
1379     (setq ret regexp)
1380     (when (string= "t" ret)
1381       (setq ret t))
1382     ret))
1383
1384 ;; Should OUTPUT-BUFFER-NAME and MESSAGE-FN really be arguments here?
1385 ;; They are needed only for our automated self-tests at the moment.
1386 ;; Or should there be some other mechanism?
1387 ;;;###autoload
1388 (defun ert-run-tests-interactively (selector
1389                                     &optional output-buffer-name message-fn)
1390   "Run the tests specified by SELECTOR and display the results in a buffer."
1391   (interactive
1392 ;;;    (list (let ((default (if ert-selector-history
1393 ;;;                             (first ert-selector-history)
1394 ;;;                           "t")))
1395 ;;;            (read-from-minibuffer (if (null default)
1396 ;;;                                      "Run tests: "
1397 ;;;                                    (format "Run tests (default %s): " default))
1398 ;;;                                  ;;nil nil t 'ert-selector-history
1399 ;;;                                  ;;
1400 ;;;                                  ;; fix-me: seems like I am misunderstanding Christians intent here.
1401 ;;;                                  nil nil nil 'ert-selector-history
1402 ;;;                                  default nil))
1403 ;;;          nil nil))
1404    (list (ert-read-test-selector)
1405          nil nil))
1406   (unless message-fn (setq message-fn 'message))
1407   (lexical-let ((output-buffer-name output-buffer-name)
1408                 buffer
1409                 listener
1410                 (message-fn message-fn))
1411     (setq listener
1412           (lambda (event-type &rest event-args)
1413             (ecase event-type
1414               (run-started
1415                (destructuring-bind (stats) event-args
1416                  (setq buffer (ert-setup-results-buffer stats
1417                                                         listener
1418                                                         output-buffer-name))
1419                  (pop-to-buffer buffer)))
1420               (run-ended
1421                (destructuring-bind (stats abortedp) event-args
1422                  (funcall message-fn
1423                           "%sRan %s tests, %s results were as expected%s"
1424                           (if (not abortedp)
1425                               ""
1426                             "Aborted: ")
1427                           (ert-stats-total stats)
1428                           (+ (ert-stats-passed-expected stats)
1429                              (ert-stats-failed-expected stats)
1430                              (ert-stats-error-expected stats))
1431                           (let ((unexpected
1432                                  (+ (ert-stats-passed-unexpected stats)
1433                                     (ert-stats-failed-unexpected stats)
1434                                     (ert-stats-error-unexpected stats))))
1435                             (if (zerop unexpected)
1436                                 ""
1437                               (format ", %s unexpected" unexpected))))
1438                  (ert-results-update-stats-display (with-current-buffer buffer
1439                                                      ert-results-ewoc)
1440                                                    stats)))
1441               (test-started
1442                (destructuring-bind (stats test) event-args
1443                  (with-current-buffer buffer
1444                    (let* ((ewoc ert-results-ewoc)
1445                           (pos (ert-stats-test-index stats test))
1446                           (node (ewoc-nth ewoc pos)))
1447                      (unless node
1448                        ;; FIXME: How expensive is this assertion?
1449                        (assert (or (zerop pos) (ewoc-nth ewoc (1- pos)))
1450                                t)
1451                        (setq node (ewoc-enter-last
1452                                    ewoc
1453                                    (make-ert-ewoc-entry :test test
1454                                                         :hidden-p t))))
1455                      (setf (ert-ewoc-entry-test (ewoc-data node)) test)
1456                      (setf (ert-ewoc-entry-result (ewoc-data node)) nil)
1457                      (aset ert-results-progress-bar-string pos
1458                            (ert-char-for-test-result nil t))
1459                      (ert-results-update-stats-display ewoc stats)
1460                      (ewoc-invalidate ewoc node)))))
1461               (test-ended
1462                (destructuring-bind (stats test result) event-args
1463                  (with-current-buffer buffer
1464                    (let* ((ewoc ert-results-ewoc)
1465                           (pos (ert-stats-test-index stats test))
1466                           (node (ewoc-nth ewoc pos)))
1467                      (setf (ert-ewoc-entry-result (ewoc-data node)) result)
1468                      (when (ert-ewoc-entry-hidden-p (ewoc-data node))
1469                        (setf (ert-ewoc-entry-hidden-p (ewoc-data node))
1470                              (ert-test-result-expected-p test result)))
1471                      (aset ert-results-progress-bar-string pos
1472                            (ert-char-for-test-result result
1473                                                      (ert-test-result-expected-p
1474                                                       test result)))
1475                      (ert-results-update-stats-display ewoc stats)
1476                      (ewoc-invalidate ewoc node))))))))
1477     (ert-run-tests
1478      selector
1479      listener)))
1480
1481 (defvar ert-batch-backtrace-right-margin 70
1482   "*The maximum line length for printing backtraces in `ert-run-tests-batch'.")
1483
1484 (defun ert-run-tests-batch (selector)
1485   "Run the tests specified by SELECTOR, printing results to the terminal.
1486
1487 Returns the stats object."
1488   (ert-run-tests
1489    selector
1490    (lambda (event-type &rest event-args)
1491      (ecase event-type
1492        (run-started
1493         (destructuring-bind (stats) event-args
1494           (message "Running %s tests (%s)"
1495                    (length (ert-stats-tests stats))
1496                    (ert-format-time-iso8601 (ert-stats-start-time stats)))))
1497        (run-ended
1498         (destructuring-bind (stats abortedp) event-args
1499           (let ((unexpected (+ (ert-stats-passed-unexpected stats)
1500                                (ert-stats-failed-unexpected stats)
1501                                (ert-stats-error-unexpected stats))))
1502             (message "\n%sRan %s tests, %s results were as expected%s (%s)\n"
1503                      (if (not abortedp)
1504                          ""
1505                        "Aborted: ")
1506                      (ert-stats-total stats)
1507                      (+ (ert-stats-passed-expected stats)
1508                         (ert-stats-failed-expected stats)
1509                         (ert-stats-error-expected stats))
1510                      (if (zerop unexpected)
1511                          ""
1512                        (format ", %s unexpected" unexpected))
1513                      (ert-format-time-iso8601 (ert-stats-end-time stats)))
1514             (unless (zerop unexpected)
1515               (message "%s unexpected results:" unexpected)
1516               (loop for test across (ert-stats-tests stats)
1517                     for result = (ert-test-most-recent-result test) do
1518                     (when (not (ert-test-result-expected-p test result))
1519                       (message "%9s  %S"
1520                                (ert-string-for-test-result result nil)
1521                                (ert-test-name test))))
1522               (message "%s" "")))))
1523        (test-started
1524         )
1525        (test-ended
1526         (destructuring-bind (stats test result) event-args
1527           (etypecase result
1528             (ert-test-passed)
1529             (ert-test-result-with-condition
1530              (message "Test %S backtrace:" (ert-test-name test))
1531              (with-temp-buffer
1532                (ert-print-backtrace (ert-test-result-with-condition-backtrace result))
1533                (goto-char (point-min))
1534                (while (not (eobp))
1535                  (let ((start (point))
1536                        (end (progn (end-of-line) (point))))
1537                    (setq end (min end
1538                                   (+ start ert-batch-backtrace-right-margin)))
1539                    (message "%s" (buffer-substring-no-properties
1540                                   start end)))
1541                  (forward-line 1)))
1542              (with-temp-buffer
1543                (insert "  ")
1544                (let ((print-escape-newlines t)
1545                      (print-level 5)
1546                      (print-length 10))
1547                  (let ((begin (point)))
1548                    (ert-pp-with-indentation-and-newline
1549                     (ert-test-result-with-condition-condition result))))
1550                (goto-char (1- (point-max)))
1551                (assert (looking-at "\n"))
1552                (delete-char 1)
1553                (message "Test %S condition:" (ert-test-name test))
1554                (message "%s" (buffer-string))))
1555             (ert-test-aborted-with-non-local-exit))
1556           (let* ((max (prin1-to-string (length (ert-stats-tests stats))))
1557                  (format-string (concat "%9s  %"
1558                                         (prin1-to-string (length max))
1559                                         "s/" max "  %S")))
1560             (message format-string
1561                      (ert-string-for-test-result result
1562                                                  (ert-test-result-expected-p
1563                                                   test result))
1564                      (1+ (ert-stats-test-index stats test))
1565                      (ert-test-name test)))))))))
1566
1567
1568 ;;; Commands and button actions for the results buffer.
1569
1570 (define-derived-mode ert-results-mode fundamental-mode "ERT-Results"
1571   "Major mode for viewing results of ERT test runs.")
1572
1573 (loop for (key binding) in
1574       '(("j" ert-results-jump-between-summary-and-result)
1575         ("." ert-results-find-test-at-point-other-window)
1576         ("r" ert-results-rerun-test-at-point)
1577         ("d" ert-results-rerun-test-at-point-debugging-errors)
1578         ("b" ert-results-pop-to-backtrace-for-test-at-point)
1579         ("m" ert-results-pop-to-messages-for-test-at-point)
1580         ("p" ert-results-toggle-printer-limits-for-test-at-point)
1581         ("D" ert-delete-test)
1582         ([?\t] forward-button)
1583         ([backtab] backward-button)
1584         )
1585       do
1586       (define-key ert-results-mode-map key binding))
1587
1588 (define-button-type 'ert-results-progress-bar-button
1589   'action #'ert-results-progress-bar-button-action
1590   'help-echo "mouse-2, RET: Reveal test result")
1591
1592 (define-button-type 'ert-test-name-button
1593   'action #'ert-test-name-button-action
1594   'help-echo "mouse-2, RET: Find test definition")
1595
1596 (define-button-type 'ert-results-expand-collapse-button
1597   'action #'ert-results-expand-collapse-button-action
1598   'help-echo "mouse-2, RET: Expand/collapse test result")
1599
1600 (defun ert-results-test-node-or-null-at-point ()
1601   "If point is on a valid ewoc node, return it; return nil otherwise.
1602
1603 To be used in the ERT results buffer."
1604   (let* ((ewoc ert-results-ewoc)
1605          (node (ewoc-locate ewoc)))
1606     ;; `ewoc-locate' will return an arbitrary node when point is on
1607     ;; header or footer, or when all nodes are invisible.  So we need
1608     ;; to validate its return value here.
1609     (if (and (>= (point) (ewoc-location node))
1610              (not (ert-ewoc-entry-hidden-p (ewoc-data node))))
1611         node
1612       nil)))
1613
1614 (defun ert-results-test-node-at-point ()
1615   "If point is on a valid ewoc node, return it; signal an error otherwise.
1616
1617 To be used in the ERT results buffer."
1618   (or (ert-results-test-node-or-null-at-point)
1619       (error "No test at point")))
1620
1621 (defun ert-results-expand-collapse-button-action (button)
1622   "Expand or collapse the test node BUTTON belongs to."
1623   (let* ((ewoc ert-results-ewoc)
1624          (node (save-excursion
1625                  (goto-char (ert-button-action-position))
1626                  (ert-results-test-node-at-point)))
1627          (entry (ewoc-data node)))
1628     (setf (ert-ewoc-entry-expanded-p entry)
1629           (not (ert-ewoc-entry-expanded-p entry)))
1630     (ewoc-invalidate ewoc node)))
1631
1632 (defun ert-results-find-test-at-point-other-window ()
1633   "Find the definition of the test at point in another window.
1634
1635 To be used in the ERT results buffer."
1636   (interactive)
1637   (let* ((node (ert-results-test-node-at-point))
1638          (entry (ewoc-data node))
1639          (test (ert-ewoc-entry-test entry))
1640          (name (ert-test-name test)))
1641     (ert-find-test-other-window name)))
1642
1643 (defun ert-test-name-button-action (button)
1644   "Find the definition of the test BUTTON belongs to, in another window."
1645   (let ((name (button-get button 'ert-test-name)))
1646     (ert-find-test-other-window name)))
1647
1648 (defun ert-ewoc-position (ewoc node)
1649   "Return the position of NODE in EWOC, or nil if NODE is not in EWOC."
1650   (loop for i from 0
1651         for node-here = (ewoc-nth ewoc 0) then (ewoc-next ewoc node-here)
1652         do (when (eql node node-here)
1653              (return i))
1654         finally (return nil)))
1655
1656 (defun ert-results-jump-between-summary-and-result ()
1657   "Jump back and forth between the test run summary and individual test results.
1658
1659 From an ewoc node, jumps to the character that represents the
1660 same test in the progress bar, and vice versa.
1661
1662 To be used in the ERT results buffer."
1663   ;; Maybe this command isn't actually needed much, but if it is, it
1664   ;; seems like an indication that the UI design is not optimal.  If
1665   ;; jumping back and forth between a summary at the top of the buffer
1666   ;; and the error log in the remainder of the buffer is useful, then
1667   ;; the summary apparently needs to be easily accessible from the
1668   ;; error log, and perhaps it would be better to have it in a
1669   ;; separate buffer to keep it visible.
1670   (interactive)
1671   (let ((ewoc ert-results-ewoc)
1672         (progress-bar-begin ert-results-progress-bar-button-begin))
1673     (cond ((ert-results-test-node-or-null-at-point)
1674            (let* ((node (ert-results-test-node-at-point))
1675                   (pos (ert-ewoc-position ewoc node)))
1676              (goto-char (+ progress-bar-begin pos))))
1677           ((and (<= progress-bar-begin (point))
1678                 (< (point) (button-end (button-at progress-bar-begin))))
1679            (let* ((node (ewoc-nth ewoc (- (point) progress-bar-begin)))
1680                   (entry (ewoc-data node)))
1681              (when (ert-ewoc-entry-hidden-p entry)
1682                (setf (ert-ewoc-entry-hidden-p entry) nil)
1683                (ewoc-invalidate ewoc node))
1684              (ewoc-goto-node ewoc node)))
1685           (t
1686            (goto-char progress-bar-begin)))))
1687
1688 (defun ert-button-action-position ()
1689   "The buffer position where the last button action was triggered."
1690   (cond ((integerp last-command-event)
1691          (point))
1692         ((eventp last-command-event)
1693          (posn-point (event-start last-command-event)))
1694         (t (assert nil))))
1695
1696 (defun ert-results-progress-bar-button-action (button)
1697   "Find the ewoc node that represents the same test as the character clicked on."
1698   (goto-char (ert-button-action-position))
1699   (ert-results-jump-between-summary-and-result))
1700
1701 (defun ert-results-rerun-test-at-point ()
1702   "Re-run the test at point.
1703
1704 To be used in the ERT results buffer."
1705   (interactive)
1706   (let* ((ewoc ert-results-ewoc)
1707          (node (ert-results-test-node-at-point))
1708          (entry (ewoc-data node))
1709          (old-test (ert-ewoc-entry-test entry))
1710          (test-name (ert-test-name old-test))
1711          ;; FIXME: Write a test for this lookup.
1712          (test (if test-name
1713                    (if (ert-test-boundp test-name)
1714                        (ert-get-test test-name)
1715                      (error "No such test: %S" test-name))
1716                  old-test))
1717          (stats ert-results-stats)
1718          (pos (gethash test (ert-stats-test-map stats)))
1719          (progress-message (format "Running test %S" (ert-test-name test))))
1720     ;; Need to save and restore point manually here: When point is on
1721     ;; the first visible ewoc entry while the header is updated, point
1722     ;; moves to the top of the buffer.  This is undesirable, and a
1723     ;; simple `save-excursion' doesn't prevent it.
1724     (let ((point (point)))
1725       (unwind-protect
1726           (unwind-protect
1727               (progn
1728                 (message "%s..." progress-message)
1729                 (ert-run-or-rerun-test stats test
1730                                        ert-results-listener))
1731             (ert-results-update-stats-display ewoc stats)
1732             (message "%s...%s"
1733                      progress-message
1734                      (let ((result (ert-test-most-recent-result test)))
1735                        (ert-string-for-test-result
1736                         result (ert-test-result-expected-p test result)))))
1737         (goto-char point)))))
1738
1739 (defun ert-results-rerun-test-at-point-debugging-errors ()
1740   "Re-run the test at point with `ert-debug-on-error' bound to t.
1741
1742 To be used in the ERT results buffer."
1743   (interactive)
1744   (let ((ert-debug-on-error t))
1745     (ert-results-rerun-test-at-point)))
1746
1747 (defun ert-print-backtrace (backtrace)
1748   "Format the backtrace BACKTRACE to the current buffer."
1749   ;; This is essentially a reimplementation of Fbacktrace
1750   ;; (src/eval.c), but for a saved backtrace, not the current one.
1751   (let ((print-escape-newlines t)
1752         (print-level 8)
1753         (print-length 50))
1754     (dolist (frame backtrace)
1755       (ecase (first frame)
1756         ((nil)
1757          ;; Special operator.
1758          (destructuring-bind (special-operator &rest arg-forms)
1759              (cdr frame)
1760            (insert
1761             (format "  %S\n" (list* special-operator arg-forms)))))
1762         ((t)
1763          ;; Function call.
1764          (destructuring-bind (fn &rest args) (cdr frame)
1765            (insert (format "  %S(" fn))
1766            (loop for firstp = t then nil
1767                  for arg in args do
1768                  (unless firstp
1769                    (insert " "))
1770                  (insert (format "%S" arg)))
1771            (insert ")\n")))))))
1772
1773 (defun ert-results-pop-to-backtrace-for-test-at-point ()
1774   "Display the backtrace for the test at point.
1775
1776 To be used in the ERT results buffer."
1777   (interactive)
1778   (let* ((node (ert-results-test-node-at-point))
1779          (entry (ewoc-data node))
1780          (test (ert-ewoc-entry-test entry))
1781          (result (ert-ewoc-entry-result entry)))
1782     (etypecase result
1783       (ert-test-passed (error "Test passed, no backtrace available"))
1784       (ert-test-result-with-condition
1785        (let ((backtrace (ert-test-result-with-condition-backtrace result))
1786              (buffer
1787               (let ((default-major-mode 'fundamental-mode))
1788                 (get-buffer-create "*ERT Backtrace*"))))
1789          (pop-to-buffer buffer)
1790          (setq buffer-read-only t)
1791          (let ((inhibit-read-only t))
1792            (erase-buffer)
1793            ;; Use unibyte because `debugger-setup-buffer' also does so.
1794            (set-buffer-multibyte nil)
1795            (setq truncate-lines t)
1796            (ert-print-backtrace backtrace)
1797            (debugger-make-xrefs)
1798            (goto-char (point-min))))))))
1799
1800 (defun ert-results-pop-to-messages-for-test-at-point ()
1801   "Display the part of the *Messages* buffer generated during the test at point.
1802
1803 To be used in the ERT results buffer."
1804   (interactive)
1805   (let* ((node (ert-results-test-node-at-point))
1806          (entry (ewoc-data node))
1807          (test (ert-ewoc-entry-test entry))
1808          (result (ert-ewoc-entry-result entry)))
1809     (let ((buffer
1810            (let ((default-major-mode 'fundamental-mode))
1811              (get-buffer-create "*ERT Messages*"))))
1812       (pop-to-buffer buffer)
1813       (setq buffer-read-only t)
1814       (let ((inhibit-read-only t))
1815         (erase-buffer)
1816         (insert (ert-test-result-messages result))
1817         (goto-char (point-min))
1818         (insert "Messages for test `")
1819         (ert-insert-test-name-button (ert-test-name test))
1820         (insert "':\n")))))
1821
1822 (defun ert-results-toggle-printer-limits-for-test-at-point ()
1823   "Toggle how much of the condition to print for the test at point.
1824
1825 To be used in the ERT results buffer."
1826   (interactive)
1827   (let* ((ewoc ert-results-ewoc)
1828          (node (ert-results-test-node-at-point))
1829          (entry (ewoc-data node)))
1830     (setf (ert-ewoc-entry-extended-printer-limits-p entry)
1831           (not (ert-ewoc-entry-extended-printer-limits-p entry)))
1832     (ewoc-invalidate ewoc node)))
1833
1834 (defun ert-activate-font-lock-keywords ()
1835   (font-lock-add-keywords
1836    nil
1837    '(("(\\(\\<ert-deftest\\)\\>\\s *\\(\\sw+\\)?"
1838       (1 font-lock-keyword-face nil t)
1839       (2 font-lock-function-name-face nil t)))))
1840
1841 (defun* ert-remove-from-list (list-var element &key key test)
1842   "Remove ELEMENT from the value of LIST-VAR if present.
1843
1844 This is an inverse of `add-to-list'."
1845   (unless key (setq key #'identity))
1846   (unless test (setq test #'equal))
1847   (setf (symbol-value list-var)
1848         (remove* element
1849                  (symbol-value list-var)
1850                  :key key
1851                  :test test)))
1852
1853
1854 ;;; Actions on load/unload.
1855
1856 (add-to-list 'find-function-regexp-alist '(ert-deftest . ert-find-test-regexp))
1857 (add-to-list 'minor-mode-alist '(ert-current-run-stats
1858                                  (:eval
1859                                   (ert-tests-running-mode-line-indicator))))
1860 (add-to-list 'emacs-lisp-mode-hook 'ert-activate-font-lock-keywords)
1861
1862 (defun ert-unload-function ()
1863   (ert-remove-from-list 'find-function-regexp-alist 'ert-deftest :key #'car)
1864   (ert-remove-from-list 'minor-mode-alist 'ert-current-run-stats :key #'car)
1865   (ert-remove-from-list 'emacs-lisp-mode-hook 'ert-activate-font-lock-keywords)
1866   nil)
1867
1868 (defvar ert-unload-hook '())
1869 (add-hook 'ert-unload-hook 'ert-unload-function)
1870
1871
1872 ;;; Self-tests.
1873
1874 (ert-delete-all-tests)
1875
1876 ;; Test that test bodies are actually run.
1877 (defvar ert-test-body-was-run)
1878 (ert-deftest ert-test-body-runs ()
1879   (setq ert-test-body-was-run t))
1880
1881
1882 ;; Test that nested test bodies run.
1883 (ert-deftest ert-nested-test-body-runs ()
1884   (lexical-let ((was-run nil))
1885     (let ((test (make-ert-test :body (lambda ()
1886                                        (setq was-run t)))))
1887       (assert (not was-run))
1888       (ert-run-test test)
1889       (assert was-run))))
1890
1891
1892 ;; Test that pass/fail works.
1893 (ert-deftest ert-test-pass ()
1894   (let ((test (make-ert-test :body (lambda ()))))
1895     (let ((result (ert-run-test test)))
1896       (assert (typep result 'ert-test-passed)))))
1897
1898 (ert-deftest ert-test-fail ()
1899   (let ((test (make-ert-test :body (lambda () (ert-fail "failure message")))))
1900     (let ((result (let ((ert-debug-on-error nil))
1901                     (ert-run-test test))))
1902       (assert (typep result 'ert-test-failed) t)
1903       (assert (equal (ert-test-result-with-condition-condition result)
1904                      '(ert-test-failed "failure message"))
1905               t))))
1906
1907 (ert-deftest ert-test-fail-debug-with-condition-case ()
1908   (let ((test (make-ert-test :body (lambda () (ert-fail "failure message")))))
1909     (condition-case condition
1910         (progn
1911           (let ((ert-debug-on-error t))
1912             (ert-run-test test))
1913           (assert nil))
1914       ((error)
1915        (assert (equal condition '(ert-test-failed "failure message")) t)))))
1916
1917 (ert-deftest ert-test-fail-debug-with-debugger-1 ()
1918   (let ((test (make-ert-test :body (lambda () (ert-fail "failure message")))))
1919     (let ((debugger (lambda (&rest debugger-args)
1920                       (assert nil))))
1921       (let ((ert-debug-on-error nil))
1922         (ert-run-test test)))))
1923
1924 (ert-deftest ert-test-fail-debug-with-debugger-2 ()
1925   (let ((test (make-ert-test :body (lambda () (ert-fail "failure message")))))
1926     (block nil
1927       (let ((debugger (lambda (&rest debugger-args)
1928                         (return-from nil nil))))
1929         (let ((ert-debug-on-error t))
1930           (ert-run-test test))
1931         (assert nil)))))
1932
1933 (ert-deftest ert-test-fail-debug-nested-with-debugger ()
1934   (let ((test (make-ert-test :body (lambda ()
1935                                      (let ((ert-debug-on-error t))
1936                                        (ert-fail "failure message"))))))
1937     (let ((debugger (lambda (&rest debugger-args)
1938                       (assert nil nil "Assertion a"))))
1939       (let ((ert-debug-on-error nil))
1940         (ert-run-test test))))
1941   (let ((test (make-ert-test :body (lambda ()
1942                                      (let ((ert-debug-on-error nil))
1943                                        (ert-fail "failure message"))))))
1944     (block nil
1945       (let ((debugger (lambda (&rest debugger-args)
1946                         (return-from nil nil))))
1947         (let ((ert-debug-on-error t))
1948           (ert-run-test test))
1949         (assert nil nil "Assertion b")))))
1950
1951 (ert-deftest ert-test-error ()
1952   (let ((test (make-ert-test :body (lambda () (error "error message")))))
1953     (let ((result (let ((ert-debug-on-error nil))
1954                     (ert-run-test test))))
1955       (assert (typep result 'ert-test-error) t)
1956       (assert (equal (ert-test-result-with-condition-condition result)
1957                      '(error "error message"))
1958               t))))
1959
1960 (ert-deftest ert-test-error-debug ()
1961   (let ((test (make-ert-test :body (lambda () (error "error message")))))
1962     (condition-case condition
1963         (progn
1964           (let ((ert-debug-on-error t))
1965             (ert-run-test test))
1966           (assert nil))
1967       ((error)
1968        (assert (equal condition '(error "error message")) t)))))
1969
1970
1971 ;; Test that `should' works.
1972 (ert-deftest ert-test-should ()
1973   (let ((test (make-ert-test :body (lambda () (ert-should nil)))))
1974     (let ((result (let ((ert-debug-on-error nil))
1975                     (ert-run-test test))))
1976       (assert (typep result 'ert-test-failed) t)
1977       (assert (equal (ert-test-result-with-condition-condition result)
1978                      '(ert-test-failed ((ert-should nil) :form nil :value nil)))
1979               t)))
1980   (let ((test (make-ert-test :body (lambda () (ert-should t)))))
1981     (let ((result (ert-run-test test)))
1982       (assert (typep result 'ert-test-passed) t))))
1983
1984 (ert-deftest ert-test-should-value ()
1985   (ert-should (eql (ert-should 'foo) 'foo))
1986   (ert-should (eql (ert-should 'bar) 'bar)))
1987
1988 (ert-deftest ert-test-should-not ()
1989   (let ((test (make-ert-test :body (lambda () (ert-should-not t)))))
1990     (let ((result (let ((ert-debug-on-error nil))
1991                     (ert-run-test test))))
1992       (assert (typep result 'ert-test-failed) t)
1993       (assert (equal (ert-test-result-with-condition-condition result)
1994                      '(ert-test-failed ((ert-should-not t) :form t :value t)))
1995               t)))
1996   (let ((test (make-ert-test :body (lambda () (ert-should-not nil)))))
1997     (let ((result (ert-run-test test)))
1998       (assert (typep result 'ert-test-passed)))))
1999
2000
2001 (ert-deftest ert-test-should-error ()
2002   ;; No error.
2003   (let ((test (make-ert-test :body (lambda () (ert-should-error (progn))))))
2004     (let ((result (let ((ert-debug-on-error nil))
2005                     (ert-run-test test))))
2006       (ert-should (typep result 'ert-test-failed))
2007       (ert-should (equal (ert-test-result-with-condition-condition result)
2008                      '(ert-test-failed
2009                        ((ert-should-error (progn))
2010                         :form (progn)
2011                         :value nil
2012                         :fail-reason "did not signal an error"))))))
2013   ;; A simple error.
2014   (let ((test (make-ert-test :body (lambda () (ert-should-error (error "foo"))))))
2015     (let ((result (ert-run-test test)))
2016       (ert-should (typep result 'ert-test-passed))))
2017   ;; Error of unexpected type, no test.
2018   (let ((test (make-ert-test :body (lambda ()
2019                                      (ert-should-error (error "foo")
2020                                                    :type 'singularity-error)))))
2021     (let ((result (ert-run-test test)))
2022       (ert-should (typep result 'ert-test-failed))
2023       (ert-should (equal
2024                (ert-test-result-with-condition-condition result)
2025                '(ert-test-failed
2026                  ((ert-should-error (error "foo") :type 'singularity-error)
2027                   :form (error "foo")
2028                   :condition (error "foo")
2029                   :fail-reason
2030                   "the error signalled did not have the expected type"))))))
2031   ;; Error of the expected type, no test.
2032   (let ((test (make-ert-test :body (lambda ()
2033                                      (ert-should-error (signal 'singularity-error
2034                                                            nil)
2035                                                    :type 'singularity-error)))))
2036     (let ((result (ert-run-test test)))
2037       (ert-should (typep result 'ert-test-passed))))
2038   ;; Error that fails the test, no type.
2039   (let ((test (make-ert-test :body (lambda ()
2040                                      (ert-should-error
2041                                       (error "foo")
2042                                       :test (lambda (error) nil))))))
2043     (let ((result (ert-run-test test)))
2044       (ert-should (typep result 'ert-test-failed))
2045       (ert-should (equal (ert-test-result-with-condition-condition result)
2046                      '(ert-test-failed
2047                        ((ert-should-error (error "foo") :test (lambda (error) nil))
2048                         :form (error "foo")
2049                         :condition (error "foo")
2050                         :fail-reason
2051                         "the error signalled did not pass the test"))))))
2052   ;; Error that passes the test, no type.
2053   (let ((test (make-ert-test :body (lambda ()
2054                                      (ert-should-error (error "foo")
2055                                                    :test (lambda (error) t))))))
2056     (let ((result (ert-run-test test)))
2057       (ert-should (typep result 'ert-test-passed))))
2058   ;; Error that has the expected type but fails the test.
2059   (let ((test (make-ert-test :body (lambda ()
2060                                      (ert-should-error
2061                                       (signal 'singularity-error nil)
2062                                       :type 'singularity-error
2063                                       :test (lambda (error) nil))))))
2064     (let ((result (ert-run-test test)))
2065       (ert-should (typep result 'ert-test-failed))
2066       (ert-should (equal (ert-test-result-with-condition-condition result)
2067                      '(ert-test-failed
2068                        ((ert-should-error (signal 'singularity-error nil)
2069                                       :type 'singularity-error
2070                                       :test (lambda (error) nil))
2071                         :form (signal singularity-error nil)
2072                         :condition (singularity-error)
2073                         :fail-reason
2074                         "the error signalled did not pass the test"))))))
2075   ;; Error that has the expected type and passes the test.
2076   (let ((test (make-ert-test :body (lambda ()
2077                                      (ert-should-error
2078                                       (signal 'singularity-error nil)
2079                                       :type 'singularity-error
2080                                       :test (lambda (error) t))))))
2081     (let ((result (ert-run-test test)))
2082       (ert-should (typep result 'ert-test-passed))))
2083   )
2084
2085 (ert-deftest ert-test-should-error-subtypes ()
2086   (let ((test (make-ert-test
2087                :body (lambda ()
2088                        (ert-should-error (signal 'singularity-error nil)
2089                                      :type 'singularity-error
2090                                      :exclude-subtypes t)))))
2091     (let ((result (ert-run-test test)))
2092       (ert-should (typep result 'ert-test-passed))))
2093   (let ((test (make-ert-test
2094                :body (lambda ()
2095                        (ert-should-error (signal 'arith-error nil)
2096                                      :type 'singularity-error)))))
2097     (let ((result (ert-run-test test)))
2098       (ert-should (typep result 'ert-test-failed))
2099       (ert-should (equal
2100                (ert-test-result-with-condition-condition result)
2101                '(ert-test-failed
2102                  ((ert-should-error (signal 'arith-error nil)
2103                                 :type 'singularity-error)
2104                   :form (signal arith-error nil)
2105                   :condition (arith-error)
2106                   :fail-reason
2107                   "the error signalled did not have the expected type"))))))
2108   (let ((test (make-ert-test
2109                :body (lambda ()
2110                        (ert-should-error (signal 'arith-error nil)
2111                                      :type 'singularity-error
2112                                      :exclude-subtypes t)))))
2113     (let ((result (ert-run-test test)))
2114       (ert-should (typep result 'ert-test-failed))
2115       (ert-should (equal
2116                (ert-test-result-with-condition-condition result)
2117                '(ert-test-failed
2118                  ((ert-should-error (signal 'arith-error nil)
2119                                 :type 'singularity-error
2120                                 :exclude-subtypes t)
2121                   :form (signal arith-error nil)
2122                   :condition (arith-error)
2123                   :fail-reason
2124                   "the error signalled did not have the expected type"))))))
2125   (let ((test (make-ert-test
2126                :body (lambda ()
2127                        (ert-should-error (signal 'singularity-error nil)
2128                                      :type 'arith-error
2129                                      :exclude-subtypes t)))))
2130     (let ((result (ert-run-test test)))
2131       (ert-should (typep result 'ert-test-failed))
2132       (ert-should (equal
2133                (ert-test-result-with-condition-condition result)
2134                '(ert-test-failed
2135                  ((ert-should-error (signal 'singularity-error nil)
2136                                 :type 'arith-error
2137                                 :exclude-subtypes t)
2138                   :form (signal singularity-error nil)
2139                   :condition (singularity-error)
2140                   :fail-reason
2141                   "the error signalled was a subtype of the expected type"))))))
2142   )
2143
2144 ;; Test that `should' errors contain the information we expect them to.
2145 (defmacro ert-test-my-list (&rest args)
2146   `(list ,@args))
2147
2148 (ert-deftest ert-test-should-failure-debugging ()
2149   (loop for (body expected-condition) in
2150         `((,(lambda () (let ((x nil)) (ert-should x)))
2151            (ert-test-failed ((ert-should x) :form x :value nil)))
2152           (,(lambda () (let ((x t)) (ert-should-not x)))
2153            (ert-test-failed ((ert-should-not x) :form x :value t)))
2154           (,(lambda () (let ((x t)) (ert-should (not x))))
2155            (ert-test-failed ((ert-should (not x)) :form (not t) :value nil)))
2156           (,(lambda () (let ((x nil)) (ert-should-not (not x))))
2157            (ert-test-failed ((ert-should-not (not x)) :form (not nil) :value t)))
2158           (,(lambda () (let ((x t) (y nil)) (ert-should-not (ert-test-my-list x y))))
2159            (ert-test-failed
2160             ((ert-should-not (ert-test-my-list x y))
2161              :form (list t nil)
2162              :value (t nil))))
2163           (,(lambda () (let ((x t)) (ert-should (error "foo"))))
2164            (error "foo")))
2165         do
2166         (let ((test (make-ert-test :body body)))
2167           (condition-case actual-condition
2168               (progn
2169                 (let ((ert-debug-on-error t))
2170                   (ert-run-test test))
2171                 (assert nil))
2172             ((error)
2173              (ert-should (equal actual-condition expected-condition)))))))
2174
2175 (ert-deftest ert-test-messages ()
2176   (let* ((message-string "Test message")
2177          (messages-buffer (get-buffer-create "*Messages*"))
2178          (test (make-ert-test :body (lambda () (message "%s" message-string)))))
2179     (with-current-buffer messages-buffer
2180       (let ((result (ert-run-test test)))
2181         (ert-should (equal (concat message-string "\n")
2182                        (ert-test-result-messages result)))))))
2183
2184 (defun ert-call-with-temporary-messages-buffer (thunk)
2185   (lexical-let ((new-buffer-name (generate-new-buffer-name
2186                                   "*Messages* orig buffer")))
2187     (unwind-protect
2188         (progn
2189           (with-current-buffer (get-buffer-create "*Messages*")
2190             (rename-buffer new-buffer-name))
2191           (get-buffer-create "*Messages*")
2192           (funcall thunk))
2193       (kill-buffer "*Messages*")
2194       (with-current-buffer new-buffer-name
2195         (rename-buffer "*Messages*")))))
2196
2197 (ert-deftest ert-test-messages-on-log-truncation ()
2198   (let ((test (make-ert-test
2199                :body (lambda ()
2200                        ;; Emacs would combine messages if we
2201                        ;; generate the same message multiple
2202                        ;; times.
2203                        (message "a")
2204                        (message "b")
2205                        (message "c")
2206                        (message "d")))))
2207     (let (result)
2208       (ert-call-with-temporary-messages-buffer
2209        (lambda ()
2210          (let ((message-log-max 2))
2211            (setq result (ert-run-test test)))
2212          (ert-should (equal (with-current-buffer "*Messages*"
2213                           (buffer-string))
2214                         "c\nd\n"))))
2215       (ert-should (equal (ert-test-result-messages result) "a\nb\nc\nd\n")))))
2216
2217 ;; Test `ert-select-tests'.
2218 (ert-deftest ert-test-select-regexp ()
2219   (ert-should (equal (ert-select-tests "^ert-test-select-regexp$" t)
2220                  (list (ert-get-test 'ert-test-select-regexp)))))
2221
2222 (ert-deftest ert-test-test-boundp ()
2223   (ert-should (ert-test-boundp 'ert-test-test-boundp))
2224   (ert-should-not (ert-test-boundp (make-symbol "ert-not-a-test"))))
2225
2226 (ert-deftest ert-test-select-member ()
2227   (ert-should (equal (ert-select-tests '(member ert-test-select-member) t)
2228                  (list (ert-get-test 'ert-test-select-member)))))
2229
2230 (ert-deftest ert-test-select-test ()
2231   (ert-should (equal (ert-select-tests (ert-get-test 'ert-test-select-test) t)
2232                  (list (ert-get-test 'ert-test-select-test)))))
2233
2234 (ert-deftest ert-test-select-symbol ()
2235   (ert-should (equal (ert-select-tests 'ert-test-select-symbol t)
2236                  (list (ert-get-test 'ert-test-select-symbol)))))
2237
2238 (ert-deftest ert-test-select-and ()
2239   (let ((test (make-ert-test
2240                :name nil
2241                :body nil
2242                :most-recent-result (make-ert-test-failed
2243                                     :condition nil
2244                                     :backtrace nil))))
2245     (ert-should (equal (ert-select-tests `(and (member ,test) :failed) t)
2246                    (list test)))))
2247
2248
2249 ;; Test utility functions.
2250 (ert-deftest ert-proper-list-p ()
2251   (ert-should (ert-proper-list-p '()))
2252   (ert-should (ert-proper-list-p '(1)))
2253   (ert-should (ert-proper-list-p '(1 2)))
2254   (ert-should (ert-proper-list-p '(1 2 3)))
2255   (ert-should (ert-proper-list-p '(1 2 3 4)))
2256   (ert-should (not (ert-proper-list-p 'a)))
2257   (ert-should (not (ert-proper-list-p '(1 . a))))
2258   (ert-should (not (ert-proper-list-p '(1 2 . a))))
2259   (ert-should (not (ert-proper-list-p '(1 2 3 . a))))
2260   (ert-should (not (ert-proper-list-p '(1 2 3 4 . a))))
2261   (let ((a (list 1)))
2262     (setf (cdr (last a)) a)
2263     (ert-should (not (ert-proper-list-p a))))
2264   (let ((a (list 1 2)))
2265     (setf (cdr (last a)) a)
2266     (ert-should (not (ert-proper-list-p a))))
2267   (let ((a (list 1 2 3)))
2268     (setf (cdr (last a)) a)
2269     (ert-should (not (ert-proper-list-p a))))
2270   (let ((a (list 1 2 3 4)))
2271     (setf (cdr (last a)) a)
2272     (ert-should (not (ert-proper-list-p a))))
2273   (let ((a (list 1 2)))
2274     (setf (cdr (last a)) (cdr a))
2275     (ert-should (not (ert-proper-list-p a))))
2276   (let ((a (list 1 2 3)))
2277     (setf (cdr (last a)) (cdr a))
2278     (ert-should (not (ert-proper-list-p a))))
2279   (let ((a (list 1 2 3 4)))
2280     (setf (cdr (last a)) (cdr a))
2281     (ert-should (not (ert-proper-list-p a))))
2282   (let ((a (list 1 2 3)))
2283     (setf (cdr (last a)) (cddr a))
2284     (ert-should (not (ert-proper-list-p a))))
2285   (let ((a (list 1 2 3 4)))
2286     (setf (cdr (last a)) (cddr a))
2287     (ert-should (not (ert-proper-list-p a))))
2288   (let ((a (list 1 2 3 4)))
2289     (setf (cdr (last a)) (cdddr a))
2290     (ert-should (not (ert-proper-list-p a)))))
2291
2292 (ert-deftest ert-parse-keys-and-body ()
2293   (ert-should (equal (ert-parse-keys-and-body "doc" '(foo))
2294                      '(nil "doc" (foo))))
2295   (ert-should (equal (ert-parse-keys-and-body "doc" '(:bar foo))
2296                      '((:bar foo) "doc" nil)))
2297   (ert-should (equal (ert-parse-keys-and-body nil '(:bar foo))
2298                      '((:bar foo) nil nil)))
2299   (ert-should (equal (ert-parse-keys-and-body "doc" '(:bar foo))
2300                      '((:bar foo) "doc" nil)))
2301   (ert-should (equal (ert-parse-keys-and-body nil '(:bar foo a (b)))
2302                      '((:bar foo) nil (a (b)))))
2303   (ert-should (equal (ert-parse-keys-and-body nil '(:bar foo :a (b)))
2304                      '((:bar foo :a (b)) nil nil)))
2305   (ert-should (equal (ert-parse-keys-and-body nil '(bar foo :a (b)))
2306                      '(nil nil (bar foo :a (b)))))
2307   (ert-should-error (ert-parse-keys-and-body nil '(:bar foo :a))))
2308
2309
2310
2311 ;; Test `ert-run-tests'.
2312 (ert-deftest ert-test-run-tests ()
2313   (let ((passing-test (make-ert-test :name 'passing-test
2314                                      :body (lambda () (ert-pass))))
2315         (failing-test (make-ert-test :name 'failing-test
2316                                      :body (lambda () (ert-fail
2317                                                        "failure message"))))
2318         )
2319     (let ((ert-debug-on-error nil))
2320       (let* ((buffer-name (generate-new-buffer-name " *ert-test-run-tests*"))
2321              (messages nil)
2322              (mock-message-fn
2323               (lambda (format-string &rest args)
2324                 (push (apply #'format format-string args) messages))))
2325         (save-window-excursion
2326           (unwind-protect
2327               (let ((case-fold-search nil))
2328                 (ert-run-tests-interactively
2329                  `(member ,passing-test ,failing-test) buffer-name
2330                  mock-message-fn)
2331                 (ert-should (equal messages `(,(concat
2332                                             "Ran 2 tests, 1 results were "
2333                                             "as expected, 1 unexpected"))))
2334                 (with-current-buffer buffer-name
2335                   (goto-char (point-min))
2336                   (ert-should (equal
2337                            (buffer-substring (point-min)
2338                                              (save-excursion
2339                                                (forward-line 5)
2340                                                (point)))
2341                            (concat
2342                             "Selector: (member <passing-test> <failing-test>)\n"
2343                             "Passed: 1 (0 unexpected)\n"
2344                             "Failed: 1 (1 unexpected)\n"
2345                             "Error:  0 (0 unexpected)\n"
2346                             "Total:  2/2\n")))))
2347             (when (get-buffer buffer-name)
2348               (kill-buffer buffer-name))))))))
2349
2350 (ert-deftest ert-test-special-operator-p ()
2351   (ert-should (ert-special-operator-p 'if))
2352   (ert-should-not (ert-special-operator-p 'car))
2353   (ert-should-not (ert-special-operator-p 'ert-special-operator-p))
2354   (let ((b (gensym)))
2355     (ert-should-not (ert-special-operator-p b))
2356     (fset b 'if)
2357     (ert-should (ert-special-operator-p b))))
2358
2359 ;; This test attempts to demonstrate that there is no way to force
2360 ;; immediate truncation of the *Messages* buffer from Lisp (and hence
2361 ;; justifies the existence of
2362 ;; `ert-force-message-log-buffer-truncation'): The only way that came
2363 ;; to my mind was (message ""), which doesn't have the desired effect.
2364 (ert-deftest ert-test-builtin-message-log-flushing ()
2365   (ert-call-with-temporary-messages-buffer
2366    (lambda ()
2367      (with-current-buffer "*Messages*"
2368        (let ((message-log-max 2))
2369          (let ((message-log-max t))
2370            (loop for i below 4 do
2371                  (message "%s" i))
2372            (ert-should (eql (count-lines (point-min) (point-max)) 4)))
2373          (ert-should (eql (count-lines (point-min) (point-max)) 4))
2374          (message "")
2375          (ert-should (eql (count-lines (point-min) (point-max)) 4))
2376          (message "Test message")
2377          (ert-should (eql (count-lines (point-min) (point-max)) 2)))))))
2378
2379 (ert-deftest ert-test-force-message-log-buffer-truncation ()
2380   (labels ((body ()
2381              (loop for i below 5 do
2382                    (message "%s" i)))
2383            (c (x)
2384              (ert-call-with-temporary-messages-buffer
2385               (lambda ()
2386                 (let ((message-log-max x))
2387                   (body))
2388                 (with-current-buffer "*Messages*"
2389                   (buffer-string)))))
2390            (lisp (x)
2391              (ert-call-with-temporary-messages-buffer
2392               (lambda ()
2393                 (let ((message-log-max t))
2394                   (body))
2395                 (let ((message-log-max x))
2396                   (ert-force-message-log-buffer-truncation))
2397                 (with-current-buffer "*Messages*"
2398                   (buffer-string))))))
2399     (loop for x in '(0 1 2 3 4 5 6 t) do
2400           (ert-should (equal (c x) (lisp x))))))
2401
2402 (defun ert-run-self-tests ()
2403   ;; Run tests and make sure they actually ran.
2404   (let ((window-configuration (current-window-configuration)))
2405     (let ((ert-test-body-was-run nil))
2406       ;; The buffer name chosen here should not compete with the default
2407       ;; results buffer name for completion in `switch-to-buffer'.
2408       (let ((stats (ert-run-tests-interactively "^ert-" " *ert self-tests*")))
2409         (assert ert-test-body-was-run)
2410         (when (zerop (+ (ert-stats-passed-unexpected stats)
2411                         (ert-stats-failed-unexpected stats)
2412                         (ert-stats-error-unexpected stats)))
2413           ;; Hide results window only when everything went well.
2414           (set-window-configuration window-configuration))))))
2415
2416 (provide 'ert)
2417
2418 ;;; ert.el ends here