2419 lines
101 KiB
EmacsLisp
2419 lines
101 KiB
EmacsLisp
|
;;; ert.el --- Emacs Lisp Regression Testing
|
||
|
|
|
||
|
|
;; Modified by Lennart Borgman 2008-07-13 to make all global symbols
|
||
|
|
;; use the "ert-" prefix.
|
||
|
|
|
||
|
|
;; Copyright (C) 2007, 2008 Christian M. Ohler
|
||
|
|
|
||
|
|
;; Author: Christian M. Ohler
|
||
|
|
;; Version: 0.2
|
||
|
|
;; Keywords: lisp, tools
|
||
|
|
|
||
|
|
;; This file is NOT part of GNU Emacs.
|
||
|
|
|
||
|
|
;; This program is free software: you can redistribute it and/or
|
||
|
|
;; modify it under the terms of the GNU General Public License as
|
||
|
|
;; published by the Free Software Foundation, either version 3 of the
|
||
|
|
;; License, or (at your option) any later version.
|
||
|
|
;;
|
||
|
|
;; This program is distributed in the hope that it will be useful, but
|
||
|
|
;; WITHOUT ANY WARRANTY; without even the implied warranty of
|
||
|
|
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
||
|
|
;; General Public License for more details.
|
||
|
|
;;
|
||
|
|
;; You should have received a copy of the GNU General Public License
|
||
|
|
;; along with this program. If not, see `http://www.gnu.org/licenses/'.
|
||
|
|
|
||
|
|
;;; Commentary:
|
||
|
|
|
||
|
|
;; ERT is a tool for automated testing in Emacs Lisp. Its main
|
||
|
|
;; features are facilities for defining and running test cases and
|
||
|
|
;; reporting the results as well as for debugging test failures
|
||
|
|
;; interactively.
|
||
|
|
;;
|
||
|
|
;; The main entry points are `ert-deftest', which is similar to
|
||
|
|
;; `defun' but defines a test, and `ert-run-tests-interactively',
|
||
|
|
;; which runs tests and offers an interactive interface for inspecting
|
||
|
|
;; results and debugging. There is also `ert-run-tests-batch' for
|
||
|
|
;; non-interactive use.
|
||
|
|
;;
|
||
|
|
;; The body of `ert-deftest' forms resembles a function body, but the
|
||
|
|
;; additional operators `should', `should-not' and `should-error' are
|
||
|
|
;; available. `should' is similar to cl's `assert', but signals a
|
||
|
|
;; different error when its condition is violated that is caught and
|
||
|
|
;; processed by ERT. In addition, it analyzes its argument form and
|
||
|
|
;; records information that helps debugging (`assert' tries to do
|
||
|
|
;; something similar when its second argument SHOW-ARGS is true, but
|
||
|
|
;; `should' is more sophisticated). For information on `should-not'
|
||
|
|
;; and `should-error', see their docstrings.
|
||
|
|
;;
|
||
|
|
;; For example,
|
||
|
|
;;
|
||
|
|
;; ;; Define a test named `foo'.
|
||
|
|
;; (ert-deftest foo ()
|
||
|
|
;; (ert-should (= (+ 1 2) 4)))
|
||
|
|
;;
|
||
|
|
;; ;; Run it.
|
||
|
|
;; (ert-run-tests-interactively 'foo)
|
||
|
|
;;
|
||
|
|
;; generates the following output (in addition to some statistics) in
|
||
|
|
;; the *ert* results buffer:
|
||
|
|
;;
|
||
|
|
;; F foo
|
||
|
|
;; (ert-test-failed
|
||
|
|
;; ((ert-should
|
||
|
|
;; (=
|
||
|
|
;; (+ 1 2)
|
||
|
|
;; 4))
|
||
|
|
;; :form
|
||
|
|
;; (= 3 4)
|
||
|
|
;; :value nil))
|
||
|
|
;;
|
||
|
|
;; This indicates that the test failed. The `should' form that failed
|
||
|
|
;; was (ert-should (= (+ 1 2) 4)), because its inner form, after
|
||
|
|
;; evaluation of its arguments, was the function call (= 3 4), which
|
||
|
|
;; returned nil.
|
||
|
|
;;
|
||
|
|
;; Obviously, this is a bug in the test case, not in the functions `+'
|
||
|
|
;; or `='. In the results buffer, with point on the test result, the
|
||
|
|
;; key "." can be used to jump to the definition of the test to modify
|
||
|
|
;; it to correct the bug. After evaluating the modified definition
|
||
|
|
;; and switching back to the results buffer, the key "r" will re-run
|
||
|
|
;; the test and show the new result.
|
||
|
|
|
||
|
|
|
||
|
|
;; Test selectors
|
||
|
|
;;
|
||
|
|
;; Functions like `ert-run-tests-interactively' accept a test
|
||
|
|
;; selector, which is a Lisp expression specifying a set of tests.
|
||
|
|
;; Each test name is a selector that refers to that test, the selector
|
||
|
|
;; `t' refers to all tests, and the selector `:failed' refers to all
|
||
|
|
;; tests that failed; but more complex selectors are available. Test
|
||
|
|
;; selector syntax is similar to cl's type specifier syntax. See the
|
||
|
|
;; docstring of `ert-select-tests' for details.
|
||
|
|
|
||
|
|
|
||
|
|
;; Comparison with other testing tools
|
||
|
|
;;
|
||
|
|
;; ERT allows test-driven development similar to *Unit frameworks for
|
||
|
|
;; other languages. However, two common *Unit features are notably
|
||
|
|
;; absent from ERT: fixtures and test suites.
|
||
|
|
;;
|
||
|
|
;; Fixtures, as used e.g. in SUnit or JUnit, have two main purposes:
|
||
|
|
;; Setting up (and tearing down) an environment for a set of test
|
||
|
|
;; cases, and making that environment accessible through object
|
||
|
|
;; attributes that can be used like local variables.
|
||
|
|
;;
|
||
|
|
;; While fixtures are a great syntactic simplification in other
|
||
|
|
;; languages, they are not very useful in Lisp, where higher-order
|
||
|
|
;; functions and `unwind-protect' are available. One way to implement
|
||
|
|
;; and use a fixture in ERT is
|
||
|
|
;;
|
||
|
|
;; (defun my-fixture (body)
|
||
|
|
;; (unwind-protect
|
||
|
|
;; (progn ...set up...
|
||
|
|
;; (funcall body))
|
||
|
|
;; ...tear down...))
|
||
|
|
;;
|
||
|
|
;; (ert-deftest my-test ()
|
||
|
|
;; (my-fixture
|
||
|
|
;; (lambda ()
|
||
|
|
;; ...test code...)))
|
||
|
|
;;
|
||
|
|
;; (Another way would be a `with-my-fixture' macro.) This solves the
|
||
|
|
;; set-up and tear-down part, and additionally allows any test case to
|
||
|
|
;; use any combination of fixtures, so it is more general than what
|
||
|
|
;; other tools typically allow.
|
||
|
|
;;
|
||
|
|
;; If the test case needs access to the environment the fixture sets
|
||
|
|
;; up, the fixture can be modified to pass arguments to the body.
|
||
|
|
;;
|
||
|
|
;; These are standard Lisp idioms. Special syntax for them could be
|
||
|
|
;; added easily enough, but would provide only a minor simplification.
|
||
|
|
;;
|
||
|
|
;; (Note that splitting set-up and tear-down into separate functions,
|
||
|
|
;; like *Unit tools usually do, makes it impossible to establish
|
||
|
|
;; dynamic `let' bindings as part of the fixture. So, blindly
|
||
|
|
;; imitating the way fixtures are implemented in other languages would
|
||
|
|
;; be counter-productive in Lisp.)
|
||
|
|
;;
|
||
|
|
;;
|
||
|
|
;; The purpose of test suites is to group related test cases together.
|
||
|
|
;; The most common use of this is to run just the tests for one
|
||
|
|
;; particular module. Since symbol prefixes are the usual way of
|
||
|
|
;; separating module namespaces in Emacs Lisp, test selectors already
|
||
|
|
;; solve this by allowing regexp matching on test names; e.g., the
|
||
|
|
;; selector "^ert-" selects ERT's self-tests.
|
||
|
|
;;
|
||
|
|
;; If test suites containing arbitrary sets of tests are found to be
|
||
|
|
;; desirable, it would be easy to add a `define-test-selector'
|
||
|
|
;; mechanism that introduces a new selector, defined in terms of
|
||
|
|
;; existing ones; e.g.
|
||
|
|
;;
|
||
|
|
;; ;; Note that `define-test-selector' does not exist yet.
|
||
|
|
;; (define-test-selector my-test-suite () `(member foo-test bar-test))
|
||
|
|
;;
|
||
|
|
;; would define a test suite named `my-test-suite' consisting of
|
||
|
|
;; `foo-test' and `bar-test'. See also `deftype' in Common Lisp.
|
||
|
|
|
||
|
|
|
||
|
|
;; TODO: Add `skip' feature for tests that can't run in current environment.
|
||
|
|
|
||
|
|
|
||
|
|
;;; Code:
|
||
|
|
|
||
|
|
(eval-when-compile (require 'cl))
|
||
|
|
(require 'ewoc)
|
||
|
|
(require 'find-func)
|
||
|
|
(require 'debug)
|
||
|
|
|
||
|
|
(defvar ert-debug-on-error nil
|
||
|
|
"Non-nil means enter debugger when a test fails or terminates with an error.")
|
||
|
|
|
||
|
|
|
||
|
|
;;; Defining and locating tests.
|
||
|
|
|
||
|
|
;; The data structure that represents a test case.
|
||
|
|
(defstruct ert-test
|
||
|
|
(name nil)
|
||
|
|
(documentation nil)
|
||
|
|
(body (assert nil))
|
||
|
|
(most-recent-result nil)
|
||
|
|
(expected-result-type 'ert-test-passed))
|
||
|
|
|
||
|
|
(defun ert-test-boundp (symbol)
|
||
|
|
"Return non-nil if SYMBOL names a test."
|
||
|
|
(and (get symbol 'ert-test) t))
|
||
|
|
|
||
|
|
(defun ert-get-test (symbol)
|
||
|
|
"If SYMBOL names a test, return that. Signal an error otherwise."
|
||
|
|
(assert (ert-test-boundp symbol) t)
|
||
|
|
(get symbol 'ert-test))
|
||
|
|
|
||
|
|
(defun ert-set-test (symbol doc definition)
|
||
|
|
"Make SYMBOL name the test DEFINITION, and return DEFINITION."
|
||
|
|
(when doc
|
||
|
|
(put symbol 'ert-test-documentation doc))
|
||
|
|
(put symbol 'ert-test definition)
|
||
|
|
definition)
|
||
|
|
|
||
|
|
(defun ert-make-test-unbound (symbol)
|
||
|
|
"Make SYMBOL name no test. Return SYMBOL."
|
||
|
|
(remprop symbol 'ert-test)
|
||
|
|
symbol)
|
||
|
|
|
||
|
|
(defun ert-test-result-expected-p (test result)
|
||
|
|
"Return non-nil if RESULT matches the expected result type for TEST."
|
||
|
|
(typep result (ert-test-expected-result-type test)))
|
||
|
|
|
||
|
|
(defvar ert-find-test-regexp
|
||
|
|
(concat "^\\s-*(ert-deftest"
|
||
|
|
find-function-space-re
|
||
|
|
"%s\\(\\s-\\|$\\)")
|
||
|
|
"The regexp the `find-function' mechanisms use for locating test definitions.")
|
||
|
|
|
||
|
|
(eval-and-compile
|
||
|
|
(defun ert-parse-keys-and-body (docstr keys-and-body)
|
||
|
|
"Split KEYS-AND-BODY into keyword-and-value pairs and the remaining body.
|
||
|
|
|
||
|
|
KEYS-AND-BODY should have the form of a property list, with the
|
||
|
|
exception that only keywords are permitted as keys and that the
|
||
|
|
tail -- the body -- is a list of forms that does not start with a
|
||
|
|
keyword.
|
||
|
|
|
||
|
|
Returns a two-element list containing the keys-and-values plist
|
||
|
|
and the body."
|
||
|
|
(unless (stringp docstr)
|
||
|
|
(when docstr
|
||
|
|
(setq keys-and-body (cons docstr keys-and-body))
|
||
|
|
(setq docstr nil)))
|
||
|
|
(let ((extracted-key-accu '())
|
||
|
|
(remaining keys-and-body))
|
||
|
|
(while (and (consp remaining) (keywordp (first remaining)))
|
||
|
|
(let ((keyword (pop remaining)))
|
||
|
|
(unless (consp remaining)
|
||
|
|
(error "Value expected after keyword %S in %S"
|
||
|
|
keyword keys-and-body))
|
||
|
|
(when (assoc keyword extracted-key-accu)
|
||
|
|
(warn "Keyword %S appears more than once in %S" keyword
|
||
|
|
keys-and-body))
|
||
|
|
(push (cons keyword (pop remaining)) extracted-key-accu)))
|
||
|
|
(setq extracted-key-accu (nreverse extracted-key-accu))
|
||
|
|
(list (loop for (key . value) in extracted-key-accu
|
||
|
|
collect key
|
||
|
|
collect value)
|
||
|
|
docstr
|
||
|
|
remaining))))
|
||
|
|
|
||
|
|
(defvar ert-error-on-test-redefinition nil)
|
||
|
|
|
||
|
|
;;;###autoload
|
||
|
|
(defmacro* ert-deftest (name ()
|
||
|
|
&optional docstr
|
||
|
|
&body keys-and-body)
|
||
|
|
"Define NAME (a symbol) as a test.
|
||
|
|
|
||
|
|
\(fn NAME () [:documentation DOCSTRING] [:expected-result TYPE] BODY...)"
|
||
|
|
;; The :documentation would be unreadable. I have therefore added
|
||
|
|
;; docstr that will look like documentation use to in Emacs. Maybe
|
||
|
|
;; add function ert-describe-test?
|
||
|
|
(declare (indent 2)
|
||
|
|
(debug (&define :name test name sexp
|
||
|
|
[&optional [":documentation" stringp]]
|
||
|
|
[&optional [":expected-result" sexp]]
|
||
|
|
def-body)))
|
||
|
|
(destructuring-bind ((&key (expected-result nil expected-result-supplied-p)
|
||
|
|
(documentation nil documentation-supplied-p))
|
||
|
|
doc
|
||
|
|
body)
|
||
|
|
(ert-parse-keys-and-body docstr keys-and-body)
|
||
|
|
`(progn
|
||
|
|
;; Guard against missing/badly named tests:
|
||
|
|
(when (and ert-error-on-test-redefinition
|
||
|
|
(symbolp ',name)
|
||
|
|
(get ',name 'ert-test))
|
||
|
|
(with-output-to-temp-buffer "*Ert Error*"
|
||
|
|
(with-current-buffer "*Ert Error*"
|
||
|
|
(insert "Test "
|
||
|
|
(format "%s" ',name)
|
||
|
|
" is already defined in "
|
||
|
|
(format "%s" (find-definition-noselect ',name 'ert-deftest))
|
||
|
|
"\n\n"
|
||
|
|
"Tip: Use `ert-delete-all-tests' or `ert-delete-test' before redefining tests."
|
||
|
|
)))
|
||
|
|
(if (y-or-n-p "Do you want to call ert-delete-all-tests and then continue? ")
|
||
|
|
;; Fix-me: This does not work, why?
|
||
|
|
(ert-delete-all-tests)
|
||
|
|
(error "Test %s is already defined in %s"
|
||
|
|
',name
|
||
|
|
(find-definition-noselect ',name 'ert-deftest))))
|
||
|
|
(ert-set-test ',name
|
||
|
|
nil ;;doc
|
||
|
|
(make-ert-test
|
||
|
|
:name ',name
|
||
|
|
:body (lambda () ,@body)
|
||
|
|
,@(when expected-result-supplied-p
|
||
|
|
`(:expected-result-type ,expected-result))
|
||
|
|
,@(when documentation-supplied-p
|
||
|
|
`(:documentation ,documentation))))
|
||
|
|
;; This hack allows `symbol-file' to associate `ert-deftest'
|
||
|
|
;; forms with files, and therefore enables `find-function' to
|
||
|
|
;; work with tests. However, it leads to warnings in
|
||
|
|
;; `unload-feature', which doesn't know how to undefine tests
|
||
|
|
;; and has no mechanism for extension.
|
||
|
|
(push '(ert-deftest . ,name) current-load-list)
|
||
|
|
',name)))
|
||
|
|
|
||
|
|
(defun ert-read-test-name (prompt &optional default-value history)
|
||
|
|
"Read the name of a test and return it as a symbol.
|
||
|
|
Prompt with PROMPT. By default, return DEFAULT-VALUE."
|
||
|
|
(when (symbolp default-value) (setq default-value (symbol-name default-value)))
|
||
|
|
(intern (completing-read prompt obarray #'ert-test-boundp
|
||
|
|
t nil history default-value nil)))
|
||
|
|
|
||
|
|
(defun ert-find-test-other-window (test-name)
|
||
|
|
"Find, in another window, the definition of TEST-NAME."
|
||
|
|
(interactive (list (ert-read-test-name "Find test definition: ")))
|
||
|
|
(find-function-do-it test-name 'ert-deftest 'switch-to-buffer-other-window))
|
||
|
|
|
||
|
|
(defun ert-delete-test (test-name)
|
||
|
|
"An interactive interface to `ert-make-test-unbound'."
|
||
|
|
(interactive (list (let ((default (thing-at-point 'symbol)))
|
||
|
|
(when default
|
||
|
|
(set-text-properties 0 (length default) nil default)
|
||
|
|
(when (or (string= default "nil") (intern-soft default))
|
||
|
|
(setq default (intern default)))
|
||
|
|
(unless (ert-test-boundp default)
|
||
|
|
(setq default nil)))
|
||
|
|
(completing-read (if (null default)
|
||
|
|
"Delete test: "
|
||
|
|
(format "Delete test (default %s): "
|
||
|
|
default))
|
||
|
|
obarray #'ert-test-boundp
|
||
|
|
'really-require-match
|
||
|
|
nil nil default nil))))
|
||
|
|
(ert-make-test-unbound test-name))
|
||
|
|
|
||
|
|
(defun ert-delete-all-tests ()
|
||
|
|
"Make all symbols in `obarray' name no test."
|
||
|
|
(interactive)
|
||
|
|
(when (interactive-p)
|
||
|
|
(unless (y-or-n-p "Delete all tests? ")
|
||
|
|
(error "Aborted")))
|
||
|
|
(mapc #'ert-delete-test (mapcar #'ert-test-name (ert-select-tests t t)))
|
||
|
|
t)
|
||
|
|
|
||
|
|
|
||
|
|
(defun ert-make-end-marker (buffer must-exist)
|
||
|
|
"Return a marker to the end of buffer BUFFER.
|
||
|
|
BUFFER may be a string or a buffer. If BUFFER does not exist
|
||
|
|
return nil.
|
||
|
|
|
||
|
|
The buffer must exist if MUST-EXIST is non-nil.
|
||
|
|
|
||
|
|
See also:
|
||
|
|
`ert-end-of-messages'
|
||
|
|
`ert-end-of-warnings'"
|
||
|
|
(let ((buf (if must-exist
|
||
|
|
(get-buffer buffer)
|
||
|
|
(get-buffer-create buffer))))
|
||
|
|
(when (and buf
|
||
|
|
(bufferp buf)
|
||
|
|
(buffer-live-p buf))
|
||
|
|
(with-current-buffer buf
|
||
|
|
(save-restriction
|
||
|
|
(widen)
|
||
|
|
(point-max-marker))))))
|
||
|
|
|
||
|
|
(defun ert-end-of-messages ()
|
||
|
|
"Return a marker to the end of *Messages* buffer."
|
||
|
|
(ert-make-end-marker "*Messages*" nil))
|
||
|
|
|
||
|
|
(defun ert-end-of-warnings ()
|
||
|
|
"Return a marker to the end of *Warnings* buffer."
|
||
|
|
(ert-make-end-marker "*Warnings*" nil))
|
||
|
|
|
||
|
|
(defun ert-search-after (after regexp)
|
||
|
|
"Search after marker in AFTER for regular expression REGEXP.
|
||
|
|
Return a alist of position and matches. AFTER should have been
|
||
|
|
created with `ert-make-end-marker'.
|
||
|
|
|
||
|
|
This is supposed to be used for messages and trace buffers.
|
||
|
|
|
||
|
|
See also
|
||
|
|
`ert-get-messages'"
|
||
|
|
(let ((buf (marker-buffer after)))
|
||
|
|
(with-current-buffer buf
|
||
|
|
(let ((here (point))
|
||
|
|
res)
|
||
|
|
(goto-char after)
|
||
|
|
(save-match-data
|
||
|
|
(while (re-search-forward regexp nil t)
|
||
|
|
(setq res (cons (match-data) res))))
|
||
|
|
(goto-char here)
|
||
|
|
(reverse res)))))
|
||
|
|
;; fix-me: add a conventient way to look at the result of
|
||
|
|
;; `ert-search-after'. Probably this means adding something more to
|
||
|
|
;; the returned result.
|
||
|
|
|
||
|
|
(defvar ert-messages-mark)
|
||
|
|
(defun ert-get-messages (regexp)
|
||
|
|
"Search *Messages* buffer for regular expression REGEXP.
|
||
|
|
This should be used within `ert-deftest'. Search begins where
|
||
|
|
the buffer ended when test started.
|
||
|
|
|
||
|
|
See also:
|
||
|
|
`ert-get-warnings'
|
||
|
|
`ert-search-after'"
|
||
|
|
(ert-search-after ert-messages-mark regexp))
|
||
|
|
|
||
|
|
(defvar ert-warnings-mark)
|
||
|
|
(defun ert-get-warnings (regexp)
|
||
|
|
"Search *Warnings* buffer for regular expression REGEXP.
|
||
|
|
See `ert-get-messages' for more information."
|
||
|
|
(ert-search-after ert-warnings-mark regexp))
|
||
|
|
|
||
|
|
|
||
|
|
;;; Test selectors.
|
||
|
|
|
||
|
|
(defun ert-select-tests (selector universe)
|
||
|
|
"Select, from UNIVERSE, a set of tests according to SELECTOR.
|
||
|
|
|
||
|
|
UNIVERSE should be a list of tests, or t, which refers to all
|
||
|
|
tests named by symbols in `obarray'.
|
||
|
|
|
||
|
|
Returns the set of tests as a list.
|
||
|
|
|
||
|
|
Valid selectors:
|
||
|
|
|
||
|
|
nil -- Selects the empty set.
|
||
|
|
t -- Selects UNIVERSE.
|
||
|
|
:new -- Selects all tests that have not been run yet.
|
||
|
|
:failed, :passed, :error -- Select tests according to their most recent result.
|
||
|
|
:expected, :unexpected -- Select tests according to their most recent result.
|
||
|
|
a string -- Selects all tests that have a name that matches the string, a regexp.
|
||
|
|
a test -- Selects that test.
|
||
|
|
a symbol -- Selects the test that the symbol names, errors if none.
|
||
|
|
\(member TESTS...\) -- Selects TESTS, a list of tests or symbols naming tests.
|
||
|
|
\(eql TEST\) -- Selects TEST, a test or a symbol naming a test.
|
||
|
|
\(and SELECTORS...\) -- Selects the tests that match all SELECTORS.
|
||
|
|
\(or SELECTORS...\) -- Selects the tests that match any SELECTOR.
|
||
|
|
\(not SELECTOR\) -- Selects all tests that do not match SELECTOR.
|
||
|
|
\(satisfies PREDICATE\) -- Selects all tests that satisfy PREDICATE.
|
||
|
|
|
||
|
|
Only selectors that require a superset of tests, such
|
||
|
|
as (satisfies ...), strings, :new, etc. make use of UNIVERSE.
|
||
|
|
Selectors that do not, such as \(member ...\), just return the
|
||
|
|
set implied by them without checking whether it is really
|
||
|
|
contained in UNIVERSE."
|
||
|
|
;; This code needs to match the etypecase in
|
||
|
|
;; `ert-insert-human-readable-selector'.
|
||
|
|
(etypecase selector
|
||
|
|
((member nil) nil)
|
||
|
|
((member t) (etypecase universe
|
||
|
|
(list universe)
|
||
|
|
((member t) (ert-select-tests "" universe))))
|
||
|
|
((member :new) (ert-select-tests
|
||
|
|
`(satisfies ,(lambda (test)
|
||
|
|
(typep (ert-test-most-recent-result test)
|
||
|
|
'null)))
|
||
|
|
universe))
|
||
|
|
((member :failed) (ert-select-tests
|
||
|
|
`(satisfies ,(lambda (test)
|
||
|
|
(typep (ert-test-most-recent-result test)
|
||
|
|
'ert-test-failed)))
|
||
|
|
universe))
|
||
|
|
((member :passed) (ert-select-tests
|
||
|
|
`(satisfies ,(lambda (test)
|
||
|
|
(typep (ert-test-most-recent-result test)
|
||
|
|
'ert-test-passed)))
|
||
|
|
universe))
|
||
|
|
((member :error) (ert-select-tests
|
||
|
|
`(satisfies ,(lambda (test)
|
||
|
|
(typep (ert-test-most-recent-result test)
|
||
|
|
'ert-test-error)))
|
||
|
|
universe))
|
||
|
|
((member :expected) (ert-select-tests
|
||
|
|
`(satisfies
|
||
|
|
,(lambda (test)
|
||
|
|
(ert-test-result-expected-p
|
||
|
|
test
|
||
|
|
(ert-test-most-recent-result test))))
|
||
|
|
universe))
|
||
|
|
((member :unexpected) (ert-select-tests `(not :expected) universe))
|
||
|
|
(string
|
||
|
|
(etypecase universe
|
||
|
|
((member t) (mapcar #'ert-get-test
|
||
|
|
(apropos-internal selector #'ert-test-boundp)))
|
||
|
|
(list (remove-if-not (lambda (test)
|
||
|
|
(and (ert-test-name test)
|
||
|
|
(string-match selector (ert-test-name test))))
|
||
|
|
universe))))
|
||
|
|
(ert-test (list selector))
|
||
|
|
(symbol
|
||
|
|
(assert (ert-test-boundp selector))
|
||
|
|
(list (ert-get-test selector)))
|
||
|
|
(cons
|
||
|
|
(destructuring-bind (operator &rest operands) selector
|
||
|
|
(ecase operator
|
||
|
|
(member
|
||
|
|
(mapcar (lambda (purported-test)
|
||
|
|
(etypecase purported-test
|
||
|
|
(symbol (assert (ert-test-boundp purported-test))
|
||
|
|
(ert-get-test purported-test))
|
||
|
|
(ert-test purported-test)))
|
||
|
|
operands))
|
||
|
|
(eql
|
||
|
|
(assert (eql (length operands) 1))
|
||
|
|
(ert-select-tests `(member ,@operands) universe))
|
||
|
|
(and
|
||
|
|
;; Do these definitions of AND, NOT and OR satisfy de
|
||
|
|
;; Morgan's rules? Should they?
|
||
|
|
(case (length operands)
|
||
|
|
(0 (ert-select-tests 't universe))
|
||
|
|
(t (ert-select-tests `(and ,@(rest operands))
|
||
|
|
(ert-select-tests (first operands) universe)))))
|
||
|
|
(not
|
||
|
|
(assert (eql (length operands) 1))
|
||
|
|
(set-difference (ert-select-tests 't universe)
|
||
|
|
(ert-select-tests (first operands) universe)))
|
||
|
|
(or
|
||
|
|
(case (length operands)
|
||
|
|
(0 (ert-select-tests 'nil universe))
|
||
|
|
(t (union (ert-select-tests (first operands) universe)
|
||
|
|
(ert-select-tests `(or ,@(rest operands)) universe)))))
|
||
|
|
(satisfies
|
||
|
|
(assert (eql (length operands) 1))
|
||
|
|
(remove-if-not (first operands) (ert-select-tests 't universe))))))))
|
||
|
|
|
||
|
|
(defun ert-insert-human-readable-selector (selector)
|
||
|
|
"Insert a human-readable presentation of SELECTOR into the current buffer."
|
||
|
|
;; This is needed to avoid printing the (huge) contents of the
|
||
|
|
;; `backtrace' slot of the result objects in the
|
||
|
|
;; `most-recent-result' slots of test case objects in (eql ...) or
|
||
|
|
;; (member ...) selectors.
|
||
|
|
(labels ((rec (selector)
|
||
|
|
;; This code needs to match the etypecase in `ert-select-tests'.
|
||
|
|
(etypecase selector
|
||
|
|
((or (member nil t
|
||
|
|
:new :failed :passed :error
|
||
|
|
:expected :unexpected)
|
||
|
|
string
|
||
|
|
symbol)
|
||
|
|
selector)
|
||
|
|
(ert-test
|
||
|
|
(if (ert-test-name selector)
|
||
|
|
(make-symbol (format "<%S>" (ert-test-name selector)))
|
||
|
|
(make-symbol "<unnamed test>")))
|
||
|
|
(cons
|
||
|
|
(destructuring-bind (operator &rest operands) selector
|
||
|
|
(ecase operator
|
||
|
|
((member eql and not or)
|
||
|
|
`(,operator ,@(mapcar #'rec operands)))
|
||
|
|
(satisfies
|
||
|
|
selector)))))))
|
||
|
|
(insert (format "%S" (rec selector)))))
|
||
|
|
|
||
|
|
|
||
|
|
;;; Running tests.
|
||
|
|
|
||
|
|
(put 'ert-test-failed 'error-conditions '(error ert-test-failed))
|
||
|
|
(put 'ert-test-failed 'error-message "Test failed")
|
||
|
|
|
||
|
|
(defun ert-pass ()
|
||
|
|
"Terminate the current test and mark it passed. Does not return."
|
||
|
|
(throw 'ert-pass nil))
|
||
|
|
|
||
|
|
(defun ert-fail (data)
|
||
|
|
"Terminate the current test and mark it failed. Does not return.
|
||
|
|
DATA is displayed to the user and should state the reason of the failure."
|
||
|
|
(signal 'ert-test-failed (list data)))
|
||
|
|
|
||
|
|
;; The data structures that represent the result of running a test.
|
||
|
|
(defstruct ert-test-result
|
||
|
|
(messages nil)
|
||
|
|
)
|
||
|
|
(defstruct (ert-test-passed (:include ert-test-result)))
|
||
|
|
(defstruct (ert-test-result-with-condition (:include ert-test-result))
|
||
|
|
(condition (assert nil))
|
||
|
|
(backtrace (assert nil)))
|
||
|
|
(defstruct (ert-test-error (:include ert-test-result-with-condition)))
|
||
|
|
(defstruct (ert-test-quit (:include ert-test-result-with-condition)))
|
||
|
|
(defstruct (ert-test-failed (:include ert-test-result-with-condition)))
|
||
|
|
(defstruct (ert-test-aborted-with-non-local-exit (:include ert-test-result)))
|
||
|
|
|
||
|
|
|
||
|
|
(defun ert-record-backtrace ()
|
||
|
|
"Record the current backtrace (as a list) and return it."
|
||
|
|
;; Since the backtrace is stored in the result object, result
|
||
|
|
;; objects must only be printed with appropriate limits
|
||
|
|
;; (`print-level' and `print-length') in place. For interactive
|
||
|
|
;; use, the cost of ensuring this possibly outweighs the advantage
|
||
|
|
;; of storing the backtrace for
|
||
|
|
;; `ert-results-pop-to-backtrace-for-test-at-point' given that we
|
||
|
|
;; already have `ert-results-rerun-test-debugging-errors-at-point'.
|
||
|
|
;; For batch use, however, printing the backtrace may be useful.
|
||
|
|
(loop
|
||
|
|
;; 6 is the number of frames our own debugger adds (when
|
||
|
|
;; compiled; more when interpreted). FIXME: Need to describe a
|
||
|
|
;; procedure for determining this constant.
|
||
|
|
for i from 6
|
||
|
|
for frame = (backtrace-frame i)
|
||
|
|
while frame
|
||
|
|
collect frame))
|
||
|
|
|
||
|
|
;; A container for the state of the execution of a single test and
|
||
|
|
;; environment data needed during its execution.
|
||
|
|
(defstruct ert-test-execution-info
|
||
|
|
(test (assert nil))
|
||
|
|
(result (assert nil))
|
||
|
|
;; A thunk that may be called when RESULT has been set to its final
|
||
|
|
;; value and test execution should be terminated. Should not
|
||
|
|
;; return.
|
||
|
|
(exit-continuation (assert nil))
|
||
|
|
;; The binding of `debugger' outside of the execution of the test.
|
||
|
|
next-debugger
|
||
|
|
;; The binding of `ert-debug-on-error' that is in effect for the
|
||
|
|
;; execution of the current test. We store it to avoid being
|
||
|
|
;; affected by any new bindings the test itself may establish. (I
|
||
|
|
;; don't remember whether this feature is important.)
|
||
|
|
ert-debug-on-error)
|
||
|
|
|
||
|
|
(defun ert-run-test-debugger (info debugger-args)
|
||
|
|
"The function that `debugger' is bound to during the execution of tests.
|
||
|
|
|
||
|
|
Records failures and errors and either terminates the test
|
||
|
|
silently or calls the interactive debugger, as appropriate."
|
||
|
|
(destructuring-bind (first-debugger-arg &rest more-debugger-args) debugger-args
|
||
|
|
(ecase first-debugger-arg
|
||
|
|
((lambda debug t exit nil)
|
||
|
|
(apply (ert-test-execution-info-next-debugger info) debugger-args))
|
||
|
|
(error
|
||
|
|
(let* ((condition (first more-debugger-args))
|
||
|
|
(type (case (car condition)
|
||
|
|
((quit) 'quit)
|
||
|
|
((ert-test-failed) 'failed)
|
||
|
|
(otherwise 'error)))
|
||
|
|
(backtrace (ert-record-backtrace)))
|
||
|
|
(setf (ert-test-execution-info-result info)
|
||
|
|
(ecase type
|
||
|
|
(quit
|
||
|
|
(make-ert-test-quit :condition condition
|
||
|
|
:backtrace backtrace))
|
||
|
|
(failed
|
||
|
|
(make-ert-test-failed :condition condition
|
||
|
|
:backtrace backtrace))
|
||
|
|
(error
|
||
|
|
(make-ert-test-error :condition condition
|
||
|
|
:backtrace backtrace))))
|
||
|
|
;; Work around Emacs' heuristic (in eval.c) for detecting
|
||
|
|
;; errors in the debugger.
|
||
|
|
(incf num-nonmacro-input-events)
|
||
|
|
;; FIXME: We should probably implement more fine-grained
|
||
|
|
;; control a la non-t `debug-on-error' here.
|
||
|
|
(cond
|
||
|
|
((ert-test-execution-info-ert-debug-on-error info)
|
||
|
|
(apply (ert-test-execution-info-next-debugger info) debugger-args))
|
||
|
|
(t))
|
||
|
|
(funcall (ert-test-execution-info-exit-continuation info)))))))
|
||
|
|
|
||
|
|
(defun ert-run-test-internal (ert-test-execution-info)
|
||
|
|
(lexical-let ((info ert-test-execution-info))
|
||
|
|
(setf (ert-test-execution-info-next-debugger info) debugger
|
||
|
|
(ert-test-execution-info-ert-debug-on-error info) ert-debug-on-error)
|
||
|
|
(catch 'ert-pass
|
||
|
|
;; For now, each test gets its own temp buffer and its own
|
||
|
|
;; window excursion, just to be safe. If this turns out to be
|
||
|
|
;; too expensive, we can remove it.
|
||
|
|
(with-temp-buffer
|
||
|
|
(save-window-excursion
|
||
|
|
(let ((debugger (lambda (&rest debugger-args)
|
||
|
|
(ert-run-test-debugger info debugger-args)))
|
||
|
|
(debug-on-error t)
|
||
|
|
(debug-on-quit t)
|
||
|
|
;; FIXME: Do we need to store the old binding of this
|
||
|
|
;; and consider it in `ert-run-test-debugger'?
|
||
|
|
(debug-ignored-errors nil)
|
||
|
|
(ert-messages-mark (ert-end-of-messages))
|
||
|
|
(ert-warnings-mark (ert-end-of-warnings)))
|
||
|
|
(funcall (ert-test-body (ert-test-execution-info-test info))))))
|
||
|
|
(ert-pass))
|
||
|
|
(setf (ert-test-execution-info-result info) (make-ert-test-passed)))
|
||
|
|
nil)
|
||
|
|
|
||
|
|
(defun ert-make-marker-in-messages-buffer ()
|
||
|
|
(with-current-buffer (get-buffer-create "*Messages*")
|
||
|
|
(set-marker (make-marker) (point-max))))
|
||
|
|
|
||
|
|
(defun ert-force-message-log-buffer-truncation ()
|
||
|
|
(with-current-buffer (get-buffer-create "*Messages*")
|
||
|
|
;; This is a reimplementation of this part of message_dolog() in xdisp.c:
|
||
|
|
;; if (NATNUMP (Vmessage_log_max))
|
||
|
|
;; {
|
||
|
|
;; scan_newline (Z, Z_BYTE, BEG, BEG_BYTE,
|
||
|
|
;; -XFASTINT (Vmessage_log_max) - 1, 0);
|
||
|
|
;; del_range_both (BEG, BEG_BYTE, PT, PT_BYTE, 0);
|
||
|
|
;; }
|
||
|
|
(when (and (integerp message-log-max) (>= message-log-max 0))
|
||
|
|
(let ((begin (point-min))
|
||
|
|
(end (save-excursion
|
||
|
|
(goto-char (point-max))
|
||
|
|
(forward-line (- message-log-max))
|
||
|
|
(point))))
|
||
|
|
(delete-region begin end)))))
|
||
|
|
|
||
|
|
(defun ert-run-test (test)
|
||
|
|
"Run TEST. Return the result and store it in TEST's `most-recent-result' slot."
|
||
|
|
(setf (ert-test-most-recent-result test) nil)
|
||
|
|
(block error
|
||
|
|
(lexical-let* ((begin-marker (ert-make-marker-in-messages-buffer))
|
||
|
|
(info (make-ert-test-execution-info
|
||
|
|
:test test
|
||
|
|
:result (make-ert-test-aborted-with-non-local-exit)
|
||
|
|
:exit-continuation (lambda ()
|
||
|
|
(return-from error nil)))))
|
||
|
|
(unwind-protect
|
||
|
|
(let ((message-log-max t))
|
||
|
|
(ert-run-test-internal info))
|
||
|
|
(let ((result (ert-test-execution-info-result info)))
|
||
|
|
(setf (ert-test-result-messages result)
|
||
|
|
(with-current-buffer (get-buffer-create "*Messages*")
|
||
|
|
(buffer-substring begin-marker (point-max))))
|
||
|
|
(ert-force-message-log-buffer-truncation)
|
||
|
|
(setf (ert-test-most-recent-result test) result)))))
|
||
|
|
(ert-test-most-recent-result test))
|
||
|
|
|
||
|
|
|
||
|
|
;;; The `should' macros.
|
||
|
|
|
||
|
|
(eval-and-compile
|
||
|
|
(defun ert-special-operator-p (thing)
|
||
|
|
"Return non-nil if THING is a symbol naming a special operator."
|
||
|
|
(and (symbolp thing)
|
||
|
|
(let ((definition (indirect-function thing t)))
|
||
|
|
(and (subrp definition)
|
||
|
|
(eql (cdr (subr-arity definition)) 'unevalled)))))
|
||
|
|
(defun ert-expand-should (whole form env inner-expander)
|
||
|
|
"Helper function for the `should' macro and its variants.
|
||
|
|
|
||
|
|
Analyzes FORM and produces an expression that has the same
|
||
|
|
semantics under evaluation but records additional debugging
|
||
|
|
information. INNER-EXPANDER adds the actual checks specific to
|
||
|
|
the particular variant of `should'."
|
||
|
|
(let ((form (macroexpand form env)))
|
||
|
|
;; It's sort of a wart that `inner-expander' can't influence the
|
||
|
|
;; value the expansion returns.
|
||
|
|
(cond
|
||
|
|
((atom form)
|
||
|
|
(funcall inner-expander form `(list ',whole :form ',form :value ,form)))
|
||
|
|
((ert-special-operator-p (car form))
|
||
|
|
(let ((value (gensym "value-")))
|
||
|
|
`(let ((,value (make-symbol "ert-form-evaluation-aborted")))
|
||
|
|
,(funcall inner-expander
|
||
|
|
`(setq ,value ,form)
|
||
|
|
`(list ',whole :form ',form :value ,value))
|
||
|
|
,value)))
|
||
|
|
(t
|
||
|
|
(let ((fn-name (car form))
|
||
|
|
(arg-forms (cdr form)))
|
||
|
|
(assert (or (symbolp fn-name)
|
||
|
|
(and (consp fn-name)
|
||
|
|
(eql (car fn-name) 'lambda)
|
||
|
|
(listp (cdr fn-name)))))
|
||
|
|
(let ((fn (gensym "fn-"))
|
||
|
|
(args (gensym "args-"))
|
||
|
|
(value (gensym "value-"))
|
||
|
|
(default-value (gensym "ert-form-evaluation-aborted-")))
|
||
|
|
`(let ((,fn (function ,fn-name))
|
||
|
|
(,args (list ,@arg-forms)))
|
||
|
|
(let ((,value ',default-value))
|
||
|
|
,(funcall inner-expander
|
||
|
|
`(setq ,value (apply ,fn ,args))
|
||
|
|
`(nconc (list ',whole)
|
||
|
|
(list :form `(,,fn ,@,args))
|
||
|
|
(unless (eql ,value ',default-value)
|
||
|
|
(list :value ,value))
|
||
|
|
(let ((-explainer-
|
||
|
|
(and (symbolp ',fn-name)
|
||
|
|
(get ',fn-name
|
||
|
|
'ert-explainer))))
|
||
|
|
(when -explainer-
|
||
|
|
(list :explanation
|
||
|
|
(apply -explainer- ,args))))))
|
||
|
|
,value)))))))))
|
||
|
|
|
||
|
|
(defmacro* ert-should (form &environment env)
|
||
|
|
"Evaluate FORM. If it returns nil, abort the current test as failed.
|
||
|
|
|
||
|
|
Returns the value of FORM."
|
||
|
|
(ert-expand-should `(ert-should ,form) form env
|
||
|
|
(lambda (inner-form form-description-form)
|
||
|
|
`(unless ,inner-form
|
||
|
|
(ert-fail ,form-description-form)))))
|
||
|
|
|
||
|
|
(defmacro* ert-should-not (form &environment env)
|
||
|
|
"Evaluate FORM. If it returns non-nil, abort the current test as failed.
|
||
|
|
|
||
|
|
Returns nil."
|
||
|
|
(ert-expand-should `(ert-should-not ,form) form env
|
||
|
|
(lambda (inner-form form-description-form)
|
||
|
|
`(unless (not ,inner-form)
|
||
|
|
(ert-fail ,form-description-form)))))
|
||
|
|
|
||
|
|
(defun ert-should-error-handle-error (form-description-fn
|
||
|
|
condition type exclude-subtypes test)
|
||
|
|
"Helper function for `should-error'.
|
||
|
|
|
||
|
|
Determines whether CONDITION matches TYPE, EXCLUDE-SUBTYPES and
|
||
|
|
TEST, and aborts the current test as failed if it doesn't."
|
||
|
|
(let ((signalled-conditions (get (car condition) 'error-conditions))
|
||
|
|
(handled-conditions (etypecase type
|
||
|
|
(list type)
|
||
|
|
(symbol (list type)))))
|
||
|
|
(assert signalled-conditions)
|
||
|
|
(unless (intersection signalled-conditions handled-conditions)
|
||
|
|
(ert-fail (append
|
||
|
|
(funcall form-description-fn)
|
||
|
|
(list
|
||
|
|
:condition condition
|
||
|
|
:fail-reason (concat "the error signalled did not"
|
||
|
|
" have the expected type")))))
|
||
|
|
(when exclude-subtypes
|
||
|
|
(unless (member (car condition) handled-conditions)
|
||
|
|
(ert-fail (append
|
||
|
|
(funcall form-description-fn)
|
||
|
|
(list
|
||
|
|
:condition condition
|
||
|
|
:fail-reason (concat "the error signalled was a subtype"
|
||
|
|
" of the expected type"))))))
|
||
|
|
(unless (funcall test condition)
|
||
|
|
(ert-fail (append
|
||
|
|
(funcall form-description-fn)
|
||
|
|
(list
|
||
|
|
:condition condition
|
||
|
|
:fail-reason "the error signalled did not pass the test"))))))
|
||
|
|
|
||
|
|
;; FIXME: The expansion will evaluate the keyword args (if any) in
|
||
|
|
;; nonstandard order.
|
||
|
|
(defmacro* ert-should-error (form &rest keys &key type exclude-subtypes test
|
||
|
|
&environment env)
|
||
|
|
"Evaluate FORM. Unless it signals an error, abort the current test as failed.
|
||
|
|
|
||
|
|
The error signalled additionally needs to match TYPE and satisfy
|
||
|
|
TEST. TYPE should be a condition name or a list of condition
|
||
|
|
names. If EXCLUDE-SUBTYPES is nil, the error matches TYPE if one
|
||
|
|
of its condition names is an element of TYPE. If
|
||
|
|
EXCLUDE-SUBTYPES is non-nil, the error matches TYPE if it is an
|
||
|
|
element of TYPE. TEST should be a predicate."
|
||
|
|
;; Returns a gensym named `ert-form-evaluation-aborted-XXX', but
|
||
|
|
;; that's a wart, so let's not document it.
|
||
|
|
(unless type (setq type ''error))
|
||
|
|
(unless test (setq test '(lambda (condition) t)))
|
||
|
|
(ert-expand-should
|
||
|
|
`(ert-should-error ,form ,@keys)
|
||
|
|
form env
|
||
|
|
(lambda (inner-form form-description-form)
|
||
|
|
(let ((errorp (gensym "errorp"))
|
||
|
|
(form-description-fn (gensym "form-description-fn-")))
|
||
|
|
`(let ((,errorp nil)
|
||
|
|
(,form-description-fn (lambda () ,form-description-form)))
|
||
|
|
(condition-case -condition-
|
||
|
|
,inner-form
|
||
|
|
;; We can't use ,type here because we want to evaluate it.
|
||
|
|
(error
|
||
|
|
(setq ,errorp t)
|
||
|
|
(ert-should-error-handle-error ,form-description-fn
|
||
|
|
-condition-
|
||
|
|
,type ,exclude-subtypes ,test)
|
||
|
|
;; It would make sense to have the `should-error' form
|
||
|
|
;; return the error in this case, but `ert-expand-should'
|
||
|
|
;; doesn't allow that at the moment.
|
||
|
|
))
|
||
|
|
(unless ,errorp
|
||
|
|
(ert-fail (append
|
||
|
|
(funcall ,form-description-fn)
|
||
|
|
(list
|
||
|
|
:fail-reason "did not signal an error")))))))))
|
||
|
|
|
||
|
|
|
||
|
|
;;; Explanation of `should' failures.
|
||
|
|
|
||
|
|
(defun ert-proper-list-p (x)
|
||
|
|
"Return non-nil if X is a proper list, nil otherwise."
|
||
|
|
(loop
|
||
|
|
for firstp = t then nil
|
||
|
|
for fast = x then (cddr fast)
|
||
|
|
for slow = x then (cdr slow) do
|
||
|
|
(when (null fast) (return t))
|
||
|
|
(when (not (consp fast)) (return nil))
|
||
|
|
(when (null (cdr fast)) (return t))
|
||
|
|
(when (not (consp (cdr fast))) (return nil))
|
||
|
|
(when (and (not firstp) (eq fast slow)) (return nil))))
|
||
|
|
|
||
|
|
(defun ert-explain-not-equal (a b)
|
||
|
|
"Return a programmer-readable explanation of why A and B are not `equal'.
|
||
|
|
|
||
|
|
Returns nil if they are equal."
|
||
|
|
(if (not (equal (type-of a) (type-of b)))
|
||
|
|
`(different-types ,a ,b)
|
||
|
|
(etypecase a
|
||
|
|
(cons
|
||
|
|
(let ((a-proper-p (ert-proper-list-p a))
|
||
|
|
(b-proper-p (ert-proper-list-p b)))
|
||
|
|
(if (not (eql (not a-proper-p) (not b-proper-p)))
|
||
|
|
`(one-list-proper-one-improper ,a ,b)
|
||
|
|
(if a-proper-p
|
||
|
|
(if (not (equal (length a) (length b)))
|
||
|
|
;; This would be even more helpful if it showed
|
||
|
|
;; something like what `set-difference' would
|
||
|
|
;; return.
|
||
|
|
`(proper-lists-of-different-length ,a ,b)
|
||
|
|
(loop for i from 0
|
||
|
|
for ai in a
|
||
|
|
for bi in b
|
||
|
|
for xi = (ert-explain-not-equal ai bi)
|
||
|
|
do (when xi (return `(list-elt ,i ,xi)))))
|
||
|
|
(let ((car-x (ert-explain-not-equal (car a) (car b))))
|
||
|
|
(if car-x
|
||
|
|
`(car ,car-x)
|
||
|
|
(let ((cdr-x (ert-explain-not-equal (cdr a) (cdr b))))
|
||
|
|
(if cdr-x
|
||
|
|
`(cdr ,cdr-x))
|
||
|
|
nil)))))))
|
||
|
|
(array (if (not (equal (length a) (length b)))
|
||
|
|
`(arrays-of-different-length ,a ,b)
|
||
|
|
(loop for i from 0
|
||
|
|
for ai across a
|
||
|
|
for bi across b
|
||
|
|
for xi = (ert-explain-not-equal ai bi)
|
||
|
|
do (when xi (return `(array-elt ,i ,xi))))))
|
||
|
|
(atom (if (not (equal a b))
|
||
|
|
`(different-atoms ,a ,b)
|
||
|
|
nil)))))
|
||
|
|
(put 'equal 'ert-explainer 'ert-explain-not-equal)
|
||
|
|
|
||
|
|
|
||
|
|
;;; Results display.
|
||
|
|
|
||
|
|
;; The data structure that contains the set of tests being executed
|
||
|
|
;; during one particular test run, their results, the state of the
|
||
|
|
;; execution, and some statistics.
|
||
|
|
;;
|
||
|
|
;; The data about results and expected results of tests may seem
|
||
|
|
;; redundant here, since the test objects also carry such information.
|
||
|
|
;; However, the information in the test objects may be more recent, it
|
||
|
|
;; may correspond to a different test run. We need the information
|
||
|
|
;; that corresponds to this run in order to be able to update the
|
||
|
|
;; statistics correctly when a test is re-run interactively and has a
|
||
|
|
;; different result than before.
|
||
|
|
(defstruct ert-stats
|
||
|
|
(selector (assert nil))
|
||
|
|
;; The tests, in order.
|
||
|
|
(tests (assert nil) :type vector)
|
||
|
|
;; A map of test names (or the test objects themselves for unnamed
|
||
|
|
;; tests) to indices into the `tests' vector.
|
||
|
|
(test-map (assert nil) :type hash-table)
|
||
|
|
;; The results of the tests during this run, in order.
|
||
|
|
(test-results (assert nil) :type vector)
|
||
|
|
;; The expected result types of the tests, in order.
|
||
|
|
(test-results-expected (assert nil) :type vector)
|
||
|
|
(total (assert nil))
|
||
|
|
(passed-expected 0)
|
||
|
|
(passed-unexpected 0)
|
||
|
|
(failed-expected 0)
|
||
|
|
(failed-unexpected 0)
|
||
|
|
(error-expected 0)
|
||
|
|
(error-unexpected 0)
|
||
|
|
(start-time (assert nil))
|
||
|
|
(end-time nil)
|
||
|
|
(aborted-p nil)
|
||
|
|
(current-test nil))
|
||
|
|
|
||
|
|
;; An entry in the results buffer ewoc. There is one entry per test.
|
||
|
|
(defstruct ert-ewoc-entry
|
||
|
|
(test (assert nil))
|
||
|
|
(result nil)
|
||
|
|
;; If the result of this test was expected, its ewoc entry is hidden
|
||
|
|
;; initially.
|
||
|
|
(hidden-p (assert nil))
|
||
|
|
;; An ewoc entry may be collapsed to hide details such as the error
|
||
|
|
;; condition.
|
||
|
|
;;
|
||
|
|
;; I'm not sure the ability to expand and collapse entries is still
|
||
|
|
;; a useful feature.
|
||
|
|
(expanded-p t)
|
||
|
|
;; By default, the ewoc entry presents the error condition with
|
||
|
|
;; certain limits on how much to print (`print-level',
|
||
|
|
;; `print-length'). The user can interactively switch to a set of
|
||
|
|
;; higher limits.
|
||
|
|
(extended-printer-limits-p nil))
|
||
|
|
|
||
|
|
;; Variables local to the results buffer.
|
||
|
|
|
||
|
|
;; The ewoc.
|
||
|
|
(defvar ert-results-ewoc)
|
||
|
|
;; The stats object.
|
||
|
|
(defvar ert-results-stats)
|
||
|
|
;; A string with one character per test. Each character represents
|
||
|
|
;; the result of the corresponding test. The string is displayed near
|
||
|
|
;; the top of the buffer and serves as a progress bar.
|
||
|
|
(defvar ert-results-progress-bar-string)
|
||
|
|
;; The position where the progress bar button begins.
|
||
|
|
(defvar ert-results-progress-bar-button-begin)
|
||
|
|
;; The test result listener that updates the buffer when tests are run.
|
||
|
|
(defvar ert-results-listener)
|
||
|
|
|
||
|
|
;; The same as `ert-results-stats', but dynamically bound. Used for
|
||
|
|
;; the mode line progress indicator.
|
||
|
|
(defvar ert-current-run-stats nil)
|
||
|
|
|
||
|
|
(defun ert-format-time-iso8601 (time)
|
||
|
|
"Format TIME in the particular variant of ISO 8601 used for timestamps in ERT."
|
||
|
|
(format-time-string "%Y-%m-%d %T%z" time))
|
||
|
|
|
||
|
|
(defun ert-insert-test-name-button (test-name)
|
||
|
|
(insert-text-button (format "%S" test-name)
|
||
|
|
:type 'ert-test-name-button
|
||
|
|
'ert-test-name test-name))
|
||
|
|
|
||
|
|
(defun ert-results-update-ewoc-hf (ewoc stats)
|
||
|
|
"Update the header and footer of EWOC to show certain information from STATS.
|
||
|
|
|
||
|
|
Also sets `ert-results-progress-bar-button-begin'."
|
||
|
|
(let ((run-count (+ (ert-stats-passed-expected stats)
|
||
|
|
(ert-stats-passed-unexpected stats)
|
||
|
|
(ert-stats-failed-expected stats)
|
||
|
|
(ert-stats-failed-unexpected stats)
|
||
|
|
(ert-stats-error-expected stats)
|
||
|
|
(ert-stats-error-unexpected stats)))
|
||
|
|
(results-buffer (current-buffer)))
|
||
|
|
(ewoc-set-hf
|
||
|
|
ewoc
|
||
|
|
;; header
|
||
|
|
(with-temp-buffer
|
||
|
|
(insert "Selector: ")
|
||
|
|
(ert-insert-human-readable-selector (ert-stats-selector stats))
|
||
|
|
(insert "\n")
|
||
|
|
(insert
|
||
|
|
(format (concat "Passed: %s (%s unexpected)\n"
|
||
|
|
"Failed: %s (%s unexpected)\n"
|
||
|
|
"Error: %s (%s unexpected)\n"
|
||
|
|
"Total: %s/%s\n\n")
|
||
|
|
(+ (ert-stats-passed-expected stats)
|
||
|
|
(ert-stats-passed-unexpected stats))
|
||
|
|
(ert-stats-passed-unexpected stats)
|
||
|
|
(+ (ert-stats-failed-expected stats)
|
||
|
|
(ert-stats-failed-unexpected stats))
|
||
|
|
(ert-stats-failed-unexpected stats)
|
||
|
|
(+ (ert-stats-error-expected stats)
|
||
|
|
(ert-stats-error-unexpected stats))
|
||
|
|
(ert-stats-error-unexpected stats)
|
||
|
|
run-count
|
||
|
|
(ert-stats-total stats)))
|
||
|
|
(insert
|
||
|
|
(format "Started at: %s\n"
|
||
|
|
(ert-format-time-iso8601 (ert-stats-start-time stats))))
|
||
|
|
;; FIXME: This is ugly. Need to properly define invariants of
|
||
|
|
;; the `stats' data structure.
|
||
|
|
(let ((state (cond ((ert-stats-aborted-p stats)
|
||
|
|
'aborted)
|
||
|
|
((ert-stats-current-test stats)
|
||
|
|
'running)
|
||
|
|
((ert-stats-end-time stats)
|
||
|
|
'finished)
|
||
|
|
(t
|
||
|
|
'preparing))))
|
||
|
|
(ecase state
|
||
|
|
(preparing
|
||
|
|
(insert ""))
|
||
|
|
(aborted
|
||
|
|
(cond ((ert-stats-current-test stats)
|
||
|
|
(insert "Aborted during test: ")
|
||
|
|
(ert-insert-test-name-button
|
||
|
|
(ert-test-name (ert-stats-current-test stats))))
|
||
|
|
(t
|
||
|
|
(insert "Aborted."))))
|
||
|
|
(running
|
||
|
|
(assert (ert-stats-current-test stats))
|
||
|
|
(insert "Running test: ")
|
||
|
|
(ert-insert-test-name-button (ert-test-name
|
||
|
|
(ert-stats-current-test stats))))
|
||
|
|
(finished
|
||
|
|
(assert (not (ert-stats-current-test stats)))
|
||
|
|
(insert "Finished.")))
|
||
|
|
(insert "\n")
|
||
|
|
(if (ert-stats-end-time stats)
|
||
|
|
(insert
|
||
|
|
(format "%s%s\n"
|
||
|
|
(if (ert-stats-aborted-p stats)
|
||
|
|
"Aborted at: "
|
||
|
|
"Finished at: ")
|
||
|
|
(ert-format-time-iso8601 (ert-stats-end-time stats))))
|
||
|
|
(insert "\n"))
|
||
|
|
(insert "\n"))
|
||
|
|
(let ((progress-bar-string (with-current-buffer results-buffer
|
||
|
|
ert-results-progress-bar-string)))
|
||
|
|
(let ((progress-bar-button-begin
|
||
|
|
(insert-text-button (substring progress-bar-string 0 run-count)
|
||
|
|
:type 'ert-results-progress-bar-button)))
|
||
|
|
(with-current-buffer results-buffer
|
||
|
|
(set (make-local-variable 'ert-results-progress-bar-button-begin)
|
||
|
|
progress-bar-button-begin)))
|
||
|
|
(insert (substring progress-bar-string run-count)))
|
||
|
|
(insert "\n\n")
|
||
|
|
(buffer-string))
|
||
|
|
;; footer
|
||
|
|
;;
|
||
|
|
;; We actually want an empty footer, but that would trigger a bug
|
||
|
|
;; in ewoc, sometimes clearing the entire buffer.
|
||
|
|
"\n")))
|
||
|
|
|
||
|
|
(defun ert-results-update-stats-display (ewoc stats)
|
||
|
|
"Update EWOC and the mode line to show data from STATS."
|
||
|
|
(ert-results-update-ewoc-hf ewoc stats)
|
||
|
|
(force-mode-line-update)
|
||
|
|
(redisplay t))
|
||
|
|
|
||
|
|
(defun ert-char-for-test-result (result expectedp)
|
||
|
|
"Return a character that represents the test result RESULT."
|
||
|
|
(let ((char
|
||
|
|
(etypecase result
|
||
|
|
(ert-test-passed ?.)
|
||
|
|
(ert-test-failed ?f)
|
||
|
|
(ert-test-error ?e)
|
||
|
|
(null ?-)
|
||
|
|
(ert-test-aborted-with-non-local-exit ?a))))
|
||
|
|
(if expectedp
|
||
|
|
char
|
||
|
|
(upcase char))))
|
||
|
|
|
||
|
|
(defun ert-string-for-test-result (result expectedp)
|
||
|
|
"Return a string that represents the test result RESULT."
|
||
|
|
(etypecase result
|
||
|
|
(ert-test-passed "passed")
|
||
|
|
(ert-test-failed "failed")
|
||
|
|
(ert-test-error "error")
|
||
|
|
(null "unknown")
|
||
|
|
(ert-test-aborted-with-non-local-exit "aborted")))
|
||
|
|
|
||
|
|
(defun ert-tests-running-mode-line-indicator ()
|
||
|
|
(let* ((stats ert-current-run-stats)
|
||
|
|
(tests-total (ert-stats-total stats))
|
||
|
|
(tests-completed (+ (ert-stats-passed-expected stats)
|
||
|
|
(ert-stats-passed-unexpected stats)
|
||
|
|
(ert-stats-failed-expected stats)
|
||
|
|
(ert-stats-failed-unexpected stats)
|
||
|
|
(ert-stats-error-expected stats)
|
||
|
|
(ert-stats-error-unexpected stats))))
|
||
|
|
(if (>= tests-completed tests-total)
|
||
|
|
(format " ERT(%s/%s,finished)" tests-completed tests-total)
|
||
|
|
(format " ERT(%s/%s):%s"
|
||
|
|
(1+ tests-completed)
|
||
|
|
tests-total
|
||
|
|
(if (null (ert-stats-current-test stats))
|
||
|
|
"?"
|
||
|
|
(format "%S"
|
||
|
|
(ert-test-name (ert-stats-current-test stats))))))))
|
||
|
|
|
||
|
|
(defun ert-pp-with-indentation-and-newline (object)
|
||
|
|
"Pretty-print OBJECT, indenting it to the current column of point.
|
||
|
|
Ensures a final newline is inserted."
|
||
|
|
(let ((begin (point)))
|
||
|
|
(pp object (current-buffer))
|
||
|
|
(unless (bolp) (insert "\n"))
|
||
|
|
(save-excursion
|
||
|
|
(goto-char begin)
|
||
|
|
(indent-sexp))))
|
||
|
|
|
||
|
|
(defun ert-print-test-for-ewoc (entry)
|
||
|
|
"The ewoc print function for ewoc test entries."
|
||
|
|
(let* ((test (ert-ewoc-entry-test entry))
|
||
|
|
(result (ert-ewoc-entry-result entry))
|
||
|
|
(hiddenp (ert-ewoc-entry-hidden-p entry))
|
||
|
|
(expandedp (ert-ewoc-entry-expanded-p entry))
|
||
|
|
(extended-printer-limits-p (ert-ewoc-entry-extended-printer-limits-p
|
||
|
|
entry)))
|
||
|
|
(cond (hiddenp)
|
||
|
|
(t
|
||
|
|
(insert-text-button (format "%c"
|
||
|
|
(ert-char-for-test-result
|
||
|
|
result
|
||
|
|
(ert-test-result-expected-p test
|
||
|
|
result)))
|
||
|
|
:type 'ert-results-expand-collapse-button)
|
||
|
|
(insert " ")
|
||
|
|
(ert-insert-test-name-button (ert-test-name test))
|
||
|
|
(insert "\n")
|
||
|
|
(when (and expandedp (not (eql result 'nil)))
|
||
|
|
(etypecase result
|
||
|
|
(ert-test-passed
|
||
|
|
(insert " passed\n")
|
||
|
|
(insert ""))
|
||
|
|
(ert-test-result-with-condition
|
||
|
|
(insert " ")
|
||
|
|
(let ((print-escape-newlines t)
|
||
|
|
(print-level (if extended-printer-limits-p 10 5))
|
||
|
|
(print-length (if extended-printer-limits-p 100 10)))
|
||
|
|
(let ((begin (point)))
|
||
|
|
(ert-pp-with-indentation-and-newline
|
||
|
|
(ert-test-result-with-condition-condition result))
|
||
|
|
(save-restriction
|
||
|
|
(narrow-to-region begin (point))
|
||
|
|
;; Inhibit optimization in `debugger-make-xrefs'
|
||
|
|
;; that sometimes inserts unrelated backtrace
|
||
|
|
;; info into our buffer.
|
||
|
|
(let ((debugger-previous-backtrace nil))
|
||
|
|
(debugger-make-xrefs))))))
|
||
|
|
(ert-test-aborted-with-non-local-exit
|
||
|
|
(insert " aborted\n")))
|
||
|
|
(insert "\n")))))
|
||
|
|
nil)
|
||
|
|
|
||
|
|
(defun ert-setup-results-buffer (stats listener buffer-name)
|
||
|
|
"Set up a test results buffer."
|
||
|
|
(unless buffer-name (setq buffer-name "*ert*"))
|
||
|
|
(let ((buffer (let ((default-major-mode 'fundamental-mode))
|
||
|
|
(get-buffer-create buffer-name))))
|
||
|
|
(with-current-buffer buffer
|
||
|
|
(setq buffer-read-only t)
|
||
|
|
(let ((inhibit-read-only t))
|
||
|
|
(buffer-disable-undo)
|
||
|
|
(erase-buffer)
|
||
|
|
(ert-results-mode)
|
||
|
|
(set (make-local-variable 'ert-results-ewoc)
|
||
|
|
(ewoc-create 'ert-print-test-for-ewoc nil nil t))
|
||
|
|
(set (make-local-variable 'ert-results-stats) stats)
|
||
|
|
(set (make-local-variable 'ert-results-progress-bar-string)
|
||
|
|
(make-string (ert-stats-total stats)
|
||
|
|
(ert-char-for-test-result nil t)))
|
||
|
|
(set (make-local-variable 'ert-results-listener) listener)
|
||
|
|
(ert-results-update-ewoc-hf ert-results-ewoc ert-results-stats)
|
||
|
|
(goto-char (1- (point-max)))
|
||
|
|
buffer))))
|
||
|
|
|
||
|
|
(defun ert-run-or-rerun-test (stats test listener)
|
||
|
|
"Run the single test TEST and record the result using STATS and LISTENER."
|
||
|
|
(let ((ert-current-run-stats stats)
|
||
|
|
(pos (ert-stats-test-index stats test))
|
||
|
|
(results (ert-stats-test-results stats))
|
||
|
|
(expected (ert-stats-test-results-expected stats)))
|
||
|
|
;; Adjust stats to remove previous result.
|
||
|
|
(if (aref expected pos)
|
||
|
|
(etypecase (aref results pos)
|
||
|
|
(ert-test-passed (decf (ert-stats-passed-expected stats)))
|
||
|
|
(ert-test-failed (decf (ert-stats-failed-expected stats)))
|
||
|
|
(ert-test-error (decf (ert-stats-error-expected stats)))
|
||
|
|
(null)
|
||
|
|
(ert-test-aborted-with-non-local-exit))
|
||
|
|
(etypecase (aref results pos)
|
||
|
|
(ert-test-passed (decf (ert-stats-passed-unexpected stats)))
|
||
|
|
(ert-test-failed (decf (ert-stats-failed-unexpected stats)))
|
||
|
|
(ert-test-error (decf (ert-stats-error-unexpected stats)))
|
||
|
|
(null)
|
||
|
|
(ert-test-aborted-with-non-local-exit)))
|
||
|
|
(setf (aref results pos) nil)
|
||
|
|
;; Call listener after setting/before resetting
|
||
|
|
;; (ert-stats-current-test stats); the listener might refresh the
|
||
|
|
;; mode line display, and if the value is not set yet/any more
|
||
|
|
;; during this refresh, the mode line will flicker unnecessarily.
|
||
|
|
(setf (ert-stats-current-test stats) test)
|
||
|
|
(funcall listener 'test-started stats test)
|
||
|
|
(setf (ert-test-most-recent-result test) nil)
|
||
|
|
(unwind-protect
|
||
|
|
(ert-run-test test)
|
||
|
|
(let* ((result (ert-test-most-recent-result test))
|
||
|
|
(expectedp (typep result (ert-test-expected-result-type test))))
|
||
|
|
;; Adjust stats to add new result.
|
||
|
|
(if expectedp
|
||
|
|
(etypecase result
|
||
|
|
(ert-test-passed (incf (ert-stats-passed-expected stats)))
|
||
|
|
(ert-test-failed (incf (ert-stats-failed-expected stats)))
|
||
|
|
(ert-test-error (incf (ert-stats-error-expected stats)))
|
||
|
|
(null)
|
||
|
|
(ert-test-aborted-with-non-local-exit))
|
||
|
|
(etypecase result
|
||
|
|
(ert-test-passed (incf (ert-stats-passed-unexpected stats)))
|
||
|
|
(ert-test-failed (incf (ert-stats-failed-unexpected stats)))
|
||
|
|
(ert-test-error (incf (ert-stats-error-unexpected stats)))
|
||
|
|
(null)
|
||
|
|
(ert-test-aborted-with-non-local-exit)))
|
||
|
|
(setf (aref results pos) result
|
||
|
|
(aref expected pos) expectedp)
|
||
|
|
(funcall listener 'test-ended stats test result))
|
||
|
|
(setf (ert-stats-current-test stats) nil))))
|
||
|
|
|
||
|
|
(defun ert-run-tests (selector listener)
|
||
|
|
"Run the tests specified by SELECTOR, sending progress updates to LISTENER."
|
||
|
|
(let* ((tests (coerce (ert-select-tests selector t) 'vector))
|
||
|
|
(map (let ((map (make-hash-table :size (length tests))))
|
||
|
|
(loop for i from 0
|
||
|
|
for test across tests
|
||
|
|
for key = (or (ert-test-name test) test) do
|
||
|
|
(assert (not (gethash key map)))
|
||
|
|
(setf (gethash key map) i))
|
||
|
|
map))
|
||
|
|
(stats (make-ert-stats :selector selector
|
||
|
|
:tests tests
|
||
|
|
:test-map map
|
||
|
|
:test-results (make-vector (length tests) nil)
|
||
|
|
:test-results-expected (make-vector
|
||
|
|
(length tests) nil)
|
||
|
|
:total (length tests)
|
||
|
|
:start-time (current-time))))
|
||
|
|
(funcall listener 'run-started stats)
|
||
|
|
(let ((abortedp t))
|
||
|
|
(let ((ert-current-run-stats stats))
|
||
|
|
(force-mode-line-update)
|
||
|
|
(unwind-protect
|
||
|
|
(progn
|
||
|
|
(loop for test across tests do
|
||
|
|
(ert-run-or-rerun-test stats test listener))
|
||
|
|
(setq abortedp nil))
|
||
|
|
(setf (ert-stats-aborted-p stats) abortedp)
|
||
|
|
(setf (ert-stats-end-time stats) (current-time))
|
||
|
|
(funcall listener 'run-ended stats abortedp)))
|
||
|
|
stats)))
|
||
|
|
|
||
|
|
(defun ert-stats-test-index (stats test)
|
||
|
|
"Return the index of TEST in the run represented by STATS."
|
||
|
|
(gethash (or (ert-test-name test) test) (ert-stats-test-map stats)))
|
||
|
|
|
||
|
|
(defvar ert-selector-history nil
|
||
|
|
"List of recent test selectors read from terminal.")
|
||
|
|
|
||
|
|
;; Fix-me: return (regep (list of matches))?
|
||
|
|
;; Fix-me: Add prompt parameter?
|
||
|
|
(defun ert-read-test-selector ()
|
||
|
|
"Read a regexp for test selection from minibuffer.
|
||
|
|
The user can use TAB to see which tests match."
|
||
|
|
(let* ((all-tests
|
||
|
|
(mapcar (lambda (rec) (format "%s" (elt rec 1)))
|
||
|
|
(ert-select-tests "" t))
|
||
|
|
;;'("ert-group1-1" "ert-group1-2" "ert-other")
|
||
|
|
)
|
||
|
|
regexp
|
||
|
|
ret
|
||
|
|
(get-completions
|
||
|
|
(lambda ()
|
||
|
|
(let* ((ret (save-match-data
|
||
|
|
(mapcar (lambda (alt)
|
||
|
|
(when (string-match regexp alt)
|
||
|
|
alt))
|
||
|
|
all-tests))))
|
||
|
|
(setq ret (delq nil ret))
|
||
|
|
ret))))
|
||
|
|
(setq all-tests (append all-tests
|
||
|
|
'(":new"
|
||
|
|
":failed" ":passed" ":error"
|
||
|
|
)
|
||
|
|
nil))
|
||
|
|
(let ((mini-map (copy-keymap minibuffer-local-map)))
|
||
|
|
(define-key mini-map [?\t]
|
||
|
|
(lambda () (interactive)
|
||
|
|
(with-output-to-temp-buffer "*Completions*"
|
||
|
|
(display-completion-list
|
||
|
|
(progn
|
||
|
|
(setq regexp (minibuffer-contents))
|
||
|
|
(set-text-properties 0 (length regexp) nil regexp)
|
||
|
|
(funcall get-completions))))))
|
||
|
|
(setq regexp
|
||
|
|
(let* ((sym-here (thing-at-point 'symbol))
|
||
|
|
(test-here (when (and sym-here
|
||
|
|
(memq sym-here all-tests))
|
||
|
|
sym-here))
|
||
|
|
(default (if sym-here
|
||
|
|
(substring-no-properties sym-here)
|
||
|
|
(if ert-selector-history
|
||
|
|
(first ert-selector-history)
|
||
|
|
"t"))))
|
||
|
|
(read-from-minibuffer
|
||
|
|
(if (null default)
|
||
|
|
"Run tests, use TAB to see matches: "
|
||
|
|
(format "Run tests, use TAB to see matches (default %s): "
|
||
|
|
default))
|
||
|
|
nil ;; initial-contents
|
||
|
|
mini-map ;; keymap
|
||
|
|
nil ;; read
|
||
|
|
'ert-selector-history
|
||
|
|
default nil))))
|
||
|
|
(setq ret regexp)
|
||
|
|
(when (string= "t" ret)
|
||
|
|
(setq ret t))
|
||
|
|
ret))
|
||
|
|
|
||
|
|
;; Should OUTPUT-BUFFER-NAME and MESSAGE-FN really be arguments here?
|
||
|
|
;; They are needed only for our automated self-tests at the moment.
|
||
|
|
;; Or should there be some other mechanism?
|
||
|
|
;;;###autoload
|
||
|
|
(defun ert-run-tests-interactively (selector
|
||
|
|
&optional output-buffer-name message-fn)
|
||
|
|
"Run the tests specified by SELECTOR and display the results in a buffer."
|
||
|
|
(interactive
|
||
|
|
;;; (list (let ((default (if ert-selector-history
|
||
|
|
;;; (first ert-selector-history)
|
||
|
|
;;; "t")))
|
||
|
|
;;; (read-from-minibuffer (if (null default)
|
||
|
|
;;; "Run tests: "
|
||
|
|
;;; (format "Run tests (default %s): " default))
|
||
|
|
;;; ;;nil nil t 'ert-selector-history
|
||
|
|
;;; ;;
|
||
|
|
;;; ;; fix-me: seems like I am misunderstanding Christians intent here.
|
||
|
|
;;; nil nil nil 'ert-selector-history
|
||
|
|
;;; default nil))
|
||
|
|
;;; nil nil))
|
||
|
|
(list (ert-read-test-selector)
|
||
|
|
nil nil))
|
||
|
|
(unless message-fn (setq message-fn 'message))
|
||
|
|
(lexical-let ((output-buffer-name output-buffer-name)
|
||
|
|
buffer
|
||
|
|
listener
|
||
|
|
(message-fn message-fn))
|
||
|
|
(setq listener
|
||
|
|
(lambda (event-type &rest event-args)
|
||
|
|
(ecase event-type
|
||
|
|
(run-started
|
||
|
|
(destructuring-bind (stats) event-args
|
||
|
|
(setq buffer (ert-setup-results-buffer stats
|
||
|
|
listener
|
||
|
|
output-buffer-name))
|
||
|
|
(pop-to-buffer buffer)))
|
||
|
|
(run-ended
|
||
|
|
(destructuring-bind (stats abortedp) event-args
|
||
|
|
(funcall message-fn
|
||
|
|
"%sRan %s tests, %s results were as expected%s"
|
||
|
|
(if (not abortedp)
|
||
|
|
""
|
||
|
|
"Aborted: ")
|
||
|
|
(ert-stats-total stats)
|
||
|
|
(+ (ert-stats-passed-expected stats)
|
||
|
|
(ert-stats-failed-expected stats)
|
||
|
|
(ert-stats-error-expected stats))
|
||
|
|
(let ((unexpected
|
||
|
|
(+ (ert-stats-passed-unexpected stats)
|
||
|
|
(ert-stats-failed-unexpected stats)
|
||
|
|
(ert-stats-error-unexpected stats))))
|
||
|
|
(if (zerop unexpected)
|
||
|
|
""
|
||
|
|
(format ", %s unexpected" unexpected))))
|
||
|
|
(ert-results-update-stats-display (with-current-buffer buffer
|
||
|
|
ert-results-ewoc)
|
||
|
|
stats)))
|
||
|
|
(test-started
|
||
|
|
(destructuring-bind (stats test) event-args
|
||
|
|
(with-current-buffer buffer
|
||
|
|
(let* ((ewoc ert-results-ewoc)
|
||
|
|
(pos (ert-stats-test-index stats test))
|
||
|
|
(node (ewoc-nth ewoc pos)))
|
||
|
|
(unless node
|
||
|
|
;; FIXME: How expensive is this assertion?
|
||
|
|
(assert (or (zerop pos) (ewoc-nth ewoc (1- pos)))
|
||
|
|
t)
|
||
|
|
(setq node (ewoc-enter-last
|
||
|
|
ewoc
|
||
|
|
(make-ert-ewoc-entry :test test
|
||
|
|
:hidden-p t))))
|
||
|
|
(setf (ert-ewoc-entry-test (ewoc-data node)) test)
|
||
|
|
(setf (ert-ewoc-entry-result (ewoc-data node)) nil)
|
||
|
|
(aset ert-results-progress-bar-string pos
|
||
|
|
(ert-char-for-test-result nil t))
|
||
|
|
(ert-results-update-stats-display ewoc stats)
|
||
|
|
(ewoc-invalidate ewoc node)))))
|
||
|
|
(test-ended
|
||
|
|
(destructuring-bind (stats test result) event-args
|
||
|
|
(with-current-buffer buffer
|
||
|
|
(let* ((ewoc ert-results-ewoc)
|
||
|
|
(pos (ert-stats-test-index stats test))
|
||
|
|
(node (ewoc-nth ewoc pos)))
|
||
|
|
(setf (ert-ewoc-entry-result (ewoc-data node)) result)
|
||
|
|
(when (ert-ewoc-entry-hidden-p (ewoc-data node))
|
||
|
|
(setf (ert-ewoc-entry-hidden-p (ewoc-data node))
|
||
|
|
(ert-test-result-expected-p test result)))
|
||
|
|
(aset ert-results-progress-bar-string pos
|
||
|
|
(ert-char-for-test-result result
|
||
|
|
(ert-test-result-expected-p
|
||
|
|
test result)))
|
||
|
|
(ert-results-update-stats-display ewoc stats)
|
||
|
|
(ewoc-invalidate ewoc node))))))))
|
||
|
|
(ert-run-tests
|
||
|
|
selector
|
||
|
|
listener)))
|
||
|
|
|
||
|
|
(defvar ert-batch-backtrace-right-margin 70
|
||
|
|
"*The maximum line length for printing backtraces in `ert-run-tests-batch'.")
|
||
|
|
|
||
|
|
(defun ert-run-tests-batch (selector)
|
||
|
|
"Run the tests specified by SELECTOR, printing results to the terminal.
|
||
|
|
|
||
|
|
Returns the stats object."
|
||
|
|
(ert-run-tests
|
||
|
|
selector
|
||
|
|
(lambda (event-type &rest event-args)
|
||
|
|
(ecase event-type
|
||
|
|
(run-started
|
||
|
|
(destructuring-bind (stats) event-args
|
||
|
|
(message "Running %s tests (%s)"
|
||
|
|
(length (ert-stats-tests stats))
|
||
|
|
(ert-format-time-iso8601 (ert-stats-start-time stats)))))
|
||
|
|
(run-ended
|
||
|
|
(destructuring-bind (stats abortedp) event-args
|
||
|
|
(let ((unexpected (+ (ert-stats-passed-unexpected stats)
|
||
|
|
(ert-stats-failed-unexpected stats)
|
||
|
|
(ert-stats-error-unexpected stats))))
|
||
|
|
(message "\n%sRan %s tests, %s results were as expected%s (%s)\n"
|
||
|
|
(if (not abortedp)
|
||
|
|
""
|
||
|
|
"Aborted: ")
|
||
|
|
(ert-stats-total stats)
|
||
|
|
(+ (ert-stats-passed-expected stats)
|
||
|
|
(ert-stats-failed-expected stats)
|
||
|
|
(ert-stats-error-expected stats))
|
||
|
|
(if (zerop unexpected)
|
||
|
|
""
|
||
|
|
(format ", %s unexpected" unexpected))
|
||
|
|
(ert-format-time-iso8601 (ert-stats-end-time stats)))
|
||
|
|
(unless (zerop unexpected)
|
||
|
|
(message "%s unexpected results:" unexpected)
|
||
|
|
(loop for test across (ert-stats-tests stats)
|
||
|
|
for result = (ert-test-most-recent-result test) do
|
||
|
|
(when (not (ert-test-result-expected-p test result))
|
||
|
|
(message "%9s %S"
|
||
|
|
(ert-string-for-test-result result nil)
|
||
|
|
(ert-test-name test))))
|
||
|
|
(message "%s" "")))))
|
||
|
|
(test-started
|
||
|
|
)
|
||
|
|
(test-ended
|
||
|
|
(destructuring-bind (stats test result) event-args
|
||
|
|
(etypecase result
|
||
|
|
(ert-test-passed)
|
||
|
|
(ert-test-result-with-condition
|
||
|
|
(message "Test %S backtrace:" (ert-test-name test))
|
||
|
|
(with-temp-buffer
|
||
|
|
(ert-print-backtrace (ert-test-result-with-condition-backtrace result))
|
||
|
|
(goto-char (point-min))
|
||
|
|
(while (not (eobp))
|
||
|
|
(let ((start (point))
|
||
|
|
(end (progn (end-of-line) (point))))
|
||
|
|
(setq end (min end
|
||
|
|
(+ start ert-batch-backtrace-right-margin)))
|
||
|
|
(message "%s" (buffer-substring-no-properties
|
||
|
|
start end)))
|
||
|
|
(forward-line 1)))
|
||
|
|
(with-temp-buffer
|
||
|
|
(insert " ")
|
||
|
|
(let ((print-escape-newlines t)
|
||
|
|
(print-level 5)
|
||
|
|
(print-length 10))
|
||
|
|
(let ((begin (point)))
|
||
|
|
(ert-pp-with-indentation-and-newline
|
||
|
|
(ert-test-result-with-condition-condition result))))
|
||
|
|
(goto-char (1- (point-max)))
|
||
|
|
(assert (looking-at "\n"))
|
||
|
|
(delete-char 1)
|
||
|
|
(message "Test %S condition:" (ert-test-name test))
|
||
|
|
(message "%s" (buffer-string))))
|
||
|
|
(ert-test-aborted-with-non-local-exit))
|
||
|
|
(let* ((max (prin1-to-string (length (ert-stats-tests stats))))
|
||
|
|
(format-string (concat "%9s %"
|
||
|
|
(prin1-to-string (length max))
|
||
|
|
"s/" max " %S")))
|
||
|
|
(message format-string
|
||
|
|
(ert-string-for-test-result result
|
||
|
|
(ert-test-result-expected-p
|
||
|
|
test result))
|
||
|
|
(1+ (ert-stats-test-index stats test))
|
||
|
|
(ert-test-name test)))))))))
|
||
|
|
|
||
|
|
|
||
|
|
;;; Commands and button actions for the results buffer.
|
||
|
|
|
||
|
|
(define-derived-mode ert-results-mode fundamental-mode "ERT-Results"
|
||
|
|
"Major mode for viewing results of ERT test runs.")
|
||
|
|
|
||
|
|
(loop for (key binding) in
|
||
|
|
'(("j" ert-results-jump-between-summary-and-result)
|
||
|
|
("." ert-results-find-test-at-point-other-window)
|
||
|
|
("r" ert-results-rerun-test-at-point)
|
||
|
|
("d" ert-results-rerun-test-at-point-debugging-errors)
|
||
|
|
("b" ert-results-pop-to-backtrace-for-test-at-point)
|
||
|
|
("m" ert-results-pop-to-messages-for-test-at-point)
|
||
|
|
("p" ert-results-toggle-printer-limits-for-test-at-point)
|
||
|
|
("D" ert-delete-test)
|
||
|
|
([?\t] forward-button)
|
||
|
|
([backtab] backward-button)
|
||
|
|
)
|
||
|
|
do
|
||
|
|
(define-key ert-results-mode-map key binding))
|
||
|
|
|
||
|
|
(define-button-type 'ert-results-progress-bar-button
|
||
|
|
'action #'ert-results-progress-bar-button-action
|
||
|
|
'help-echo "mouse-2, RET: Reveal test result")
|
||
|
|
|
||
|
|
(define-button-type 'ert-test-name-button
|
||
|
|
'action #'ert-test-name-button-action
|
||
|
|
'help-echo "mouse-2, RET: Find test definition")
|
||
|
|
|
||
|
|
(define-button-type 'ert-results-expand-collapse-button
|
||
|
|
'action #'ert-results-expand-collapse-button-action
|
||
|
|
'help-echo "mouse-2, RET: Expand/collapse test result")
|
||
|
|
|
||
|
|
(defun ert-results-test-node-or-null-at-point ()
|
||
|
|
"If point is on a valid ewoc node, return it; return nil otherwise.
|
||
|
|
|
||
|
|
To be used in the ERT results buffer."
|
||
|
|
(let* ((ewoc ert-results-ewoc)
|
||
|
|
(node (ewoc-locate ewoc)))
|
||
|
|
;; `ewoc-locate' will return an arbitrary node when point is on
|
||
|
|
;; header or footer, or when all nodes are invisible. So we need
|
||
|
|
;; to validate its return value here.
|
||
|
|
(if (and (>= (point) (ewoc-location node))
|
||
|
|
(not (ert-ewoc-entry-hidden-p (ewoc-data node))))
|
||
|
|
node
|
||
|
|
nil)))
|
||
|
|
|
||
|
|
(defun ert-results-test-node-at-point ()
|
||
|
|
"If point is on a valid ewoc node, return it; signal an error otherwise.
|
||
|
|
|
||
|
|
To be used in the ERT results buffer."
|
||
|
|
(or (ert-results-test-node-or-null-at-point)
|
||
|
|
(error "No test at point")))
|
||
|
|
|
||
|
|
(defun ert-results-expand-collapse-button-action (button)
|
||
|
|
"Expand or collapse the test node BUTTON belongs to."
|
||
|
|
(let* ((ewoc ert-results-ewoc)
|
||
|
|
(node (save-excursion
|
||
|
|
(goto-char (ert-button-action-position))
|
||
|
|
(ert-results-test-node-at-point)))
|
||
|
|
(entry (ewoc-data node)))
|
||
|
|
(setf (ert-ewoc-entry-expanded-p entry)
|
||
|
|
(not (ert-ewoc-entry-expanded-p entry)))
|
||
|
|
(ewoc-invalidate ewoc node)))
|
||
|
|
|
||
|
|
(defun ert-results-find-test-at-point-other-window ()
|
||
|
|
"Find the definition of the test at point in another window.
|
||
|
|
|
||
|
|
To be used in the ERT results buffer."
|
||
|
|
(interactive)
|
||
|
|
(let* ((node (ert-results-test-node-at-point))
|
||
|
|
(entry (ewoc-data node))
|
||
|
|
(test (ert-ewoc-entry-test entry))
|
||
|
|
(name (ert-test-name test)))
|
||
|
|
(ert-find-test-other-window name)))
|
||
|
|
|
||
|
|
(defun ert-test-name-button-action (button)
|
||
|
|
"Find the definition of the test BUTTON belongs to, in another window."
|
||
|
|
(let ((name (button-get button 'ert-test-name)))
|
||
|
|
(ert-find-test-other-window name)))
|
||
|
|
|
||
|
|
(defun ert-ewoc-position (ewoc node)
|
||
|
|
"Return the position of NODE in EWOC, or nil if NODE is not in EWOC."
|
||
|
|
(loop for i from 0
|
||
|
|
for node-here = (ewoc-nth ewoc 0) then (ewoc-next ewoc node-here)
|
||
|
|
do (when (eql node node-here)
|
||
|
|
(return i))
|
||
|
|
finally (return nil)))
|
||
|
|
|
||
|
|
(defun ert-results-jump-between-summary-and-result ()
|
||
|
|
"Jump back and forth between the test run summary and individual test results.
|
||
|
|
|
||
|
|
From an ewoc node, jumps to the character that represents the
|
||
|
|
same test in the progress bar, and vice versa.
|
||
|
|
|
||
|
|
To be used in the ERT results buffer."
|
||
|
|
;; Maybe this command isn't actually needed much, but if it is, it
|
||
|
|
;; seems like an indication that the UI design is not optimal. If
|
||
|
|
;; jumping back and forth between a summary at the top of the buffer
|
||
|
|
;; and the error log in the remainder of the buffer is useful, then
|
||
|
|
;; the summary apparently needs to be easily accessible from the
|
||
|
|
;; error log, and perhaps it would be better to have it in a
|
||
|
|
;; separate buffer to keep it visible.
|
||
|
|
(interactive)
|
||
|
|
(let ((ewoc ert-results-ewoc)
|
||
|
|
(progress-bar-begin ert-results-progress-bar-button-begin))
|
||
|
|
(cond ((ert-results-test-node-or-null-at-point)
|
||
|
|
(let* ((node (ert-results-test-node-at-point))
|
||
|
|
(pos (ert-ewoc-position ewoc node)))
|
||
|
|
(goto-char (+ progress-bar-begin pos))))
|
||
|
|
((and (<= progress-bar-begin (point))
|
||
|
|
(< (point) (button-end (button-at progress-bar-begin))))
|
||
|
|
(let* ((node (ewoc-nth ewoc (- (point) progress-bar-begin)))
|
||
|
|
(entry (ewoc-data node)))
|
||
|
|
(when (ert-ewoc-entry-hidden-p entry)
|
||
|
|
(setf (ert-ewoc-entry-hidden-p entry) nil)
|
||
|
|
(ewoc-invalidate ewoc node))
|
||
|
|
(ewoc-goto-node ewoc node)))
|
||
|
|
(t
|
||
|
|
(goto-char progress-bar-begin)))))
|
||
|
|
|
||
|
|
(defun ert-button-action-position ()
|
||
|
|
"The buffer position where the last button action was triggered."
|
||
|
|
(cond ((integerp last-command-event)
|
||
|
|
(point))
|
||
|
|
((eventp last-command-event)
|
||
|
|
(posn-point (event-start last-command-event)))
|
||
|
|
(t (assert nil))))
|
||
|
|
|
||
|
|
(defun ert-results-progress-bar-button-action (button)
|
||
|
|
"Find the ewoc node that represents the same test as the character clicked on."
|
||
|
|
(goto-char (ert-button-action-position))
|
||
|
|
(ert-results-jump-between-summary-and-result))
|
||
|
|
|
||
|
|
(defun ert-results-rerun-test-at-point ()
|
||
|
|
"Re-run the test at point.
|
||
|
|
|
||
|
|
To be used in the ERT results buffer."
|
||
|
|
(interactive)
|
||
|
|
(let* ((ewoc ert-results-ewoc)
|
||
|
|
(node (ert-results-test-node-at-point))
|
||
|
|
(entry (ewoc-data node))
|
||
|
|
(old-test (ert-ewoc-entry-test entry))
|
||
|
|
(test-name (ert-test-name old-test))
|
||
|
|
;; FIXME: Write a test for this lookup.
|
||
|
|
(test (if test-name
|
||
|
|
(if (ert-test-boundp test-name)
|
||
|
|
(ert-get-test test-name)
|
||
|
|
(error "No such test: %S" test-name))
|
||
|
|
old-test))
|
||
|
|
(stats ert-results-stats)
|
||
|
|
(pos (gethash test (ert-stats-test-map stats)))
|
||
|
|
(progress-message (format "Running test %S" (ert-test-name test))))
|
||
|
|
;; Need to save and restore point manually here: When point is on
|
||
|
|
;; the first visible ewoc entry while the header is updated, point
|
||
|
|
;; moves to the top of the buffer. This is undesirable, and a
|
||
|
|
;; simple `save-excursion' doesn't prevent it.
|
||
|
|
(let ((point (point)))
|
||
|
|
(unwind-protect
|
||
|
|
(unwind-protect
|
||
|
|
(progn
|
||
|
|
(message "%s..." progress-message)
|
||
|
|
(ert-run-or-rerun-test stats test
|
||
|
|
ert-results-listener))
|
||
|
|
(ert-results-update-stats-display ewoc stats)
|
||
|
|
(message "%s...%s"
|
||
|
|
progress-message
|
||
|
|
(let ((result (ert-test-most-recent-result test)))
|
||
|
|
(ert-string-for-test-result
|
||
|
|
result (ert-test-result-expected-p test result)))))
|
||
|
|
(goto-char point)))))
|
||
|
|
|
||
|
|
(defun ert-results-rerun-test-at-point-debugging-errors ()
|
||
|
|
"Re-run the test at point with `ert-debug-on-error' bound to t.
|
||
|
|
|
||
|
|
To be used in the ERT results buffer."
|
||
|
|
(interactive)
|
||
|
|
(let ((ert-debug-on-error t))
|
||
|
|
(ert-results-rerun-test-at-point)))
|
||
|
|
|
||
|
|
(defun ert-print-backtrace (backtrace)
|
||
|
|
"Format the backtrace BACKTRACE to the current buffer."
|
||
|
|
;; This is essentially a reimplementation of Fbacktrace
|
||
|
|
;; (src/eval.c), but for a saved backtrace, not the current one.
|
||
|
|
(let ((print-escape-newlines t)
|
||
|
|
(print-level 8)
|
||
|
|
(print-length 50))
|
||
|
|
(dolist (frame backtrace)
|
||
|
|
(ecase (first frame)
|
||
|
|
((nil)
|
||
|
|
;; Special operator.
|
||
|
|
(destructuring-bind (special-operator &rest arg-forms)
|
||
|
|
(cdr frame)
|
||
|
|
(insert
|
||
|
|
(format " %S\n" (list* special-operator arg-forms)))))
|
||
|
|
((t)
|
||
|
|
;; Function call.
|
||
|
|
(destructuring-bind (fn &rest args) (cdr frame)
|
||
|
|
(insert (format " %S(" fn))
|
||
|
|
(loop for firstp = t then nil
|
||
|
|
for arg in args do
|
||
|
|
(unless firstp
|
||
|
|
(insert " "))
|
||
|
|
(insert (format "%S" arg)))
|
||
|
|
(insert ")\n")))))))
|
||
|
|
|
||
|
|
(defun ert-results-pop-to-backtrace-for-test-at-point ()
|
||
|
|
"Display the backtrace for the test at point.
|
||
|
|
|
||
|
|
To be used in the ERT results buffer."
|
||
|
|
(interactive)
|
||
|
|
(let* ((node (ert-results-test-node-at-point))
|
||
|
|
(entry (ewoc-data node))
|
||
|
|
(test (ert-ewoc-entry-test entry))
|
||
|
|
(result (ert-ewoc-entry-result entry)))
|
||
|
|
(etypecase result
|
||
|
|
(ert-test-passed (error "Test passed, no backtrace available"))
|
||
|
|
(ert-test-result-with-condition
|
||
|
|
(let ((backtrace (ert-test-result-with-condition-backtrace result))
|
||
|
|
(buffer
|
||
|
|
(let ((default-major-mode 'fundamental-mode))
|
||
|
|
(get-buffer-create "*ERT Backtrace*"))))
|
||
|
|
(pop-to-buffer buffer)
|
||
|
|
(setq buffer-read-only t)
|
||
|
|
(let ((inhibit-read-only t))
|
||
|
|
(erase-buffer)
|
||
|
|
;; Use unibyte because `debugger-setup-buffer' also does so.
|
||
|
|
(set-buffer-multibyte nil)
|
||
|
|
(setq truncate-lines t)
|
||
|
|
(ert-print-backtrace backtrace)
|
||
|
|
(debugger-make-xrefs)
|
||
|
|
(goto-char (point-min))))))))
|
||
|
|
|
||
|
|
(defun ert-results-pop-to-messages-for-test-at-point ()
|
||
|
|
"Display the part of the *Messages* buffer generated during the test at point.
|
||
|
|
|
||
|
|
To be used in the ERT results buffer."
|
||
|
|
(interactive)
|
||
|
|
(let* ((node (ert-results-test-node-at-point))
|
||
|
|
(entry (ewoc-data node))
|
||
|
|
(test (ert-ewoc-entry-test entry))
|
||
|
|
(result (ert-ewoc-entry-result entry)))
|
||
|
|
(let ((buffer
|
||
|
|
(let ((default-major-mode 'fundamental-mode))
|
||
|
|
(get-buffer-create "*ERT Messages*"))))
|
||
|
|
(pop-to-buffer buffer)
|
||
|
|
(setq buffer-read-only t)
|
||
|
|
(let ((inhibit-read-only t))
|
||
|
|
(erase-buffer)
|
||
|
|
(insert (ert-test-result-messages result))
|
||
|
|
(goto-char (point-min))
|
||
|
|
(insert "Messages for test `")
|
||
|
|
(ert-insert-test-name-button (ert-test-name test))
|
||
|
|
(insert "':\n")))))
|
||
|
|
|
||
|
|
(defun ert-results-toggle-printer-limits-for-test-at-point ()
|
||
|
|
"Toggle how much of the condition to print for the test at point.
|
||
|
|
|
||
|
|
To be used in the ERT results buffer."
|
||
|
|
(interactive)
|
||
|
|
(let* ((ewoc ert-results-ewoc)
|
||
|
|
(node (ert-results-test-node-at-point))
|
||
|
|
(entry (ewoc-data node)))
|
||
|
|
(setf (ert-ewoc-entry-extended-printer-limits-p entry)
|
||
|
|
(not (ert-ewoc-entry-extended-printer-limits-p entry)))
|
||
|
|
(ewoc-invalidate ewoc node)))
|
||
|
|
|
||
|
|
(defun ert-activate-font-lock-keywords ()
|
||
|
|
(font-lock-add-keywords
|
||
|
|
nil
|
||
|
|
'(("(\\(\\<ert-deftest\\)\\>\\s *\\(\\sw+\\)?"
|
||
|
|
(1 font-lock-keyword-face nil t)
|
||
|
|
(2 font-lock-function-name-face nil t)))))
|
||
|
|
|
||
|
|
(defun* ert-remove-from-list (list-var element &key key test)
|
||
|
|
"Remove ELEMENT from the value of LIST-VAR if present.
|
||
|
|
|
||
|
|
This is an inverse of `add-to-list'."
|
||
|
|
(unless key (setq key #'identity))
|
||
|
|
(unless test (setq test #'equal))
|
||
|
|
(setf (symbol-value list-var)
|
||
|
|
(remove* element
|
||
|
|
(symbol-value list-var)
|
||
|
|
:key key
|
||
|
|
:test test)))
|
||
|
|
|
||
|
|
|
||
|
|
;;; Actions on load/unload.
|
||
|
|
|
||
|
|
(add-to-list 'find-function-regexp-alist '(ert-deftest . ert-find-test-regexp))
|
||
|
|
(add-to-list 'minor-mode-alist '(ert-current-run-stats
|
||
|
|
(:eval
|
||
|
|
(ert-tests-running-mode-line-indicator))))
|
||
|
|
(add-to-list 'emacs-lisp-mode-hook 'ert-activate-font-lock-keywords)
|
||
|
|
|
||
|
|
(defun ert-unload-function ()
|
||
|
|
(ert-remove-from-list 'find-function-regexp-alist 'ert-deftest :key #'car)
|
||
|
|
(ert-remove-from-list 'minor-mode-alist 'ert-current-run-stats :key #'car)
|
||
|
|
(ert-remove-from-list 'emacs-lisp-mode-hook 'ert-activate-font-lock-keywords)
|
||
|
|
nil)
|
||
|
|
|
||
|
|
(defvar ert-unload-hook '())
|
||
|
|
(add-hook 'ert-unload-hook 'ert-unload-function)
|
||
|
|
|
||
|
|
|
||
|
|
;;; Self-tests.
|
||
|
|
|
||
|
|
(ert-delete-all-tests)
|
||
|
|
|
||
|
|
;; Test that test bodies are actually run.
|
||
|
|
(defvar ert-test-body-was-run)
|
||
|
|
(ert-deftest ert-test-body-runs ()
|
||
|
|
(setq ert-test-body-was-run t))
|
||
|
|
|
||
|
|
|
||
|
|
;; Test that nested test bodies run.
|
||
|
|
(ert-deftest ert-nested-test-body-runs ()
|
||
|
|
(lexical-let ((was-run nil))
|
||
|
|
(let ((test (make-ert-test :body (lambda ()
|
||
|
|
(setq was-run t)))))
|
||
|
|
(assert (not was-run))
|
||
|
|
(ert-run-test test)
|
||
|
|
(assert was-run))))
|
||
|
|
|
||
|
|
|
||
|
|
;; Test that pass/fail works.
|
||
|
|
(ert-deftest ert-test-pass ()
|
||
|
|
(let ((test (make-ert-test :body (lambda ()))))
|
||
|
|
(let ((result (ert-run-test test)))
|
||
|
|
(assert (typep result 'ert-test-passed)))))
|
||
|
|
|
||
|
|
(ert-deftest ert-test-fail ()
|
||
|
|
(let ((test (make-ert-test :body (lambda () (ert-fail "failure message")))))
|
||
|
|
(let ((result (let ((ert-debug-on-error nil))
|
||
|
|
(ert-run-test test))))
|
||
|
|
(assert (typep result 'ert-test-failed) t)
|
||
|
|
(assert (equal (ert-test-result-with-condition-condition result)
|
||
|
|
'(ert-test-failed "failure message"))
|
||
|
|
t))))
|
||
|
|
|
||
|
|
(ert-deftest ert-test-fail-debug-with-condition-case ()
|
||
|
|
(let ((test (make-ert-test :body (lambda () (ert-fail "failure message")))))
|
||
|
|
(condition-case condition
|
||
|
|
(progn
|
||
|
|
(let ((ert-debug-on-error t))
|
||
|
|
(ert-run-test test))
|
||
|
|
(assert nil))
|
||
|
|
((error)
|
||
|
|
(assert (equal condition '(ert-test-failed "failure message")) t)))))
|
||
|
|
|
||
|
|
(ert-deftest ert-test-fail-debug-with-debugger-1 ()
|
||
|
|
(let ((test (make-ert-test :body (lambda () (ert-fail "failure message")))))
|
||
|
|
(let ((debugger (lambda (&rest debugger-args)
|
||
|
|
(assert nil))))
|
||
|
|
(let ((ert-debug-on-error nil))
|
||
|
|
(ert-run-test test)))))
|
||
|
|
|
||
|
|
(ert-deftest ert-test-fail-debug-with-debugger-2 ()
|
||
|
|
(let ((test (make-ert-test :body (lambda () (ert-fail "failure message")))))
|
||
|
|
(block nil
|
||
|
|
(let ((debugger (lambda (&rest debugger-args)
|
||
|
|
(return-from nil nil))))
|
||
|
|
(let ((ert-debug-on-error t))
|
||
|
|
(ert-run-test test))
|
||
|
|
(assert nil)))))
|
||
|
|
|
||
|
|
(ert-deftest ert-test-fail-debug-nested-with-debugger ()
|
||
|
|
(let ((test (make-ert-test :body (lambda ()
|
||
|
|
(let ((ert-debug-on-error t))
|
||
|
|
(ert-fail "failure message"))))))
|
||
|
|
(let ((debugger (lambda (&rest debugger-args)
|
||
|
|
(assert nil nil "Assertion a"))))
|
||
|
|
(let ((ert-debug-on-error nil))
|
||
|
|
(ert-run-test test))))
|
||
|
|
(let ((test (make-ert-test :body (lambda ()
|
||
|
|
(let ((ert-debug-on-error nil))
|
||
|
|
(ert-fail "failure message"))))))
|
||
|
|
(block nil
|
||
|
|
(let ((debugger (lambda (&rest debugger-args)
|
||
|
|
(return-from nil nil))))
|
||
|
|
(let ((ert-debug-on-error t))
|
||
|
|
(ert-run-test test))
|
||
|
|
(assert nil nil "Assertion b")))))
|
||
|
|
|
||
|
|
(ert-deftest ert-test-error ()
|
||
|
|
(let ((test (make-ert-test :body (lambda () (error "error message")))))
|
||
|
|
(let ((result (let ((ert-debug-on-error nil))
|
||
|
|
(ert-run-test test))))
|
||
|
|
(assert (typep result 'ert-test-error) t)
|
||
|
|
(assert (equal (ert-test-result-with-condition-condition result)
|
||
|
|
'(error "error message"))
|
||
|
|
t))))
|
||
|
|
|
||
|
|
(ert-deftest ert-test-error-debug ()
|
||
|
|
(let ((test (make-ert-test :body (lambda () (error "error message")))))
|
||
|
|
(condition-case condition
|
||
|
|
(progn
|
||
|
|
(let ((ert-debug-on-error t))
|
||
|
|
(ert-run-test test))
|
||
|
|
(assert nil))
|
||
|
|
((error)
|
||
|
|
(assert (equal condition '(error "error message")) t)))))
|
||
|
|
|
||
|
|
|
||
|
|
;; Test that `should' works.
|
||
|
|
(ert-deftest ert-test-should ()
|
||
|
|
(let ((test (make-ert-test :body (lambda () (ert-should nil)))))
|
||
|
|
(let ((result (let ((ert-debug-on-error nil))
|
||
|
|
(ert-run-test test))))
|
||
|
|
(assert (typep result 'ert-test-failed) t)
|
||
|
|
(assert (equal (ert-test-result-with-condition-condition result)
|
||
|
|
'(ert-test-failed ((ert-should nil) :form nil :value nil)))
|
||
|
|
t)))
|
||
|
|
(let ((test (make-ert-test :body (lambda () (ert-should t)))))
|
||
|
|
(let ((result (ert-run-test test)))
|
||
|
|
(assert (typep result 'ert-test-passed) t))))
|
||
|
|
|
||
|
|
(ert-deftest ert-test-should-value ()
|
||
|
|
(ert-should (eql (ert-should 'foo) 'foo))
|
||
|
|
(ert-should (eql (ert-should 'bar) 'bar)))
|
||
|
|
|
||
|
|
(ert-deftest ert-test-should-not ()
|
||
|
|
(let ((test (make-ert-test :body (lambda () (ert-should-not t)))))
|
||
|
|
(let ((result (let ((ert-debug-on-error nil))
|
||
|
|
(ert-run-test test))))
|
||
|
|
(assert (typep result 'ert-test-failed) t)
|
||
|
|
(assert (equal (ert-test-result-with-condition-condition result)
|
||
|
|
'(ert-test-failed ((ert-should-not t) :form t :value t)))
|
||
|
|
t)))
|
||
|
|
(let ((test (make-ert-test :body (lambda () (ert-should-not nil)))))
|
||
|
|
(let ((result (ert-run-test test)))
|
||
|
|
(assert (typep result 'ert-test-passed)))))
|
||
|
|
|
||
|
|
|
||
|
|
(ert-deftest ert-test-should-error ()
|
||
|
|
;; No error.
|
||
|
|
(let ((test (make-ert-test :body (lambda () (ert-should-error (progn))))))
|
||
|
|
(let ((result (let ((ert-debug-on-error nil))
|
||
|
|
(ert-run-test test))))
|
||
|
|
(ert-should (typep result 'ert-test-failed))
|
||
|
|
(ert-should (equal (ert-test-result-with-condition-condition result)
|
||
|
|
'(ert-test-failed
|
||
|
|
((ert-should-error (progn))
|
||
|
|
:form (progn)
|
||
|
|
:value nil
|
||
|
|
:fail-reason "did not signal an error"))))))
|
||
|
|
;; A simple error.
|
||
|
|
(let ((test (make-ert-test :body (lambda () (ert-should-error (error "foo"))))))
|
||
|
|
(let ((result (ert-run-test test)))
|
||
|
|
(ert-should (typep result 'ert-test-passed))))
|
||
|
|
;; Error of unexpected type, no test.
|
||
|
|
(let ((test (make-ert-test :body (lambda ()
|
||
|
|
(ert-should-error (error "foo")
|
||
|
|
:type 'singularity-error)))))
|
||
|
|
(let ((result (ert-run-test test)))
|
||
|
|
(ert-should (typep result 'ert-test-failed))
|
||
|
|
(ert-should (equal
|
||
|
|
(ert-test-result-with-condition-condition result)
|
||
|
|
'(ert-test-failed
|
||
|
|
((ert-should-error (error "foo") :type 'singularity-error)
|
||
|
|
:form (error "foo")
|
||
|
|
:condition (error "foo")
|
||
|
|
:fail-reason
|
||
|
|
"the error signalled did not have the expected type"))))))
|
||
|
|
;; Error of the expected type, no test.
|
||
|
|
(let ((test (make-ert-test :body (lambda ()
|
||
|
|
(ert-should-error (signal 'singularity-error
|
||
|
|
nil)
|
||
|
|
:type 'singularity-error)))))
|
||
|
|
(let ((result (ert-run-test test)))
|
||
|
|
(ert-should (typep result 'ert-test-passed))))
|
||
|
|
;; Error that fails the test, no type.
|
||
|
|
(let ((test (make-ert-test :body (lambda ()
|
||
|
|
(ert-should-error
|
||
|
|
(error "foo")
|
||
|
|
:test (lambda (error) nil))))))
|
||
|
|
(let ((result (ert-run-test test)))
|
||
|
|
(ert-should (typep result 'ert-test-failed))
|
||
|
|
(ert-should (equal (ert-test-result-with-condition-condition result)
|
||
|
|
'(ert-test-failed
|
||
|
|
((ert-should-error (error "foo") :test (lambda (error) nil))
|
||
|
|
:form (error "foo")
|
||
|
|
:condition (error "foo")
|
||
|
|
:fail-reason
|
||
|
|
"the error signalled did not pass the test"))))))
|
||
|
|
;; Error that passes the test, no type.
|
||
|
|
(let ((test (make-ert-test :body (lambda ()
|
||
|
|
(ert-should-error (error "foo")
|
||
|
|
:test (lambda (error) t))))))
|
||
|
|
(let ((result (ert-run-test test)))
|
||
|
|
(ert-should (typep result 'ert-test-passed))))
|
||
|
|
;; Error that has the expected type but fails the test.
|
||
|
|
(let ((test (make-ert-test :body (lambda ()
|
||
|
|
(ert-should-error
|
||
|
|
(signal 'singularity-error nil)
|
||
|
|
:type 'singularity-error
|
||
|
|
:test (lambda (error) nil))))))
|
||
|
|
(let ((result (ert-run-test test)))
|
||
|
|
(ert-should (typep result 'ert-test-failed))
|
||
|
|
(ert-should (equal (ert-test-result-with-condition-condition result)
|
||
|
|
'(ert-test-failed
|
||
|
|
((ert-should-error (signal 'singularity-error nil)
|
||
|
|
:type 'singularity-error
|
||
|
|
:test (lambda (error) nil))
|
||
|
|
:form (signal singularity-error nil)
|
||
|
|
:condition (singularity-error)
|
||
|
|
:fail-reason
|
||
|
|
"the error signalled did not pass the test"))))))
|
||
|
|
;; Error that has the expected type and passes the test.
|
||
|
|
(let ((test (make-ert-test :body (lambda ()
|
||
|
|
(ert-should-error
|
||
|
|
(signal 'singularity-error nil)
|
||
|
|
:type 'singularity-error
|
||
|
|
:test (lambda (error) t))))))
|
||
|
|
(let ((result (ert-run-test test)))
|
||
|
|
(ert-should (typep result 'ert-test-passed))))
|
||
|
|
)
|
||
|
|
|
||
|
|
(ert-deftest ert-test-should-error-subtypes ()
|
||
|
|
(let ((test (make-ert-test
|
||
|
|
:body (lambda ()
|
||
|
|
(ert-should-error (signal 'singularity-error nil)
|
||
|
|
:type 'singularity-error
|
||
|
|
:exclude-subtypes t)))))
|
||
|
|
(let ((result (ert-run-test test)))
|
||
|
|
(ert-should (typep result 'ert-test-passed))))
|
||
|
|
(let ((test (make-ert-test
|
||
|
|
:body (lambda ()
|
||
|
|
(ert-should-error (signal 'arith-error nil)
|
||
|
|
:type 'singularity-error)))))
|
||
|
|
(let ((result (ert-run-test test)))
|
||
|
|
(ert-should (typep result 'ert-test-failed))
|
||
|
|
(ert-should (equal
|
||
|
|
(ert-test-result-with-condition-condition result)
|
||
|
|
'(ert-test-failed
|
||
|
|
((ert-should-error (signal 'arith-error nil)
|
||
|
|
:type 'singularity-error)
|
||
|
|
:form (signal arith-error nil)
|
||
|
|
:condition (arith-error)
|
||
|
|
:fail-reason
|
||
|
|
"the error signalled did not have the expected type"))))))
|
||
|
|
(let ((test (make-ert-test
|
||
|
|
:body (lambda ()
|
||
|
|
(ert-should-error (signal 'arith-error nil)
|
||
|
|
:type 'singularity-error
|
||
|
|
:exclude-subtypes t)))))
|
||
|
|
(let ((result (ert-run-test test)))
|
||
|
|
(ert-should (typep result 'ert-test-failed))
|
||
|
|
(ert-should (equal
|
||
|
|
(ert-test-result-with-condition-condition result)
|
||
|
|
'(ert-test-failed
|
||
|
|
((ert-should-error (signal 'arith-error nil)
|
||
|
|
:type 'singularity-error
|
||
|
|
:exclude-subtypes t)
|
||
|
|
:form (signal arith-error nil)
|
||
|
|
:condition (arith-error)
|
||
|
|
:fail-reason
|
||
|
|
"the error signalled did not have the expected type"))))))
|
||
|
|
(let ((test (make-ert-test
|
||
|
|
:body (lambda ()
|
||
|
|
(ert-should-error (signal 'singularity-error nil)
|
||
|
|
:type 'arith-error
|
||
|
|
:exclude-subtypes t)))))
|
||
|
|
(let ((result (ert-run-test test)))
|
||
|
|
(ert-should (typep result 'ert-test-failed))
|
||
|
|
(ert-should (equal
|
||
|
|
(ert-test-result-with-condition-condition result)
|
||
|
|
'(ert-test-failed
|
||
|
|
((ert-should-error (signal 'singularity-error nil)
|
||
|
|
:type 'arith-error
|
||
|
|
:exclude-subtypes t)
|
||
|
|
:form (signal singularity-error nil)
|
||
|
|
:condition (singularity-error)
|
||
|
|
:fail-reason
|
||
|
|
"the error signalled was a subtype of the expected type"))))))
|
||
|
|
)
|
||
|
|
|
||
|
|
;; Test that `should' errors contain the information we expect them to.
|
||
|
|
(defmacro ert-test-my-list (&rest args)
|
||
|
|
`(list ,@args))
|
||
|
|
|
||
|
|
(ert-deftest ert-test-should-failure-debugging ()
|
||
|
|
(loop for (body expected-condition) in
|
||
|
|
`((,(lambda () (let ((x nil)) (ert-should x)))
|
||
|
|
(ert-test-failed ((ert-should x) :form x :value nil)))
|
||
|
|
(,(lambda () (let ((x t)) (ert-should-not x)))
|
||
|
|
(ert-test-failed ((ert-should-not x) :form x :value t)))
|
||
|
|
(,(lambda () (let ((x t)) (ert-should (not x))))
|
||
|
|
(ert-test-failed ((ert-should (not x)) :form (not t) :value nil)))
|
||
|
|
(,(lambda () (let ((x nil)) (ert-should-not (not x))))
|
||
|
|
(ert-test-failed ((ert-should-not (not x)) :form (not nil) :value t)))
|
||
|
|
(,(lambda () (let ((x t) (y nil)) (ert-should-not (ert-test-my-list x y))))
|
||
|
|
(ert-test-failed
|
||
|
|
((ert-should-not (ert-test-my-list x y))
|
||
|
|
:form (list t nil)
|
||
|
|
:value (t nil))))
|
||
|
|
(,(lambda () (let ((x t)) (ert-should (error "foo"))))
|
||
|
|
(error "foo")))
|
||
|
|
do
|
||
|
|
(let ((test (make-ert-test :body body)))
|
||
|
|
(condition-case actual-condition
|
||
|
|
(progn
|
||
|
|
(let ((ert-debug-on-error t))
|
||
|
|
(ert-run-test test))
|
||
|
|
(assert nil))
|
||
|
|
((error)
|
||
|
|
(ert-should (equal actual-condition expected-condition)))))))
|
||
|
|
|
||
|
|
(ert-deftest ert-test-messages ()
|
||
|
|
(let* ((message-string "Test message")
|
||
|
|
(messages-buffer (get-buffer-create "*Messages*"))
|
||
|
|
(test (make-ert-test :body (lambda () (message "%s" message-string)))))
|
||
|
|
(with-current-buffer messages-buffer
|
||
|
|
(let ((result (ert-run-test test)))
|
||
|
|
(ert-should (equal (concat message-string "\n")
|
||
|
|
(ert-test-result-messages result)))))))
|
||
|
|
|
||
|
|
(defun ert-call-with-temporary-messages-buffer (thunk)
|
||
|
|
(lexical-let ((new-buffer-name (generate-new-buffer-name
|
||
|
|
"*Messages* orig buffer")))
|
||
|
|
(unwind-protect
|
||
|
|
(progn
|
||
|
|
(with-current-buffer (get-buffer-create "*Messages*")
|
||
|
|
(rename-buffer new-buffer-name))
|
||
|
|
(get-buffer-create "*Messages*")
|
||
|
|
(funcall thunk))
|
||
|
|
(kill-buffer "*Messages*")
|
||
|
|
(with-current-buffer new-buffer-name
|
||
|
|
(rename-buffer "*Messages*")))))
|
||
|
|
|
||
|
|
(ert-deftest ert-test-messages-on-log-truncation ()
|
||
|
|
(let ((test (make-ert-test
|
||
|
|
:body (lambda ()
|
||
|
|
;; Emacs would combine messages if we
|
||
|
|
;; generate the same message multiple
|
||
|
|
;; times.
|
||
|
|
(message "a")
|
||
|
|
(message "b")
|
||
|
|
(message "c")
|
||
|
|
(message "d")))))
|
||
|
|
(let (result)
|
||
|
|
(ert-call-with-temporary-messages-buffer
|
||
|
|
(lambda ()
|
||
|
|
(let ((message-log-max 2))
|
||
|
|
(setq result (ert-run-test test)))
|
||
|
|
(ert-should (equal (with-current-buffer "*Messages*"
|
||
|
|
(buffer-string))
|
||
|
|
"c\nd\n"))))
|
||
|
|
(ert-should (equal (ert-test-result-messages result) "a\nb\nc\nd\n")))))
|
||
|
|
|
||
|
|
;; Test `ert-select-tests'.
|
||
|
|
(ert-deftest ert-test-select-regexp ()
|
||
|
|
(ert-should (equal (ert-select-tests "^ert-test-select-regexp$" t)
|
||
|
|
(list (ert-get-test 'ert-test-select-regexp)))))
|
||
|
|
|
||
|
|
(ert-deftest ert-test-test-boundp ()
|
||
|
|
(ert-should (ert-test-boundp 'ert-test-test-boundp))
|
||
|
|
(ert-should-not (ert-test-boundp (make-symbol "ert-not-a-test"))))
|
||
|
|
|
||
|
|
(ert-deftest ert-test-select-member ()
|
||
|
|
(ert-should (equal (ert-select-tests '(member ert-test-select-member) t)
|
||
|
|
(list (ert-get-test 'ert-test-select-member)))))
|
||
|
|
|
||
|
|
(ert-deftest ert-test-select-test ()
|
||
|
|
(ert-should (equal (ert-select-tests (ert-get-test 'ert-test-select-test) t)
|
||
|
|
(list (ert-get-test 'ert-test-select-test)))))
|
||
|
|
|
||
|
|
(ert-deftest ert-test-select-symbol ()
|
||
|
|
(ert-should (equal (ert-select-tests 'ert-test-select-symbol t)
|
||
|
|
(list (ert-get-test 'ert-test-select-symbol)))))
|
||
|
|
|
||
|
|
(ert-deftest ert-test-select-and ()
|
||
|
|
(let ((test (make-ert-test
|
||
|
|
:name nil
|
||
|
|
:body nil
|
||
|
|
:most-recent-result (make-ert-test-failed
|
||
|
|
:condition nil
|
||
|
|
:backtrace nil))))
|
||
|
|
(ert-should (equal (ert-select-tests `(and (member ,test) :failed) t)
|
||
|
|
(list test)))))
|
||
|
|
|
||
|
|
|
||
|
|
;; Test utility functions.
|
||
|
|
(ert-deftest ert-proper-list-p ()
|
||
|
|
(ert-should (ert-proper-list-p '()))
|
||
|
|
(ert-should (ert-proper-list-p '(1)))
|
||
|
|
(ert-should (ert-proper-list-p '(1 2)))
|
||
|
|
(ert-should (ert-proper-list-p '(1 2 3)))
|
||
|
|
(ert-should (ert-proper-list-p '(1 2 3 4)))
|
||
|
|
(ert-should (not (ert-proper-list-p 'a)))
|
||
|
|
(ert-should (not (ert-proper-list-p '(1 . a))))
|
||
|
|
(ert-should (not (ert-proper-list-p '(1 2 . a))))
|
||
|
|
(ert-should (not (ert-proper-list-p '(1 2 3 . a))))
|
||
|
|
(ert-should (not (ert-proper-list-p '(1 2 3 4 . a))))
|
||
|
|
(let ((a (list 1)))
|
||
|
|
(setf (cdr (last a)) a)
|
||
|
|
(ert-should (not (ert-proper-list-p a))))
|
||
|
|
(let ((a (list 1 2)))
|
||
|
|
(setf (cdr (last a)) a)
|
||
|
|
(ert-should (not (ert-proper-list-p a))))
|
||
|
|
(let ((a (list 1 2 3)))
|
||
|
|
(setf (cdr (last a)) a)
|
||
|
|
(ert-should (not (ert-proper-list-p a))))
|
||
|
|
(let ((a (list 1 2 3 4)))
|
||
|
|
(setf (cdr (last a)) a)
|
||
|
|
(ert-should (not (ert-proper-list-p a))))
|
||
|
|
(let ((a (list 1 2)))
|
||
|
|
(setf (cdr (last a)) (cdr a))
|
||
|
|
(ert-should (not (ert-proper-list-p a))))
|
||
|
|
(let ((a (list 1 2 3)))
|
||
|
|
(setf (cdr (last a)) (cdr a))
|
||
|
|
(ert-should (not (ert-proper-list-p a))))
|
||
|
|
(let ((a (list 1 2 3 4)))
|
||
|
|
(setf (cdr (last a)) (cdr a))
|
||
|
|
(ert-should (not (ert-proper-list-p a))))
|
||
|
|
(let ((a (list 1 2 3)))
|
||
|
|
(setf (cdr (last a)) (cddr a))
|
||
|
|
(ert-should (not (ert-proper-list-p a))))
|
||
|
|
(let ((a (list 1 2 3 4)))
|
||
|
|
(setf (cdr (last a)) (cddr a))
|
||
|
|
(ert-should (not (ert-proper-list-p a))))
|
||
|
|
(let ((a (list 1 2 3 4)))
|
||
|
|
(setf (cdr (last a)) (cdddr a))
|
||
|
|
(ert-should (not (ert-proper-list-p a)))))
|
||
|
|
|
||
|
|
(ert-deftest ert-parse-keys-and-body ()
|
||
|
|
(ert-should (equal (ert-parse-keys-and-body "doc" '(foo))
|
||
|
|
'(nil "doc" (foo))))
|
||
|
|
(ert-should (equal (ert-parse-keys-and-body "doc" '(:bar foo))
|
||
|
|
'((:bar foo) "doc" nil)))
|
||
|
|
(ert-should (equal (ert-parse-keys-and-body nil '(:bar foo))
|
||
|
|
'((:bar foo) nil nil)))
|
||
|
|
(ert-should (equal (ert-parse-keys-and-body "doc" '(:bar foo))
|
||
|
|
'((:bar foo) "doc" nil)))
|
||
|
|
(ert-should (equal (ert-parse-keys-and-body nil '(:bar foo a (b)))
|
||
|
|
'((:bar foo) nil (a (b)))))
|
||
|
|
(ert-should (equal (ert-parse-keys-and-body nil '(:bar foo :a (b)))
|
||
|
|
'((:bar foo :a (b)) nil nil)))
|
||
|
|
(ert-should (equal (ert-parse-keys-and-body nil '(bar foo :a (b)))
|
||
|
|
'(nil nil (bar foo :a (b)))))
|
||
|
|
(ert-should-error (ert-parse-keys-and-body nil '(:bar foo :a))))
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
;; Test `ert-run-tests'.
|
||
|
|
(ert-deftest ert-test-run-tests ()
|
||
|
|
(let ((passing-test (make-ert-test :name 'passing-test
|
||
|
|
:body (lambda () (ert-pass))))
|
||
|
|
(failing-test (make-ert-test :name 'failing-test
|
||
|
|
:body (lambda () (ert-fail
|
||
|
|
"failure message"))))
|
||
|
|
)
|
||
|
|
(let ((ert-debug-on-error nil))
|
||
|
|
(let* ((buffer-name (generate-new-buffer-name " *ert-test-run-tests*"))
|
||
|
|
(messages nil)
|
||
|
|
(mock-message-fn
|
||
|
|
(lambda (format-string &rest args)
|
||
|
|
(push (apply #'format format-string args) messages))))
|
||
|
|
(save-window-excursion
|
||
|
|
(unwind-protect
|
||
|
|
(let ((case-fold-search nil))
|
||
|
|
(ert-run-tests-interactively
|
||
|
|
`(member ,passing-test ,failing-test) buffer-name
|
||
|
|
mock-message-fn)
|
||
|
|
(ert-should (equal messages `(,(concat
|
||
|
|
"Ran 2 tests, 1 results were "
|
||
|
|
"as expected, 1 unexpected"))))
|
||
|
|
(with-current-buffer buffer-name
|
||
|
|
(goto-char (point-min))
|
||
|
|
(ert-should (equal
|
||
|
|
(buffer-substring (point-min)
|
||
|
|
(save-excursion
|
||
|
|
(forward-line 5)
|
||
|
|
(point)))
|
||
|
|
(concat
|
||
|
|
"Selector: (member <passing-test> <failing-test>)\n"
|
||
|
|
"Passed: 1 (0 unexpected)\n"
|
||
|
|
"Failed: 1 (1 unexpected)\n"
|
||
|
|
"Error: 0 (0 unexpected)\n"
|
||
|
|
"Total: 2/2\n")))))
|
||
|
|
(when (get-buffer buffer-name)
|
||
|
|
(kill-buffer buffer-name))))))))
|
||
|
|
|
||
|
|
(ert-deftest ert-test-special-operator-p ()
|
||
|
|
(ert-should (ert-special-operator-p 'if))
|
||
|
|
(ert-should-not (ert-special-operator-p 'car))
|
||
|
|
(ert-should-not (ert-special-operator-p 'ert-special-operator-p))
|
||
|
|
(let ((b (gensym)))
|
||
|
|
(ert-should-not (ert-special-operator-p b))
|
||
|
|
(fset b 'if)
|
||
|
|
(ert-should (ert-special-operator-p b))))
|
||
|
|
|
||
|
|
;; This test attempts to demonstrate that there is no way to force
|
||
|
|
;; immediate truncation of the *Messages* buffer from Lisp (and hence
|
||
|
|
;; justifies the existence of
|
||
|
|
;; `ert-force-message-log-buffer-truncation'): The only way that came
|
||
|
|
;; to my mind was (message ""), which doesn't have the desired effect.
|
||
|
|
(ert-deftest ert-test-builtin-message-log-flushing ()
|
||
|
|
(ert-call-with-temporary-messages-buffer
|
||
|
|
(lambda ()
|
||
|
|
(with-current-buffer "*Messages*"
|
||
|
|
(let ((message-log-max 2))
|
||
|
|
(let ((message-log-max t))
|
||
|
|
(loop for i below 4 do
|
||
|
|
(message "%s" i))
|
||
|
|
(ert-should (eql (count-lines (point-min) (point-max)) 4)))
|
||
|
|
(ert-should (eql (count-lines (point-min) (point-max)) 4))
|
||
|
|
(message "")
|
||
|
|
(ert-should (eql (count-lines (point-min) (point-max)) 4))
|
||
|
|
(message "Test message")
|
||
|
|
(ert-should (eql (count-lines (point-min) (point-max)) 2)))))))
|
||
|
|
|
||
|
|
(ert-deftest ert-test-force-message-log-buffer-truncation ()
|
||
|
|
(labels ((body ()
|
||
|
|
(loop for i below 5 do
|
||
|
|
(message "%s" i)))
|
||
|
|
(c (x)
|
||
|
|
(ert-call-with-temporary-messages-buffer
|
||
|
|
(lambda ()
|
||
|
|
(let ((message-log-max x))
|
||
|
|
(body))
|
||
|
|
(with-current-buffer "*Messages*"
|
||
|
|
(buffer-string)))))
|
||
|
|
(lisp (x)
|
||
|
|
(ert-call-with-temporary-messages-buffer
|
||
|
|
(lambda ()
|
||
|
|
(let ((message-log-max t))
|
||
|
|
(body))
|
||
|
|
(let ((message-log-max x))
|
||
|
|
(ert-force-message-log-buffer-truncation))
|
||
|
|
(with-current-buffer "*Messages*"
|
||
|
|
(buffer-string))))))
|
||
|
|
(loop for x in '(0 1 2 3 4 5 6 t) do
|
||
|
|
(ert-should (equal (c x) (lisp x))))))
|
||
|
|
|
||
|
|
(defun ert-run-self-tests ()
|
||
|
|
;; Run tests and make sure they actually ran.
|
||
|
|
(let ((window-configuration (current-window-configuration)))
|
||
|
|
(let ((ert-test-body-was-run nil))
|
||
|
|
;; The buffer name chosen here should not compete with the default
|
||
|
|
;; results buffer name for completion in `switch-to-buffer'.
|
||
|
|
(let ((stats (ert-run-tests-interactively "^ert-" " *ert self-tests*")))
|
||
|
|
(assert ert-test-body-was-run)
|
||
|
|
(when (zerop (+ (ert-stats-passed-unexpected stats)
|
||
|
|
(ert-stats-failed-unexpected stats)
|
||
|
|
(ert-stats-error-unexpected stats)))
|
||
|
|
;; Hide results window only when everything went well.
|
||
|
|
(set-window-configuration window-configuration))))))
|
||
|
|
|
||
|
|
(provide 'ert)
|
||
|
|
|
||
|
|
;;; ert.el ends here
|