[PATCH 1/3] test: Add ERT for emacs testing.
David Edmondson
dme at dme.org
Thu Nov 25 02:59:08 PST 2010
ERT is for Emacs Lisp Regression Testing, from
https://github.com/ohler/ert.git.
The ERT files added here were extracted from the ERT repository.
The 'basic' test should ignore emacs backup files (*~).
---
test/basic | 2 +-
test/ert/ert-batch.el | 152 +++
test/ert/ert-run.el | 687 +++++++++++++
test/ert/ert-ui.el | 1047 ++++++++++++++++++++
test/ert/ert-x.el | 290 ++++++
test/ert/ert.el | 2539 +++++++++++++++++++++++++++++++++++++++++++++++++
test/notmuch-test | 2 +-
7 files changed, 4717 insertions(+), 2 deletions(-)
create mode 100644 test/ert/ert-batch.el
create mode 100644 test/ert/ert-run.el
create mode 100644 test/ert/ert-ui.el
create mode 100644 test/ert/ert-x.el
create mode 100644 test/ert/ert.el
diff --git a/test/basic b/test/basic
index 309779c..b3597b9 100755
--- a/test/basic
+++ b/test/basic
@@ -52,7 +52,7 @@ test_expect_code 2 'failure to clean up causes the test to fail' '
# Ensure that all tests are being run
test_begin_subtest 'Ensure that all available tests will be run by notmuch-test'
tests_in_suite=$(grep TESTS= ../notmuch-test | sed -e "s/TESTS=\"\(.*\)\"/\1/" | tr " " "\n" | sort)
-available=$(ls -1 ../ | grep -v -E "^(aggregate-results.sh|Makefile|Makefile.local|notmuch-test|README|test-lib.sh|test-results|tmp.*|valgrind|corpus*|emacs.expected-output|smtp-dummy|smtp-dummy.c|test-verbose|test.expected-output)" | sort)
+available=$(ls -1 ../ | grep -v -E "^(aggregate-results.sh|ert|Makefile|Makefile.local|notmuch-test|README|test-lib.sh|test-results|tmp.*|valgrind|corpus*|emacs.expected-output|smtp-dummy|smtp-dummy.c|test-verbose|test.expected-output|*~)" | sort)
test_expect_equal "$tests_in_suite" "$available"
EXPECTED=../test.expected-output
diff --git a/test/ert/ert-batch.el b/test/ert/ert-batch.el
new file mode 100644
index 0000000..86424ba
--- /dev/null
+++ b/test/ert/ert-batch.el
@@ -0,0 +1,152 @@
+;;; ert-batch.el --- Functions for running ERT tests in batch mode
+
+;; Copyright (C) 2007, 2008, 2010 Free Software Foundation, Inc.
+
+;; Author: Christian M. Ohler
+
+;; 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:
+
+;; This file is part of ERT, the Emacs Lisp Regression Testing tool.
+;; See ert.el or the texinfo manual for more details.
+
+;;; Code:
+
+(eval-when-compile
+ (require 'cl))
+(require 'ert-run)
+
+(defvar ert-batch-backtrace-right-margin 70
+ "*The maximum line length for printing backtraces in `ert-run-tests-batch'.")
+
+;;;###autoload
+(defun ert-run-tests-batch (&optional selector)
+ "Run the tests specified by SELECTOR, printing results to the terminal.
+
+SELECTOR works as described in `ert-select-tests', except if
+SELECTOR is nil, in which case all tests rather than none will be
+run; this makes the command line \"emacs -batch -l my-tests.el -f
+ert-run-tests-batch-and-exit\" useful.
+
+Returns the stats object."
+ (unless selector (setq selector 't))
+ (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-completed-unexpected stats))
+ (expected-failures (ert--stats-failed-expected stats)))
+ (message "\n%sRan %s tests, %s results as expected%s (%s)%s\n"
+ (if (not abortedp)
+ ""
+ "Aborted: ")
+ (ert-stats-total stats)
+ (ert-stats-completed-expected stats)
+ (if (zerop unexpected)
+ ""
+ (format ", %s unexpected" unexpected))
+ (ert--format-time-iso8601 (ert--stats-end-time stats))
+ (if (zerop expected-failures)
+ ""
+ (format "\n%s expected failures" expected-failures)))
+ (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
+ (unless (ert-test-result-expected-p test result)
+ (etypecase result
+ (ert-test-passed
+ (message "Test %S passed unexpectedly" (ert-test-name test)))
+ (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
+ (ert--insert-infos result)
+ (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
+ (message "Test %S aborted with non-local exit"
+ (ert-test-name test)))))
+ (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-pos stats test))
+ (ert-test-name test)))))))))
+
+;;;###autoload
+(defun ert-run-tests-batch-and-exit (&optional selector)
+ "Like `ert-run-tests-batch', but exits Emacs when done.
+
+The exit status will be 0 if all test results were as expected, 1
+on unexpected results, or 2 if the framework detected an error
+outside of the tests (e.g. invalid SELECTOR or bug in the code
+that runs the tests)."
+ (unwind-protect
+ (let ((stats (ert-run-tests-batch selector)))
+ (kill-emacs (if (zerop (ert-stats-completed-unexpected stats)) 0 1)))
+ (unwind-protect
+ (progn
+ (message "Error running tests")
+ (backtrace))
+ (kill-emacs 2))))
+
+
+(provide 'ert-batch)
+
+;;; ert-batch.el ends here
diff --git a/test/ert/ert-run.el b/test/ert/ert-run.el
new file mode 100644
index 0000000..7c91406
--- /dev/null
+++ b/test/ert/ert-run.el
@@ -0,0 +1,687 @@
+;;; ert-run.el --- ERT's internal infrastructure for running tests
+
+;; Copyright (C) 2007, 2008, 2010 Free Software Foundation, Inc.
+
+;; Author: Christian M. Ohler
+
+;; 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:
+
+;; This file is part of ERT, the Emacs Lisp Regression Testing tool.
+;; See ert.el or the texinfo manual for more details.
+
+;;; Code:
+
+(eval-when-compile
+ (require 'cl))
+(require 'ert)
+
+
+(defvar ert-debug-on-error nil
+ "Non-nil means enter debugger when a test fails or terminates with an error.")
+
+;;; Running tests.
+
+;; The data structures that represent the result of running a test.
+(defstruct ert-test-result
+ (messages nil)
+ (should-forms 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))
+ (infos (assert nil)))
+(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))
+
+(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")))))))
+
+;; 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)
+ "During a test run, `debugger' is bound to a closure that calls this function.
+
+This function records failures and errors and either terminates
+the test silently or calls the interactive debugger, as
+appropriate.
+
+INFO is the ert--test-execution-info corresponding to this test
+run. DEBUGGER-ARGS are the arguments to `debugger'."
+ (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)
+ (otherwise 'failed)))
+ (backtrace (ert--record-backtrace))
+ (infos (reverse ert--infos)))
+ (setf (ert--test-execution-info-result info)
+ (ecase type
+ (quit
+ (make-ert-test-quit :condition condition
+ :backtrace backtrace
+ :infos infos))
+ (failed
+ (make-ert-test-failed :condition condition
+ :backtrace backtrace
+ :infos infos))))
+ ;; 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)
+ "Low-level function to run a test according to ERT-TEST-EXECUTION-INFO.
+
+This mainly sets up debugger-related bindings."
+ (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--infos '()))
+ (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--force-message-log-buffer-truncation ()
+ "Immediately truncate *Messages* buffer according to `message-log-max'.
+
+This can be useful after reducing the value of `message-log-max'."
+ (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)))))
+
+(defvar ert--running-tests nil
+ "List of tests that are currently in execution.
+
+This list is empty while no test is running, has one element
+while a test is running, two elements while a test run from
+inside a test is running, etc. The list is in order of nesting,
+innermost test first.
+
+The elements are of type `ert-test'.")
+
+(defun ert-run-test (ert-test)
+ "Run ERT-TEST.
+
+Returns the result and stores it in ERT-TEST's `most-recent-result' slot."
+ (setf (ert-test-most-recent-result ert-test) nil)
+ (block error
+ (lexical-let ((begin-marker
+ (with-current-buffer (get-buffer-create "*Messages*")
+ (set-marker (make-marker) (point-max)))))
+ (unwind-protect
+ (lexical-let ((info (make-ert--test-execution-info
+ :test ert-test
+ :result
+ (make-ert-test-aborted-with-non-local-exit)
+ :exit-continuation (lambda ()
+ (return-from error nil))))
+ (should-form-accu (list)))
+ (unwind-protect
+ (let ((ert--should-execution-observer
+ (lambda (form-description)
+ (push form-description should-form-accu)))
+ (message-log-max t)
+ (ert--running-tests (cons ert-test ert--running-tests)))
+ (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)
+ (setq should-form-accu (nreverse should-form-accu))
+ (setf (ert-test-result-should-forms result)
+ should-form-accu)
+ (setf (ert-test-most-recent-result ert-test) result))))
+ (set-marker begin-marker nil))))
+ (ert-test-most-recent-result ert-test))
+
+(defun ert-running-test ()
+ "Return the top-level test currently executing."
+ (car (last ert--running-tests)))
+
+
+;;; Test selectors.
+
+;; Autoload since ert.el refers to it in the docstring of
+;; `ert-deftest'.
+;;;###autoload
+(defun ert-test-result-type-p (result result-type)
+ "Return non-nil if RESULT matches type RESULT-TYPE.
+
+Valid result types:
+
+nil -- Never matches.
+t -- Always matches.
+:failed, :passed -- Matches corresponding results.
+\(and TYPES...\) -- Matches if all TYPES match.
+\(or TYPES...\) -- Matches if some TYPES match.
+\(not TYPE\) -- Matches if TYPE does not match.
+\(satisfies PREDICATE\) -- Matches if PREDICATE returns true when called with
+ RESULT."
+ ;; It would be easy to add `member' and `eql' types etc., but I
+ ;; haven't bothered yet.
+ (etypecase result-type
+ ((member nil) nil)
+ ((member t) t)
+ ((member :failed) (ert-test-failed-p result))
+ ((member :passed) (ert-test-passed-p result))
+ (cons
+ (destructuring-bind (operator &rest operands) result-type
+ (ecase operator
+ (and
+ (case (length operands)
+ (0 t)
+ (t
+ (and (ert-test-result-type-p result (first operands))
+ (ert-test-result-type-p result `(and ,@(rest operands)))))))
+ (or
+ (case (length operands)
+ (0 nil)
+ (t
+ (or (ert-test-result-type-p result (first operands))
+ (ert-test-result-type-p result `(or ,@(rest operands)))))))
+ (not
+ (assert (eql (length operands) 1))
+ (not (ert-test-result-type-p result (first operands))))
+ (satisfies
+ (assert (eql (length operands) 1))
+ (funcall (first operands) result)))))))
+
+(defun ert-test-result-expected-p (test result)
+ "Return non-nil if TEST's expected result type matches RESULT."
+ (ert-test-result-type-p result (ert-test-expected-result-type test)))
+
+;; Autoload since ert-ui.el refers to it in the docstring of
+;; `ert-run-tests-interactively'.
+;;;###autoload
+(defun ert-select-tests (selector universe)
+ "Return the tests that match SELECTOR.
+
+UNIVERSE specifies the set of tests to select from; it 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 -- 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.
+\(tag TAG) -- Selects all tests that have TAG on their tags list.
+\(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)
+ (null (ert-test-most-recent-result test))))
+ universe))
+ ((member :failed) (ert-select-tests
+ `(satisfies ,(lambda (test)
+ (ert-test-result-type-p
+ (ert-test-most-recent-result test)
+ ':failed)))
+ universe))
+ ((member :passed) (ert-select-tests
+ `(satisfies ,(lambda (test)
+ (ert-test-result-type-p
+ (ert-test-most-recent-result test)
+ ':passed)))
+ 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 (ert--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 , at operands) universe))
+ (and
+ ;; Do these definitions of AND, NOT and OR satisfy de
+ ;; Morgan's laws? 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))
+ (let ((all-tests (ert-select-tests 't universe)))
+ (ert--set-difference all-tests
+ (ert-select-tests (first operands) all-tests))))
+ (or
+ (case (length operands)
+ (0 (ert-select-tests 'nil universe))
+ (t (ert--union (ert-select-tests (first operands) universe)
+ (ert-select-tests `(or ,@(rest operands))
+ universe)))))
+ (tag
+ (assert (eql (length operands) 1))
+ (let ((tag (first operands)))
+ (ert-select-tests `(satisfies
+ ,(lambda (test)
+ (member tag (ert-test-tags test))))
+ universe)))
+ (satisfies
+ (assert (eql (length operands) 1))
+ (ert--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
+ :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)))
+ ((member tag satisfies)
+ selector)))))))
+ (insert (format "%S" (rec selector)))))
+
+
+;;; Facilities for running a whole set of tests.
+
+;; 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 start times of the tests, in order, as reported by
+ ;; `current-time'.
+ (test-start-times (assert nil) :type vector)
+ ;; The end times of the tests, in order, as reported by
+ ;; `current-time'.
+ (test-end-times (assert nil) :type vector)
+ (passed-expected 0)
+ (passed-unexpected 0)
+ (failed-expected 0)
+ (failed-unexpected 0)
+ (start-time nil)
+ (end-time nil)
+ (aborted-p nil)
+ (current-test nil)
+ ;; The time at or after which the next redisplay should occur, as a
+ ;; float.
+ (next-redisplay 0.0))
+
+(defun ert-stats-completed-expected (stats)
+ "Return the number of tests in STATS that had expected results."
+ (+ (ert--stats-passed-expected stats)
+ (ert--stats-failed-expected stats)))
+
+(defun ert-stats-completed-unexpected (stats)
+ "Return the number of tests in STATS that had unexpected results."
+ (+ (ert--stats-passed-unexpected stats)
+ (ert--stats-failed-unexpected stats)))
+
+(defun ert-stats-completed (stats)
+ "Number of tests in STATS that have run so far."
+ (+ (ert-stats-completed-expected stats)
+ (ert-stats-completed-unexpected stats)))
+
+(defun ert-stats-total (stats)
+ "Number of tests in STATS, regardless of whether they have run yet."
+ (length (ert--stats-tests stats)))
+
+;; The stats object of the current run, dynamically bound. This is
+;; used for the mode line progress indicator.
+(defvar ert--current-run-stats nil)
+
+(defun ert--stats-test-key (test)
+ "Return the key used for TEST in the test map of ert--stats objects.
+
+Returns the name of TEST if it has one, or TEST itself otherwise."
+ (or (ert-test-name test) test))
+
+(defun ert--stats-set-test-and-result (stats pos test result)
+ "Change STATS by replacing the test at position POS with TEST and RESULT.
+
+Also changes the counters in STATS to match."
+ (let* ((tests (ert--stats-tests stats))
+ (results (ert--stats-test-results stats))
+ (old-test (aref tests pos))
+ (map (ert--stats-test-map stats)))
+ (flet ((update (d)
+ (if (ert-test-result-expected-p (aref tests pos) (aref results pos))
+ (etypecase (aref results pos)
+ (ert-test-passed (incf (ert--stats-passed-expected stats) d))
+ (ert-test-failed (incf (ert--stats-failed-expected stats) d))
+ (null)
+ (ert-test-aborted-with-non-local-exit))
+ (etypecase (aref results pos)
+ (ert-test-passed (incf (ert--stats-passed-unexpected stats) d))
+ (ert-test-failed (incf (ert--stats-failed-unexpected stats) d))
+ (null)
+ (ert-test-aborted-with-non-local-exit)))))
+ ;; Adjust counters to remove the result that is currently in stats.
+ (update -1)
+ ;; Put new test and result into stats.
+ (setf (aref tests pos) test
+ (aref results pos) result)
+ (remhash (ert--stats-test-key old-test) map)
+ (setf (gethash (ert--stats-test-key test) map) pos)
+ ;; Adjust counters to match new result.
+ (update +1)
+ nil)))
+
+(defun ert--make-stats (tests selector)
+ "Create a new `ert--stats' object for running TESTS.
+
+SELECTOR is the selector that was used to select TESTS."
+ (setq tests (ert--coerce-to-vector tests))
+ (let ((map (make-hash-table :size (length tests))))
+ (loop for i from 0
+ for test across tests
+ for key = (ert--stats-test-key test) do
+ (assert (not (gethash key map)))
+ (setf (gethash key map) i))
+ (make-ert--stats :selector selector
+ :tests tests
+ :test-map map
+ :test-results (make-vector (length tests) nil)
+ :test-start-times (make-vector (length tests) nil)
+ :test-end-times (make-vector (length tests) nil))))
+
+(defun ert-run-or-rerun-test (stats test listener)
+ ;; checkdoc-order: nil
+ "Run the single test TEST and record the result using STATS and LISTENER."
+ (let ((ert--current-run-stats stats)
+ (pos (ert--stats-test-pos stats test)))
+ (ert--stats-set-test-and-result stats pos test 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)
+ (setf (aref (ert--stats-test-start-times stats) pos) (current-time))
+ (unwind-protect
+ (ert-run-test test)
+ (setf (aref (ert--stats-test-end-times stats) pos) (current-time))
+ (let ((result (ert-test-most-recent-result test)))
+ (ert--stats-set-test-and-result stats pos test result)
+ (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 (ert-select-tests selector t))
+ (stats (ert--make-stats tests selector)))
+ (setf (ert--stats-start-time stats) (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 in 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-pos (stats test)
+ ;; checkdoc-order: nil
+ "Return the position (index) of TEST in the run represented by STATS."
+ (gethash (ert--stats-test-key test) (ert--stats-test-map stats)))
+
+
+;;; Formatting functions shared across UIs.
+
+(defun ert--format-time-iso8601 (time)
+ "Format TIME in the variant of ISO 8601 used for timestamps in ERT."
+ (format-time-string "%Y-%m-%d %T%z" time))
+
+(defun ert-char-for-test-result (result expectedp)
+ "Return a character that represents the test result RESULT.
+
+EXPECTEDP specifies whether the result was expected."
+ (let ((s (etypecase result
+ (ert-test-passed ".P")
+ (ert-test-failed "fF")
+ (null "--")
+ (ert-test-aborted-with-non-local-exit "aA"))))
+ (elt s (if expectedp 0 1))))
+
+(defun ert-string-for-test-result (result expectedp)
+ "Return a string that represents the test result RESULT.
+
+EXPECTEDP specifies whether the result was expected."
+ (let ((s (etypecase result
+ (ert-test-passed '("passed" "PASSED"))
+ (ert-test-failed '("failed" "FAILED"))
+ (null '("unknown" "UNKNOWN"))
+ (ert-test-aborted-with-non-local-exit '("aborted" "ABORTED")))))
+ (elt s (if expectedp 0 1))))
+
+(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--insert-infos (result)
+ "Insert `ert-info' infos from RESULT into current buffer.
+
+RESULT must be an `ert-test-result-with-condition'."
+ (check-type result ert-test-result-with-condition)
+ (dolist (info (ert-test-result-with-condition-infos result))
+ (destructuring-bind (prefix . message) info
+ (let ((begin (point))
+ (indentation (make-string (+ (length prefix) 4) ?\s))
+ (end nil))
+ (unwind-protect
+ (progn
+ (insert message "\n")
+ (setq end (copy-marker (point)))
+ (goto-char begin)
+ (insert " " prefix)
+ (forward-line 1)
+ (while (< (point) end)
+ (insert indentation)
+ (forward-line 1)))
+ (when end (set-marker end nil)))))))
+
+
+(provide 'ert-run)
+
+;;; ert-run.el ends here
diff --git a/test/ert/ert-ui.el b/test/ert/ert-ui.el
new file mode 100644
index 0000000..bf58492
--- /dev/null
+++ b/test/ert/ert-ui.el
@@ -0,0 +1,1047 @@
+;;; ert-ui.el --- ERT's interactive UI
+
+;; Copyright (C) 2007, 2008, 2010 Free Software Foundation, Inc.
+
+;; Author: Christian M. Ohler
+
+;; 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:
+
+;; This file is part of ERT, the Emacs Lisp Regression Testing tool.
+;; See ert.el or the texinfo manual for more details.
+
+;;; Code:
+
+(eval-when-compile
+ (require 'cl))
+(require 'ert)
+(require 'ert-run)
+(require 'easymenu)
+(require 'ewoc)
+(require 'help)
+(require 'button)
+
+
+;;; UI customization options.
+
+(defgroup ert ()
+ "ERT, the Emacs Lisp regression testing tool."
+ :prefix "ert-"
+ :group 'lisp)
+
+(defface ert-test-result-expected '((((class color) (background light))
+ :background "green1")
+ (((class color) (background dark))
+ :background "green3"))
+ "Face used for expected results in the ERT results buffer."
+ :group 'ert)
+
+(defface ert-test-result-unexpected '((((class color) (background light))
+ :background "red1")
+ (((class color) (background dark))
+ :background "red3"))
+ "Face used for unexpected results in the ERT results buffer."
+ :group 'ert)
+
+
+;;; Some basic interactive functions.
+
+(defun ert-read-test-name (prompt &optional default history
+ add-default-to-prompt)
+ "Read the name of a test and return it as a symbol.
+
+Prompt with PROMPT. If DEFAULT is a valid test name, use it as a
+default. HISTORY is the history to use; see `completing-read'.
+If ADD-DEFAULT-TO-PROMPT is non-nil, PROMPT will be modified to
+include the default, if any.
+
+Signals an error if no test name was read."
+ (etypecase default
+ (string (let ((symbol (intern-soft default)))
+ (unless (and symbol (ert-test-boundp symbol))
+ (setq default nil))))
+ (symbol (setq default
+ (if (ert-test-boundp default)
+ (symbol-name default)
+ nil)))
+ (ert-test (setq default (ert-test-name default))))
+ (when add-default-to-prompt
+ (setq prompt (if (null default)
+ (format "%s: " prompt)
+ (format "%s (default %s): " prompt default))))
+ (let ((input (completing-read prompt obarray #'ert-test-boundp
+ t nil history default nil)))
+ ;; completing-read returns an empty string if default was nil and
+ ;; the user just hit enter.
+ (let ((sym (intern-soft input)))
+ (if (ert-test-boundp sym)
+ sym
+ (error "Input does not name a test")))))
+
+(defun ert-read-test-name-at-point (prompt)
+ "Read the name of a test and return it as a symbol.
+As a default, use the symbol at point, or the test at point if in
+the ERT results buffer. Prompt with PROMPT, augmented with the
+default (if any)."
+ (ert-read-test-name prompt (ert-test-at-point) nil t))
+
+(defun ert-find-test-other-window (test-name)
+ "Find, in another window, the definition of TEST-NAME."
+ (interactive (list (ert-read-test-name-at-point "Find test definition: ")))
+ (find-function-do-it test-name 'ert-deftest 'switch-to-buffer-other-window))
+
+(defun ert-delete-test (test-name)
+ "Make the test TEST-NAME unbound.
+
+Nothing more than an interactive interface to `ert-make-test-unbound'."
+ (interactive (list (ert-read-test-name-at-point "Delete test")))
+ (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")))
+ ;; We can't use `ert-select-tests' here since that gives us only
+ ;; test objects, and going from them back to the test name symbols
+ ;; can fail if the `ert-test' defstruct has been redefined.
+ (mapc #'ert-make-test-unbound (apropos-internal "" #'ert-test-boundp))
+ t)
+
+
+;;; Display of test progress and results.
+
+;; An entry in the results buffer ewoc. There is one entry per test.
+(defstruct ert--ewoc-entry
+ (test (assert 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)
+
+(defun ert-insert-test-name-button (test-name)
+ "Insert a button that links to TEST-NAME."
+ (insert-text-button (format "%S" test-name)
+ :type 'ert--test-name-button
+ 'ert-test-name test-name))
+
+(defun ert--results-format-expected-unexpected (expected unexpected)
+ "Return a string indicating EXPECTED expected results, UNEXPECTED unexpected."
+ (if (zerop unexpected)
+ (format "%s" expected)
+ (format "%s (%s unexpected)" (+ expected unexpected) unexpected)))
+
+(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-completed stats))
+ (results-buffer (current-buffer))
+ ;; Need to save buffer-local value.
+ (font-lock font-lock-mode))
+ (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\n"
+ "Failed: %s\n"
+ "Total: %s/%s\n\n")
+ (ert--results-format-expected-unexpected
+ (ert--stats-passed-expected stats)
+ (ert--stats-passed-unexpected stats))
+ (ert--results-format-expected-unexpected
+ (ert--stats-failed-expected stats)
+ (ert--stats-failed-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 progress-bar-string
+ :type 'ert--results-progress-bar-button
+ 'face (or (and font-lock
+ (ert-face-for-stats stats))
+ 'button))))
+ ;; The header gets copied verbatim to the results buffer,
+ ;; and all positions remain the same, so
+ ;; `progress-bar-button-begin' will be the right position
+ ;; even in the results buffer.
+ (with-current-buffer results-buffer
+ (set (make-local-variable 'ert--results-progress-bar-button-begin)
+ progress-bar-button-begin))))
+ (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. (It's possible
+ ;; that this bug has been fixed since this has been tested; we
+ ;; should test it again.)
+ "\n")))
+
+
+(defvar ert-test-run-redisplay-interval-secs .1
+ "How many seconds ERT should wait between redisplays while running tests.
+
+While running tests, ERT shows the current progress, and this variable
+determines how frequently the progress display is updated.")
+
+(defun ert--results-update-stats-display (ewoc stats)
+ "Update EWOC and the mode line to show data from STATS."
+ ;; TODO(ohler): investigate using `make-progress-reporter'.
+ (ert--results-update-ewoc-hf ewoc stats)
+ (force-mode-line-update)
+ (redisplay t)
+ (setf (ert--stats-next-redisplay stats)
+ (+ (float-time) ert-test-run-redisplay-interval-secs)))
+
+(defun ert--results-update-stats-display-maybe (ewoc stats)
+ "Call `ert--results-update-stats-display' if not called recently.
+
+EWOC and STATS are arguments for `ert--results-update-stats-display'."
+ (when (>= (float-time) (ert--stats-next-redisplay stats))
+ (ert--results-update-stats-display ewoc stats)))
+
+(defun ert--tests-running-mode-line-indicator ()
+ "Return a string for the mode line that shows the test run progress."
+ (let* ((stats ert--current-run-stats)
+ (tests-total (ert-stats-total stats))
+ (tests-completed (ert-stats-completed 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--make-xrefs-region (begin end)
+ "Attach cross-references to function names between BEGIN and END.
+
+BEGIN and END specify a region in the current buffer."
+ (save-excursion
+ (save-restriction
+ (narrow-to-region begin (point))
+ ;; Inhibit optimization in `debugger-make-xrefs' that would
+ ;; sometimes insert unrelated backtrace info into our buffer.
+ (let ((debugger-previous-backtrace nil))
+ (debugger-make-xrefs)))))
+
+(defun ert--string-first-line (s)
+ "Return the first line of S, or S if it contains no newlines.
+
+The return value does not include the line terminator."
+ (substring s 0 (ert--string-position ?\n s)))
+
+(defun ert-face-for-test-result (expectedp)
+ "Return a face that shows whether a test result was expected or unexpected.
+
+If EXPECTEDP is nil, returns the face for unexpected results; if
+non-nil, returns the face for expected results.."
+ (if expectedp 'ert-test-result-expected 'ert-test-result-unexpected))
+
+(defun ert-face-for-stats (stats)
+ "Return a face that represents STATS."
+ (cond ((ert--stats-aborted-p stats) 'nil)
+ ((plusp (ert-stats-completed-unexpected stats))
+ (ert-face-for-test-result nil))
+ ((eql (ert-stats-completed-expected stats) (ert-stats-total stats))
+ (ert-face-for-test-result t))
+ (t 'nil)))
+
+(defun ert--print-test-for-ewoc (entry)
+ "The ewoc print function for ewoc test entries. ENTRY is the entry to print."
+ (let* ((test (ert--ewoc-entry-test entry))
+ (stats ert--results-stats)
+ (result (let ((pos (ert--stats-test-pos stats test)))
+ (assert pos)
+ (aref (ert--stats-test-results stats) pos)))
+ (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
+ (let ((expectedp (ert-test-result-expected-p test result)))
+ (insert-text-button (format "%c" (ert-char-for-test-result
+ result expectedp))
+ :type 'ert--results-expand-collapse-button
+ 'face (or (and font-lock-mode
+ (ert-face-for-test-result
+ expectedp))
+ 'button)))
+ (insert " ")
+ (ert-insert-test-name-button (ert-test-name test))
+ (insert "\n")
+ (when (and expandedp (not (eql result 'nil)))
+ (when (ert-test-documentation test)
+ (insert " "
+ (propertize
+ (ert--string-first-line (ert-test-documentation test))
+ 'font-lock-face 'font-lock-doc-face)
+ "\n"))
+ (etypecase result
+ (ert-test-passed
+ (if (ert-test-result-expected-p test result)
+ (insert " passed\n")
+ (insert " passed unexpectedly\n"))
+ (insert ""))
+ (ert-test-result-with-condition
+ (ert--insert-infos result)
+ (let ((print-escape-newlines t)
+ (print-level (if extended-printer-limits-p 12 6))
+ (print-length (if extended-printer-limits-p 100 10)))
+ (insert " ")
+ (let ((begin (point)))
+ (ert--pp-with-indentation-and-newline
+ (ert-test-result-with-condition-condition result))
+ (ert--make-xrefs-region begin (point)))))
+ (ert-test-aborted-with-non-local-exit
+ (insert " aborted\n")))
+ (insert "\n")))))
+ nil)
+
+(defun ert--results-font-lock-function (enabledp)
+ "Redraw the ERT results buffer after font-lock-mode was switched on or off.
+
+ENABLEDP is true if font-lock-mode is switched on, false
+otherwise."
+ (ert--results-update-ewoc-hf ert--results-ewoc ert--results-stats)
+ (ewoc-refresh ert--results-ewoc)
+ (font-lock-default-function enabledp))
+
+(defun ert--setup-results-buffer (stats listener buffer-name)
+ "Set up a test results buffer.
+
+STATS is the stats object; LISTENER is the results listener;
+BUFFER-NAME, if non-nil, is the buffer name to use."
+ (unless buffer-name (setq buffer-name "*ert*"))
+ (let ((buffer (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)
+ ;; Erase buffer again in case switching out of the previous
+ ;; mode inserted anything. (This happens e.g. when switching
+ ;; from ert-results-mode to ert-results-mode when
+ ;; font-lock-mode turns itself off in change-major-mode-hook.)
+ (erase-buffer)
+ (set (make-local-variable 'font-lock-function)
+ 'ert--results-font-lock-function)
+ (let ((ewoc (ewoc-create 'ert--print-test-for-ewoc nil nil t)))
+ (set (make-local-variable 'ert--results-ewoc) ewoc)
+ (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)
+ (loop for test across (ert--stats-tests stats) do
+ (ewoc-enter-last ewoc
+ (make-ert--ewoc-entry :test test :hidden-p t)))
+ (ert--results-update-ewoc-hf ert--results-ewoc ert--results-stats)
+ (goto-char (1- (point-max)))
+ buffer)))))
+
+
+(defvar ert--selector-history nil
+ "List of recent test selectors read from terminal.")
+
+;; 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.
+
+SELECTOR works as described in `ert-select-tests'.
+OUTPUT-BUFFER-NAME and MESSAGE-FN should normally be nil; they
+are used for automated self-tests and specify which buffer to use
+and how to display message."
+ (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
+ default 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-completed-expected stats)
+ (let ((unexpected
+ (ert-stats-completed-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-pos stats test))
+ (node (ewoc-nth ewoc pos)))
+ (assert node)
+ (setf (ert--ewoc-entry-test (ewoc-data node)) test)
+ (aset ert--results-progress-bar-string pos
+ (ert-char-for-test-result nil t))
+ (ert--results-update-stats-display-maybe 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-pos stats test))
+ (node (ewoc-nth ewoc pos)))
+ (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-maybe ewoc stats)
+ (ewoc-invalidate ewoc node))))))))
+ (ert-run-tests
+ selector
+ listener)))
+;;;###autoload
+(defalias 'ert 'ert-run-tests-interactively)
+
+
+;;; Simple view mode for auxiliary information like stack traces or
+;;; messages. Mainly binds "q" for quit.
+
+(define-derived-mode ert-simple-view-mode fundamental-mode "ERT-View"
+ "Major mode for viewing auxiliary information in ERT.")
+
+(loop for (key binding) in
+ '(("q" quit-window)
+ )
+ do
+ (define-key ert-simple-view-mode-map key binding))
+
+
+;;; 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
+ '(;; Stuff that's not in the menu.
+ ("\t" forward-button)
+ ([backtab] backward-button)
+ ("j" ert-results-jump-between-summary-and-result)
+ ("q" quit-window)
+ ("L" ert-results-toggle-printer-limits-for-test-at-point)
+ ("n" ert-results-next-test)
+ ("p" ert-results-previous-test)
+ ;; Stuff that is in the menu.
+ ("R" ert-results-rerun-all-tests)
+ ("r" ert-results-rerun-test-at-point)
+ ("d" ert-results-rerun-test-at-point-debugging-errors)
+ ("." ert-results-find-test-at-point-other-window)
+ ("b" ert-results-pop-to-backtrace-for-test-at-point)
+ ("m" ert-results-pop-to-messages-for-test-at-point)
+ ("l" ert-results-pop-to-should-forms-for-test-at-point)
+ ("h" ert-results-describe-test-at-point)
+ ("D" ert-delete-test)
+ ("T" ert-results-pop-to-timings)
+ )
+ do
+ (define-key ert-results-mode-map key binding))
+
+(easy-menu-define ert-results-mode-menu ert-results-mode-map
+ "Menu for `ert-results-mode'."
+ '("ERT Results"
+ ["Re-run all tests" ert-results-rerun-all-tests]
+ "--"
+ ["Re-run test" ert-results-rerun-test-at-point]
+ ["Debug test" ert-results-rerun-test-at-point-debugging-errors]
+ ["Show test definition" ert-results-find-test-at-point-other-window]
+ "--"
+ ["Show backtrace" ert-results-pop-to-backtrace-for-test-at-point]
+ ["Show messages" ert-results-pop-to-messages-for-test-at-point]
+ ["Show `should' forms" ert-results-pop-to-should-forms-for-test-at-point]
+ ["Describe test" ert-results-describe-test-at-point]
+ "--"
+ ["Delete test" ert-delete-test]
+ "--"
+ ["Show execution time of each test" ert-results-pop-to-timings]
+ ))
+
+(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.
+ ;;
+ ;; Update: I'm seeing nil being returned in some cases now,
+ ;; perhaps this has been changed?
+ (if (and node
+ (>= (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-next-test ()
+ "Move point to the next test.
+
+To be used in the ERT results buffer."
+ (interactive)
+ (ert--results-move (ewoc-locate ert--results-ewoc) 'ewoc-next
+ "No tests below"))
+
+(defun ert-results-previous-test ()
+ "Move point to the previous test.
+
+To be used in the ERT results buffer."
+ (interactive)
+ (ert--results-move (ewoc-locate ert--results-ewoc) 'ewoc-prev
+ "No tests above"))
+
+(defun ert--results-move (node ewoc-fn error-message)
+ "Move point from NODE to the previous or next node.
+
+EWOC-FN specifies the direction and should be either `ewoc-prev'
+or `ewoc-next'. If there are no more nodes in that direction, an
+error is signalled with the message ERROR-MESSAGE."
+ (loop
+ (setq node (funcall ewoc-fn ert--results-ewoc node))
+ (when (null node)
+ (error "%s" error-message))
+ (unless (ert--ewoc-entry-hidden-p (ewoc-data node))
+ (goto-char (ewoc-location node))
+ (return))))
+
+(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 ((name (ert-test-at-point)))
+ (unless name
+ (error "No test at point"))
+ (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)
+ ;; checkdoc-order: nil
+ "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-test-at-point ()
+ "Return the name of the test at point as a symbol, or nil if none."
+ (or (and (eql major-mode 'ert-results-mode)
+ (let ((test (ert--results-test-at-point-no-redefinition)))
+ (and test (ert-test-name test))))
+ (let* ((thing (thing-at-point 'symbol))
+ (sym (intern-soft thing)))
+ (and (ert-test-boundp sym)
+ sym))))
+
+(defun ert--results-test-at-point-no-redefinition ()
+ "Return the test at point, or nil.
+
+To be used in the ERT results buffer."
+ (assert (eql major-mode 'ert-results-mode))
+ (if (ert--results-test-node-or-null-at-point)
+ (let* ((node (ert--results-test-node-at-point))
+ (test (ert--ewoc-entry-test (ewoc-data node))))
+ test)
+ (let ((progress-bar-begin ert--results-progress-bar-button-begin))
+ (when (and (<= progress-bar-begin (point))
+ (< (point) (button-end (button-at progress-bar-begin))))
+ (let* ((test-index (- (point) progress-bar-begin))
+ (test (aref (ert--stats-tests ert--results-stats)
+ test-index)))
+ test)))))
+
+(defun ert--results-test-at-point-allow-redefinition ()
+ "Look up the test at point, and check whether it has been redefined.
+
+To be used in the ERT results buffer.
+
+Returns a list of two elements: the test (or nil) and a symbol
+specifying whether the test has been redefined.
+
+If a new test has been defined with the same name as the test at
+point, replaces the test at point with the new test, and returns
+the new test and the symbol `redefined'.
+
+If the test has been deleted, returns the old test and the symbol
+`deleted'.
+
+If the test is still current, returns the test and the symbol nil.
+
+If there is no test at point, returns a list with two nils."
+ (let ((test (ert--results-test-at-point-no-redefinition)))
+ (cond ((null test)
+ `(nil nil))
+ ((null (ert-test-name test))
+ `(,test nil))
+ (t
+ (let* ((name (ert-test-name test))
+ (new-test (and (ert-test-boundp name)
+ (ert-get-test name))))
+ (cond ((eql test new-test)
+ `(,test nil))
+ ((null new-test)
+ `(,test deleted))
+ (t
+ (ert--results-update-after-test-redefinition
+ (ert--stats-test-pos ert--results-stats test)
+ new-test)
+ `(,new-test redefined))))))))
+
+(defun ert--results-update-after-test-redefinition (pos new-test)
+ "Update results buffer after the test at pos POS has been redefined.
+
+Also updates the stats object. NEW-TEST is the new test
+definition."
+ (let* ((stats ert--results-stats)
+ (ewoc ert--results-ewoc)
+ (node (ewoc-nth ewoc pos))
+ (entry (ewoc-data node)))
+ (ert--stats-set-test-and-result stats pos new-test nil)
+ (setf (ert--ewoc-entry-test entry) new-test
+ (aref ert--results-progress-bar-string pos) (ert-char-for-test-result
+ nil t))
+ (ewoc-invalidate ewoc node))
+ nil)
+
+(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)
+ "Jump to details for the test represented by the character clicked in BUTTON."
+ (goto-char (ert--button-action-position))
+ (ert-results-jump-between-summary-and-result))
+
+(defun ert-results-rerun-all-tests ()
+ "Re-run all tests, using the same selector.
+
+To be used in the ERT results buffer."
+ (interactive)
+ (assert (eql major-mode 'ert-results-mode))
+ (let ((selector (ert--stats-selector ert--results-stats)))
+ (ert-run-tests-interactively selector (buffer-name))))
+
+(defun ert-results-rerun-test-at-point ()
+ "Re-run the test at point.
+
+To be used in the ERT results buffer."
+ (interactive)
+ (destructuring-bind (test redefinition-state)
+ (ert--results-test-at-point-allow-redefinition)
+ (when (null test)
+ (error "No test at point"))
+ (let* ((stats ert--results-stats)
+ (progress-message (format "Running %stest %S"
+ (ecase redefinition-state
+ ((nil) "")
+ (redefined "new definition of ")
+ (deleted "deleted "))
+ (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 ert--results-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-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* ((test (ert--results-test-at-point-no-redefinition))
+ (stats ert--results-stats)
+ (pos (ert--stats-test-pos stats test))
+ (result (aref (ert--stats-test-results stats) pos)))
+ (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 (get-buffer-create "*ERT Backtrace*")))
+ (pop-to-buffer buffer)
+ (setq buffer-read-only t)
+ (let ((inhibit-read-only t))
+ (buffer-disable-undo)
+ (erase-buffer)
+ (ert-simple-view-mode)
+ ;; 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))
+ (insert "Backtrace for test `")
+ (ert-insert-test-name-button (ert-test-name test))
+ (insert "':\n")))))))
+
+(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* ((test (ert--results-test-at-point-no-redefinition))
+ (stats ert--results-stats)
+ (pos (ert--stats-test-pos stats test))
+ (result (aref (ert--stats-test-results stats) pos)))
+ (let ((buffer (get-buffer-create "*ERT Messages*")))
+ (pop-to-buffer buffer)
+ (setq buffer-read-only t)
+ (let ((inhibit-read-only t))
+ (buffer-disable-undo)
+ (erase-buffer)
+ (ert-simple-view-mode)
+ (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-pop-to-should-forms-for-test-at-point ()
+ "Display the list of `should' forms executed during the test at point.
+
+To be used in the ERT results buffer."
+ (interactive)
+ (let* ((test (ert--results-test-at-point-no-redefinition))
+ (stats ert--results-stats)
+ (pos (ert--stats-test-pos stats test))
+ (result (aref (ert--stats-test-results stats) pos)))
+ (let ((buffer (get-buffer-create "*ERT list of should forms*")))
+ (pop-to-buffer buffer)
+ (setq buffer-read-only t)
+ (let ((inhibit-read-only t))
+ (buffer-disable-undo)
+ (erase-buffer)
+ (ert-simple-view-mode)
+ (if (null (ert-test-result-should-forms result))
+ (insert "\n(No should forms during this test.)\n")
+ (loop for form-description in (ert-test-result-should-forms result)
+ for i from 1 do
+ (insert "\n")
+ (insert (format "%s: " i))
+ (let ((begin (point)))
+ (ert--pp-with-indentation-and-newline form-description)
+ (ert--make-xrefs-region begin (point)))))
+ (goto-char (point-min))
+ (insert "`should' forms executed during test `")
+ (ert-insert-test-name-button (ert-test-name test))
+ (insert "':\n")
+ (insert "\n")
+ (insert (concat "(Values are shallow copies and may have "
+ "looked different during the test if they\n"
+ "have been modified destructively.)\n"))
+ (forward-line 1)))))
+
+(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-results-pop-to-timings ()
+ "Display test timings for the last run.
+
+To be used in the ERT results buffer."
+ (interactive)
+ (let* ((stats ert--results-stats)
+ (start-times (ert--stats-test-start-times stats))
+ (end-times (ert--stats-test-end-times stats))
+ (buffer (get-buffer-create "*ERT timings*"))
+ (data (loop for test across (ert--stats-tests stats)
+ for start-time across (ert--stats-test-start-times stats)
+ for end-time across (ert--stats-test-end-times stats)
+ collect (list test
+ (float-time (subtract-time end-time
+ start-time))))))
+ (setq data (sort data (lambda (a b)
+ (> (second a) (second b)))))
+ (pop-to-buffer buffer)
+ (setq buffer-read-only t)
+ (let ((inhibit-read-only t))
+ (buffer-disable-undo)
+ (erase-buffer)
+ (ert-simple-view-mode)
+ (if (null data)
+ (insert "(No data)\n")
+ (insert (format "%-3s %8s %8s\n" "" "time" "cumul"))
+ (loop for (test time) in data
+ for cumul-time = time then (+ cumul-time time)
+ for i from 1 do
+ (let ((begin (point)))
+ (insert (format "%3s: %8.3f %8.3f " i time cumul-time))
+ (ert-insert-test-name-button (ert-test-name test))
+ (insert "\n"))))
+ (goto-char (point-min))
+ (insert "Tests by run time (seconds):\n\n")
+ (forward-line 1))))
+
+;;;###autoload
+(defun ert-describe-test (test-or-test-name)
+ "Display the documentation for TEST-OR-TEST-NAME (a symbol or ert-test)."
+ (interactive (list (ert-read-test-name-at-point "Describe test")))
+ (when (< emacs-major-version 24)
+ (error "Requires Emacs 24"))
+ (let (test-name
+ test-definition)
+ (etypecase test-or-test-name
+ (symbol (setq test-name test-or-test-name
+ test-definition (ert-get-test test-or-test-name)))
+ (ert-test (setq test-name (ert-test-name test-or-test-name)
+ test-definition test-or-test-name)))
+ (help-setup-xref (list #'ert-describe-test test-or-test-name)
+ (called-interactively-p 'interactive))
+ (save-excursion
+ (with-help-window (help-buffer)
+ (with-current-buffer (help-buffer)
+ (insert (if test-name (format "%S" test-name) "<anonymous test>"))
+ (insert " is a test")
+ (let ((file-name (and test-name
+ (symbol-file test-name 'ert-deftest))))
+ (when file-name
+ (insert " defined in `" (file-name-nondirectory file-name) "'")
+ (save-excursion
+ (re-search-backward "`\\([^`']+\\)'" nil t)
+ (help-xref-button 1 'help-function-def test-name file-name)))
+ (insert ".")
+ (fill-region-as-paragraph (point-min) (point))
+ (insert "\n\n")
+ (unless (and (ert-test-boundp test-name)
+ (eql (ert-get-test test-name) test-definition))
+ (let ((begin (point)))
+ (insert "Note: This test has been redefined or deleted, "
+ "this documentation refers to an old definition.")
+ (fill-region-as-paragraph begin (point)))
+ (insert "\n\n"))
+ (insert (or (ert-test-documentation test-definition)
+ "It is not documented.")
+ "\n")))))))
+
+(defun ert-results-describe-test-at-point ()
+ "Display the documentation of the test at point.
+
+To be used in the ERT results buffer."
+ (interactive)
+ (ert-describe-test (ert--results-test-at-point-no-redefinition)))
+
+(provide 'ert-ui)
+
+;;; ert-ui.el ends here
diff --git a/test/ert/ert-x.el b/test/ert/ert-x.el
new file mode 100644
index 0000000..692aad6
--- /dev/null
+++ b/test/ert/ert-x.el
@@ -0,0 +1,290 @@
+;;; ert-x.el --- Staging area for experimental extensions to ERT
+
+;; Copyright (C) 2008, 2010 Free Software Foundation, Inc.
+
+;; Author: Lennart Borgman (lennart O borgman A gmail O com)
+;; Author: Christian M. Ohler
+
+;; 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:
+
+;; This file includes some extra helper functions to use while writing
+;; automated tests with ERT. These have been proposed as extensions
+;; to ERT but are not mature yet and likely to change.
+
+;;; Code:
+
+(eval-when-compile
+ (require 'cl))
+(require 'ert)
+
+
+;;; Test buffers.
+
+(defun ert--text-button (string &rest properties)
+ "Return a string containing STRING as a text button with PROPERTIES.
+
+See `make-text-button'."
+ (with-temp-buffer
+ (insert string)
+ (apply #'make-text-button (point-min) (point-max) properties)
+ (buffer-string)))
+
+(defun ert--format-test-buffer-name (base-name)
+ "Compute a test buffer name based on BASE-NAME.
+
+Helper function for `ert--test-buffers'."
+ (format "*Test buffer (%s)%s*"
+ (or (and (ert-running-test)
+ (ert-test-name (ert-running-test)))
+ "<anonymous test>")
+ (if base-name
+ (format ": %s" base-name)
+ "")))
+
+(defvar ert--test-buffers (make-hash-table :weakness t)
+ "Table of all test buffers. Keys are the buffer objects, values are t.
+
+The main use of this table is for `ert-kill-all-test-buffers'.
+Not all buffers in this table are necessarily live, but all live
+test buffers are in this table.")
+
+(define-button-type 'ert--test-buffer-button
+ 'action #'ert--test-buffer-button-action
+ 'help-echo "mouse-2, RET: Pop to test buffer")
+
+(defun ert--test-buffer-button-action (button)
+ "Pop to the test buffer that BUTTON is associated with."
+ (pop-to-buffer (button-get button 'ert--test-buffer)))
+
+(defun ert--call-with-test-buffer (ert--base-name ert--thunk)
+ "Helper function for `ert-with-test-buffer'.
+
+Create a test buffer with a name based on ERT--BASE-NAME and run
+ERT--THUNK with that buffer as current."
+ (let* ((ert--buffer (generate-new-buffer
+ (ert--format-test-buffer-name ert--base-name)))
+ (ert--button (ert--text-button (buffer-name ert--buffer)
+ :type 'ert--test-buffer-button
+ 'ert--test-buffer ert--buffer)))
+ (puthash ert--buffer 't ert--test-buffers)
+ ;; We don't use `unwind-protect' here since we want to kill the
+ ;; buffer only on success.
+ (prog1 (with-current-buffer ert--buffer
+ (ert-info (ert--button :prefix "Buffer: ")
+ (funcall ert--thunk)))
+ (kill-buffer ert--buffer)
+ (remhash ert--buffer ert--test-buffers))))
+
+(defmacro* ert-with-test-buffer ((&key ((:name name-form)))
+ &body body)
+ "Create a test buffer and run BODY in that buffer.
+
+To be used in ERT tests. If BODY finishes successfully, the test
+buffer is killed; if there is an error, the test buffer is kept
+around on error for further inspection. Its name is derived from
+the name of the test and the result of NAME-FORM."
+ (declare (debug ((form) body))
+ (indent 1))
+ `(ert--call-with-test-buffer ,name-form (lambda () , at body)))
+
+;; We use these `put' forms in addition to the (declare (indent)) in
+;; the defmacro form since the `declare' alone does not lead to
+;; correct indentation before the .el/.elc file is loaded.
+;; Autoloading these `put' forms solves this.
+;;;###autoload
+(progn
+ ;; TODO(ohler): Figure out what these mean and make sure they are correct.
+ (put 'ert-with-test-buffer 'lisp-indent-function 1))
+
+;;;###autoload
+(defun ert-kill-all-test-buffers ()
+ "Kill all test buffers that are still live."
+ (interactive)
+ (let ((count 0))
+ (maphash (lambda (buffer dummy)
+ (when (or (not (buffer-live-p buffer))
+ (kill-buffer buffer))
+ (incf count)))
+ ert--test-buffers)
+ (message "%s out of %s test buffers killed"
+ count (hash-table-count ert--test-buffers)))
+ ;; It could be that some test buffers were actually kept alive
+ ;; (e.g., due to `kill-buffer-query-functions'). I'm not sure what
+ ;; to do about this. For now, let's just forget them.
+ (clrhash ert--test-buffers)
+ nil)
+
+
+;;; Simulate commands.
+
+(defun ert-simulate-command (command)
+ ;; FIXME: add unread-events
+ "Simulate calling COMMAND the way the Emacs command loop would call it.
+
+This effectively executes
+
+ \(apply (car COMMAND) (cdr COMMAND)\)
+
+and returns the same value, but additionally runs hooks like
+`pre-command-hook' and `post-command-hook', and sets variables
+like `this-command' and `last-command'.
+
+COMMAND should be a list where the car is the command symbol and
+the rest are arguments to the command.
+
+NOTE: Since the command is not called by `call-interactively'
+test for `called-interactively' in the command will fail."
+ (assert (listp command) t)
+ (assert (commandp (car command)) t)
+ (assert (not unread-command-events) t)
+ (let (return-value)
+ ;; For the order of things here see command_loop_1 in keyboard.c.
+ ;;
+ ;; The command loop will reset the command-related variables so
+ ;; there is no reason to let-bind them. They are set here,
+ ;; however, to be able to test several commands in a row and how
+ ;; they affect each other.
+ (setq deactivate-mark nil
+ this-original-command (car command)
+ ;; remap through active keymaps
+ this-command (or (command-remapping this-original-command)
+ this-original-command))
+ (run-hooks 'pre-command-hook)
+ (setq return-value (apply (car command) (cdr command)))
+ (run-hooks 'post-command-hook)
+ (when deferred-action-list
+ (run-hooks 'deferred-action-function))
+ (setq real-last-command (car command)
+ last-command this-command)
+ (when (boundp 'last-repeatable-command)
+ (setq last-repeatable-command real-last-command))
+ (when (and deactivate-mark transient-mark-mode) (deactivate-mark))
+ (assert (not unread-command-events) t)
+ return-value))
+
+(defun ert-run-idle-timers ()
+ "Run all idle timers (from `timer-idle-list')."
+ (dolist (timer (copy-sequence timer-idle-list))
+ (timer-event-handler timer)))
+
+
+;;; Miscellaneous utilities.
+
+(defun ert-filter-string (s &rest regexps)
+ "Return a copy of S with all matches of REGEXPS removed.
+
+Elements of REGEXPS may also be two-element lists \(REGEXP
+SUBEXP\), where SUBEXP is the number of a subexpression in
+REGEXP. In that case, only that subexpression will be removed
+rather than the entire match."
+ ;; Use a temporary buffer since replace-match copies strings, which
+ ;; would lead to N^2 runtime.
+ (with-temp-buffer
+ (insert s)
+ (dolist (x regexps)
+ (destructuring-bind (regexp subexp) (if (listp x) x `(,x nil))
+ (goto-char (point-min))
+ (while (re-search-forward regexp nil t)
+ (replace-match "" t t nil subexp))))
+ (buffer-string)))
+
+
+(defun ert-propertized-string (&rest args)
+ "Return a string with properties as specified by ARGS.
+
+ARGS is a list of strings and plists. The strings in ARGS are
+concatenated to produce an output string. In the output string,
+each string from ARGS will be have the preceding plist as its
+property list, or no properties if there is no plist before it.
+
+As a simple example,
+
+\(ert-propertized-string \"foo \" '(face italic) \"bar\" \" baz\" nil \
+\" quux\"\)
+
+would return the string \"foo bar baz quux\" where the substring
+\"bar baz\" has a `face' property with the value `italic'.
+
+None of the ARGS are modified, but the return value may share
+structure with the plists in ARGS."
+ (with-temp-buffer
+ (loop with current-plist = nil
+ for x in args do
+ (etypecase x
+ (string (let ((begin (point)))
+ (insert x)
+ (set-text-properties begin (point) current-plist)))
+ (list (unless (zerop (mod (length x) 2))
+ (error "Odd number of args in plist: %S" x))
+ (setq current-plist x))))
+ (buffer-string)))
+
+
+(defun ert-call-with-buffer-renamed (buffer-name thunk)
+ "Protect the buffer named BUFFER-NAME from side-effects and run THUNK.
+
+Renames the buffer BUFFER-NAME to a new temporary name, creates a
+new buffer named BUFFER-NAME, executes THUNK, kills the new
+buffer, and renames the original buffer back to BUFFER-NAME.
+
+This is useful if THUNK has undesirable side-effects on an Emacs
+buffer with a fixed name such as *Messages*."
+ (lexical-let ((new-buffer-name (generate-new-buffer-name
+ (format "%s orig buffer" buffer-name))))
+ (with-current-buffer (get-buffer-create buffer-name)
+ (rename-buffer new-buffer-name))
+ (unwind-protect
+ (progn
+ (get-buffer-create buffer-name)
+ (funcall thunk))
+ (when (get-buffer buffer-name)
+ (kill-buffer buffer-name))
+ (with-current-buffer new-buffer-name
+ (rename-buffer buffer-name)))))
+
+(defmacro* ert-with-buffer-renamed ((buffer-name-form) &body body)
+ "Protect the buffer named BUFFER-NAME from side-effects and run BODY.
+
+See `ert-call-with-buffer-renamed' for details."
+ (declare (indent 1))
+ `(ert-call-with-buffer-renamed ,buffer-name-form (lambda () , at body)))
+
+
+(defun ert-buffer-string-reindented (&optional buffer)
+ "Return the contents of BUFFER after reindentation.
+
+BUFFER defaults to current buffer. Does not modify BUFFER."
+ (with-current-buffer (or buffer (current-buffer))
+ (let ((clone nil))
+ (unwind-protect
+ (progn
+ ;; `clone-buffer' doesn't work if `buffer-file-name' is non-nil.
+ (let ((buffer-file-name nil))
+ (setq clone (clone-buffer)))
+ (with-current-buffer clone
+ (let ((inhibit-read-only t))
+ (indent-region (point-min) (point-max)))
+ (buffer-string)))
+ (when clone
+ (let ((kill-buffer-query-functions nil))
+ (kill-buffer clone)))))))
+
+
+(provide 'ert-x)
+
+;;; ert-x.el ends here
diff --git a/test/ert/ert.el b/test/ert/ert.el
new file mode 100644
index 0000000..997abfe
--- /dev/null
+++ b/test/ert/ert.el
@@ -0,0 +1,2539 @@
+;;; ert.el --- Emacs Lisp Regression Testing
+
+;; Copyright (C) 2007, 2008, 2010 Free Software Foundation, Inc.
+
+;; Author: Christian M. Ohler
+;; 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-and-exit' 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.
+;;
+;; See ERT's info manual as well as the docstrings for more details.
+;; To compile the manual, run `makeinfo ert.texinfo' in the ERT
+;; directory, then C-u M-x info ert.info in Emacs to view it.
+;;
+;; To see some examples of tests written in ERT, see its self-tests in
+;; ert-tests.el. Some of these are tricky due to the bootstrapping
+;; problem of writing tests for a testing tool, others test simple
+;; functions and are straightforward.
+
+;;; Code:
+
+(eval-when-compile
+ (require 'cl))
+(require 'button)
+(require 'debug)
+(require 'easymenu)
+(require 'ewoc)
+(require 'find-func)
+(require 'help)
+
+
+;;; UI customization options.
+
+(defgroup ert ()
+ "ERT, the Emacs Lisp regression testing tool."
+ :prefix "ert-"
+ :group 'lisp)
+
+(defface ert-test-result-expected '((((class color) (background light))
+ :background "green1")
+ (((class color) (background dark))
+ :background "green3"))
+ "Face used for expected results in the ERT results buffer."
+ :group 'ert)
+
+(defface ert-test-result-unexpected '((((class color) (background light))
+ :background "red1")
+ (((class color) (background dark))
+ :background "red3"))
+ "Face used for unexpected results in the ERT results buffer."
+ :group 'ert)
+
+
+;;; Copies/reimplementations of cl functions.
+
+(defun ert--cl-do-remf (plist tag)
+ "Copy of `cl-do-remf'. Modify PLIST by removing TAG."
+ (let ((p (cdr plist)))
+ (while (and (cdr p) (not (eq (car (cdr p)) tag))) (setq p (cdr (cdr p))))
+ (and (cdr p) (progn (setcdr p (cdr (cdr (cdr p)))) t))))
+
+(defun ert--remprop (sym tag)
+ "Copy of `cl-remprop'. Modify SYM's plist by removing TAG."
+ (let ((plist (symbol-plist sym)))
+ (if (and plist (eq tag (car plist)))
+ (progn (setplist sym (cdr (cdr plist))) t)
+ (ert--cl-do-remf plist tag))))
+
+(defun ert--remove-if-not (ert-pred ert-list)
+ "A reimplementation of `remove-if-not'.
+
+ERT-PRED is a predicate, ERT-LIST is the input list."
+ (loop for ert-x in ert-list
+ if (funcall ert-pred ert-x)
+ collect ert-x))
+
+(defun ert--intersection (a b)
+ "A reimplementation of `intersection'. Intersect the sets A and B.
+
+Elements are compared using `eql'."
+ (loop for x in a
+ if (memql x b)
+ collect x))
+
+(defun ert--set-difference (a b)
+ "A reimplementation of `set-difference'. Subtract the set B from the set A.
+
+Elements are compared using `eql'."
+ (loop for x in a
+ unless (memql x b)
+ collect x))
+
+(defun ert--set-difference-eq (a b)
+ "A reimplementation of `set-difference'. Subtract the set B from the set A.
+
+Elements are compared using `eq'."
+ (loop for x in a
+ unless (memq x b)
+ collect x))
+
+(defun ert--union (a b)
+ "A reimplementation of `union'. Compute the union of the sets A and B.
+
+Elements are compared using `eql'."
+ (append a (ert--set-difference b a)))
+
+(eval-and-compile
+ (defvar ert--gensym-counter 0))
+
+(eval-and-compile
+ (defun ert--gensym (&optional prefix)
+ "Only allows string PREFIX, not compatible with CL."
+ (unless prefix (setq prefix "G"))
+ (make-symbol (format "%s%s"
+ prefix
+ (prog1 ert--gensym-counter
+ (incf ert--gensym-counter))))))
+
+(defun ert--coerce-to-vector (x)
+ "Coerce X to a vector."
+ (when (char-table-p x) (error "Not supported"))
+ (if (vectorp x)
+ x
+ (vconcat x)))
+
+(defun* ert--remove* (x list &key key test)
+ "Does not support all the keywords of remove*."
+ (unless key (setq key #'identity))
+ (unless test (setq test #'eql))
+ (loop for y in list
+ unless (funcall test x (funcall key y))
+ collect y))
+
+(defun ert--string-position (c s)
+ "Return the position of the first occurrence of C in S, or nil if none."
+ (loop for i from 0
+ for x across s
+ when (eql x c) return i))
+
+(defun ert--mismatch (a b)
+ "Return index of first element that differs between A and B.
+
+Like `mismatch'. Uses `equal' for comparison."
+ (cond ((or (listp a) (listp b))
+ (ert--mismatch (ert--coerce-to-vector a)
+ (ert--coerce-to-vector b)))
+ ((> (length a) (length b))
+ (ert--mismatch b a))
+ (t
+ (let ((la (length a))
+ (lb (length b)))
+ (assert (arrayp a) t)
+ (assert (arrayp b) t)
+ (assert (<= la lb) t)
+ (loop for i below la
+ when (not (equal (aref a i) (aref b i))) return i
+ finally (return (if (/= la lb)
+ la
+ (assert (equal a b) t)
+ nil)))))))
+
+(defun ert--subseq (seq start &optional end)
+ "Return a subsequence of SEQ from START to END."
+ (when (char-table-p seq) (error "Not supported"))
+ (let ((vector (substring (ert--coerce-to-vector seq) start end)))
+ (etypecase seq
+ (vector vector)
+ (string (concat vector))
+ (list (append vector nil))
+ (bool-vector (loop with result = (make-bool-vector (length vector) nil)
+ for i below (length vector) do
+ (setf (aref result i) (aref vector i))
+ finally (return result)))
+ (char-table (assert nil)))))
+
+(defun ert-equal-including-properties (a b)
+ "Return t if A and B have similar structure and contents.
+
+This is like `equal-including-properties' except that it compares
+the property values of text properties structurally (by
+recursing) rather than with `eq'. Perhaps this is what
+`equal-including-properties' should do in the first place; see
+Emacs bug 6581 at URL `http://debbugs.gnu.org/cgi/bugreport.cgi?bug=6581'."
+ ;; This implementation is inefficient. Rather than making it
+ ;; efficient, let's hope bug 6581 gets fixed so that we can delete
+ ;; it altogether.
+ (not (ert--explain-not-equal-including-properties a b)))
+
+
+;;; 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 ':passed)
+ (tags '()))
+
+(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."
+ (unless (ert-test-boundp symbol) (error "No test named `%S'" symbol))
+ (get symbol 'ert--test))
+
+(defun ert-set-test (symbol definition)
+ "Make SYMBOL name the test DEFINITION, and return DEFINITION."
+ (when (eq symbol 'nil)
+ ;; We disallow nil since `ert-test-at-point' and related functions
+ ;; want to return a test name, but also need an out-of-band value
+ ;; on failure. Nil is the most natural out-of-band value; using 0
+ ;; or "" or signalling an error would be too awkward.
+ ;;
+ ;; Note that nil is still a valid value for the `name' slot in
+ ;; ert-test objects. It designates an anonymous test.
+ (error "Attempt to define a test named nil"))
+ (put symbol 'ert--test definition)
+ definition)
+
+(defun ert-make-test-unbound (symbol)
+ "Make SYMBOL name no test. Return SYMBOL."
+ (ert--remprop symbol 'ert--test)
+ symbol)
+
+(defun ert--parse-keys-and-body (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."
+ (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)
+ remaining)))
+
+;;;###autoload
+(defmacro* ert-deftest (name () &body docstring-keys-and-body)
+ "Define NAME (a symbol) as a test.
+
+BODY is evaluated as a `progn' when the test is run. It should
+signal a condition on failure or just return if the test passes.
+
+`should', `should-not' and `should-error' are useful for
+assertions in BODY.
+
+Use `ert' to run tests interactively.
+
+Tests that are expected to fail can be marked as such
+using :expected-result. See `ert-test-result-type-p' for a
+description of valid values for RESULT-TYPE.
+
+\(fn NAME () [DOCSTRING] [:expected-result RESULT-TYPE] \
+\[:tags '(TAG...)] BODY...)"
+ (declare (debug (&define :name test
+ name sexp [&optional stringp]
+ [&rest keywordp sexp] def-body))
+ (doc-string 3)
+ (indent 2))
+ (let ((documentation nil)
+ (documentation-supplied-p nil))
+ (when (stringp (first docstring-keys-and-body))
+ (setq documentation (pop docstring-keys-and-body)
+ documentation-supplied-p t))
+ (destructuring-bind ((&key (expected-result nil expected-result-supplied-p)
+ (tags nil tags-supplied-p))
+ body)
+ (ert--parse-keys-and-body docstring-keys-and-body)
+ `(progn
+ (ert-set-test ',name
+ (make-ert-test
+ :name ',name
+ ,@(when documentation-supplied-p
+ `(:documentation ,documentation))
+ ,@(when expected-result-supplied-p
+ `(:expected-result-type ,expected-result))
+ ,@(when tags-supplied-p
+ `(:tags ,tags))
+ :body (lambda () , at body)))
+ ;; 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))))
+
+;; We use these `put' forms in addition to the (declare (indent)) in
+;; the defmacro form since the `declare' alone does not lead to
+;; correct indentation before the .el/.elc file is loaded.
+;; Autoloading these `put' forms solves this.
+;;;###autoload
+(progn
+ ;; TODO(ohler): Figure out what these mean and make sure they are correct.
+ (put 'ert-deftest 'lisp-indent-function 2)
+ (put 'ert-info 'lisp-indent-function 1))
+
+(defvar ert--find-test-regexp
+ (concat "^\\s-*(ert-deftest"
+ find-function-space-re
+ "%s\\(\\s-\\|$\\)")
+ "The regexp the `find-function' mechanisms use for finding test definitions.")
+
+
+(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 `should' macros.
+
+(defvar ert--should-execution-observer nil)
+
+(defun ert--signal-should-execution (form-description)
+ "Tell the current `should' form observer (if any) about FORM-DESCRIPTION."
+ (when ert--should-execution-observer
+ (funcall ert--should-execution-observer form-description)))
+
+(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-1 (whole form inner-expander)
+ "Helper function for the `should' macro and its variants."
+ (let ((form
+ ;; If `cl-macroexpand' isn't bound, the code that we're
+ ;; compiling doesn't depend on cl and thus doesn't need an
+ ;; environment arg for `macroexpand'.
+ (if (fboundp 'cl-macroexpand)
+ ;; Suppress warning about run-time call to cl funtion: we
+ ;; only call it if it's fboundp.
+ (with-no-warnings
+ (cl-macroexpand form (and (boundp 'cl-macro-environment)
+ cl-macro-environment)))
+ (macroexpand form))))
+ (cond
+ ((or (atom form) (ert--special-operator-p (car form)))
+ (let ((value (ert--gensym "value-")))
+ `(let ((,value (ert--gensym "ert-form-evaluation-aborted-")))
+ ,(funcall inner-expander
+ `(setq ,value ,form)
+ `(list ',whole :form ',form :value ,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 (ert--gensym "fn-"))
+ (args (ert--gensym "args-"))
+ (value (ert--gensym "value-"))
+ (default-value (ert--gensym "ert-form-evaluation-aborted-")))
+ `(let ((,fn (function ,fn-name))
+ (,args (list , at 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)
+ ,value))))))))
+
+(defun ert--expand-should (whole form inner-expander)
+ "Helper function for the `should' macro and its variants.
+
+Analyzes FORM and returns an expression that has the same
+semantics under evaluation but records additional debugging
+information.
+
+INNER-EXPANDER should be a function and is called with two
+arguments: INNER-FORM and FORM-DESCRIPTION-FORM, where INNER-FORM
+is an expression equivalent to FORM, and FORM-DESCRIPTION-FORM is
+an expression that returns a description of FORM. INNER-EXPANDER
+should return code that calls INNER-FORM and performs the checks
+and error signalling specific to the particular variant of
+`should'. The code that INNER-EXPANDER returns must not call
+FORM-DESCRIPTION-FORM before it has called INNER-FORM."
+ (lexical-let ((inner-expander inner-expander))
+ (ert--expand-should-1
+ whole form
+ (lambda (inner-form form-description-form value-var)
+ (let ((form-description (ert--gensym "form-description-")))
+ `(let (,form-description)
+ ,(funcall inner-expander
+ `(unwind-protect
+ ,inner-form
+ (setq ,form-description ,form-description-form)
+ (ert--signal-should-execution ,form-description))
+ `,form-description
+ value-var)))))))
+
+(defmacro* should (form)
+ "Evaluate FORM. If it returns nil, abort the current test as failed.
+
+Returns the value of FORM."
+ (ert--expand-should `(should ,form) form
+ (lambda (inner-form form-description-form value-var)
+ `(unless ,inner-form
+ (ert-fail ,form-description-form)))))
+
+(defmacro* should-not (form)
+ "Evaluate FORM. If it returns non-nil, abort the current test as failed.
+
+Returns nil."
+ (ert--expand-should `(should-not ,form) form
+ (lambda (inner-form form-description-form value-var)
+ `(unless (not ,inner-form)
+ (ert-fail ,form-description-form)))))
+
+(defun ert--should-error-handle-error (form-description-fn
+ condition type exclude-subtypes)
+ "Helper function for `should-error'.
+
+Determines whether CONDITION matches TYPE and EXCLUDE-SUBTYPES,
+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 (ert--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"))))))))
+
+;; FIXME: The expansion will evaluate the keyword args (if any) in
+;; nonstandard order.
+(defmacro* should-error (form &rest keys &key type exclude-subtypes)
+ "Evaluate FORM and check that it signals an error.
+
+The error signalled needs to match TYPE. TYPE should be a list
+of condition names. (It can also be a non-nil symbol, which is
+equivalent to a singleton list containing that symbol.) 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.
+
+If the error matches, returns (ERROR-SYMBOL . DATA) from the
+error. If not, or if no error was signalled, abort the test as
+failed."
+ (unless type (setq type ''error))
+ (ert--expand-should
+ `(should-error ,form , at keys)
+ form
+ (lambda (inner-form form-description-form value-var)
+ (let ((errorp (ert--gensym "errorp"))
+ (form-description-fn (ert--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)
+ (setq ,value-var -condition-)))
+ (unless ,errorp
+ (ert-fail (append
+ (funcall ,form-description-fn)
+ (list
+ :fail-reason "did not signal an error")))))))))
+
+
+;;; Explanation of `should' failures.
+
+;; TODO(ohler): Rework explanations so that they are displayed in a
+;; similar way to `ert-info' messages; in particular, allow text
+;; buttons in explanations that give more detail or open an ediff
+;; buffer. Perhaps explanations should be reported through `ert-info'
+;; rather than as part of the condition.
+
+(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-format-atom (x)
+ "Format the atom X for `ert--explain-not-equal'."
+ (typecase x
+ (fixnum (list x (format "#x%x" x) (format "?%c" x)))
+ (t x)))
+
+(defun ert--explain-not-equal (a b)
+ "Explainer function for `equal'.
+
+Returns a programmer-readable explanation of why A and B are not
+`equal', or nil if they are."
+ (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)))
+ `(proper-lists-of-different-length ,(length a) ,(length b)
+ ,a ,b
+ first-mismatch-at
+ ,(ert--mismatch 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)))
+ finally (assert (equal a b) t)))
+ (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)
+ (assert (equal a b) t)
+ nil))))))))
+ (array (if (not (equal (length a) (length b)))
+ `(arrays-of-different-length ,(length a) ,(length b)
+ ,a ,b
+ ,@(unless (char-table-p a)
+ `(first-mismatch-at
+ ,(ert--mismatch 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)))
+ finally (assert (equal a b) t))))
+ (atom (if (not (equal a b))
+ (if (and (symbolp a) (symbolp b) (string= a b))
+ `(different-symbols-with-the-same-name ,a ,b)
+ `(different-atoms ,(ert--explain-format-atom a)
+ ,(ert--explain-format-atom b)))
+ nil)))))
+(put 'equal 'ert-explainer 'ert--explain-not-equal)
+
+(defun ert--significant-plist-keys (plist)
+ "Return the keys of PLIST that have non-null values, in order."
+ (assert (zerop (mod (length plist) 2)) t)
+ (loop for (key value . rest) on plist by #'cddr
+ unless (or (null value) (memq key accu)) collect key into accu
+ finally (return accu)))
+
+(defun ert--plist-difference-explanation (a b)
+ "Return a programmer-readable explanation of why A and B are different plists.
+
+Returns nil if they are equivalent, i.e., have the same value for
+each key, where absent values are treated as nil. The order of
+key/value pairs in each list does not matter."
+ (assert (zerop (mod (length a) 2)) t)
+ (assert (zerop (mod (length b) 2)) t)
+ ;; Normalizing the plists would be another way to do this but it
+ ;; requires a total ordering on all lisp objects (since any object
+ ;; is valid as a text property key). Perhaps defining such an
+ ;; ordering is useful in other contexts, too, but it's a lot of
+ ;; work, so let's punt on it for now.
+ (let* ((keys-a (ert--significant-plist-keys a))
+ (keys-b (ert--significant-plist-keys b))
+ (keys-in-a-not-in-b (ert--set-difference-eq keys-a keys-b))
+ (keys-in-b-not-in-a (ert--set-difference-eq keys-b keys-a)))
+ (flet ((explain-with-key (key)
+ (let ((value-a (plist-get a key))
+ (value-b (plist-get b key)))
+ (assert (not (equal value-a value-b)) t)
+ `(different-properties-for-key
+ ,key ,(ert--explain-not-equal-including-properties value-a
+ value-b)))))
+ (cond (keys-in-a-not-in-b
+ (explain-with-key (first keys-in-a-not-in-b)))
+ (keys-in-b-not-in-a
+ (explain-with-key (first keys-in-b-not-in-a)))
+ (t
+ (loop for key in keys-a
+ when (not (equal (plist-get a key) (plist-get b key)))
+ return (explain-with-key key)))))))
+
+(defun ert--abbreviate-string (s len suffixp)
+ "Shorten string S to at most LEN chars.
+
+If SUFFIXP is non-nil, returns a suffix of S, otherwise a prefix."
+ (let ((n (length s)))
+ (cond ((< n len)
+ s)
+ (suffixp
+ (substring s (- n len)))
+ (t
+ (substring s 0 len)))))
+
+(defun ert--explain-not-equal-including-properties (a b)
+ "Explainer function for `ert-equal-including-properties'.
+
+Returns a programmer-readable explanation of why A and B are not
+`ert-equal-including-properties', or nil if they are."
+ (if (not (equal a b))
+ (ert--explain-not-equal a b)
+ (assert (stringp a) t)
+ (assert (stringp b) t)
+ (assert (eql (length a) (length b)) t)
+ (loop for i from 0 to (length a)
+ for props-a = (text-properties-at i a)
+ for props-b = (text-properties-at i b)
+ for difference = (ert--plist-difference-explanation props-a props-b)
+ do (when difference
+ (return `(char ,i ,(substring-no-properties a i (1+ i))
+ ,difference
+ context-before
+ ,(ert--abbreviate-string
+ (substring-no-properties a 0 i)
+ 10 t)
+ context-after
+ ,(ert--abbreviate-string
+ (substring-no-properties a (1+ i))
+ 10 nil))))
+ ;; TODO(ohler): Get `equal-including-properties' fixed in
+ ;; Emacs, delete `ert-equal-including-properties', and
+ ;; re-enable this assertion.
+ ;;finally (assert (equal-including-properties a b) t)
+ )))
+(put 'ert-equal-including-properties
+ 'ert-explainer
+ 'ert--explain-not-equal-including-properties)
+
+
+;;; Implementation of `ert-info'.
+
+;; TODO(ohler): The name `info' clashes with
+;; `ert--test-execution-info'. One or both should be renamed.
+(defvar ert--infos '()
+ "The stack of `ert-info' infos that currently apply.
+
+Bound dynamically. This is a list of (PREFIX . MESSAGE) pairs.")
+
+(defmacro* ert-info ((message-form &key ((:prefix prefix-form) "Info: "))
+ &body body)
+ "Evaluate MESSAGE-FORM and BODY, and report the message if BODY fails.
+
+To be used within ERT tests. MESSAGE-FORM should evaluate to a
+string that will be displayed together with the test result if
+the test fails. PREFIX-FORM should evaluate to a string as well
+and is displayed in front of the value of MESSAGE-FORM."
+ (declare (debug ((form &rest [sexp form]) body))
+ (indent 1))
+ `(let ((ert--infos (cons (cons ,prefix-form ,message-form) ert--infos)))
+ , at body))
+
+
+
+;;; Facilities for running a single test.
+
+(defvar ert-debug-on-error nil
+ "Non-nil means enter debugger when a test fails or terminates with an error.")
+
+;; The data structures that represent the result of running a test.
+(defstruct ert-test-result
+ (messages nil)
+ (should-forms 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))
+ (infos (assert nil)))
+(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))
+
+(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")))))))
+
+;; 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)
+ "During a test run, `debugger' is bound to a closure that calls this function.
+
+This function records failures and errors and either terminates
+the test silently or calls the interactive debugger, as
+appropriate.
+
+INFO is the ert--test-execution-info corresponding to this test
+run. DEBUGGER-ARGS are the arguments to `debugger'."
+ (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)
+ (otherwise 'failed)))
+ (backtrace (ert--record-backtrace))
+ (infos (reverse ert--infos)))
+ (setf (ert--test-execution-info-result info)
+ (ecase type
+ (quit
+ (make-ert-test-quit :condition condition
+ :backtrace backtrace
+ :infos infos))
+ (failed
+ (make-ert-test-failed :condition condition
+ :backtrace backtrace
+ :infos infos))))
+ ;; 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)
+ "Low-level function to run a test according to ERT-TEST-EXECUTION-INFO.
+
+This mainly sets up debugger-related bindings."
+ (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--infos '()))
+ (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--force-message-log-buffer-truncation ()
+ "Immediately truncate *Messages* buffer according to `message-log-max'.
+
+This can be useful after reducing the value of `message-log-max'."
+ (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)))))
+
+(defvar ert--running-tests nil
+ "List of tests that are currently in execution.
+
+This list is empty while no test is running, has one element
+while a test is running, two elements while a test run from
+inside a test is running, etc. The list is in order of nesting,
+innermost test first.
+
+The elements are of type `ert-test'.")
+
+(defun ert-run-test (ert-test)
+ "Run ERT-TEST.
+
+Returns the result and stores it in ERT-TEST's `most-recent-result' slot."
+ (setf (ert-test-most-recent-result ert-test) nil)
+ (block error
+ (lexical-let ((begin-marker
+ (with-current-buffer (get-buffer-create "*Messages*")
+ (set-marker (make-marker) (point-max)))))
+ (unwind-protect
+ (lexical-let ((info (make-ert--test-execution-info
+ :test ert-test
+ :result
+ (make-ert-test-aborted-with-non-local-exit)
+ :exit-continuation (lambda ()
+ (return-from error nil))))
+ (should-form-accu (list)))
+ (unwind-protect
+ (let ((ert--should-execution-observer
+ (lambda (form-description)
+ (push form-description should-form-accu)))
+ (message-log-max t)
+ (ert--running-tests (cons ert-test ert--running-tests)))
+ (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)
+ (setq should-form-accu (nreverse should-form-accu))
+ (setf (ert-test-result-should-forms result)
+ should-form-accu)
+ (setf (ert-test-most-recent-result ert-test) result))))
+ (set-marker begin-marker nil))))
+ (ert-test-most-recent-result ert-test))
+
+(defun ert-running-test ()
+ "Return the top-level test currently executing."
+ (car (last ert--running-tests)))
+
+
+;;; Test selectors.
+
+(defun ert-test-result-type-p (result result-type)
+ "Return non-nil if RESULT matches type RESULT-TYPE.
+
+Valid result types:
+
+nil -- Never matches.
+t -- Always matches.
+:failed, :passed -- Matches corresponding results.
+\(and TYPES...\) -- Matches if all TYPES match.
+\(or TYPES...\) -- Matches if some TYPES match.
+\(not TYPE\) -- Matches if TYPE does not match.
+\(satisfies PREDICATE\) -- Matches if PREDICATE returns true when called with
+ RESULT."
+ ;; It would be easy to add `member' and `eql' types etc., but I
+ ;; haven't bothered yet.
+ (etypecase result-type
+ ((member nil) nil)
+ ((member t) t)
+ ((member :failed) (ert-test-failed-p result))
+ ((member :passed) (ert-test-passed-p result))
+ (cons
+ (destructuring-bind (operator &rest operands) result-type
+ (ecase operator
+ (and
+ (case (length operands)
+ (0 t)
+ (t
+ (and (ert-test-result-type-p result (first operands))
+ (ert-test-result-type-p result `(and ,@(rest operands)))))))
+ (or
+ (case (length operands)
+ (0 nil)
+ (t
+ (or (ert-test-result-type-p result (first operands))
+ (ert-test-result-type-p result `(or ,@(rest operands)))))))
+ (not
+ (assert (eql (length operands) 1))
+ (not (ert-test-result-type-p result (first operands))))
+ (satisfies
+ (assert (eql (length operands) 1))
+ (funcall (first operands) result)))))))
+
+(defun ert-test-result-expected-p (test result)
+ "Return non-nil if TEST's expected result type matches RESULT."
+ (ert-test-result-type-p result (ert-test-expected-result-type test)))
+
+(defun ert-select-tests (selector universe)
+ "Return the tests that match SELECTOR.
+
+UNIVERSE specifies the set of tests to select from; it 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 -- 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.
+\(tag TAG) -- Selects all tests that have TAG on their tags list.
+\(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)
+ (null (ert-test-most-recent-result test))))
+ universe))
+ ((member :failed) (ert-select-tests
+ `(satisfies ,(lambda (test)
+ (ert-test-result-type-p
+ (ert-test-most-recent-result test)
+ ':failed)))
+ universe))
+ ((member :passed) (ert-select-tests
+ `(satisfies ,(lambda (test)
+ (ert-test-result-type-p
+ (ert-test-most-recent-result test)
+ ':passed)))
+ 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 (ert--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 , at operands) universe))
+ (and
+ ;; Do these definitions of AND, NOT and OR satisfy de
+ ;; Morgan's laws? 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))
+ (let ((all-tests (ert-select-tests 't universe)))
+ (ert--set-difference all-tests
+ (ert-select-tests (first operands)
+ all-tests))))
+ (or
+ (case (length operands)
+ (0 (ert-select-tests 'nil universe))
+ (t (ert--union (ert-select-tests (first operands) universe)
+ (ert-select-tests `(or ,@(rest operands))
+ universe)))))
+ (tag
+ (assert (eql (length operands) 1))
+ (let ((tag (first operands)))
+ (ert-select-tests `(satisfies
+ ,(lambda (test)
+ (member tag (ert-test-tags test))))
+ universe)))
+ (satisfies
+ (assert (eql (length operands) 1))
+ (ert--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
+ :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)))
+ ((member tag satisfies)
+ selector)))))))
+ (insert (format "%S" (rec selector)))))
+
+
+;;; Facilities for running a whole set of tests.
+
+;; 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 start times of the tests, in order, as reported by
+ ;; `current-time'.
+ (test-start-times (assert nil) :type vector)
+ ;; The end times of the tests, in order, as reported by
+ ;; `current-time'.
+ (test-end-times (assert nil) :type vector)
+ (passed-expected 0)
+ (passed-unexpected 0)
+ (failed-expected 0)
+ (failed-unexpected 0)
+ (start-time nil)
+ (end-time nil)
+ (aborted-p nil)
+ (current-test nil)
+ ;; The time at or after which the next redisplay should occur, as a
+ ;; float.
+ (next-redisplay 0.0))
+
+(defun ert-stats-completed-expected (stats)
+ "Return the number of tests in STATS that had expected results."
+ (+ (ert--stats-passed-expected stats)
+ (ert--stats-failed-expected stats)))
+
+(defun ert-stats-completed-unexpected (stats)
+ "Return the number of tests in STATS that had unexpected results."
+ (+ (ert--stats-passed-unexpected stats)
+ (ert--stats-failed-unexpected stats)))
+
+(defun ert-stats-completed (stats)
+ "Number of tests in STATS that have run so far."
+ (+ (ert-stats-completed-expected stats)
+ (ert-stats-completed-unexpected stats)))
+
+(defun ert-stats-total (stats)
+ "Number of tests in STATS, regardless of whether they have run yet."
+ (length (ert--stats-tests stats)))
+
+;; The stats object of the current run, dynamically bound. This is
+;; used for the mode line progress indicator.
+(defvar ert--current-run-stats nil)
+
+(defun ert--stats-test-key (test)
+ "Return the key used for TEST in the test map of ert--stats objects.
+
+Returns the name of TEST if it has one, or TEST itself otherwise."
+ (or (ert-test-name test) test))
+
+(defun ert--stats-set-test-and-result (stats pos test result)
+ "Change STATS by replacing the test at position POS with TEST and RESULT.
+
+Also changes the counters in STATS to match."
+ (let* ((tests (ert--stats-tests stats))
+ (results (ert--stats-test-results stats))
+ (old-test (aref tests pos))
+ (map (ert--stats-test-map stats)))
+ (flet ((update (d)
+ (if (ert-test-result-expected-p (aref tests pos)
+ (aref results pos))
+ (etypecase (aref results pos)
+ (ert-test-passed (incf (ert--stats-passed-expected stats) d))
+ (ert-test-failed (incf (ert--stats-failed-expected stats) d))
+ (null)
+ (ert-test-aborted-with-non-local-exit))
+ (etypecase (aref results pos)
+ (ert-test-passed (incf (ert--stats-passed-unexpected stats) d))
+ (ert-test-failed (incf (ert--stats-failed-unexpected stats) d))
+ (null)
+ (ert-test-aborted-with-non-local-exit)))))
+ ;; Adjust counters to remove the result that is currently in stats.
+ (update -1)
+ ;; Put new test and result into stats.
+ (setf (aref tests pos) test
+ (aref results pos) result)
+ (remhash (ert--stats-test-key old-test) map)
+ (setf (gethash (ert--stats-test-key test) map) pos)
+ ;; Adjust counters to match new result.
+ (update +1)
+ nil)))
+
+(defun ert--make-stats (tests selector)
+ "Create a new `ert--stats' object for running TESTS.
+
+SELECTOR is the selector that was used to select TESTS."
+ (setq tests (ert--coerce-to-vector tests))
+ (let ((map (make-hash-table :size (length tests))))
+ (loop for i from 0
+ for test across tests
+ for key = (ert--stats-test-key test) do
+ (assert (not (gethash key map)))
+ (setf (gethash key map) i))
+ (make-ert--stats :selector selector
+ :tests tests
+ :test-map map
+ :test-results (make-vector (length tests) nil)
+ :test-start-times (make-vector (length tests) nil)
+ :test-end-times (make-vector (length tests) nil))))
+
+(defun ert-run-or-rerun-test (stats test listener)
+ ;; checkdoc-order: nil
+ "Run the single test TEST and record the result using STATS and LISTENER."
+ (let ((ert--current-run-stats stats)
+ (pos (ert--stats-test-pos stats test)))
+ (ert--stats-set-test-and-result stats pos test 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)
+ (setf (aref (ert--stats-test-start-times stats) pos) (current-time))
+ (unwind-protect
+ (ert-run-test test)
+ (setf (aref (ert--stats-test-end-times stats) pos) (current-time))
+ (let ((result (ert-test-most-recent-result test)))
+ (ert--stats-set-test-and-result stats pos test result)
+ (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 (ert-select-tests selector t))
+ (stats (ert--make-stats tests selector)))
+ (setf (ert--stats-start-time stats) (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 in 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-pos (stats test)
+ ;; checkdoc-order: nil
+ "Return the position (index) of TEST in the run represented by STATS."
+ (gethash (ert--stats-test-key test) (ert--stats-test-map stats)))
+
+
+;;; Formatting functions shared across UIs.
+
+(defun ert--format-time-iso8601 (time)
+ "Format TIME in the variant of ISO 8601 used for timestamps in ERT."
+ (format-time-string "%Y-%m-%d %T%z" time))
+
+(defun ert-char-for-test-result (result expectedp)
+ "Return a character that represents the test result RESULT.
+
+EXPECTEDP specifies whether the result was expected."
+ (let ((s (etypecase result
+ (ert-test-passed ".P")
+ (ert-test-failed "fF")
+ (null "--")
+ (ert-test-aborted-with-non-local-exit "aA"))))
+ (elt s (if expectedp 0 1))))
+
+(defun ert-string-for-test-result (result expectedp)
+ "Return a string that represents the test result RESULT.
+
+EXPECTEDP specifies whether the result was expected."
+ (let ((s (etypecase result
+ (ert-test-passed '("passed" "PASSED"))
+ (ert-test-failed '("failed" "FAILED"))
+ (null '("unknown" "UNKNOWN"))
+ (ert-test-aborted-with-non-local-exit '("aborted" "ABORTED")))))
+ (elt s (if expectedp 0 1))))
+
+(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--insert-infos (result)
+ "Insert `ert-info' infos from RESULT into current buffer.
+
+RESULT must be an `ert-test-result-with-condition'."
+ (check-type result ert-test-result-with-condition)
+ (dolist (info (ert-test-result-with-condition-infos result))
+ (destructuring-bind (prefix . message) info
+ (let ((begin (point))
+ (indentation (make-string (+ (length prefix) 4) ?\s))
+ (end nil))
+ (unwind-protect
+ (progn
+ (insert message "\n")
+ (setq end (copy-marker (point)))
+ (goto-char begin)
+ (insert " " prefix)
+ (forward-line 1)
+ (while (< (point) end)
+ (insert indentation)
+ (forward-line 1)))
+ (when end (set-marker end nil)))))))
+
+
+;;; Running tests in batch mode.
+
+(defvar ert-batch-backtrace-right-margin 70
+ "*The maximum line length for printing backtraces in `ert-run-tests-batch'.")
+
+;;;###autoload
+(defun ert-run-tests-batch (&optional selector)
+ "Run the tests specified by SELECTOR, printing results to the terminal.
+
+SELECTOR works as described in `ert-select-tests', except if
+SELECTOR is nil, in which case all tests rather than none will be
+run; this makes the command line \"emacs -batch -l my-tests.el -f
+ert-run-tests-batch-and-exit\" useful.
+
+Returns the stats object."
+ (unless selector (setq selector 't))
+ (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-completed-unexpected stats))
+ (expected-failures (ert--stats-failed-expected stats)))
+ (message "\n%sRan %s tests, %s results as expected%s (%s)%s\n"
+ (if (not abortedp)
+ ""
+ "Aborted: ")
+ (ert-stats-total stats)
+ (ert-stats-completed-expected stats)
+ (if (zerop unexpected)
+ ""
+ (format ", %s unexpected" unexpected))
+ (ert--format-time-iso8601 (ert--stats-end-time stats))
+ (if (zerop expected-failures)
+ ""
+ (format "\n%s expected failures" expected-failures)))
+ (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
+ (unless (ert-test-result-expected-p test result)
+ (etypecase result
+ (ert-test-passed
+ (message "Test %S passed unexpectedly" (ert-test-name test)))
+ (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
+ (ert--insert-infos result)
+ (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
+ (message "Test %S aborted with non-local exit"
+ (ert-test-name test)))))
+ (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-pos stats test))
+ (ert-test-name test)))))))))
+
+;;;###autoload
+(defun ert-run-tests-batch-and-exit (&optional selector)
+ "Like `ert-run-tests-batch', but exits Emacs when done.
+
+The exit status will be 0 if all test results were as expected, 1
+on unexpected results, or 2 if the framework detected an error
+outside of the tests (e.g. invalid SELECTOR or bug in the code
+that runs the tests)."
+ (unwind-protect
+ (let ((stats (ert-run-tests-batch selector)))
+ (kill-emacs (if (zerop (ert-stats-completed-unexpected stats)) 0 1)))
+ (unwind-protect
+ (progn
+ (message "Error running tests")
+ (backtrace))
+ (kill-emacs 2))))
+
+
+;;; Utility functions for load/unload actions.
+
+(defun ert--activate-font-lock-keywords ()
+ "Activate font-lock keywords for some of ERT's symbols."
+ (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 can be used as an inverse of `add-to-list'."
+ (unless key (setq key #'identity))
+ (unless test (setq test #'equal))
+ (setf (symbol-value list-var)
+ (ert--remove* element
+ (symbol-value list-var)
+ :key key
+ :test test)))
+
+
+;;; Some basic interactive functions.
+
+(defun ert-read-test-name (prompt &optional default history
+ add-default-to-prompt)
+ "Read the name of a test and return it as a symbol.
+
+Prompt with PROMPT. If DEFAULT is a valid test name, use it as a
+default. HISTORY is the history to use; see `completing-read'.
+If ADD-DEFAULT-TO-PROMPT is non-nil, PROMPT will be modified to
+include the default, if any.
+
+Signals an error if no test name was read."
+ (etypecase default
+ (string (let ((symbol (intern-soft default)))
+ (unless (and symbol (ert-test-boundp symbol))
+ (setq default nil))))
+ (symbol (setq default
+ (if (ert-test-boundp default)
+ (symbol-name default)
+ nil)))
+ (ert-test (setq default (ert-test-name default))))
+ (when add-default-to-prompt
+ (setq prompt (if (null default)
+ (format "%s: " prompt)
+ (format "%s (default %s): " prompt default))))
+ (let ((input (completing-read prompt obarray #'ert-test-boundp
+ t nil history default nil)))
+ ;; completing-read returns an empty string if default was nil and
+ ;; the user just hit enter.
+ (let ((sym (intern-soft input)))
+ (if (ert-test-boundp sym)
+ sym
+ (error "Input does not name a test")))))
+
+(defun ert-read-test-name-at-point (prompt)
+ "Read the name of a test and return it as a symbol.
+As a default, use the symbol at point, or the test at point if in
+the ERT results buffer. Prompt with PROMPT, augmented with the
+default (if any)."
+ (ert-read-test-name prompt (ert-test-at-point) nil t))
+
+(defun ert-find-test-other-window (test-name)
+ "Find, in another window, the definition of TEST-NAME."
+ (interactive (list (ert-read-test-name-at-point "Find test definition: ")))
+ (find-function-do-it test-name 'ert-deftest 'switch-to-buffer-other-window))
+
+(defun ert-delete-test (test-name)
+ "Make the test TEST-NAME unbound.
+
+Nothing more than an interactive interface to `ert-make-test-unbound'."
+ (interactive (list (ert-read-test-name-at-point "Delete test")))
+ (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")))
+ ;; We can't use `ert-select-tests' here since that gives us only
+ ;; test objects, and going from them back to the test name symbols
+ ;; can fail if the `ert-test' defstruct has been redefined.
+ (mapc #'ert-make-test-unbound (apropos-internal "" #'ert-test-boundp))
+ t)
+
+
+;;; Display of test progress and results.
+
+;; An entry in the results buffer ewoc. There is one entry per test.
+(defstruct ert--ewoc-entry
+ (test (assert 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)
+
+(defun ert-insert-test-name-button (test-name)
+ "Insert a button that links to TEST-NAME."
+ (insert-text-button (format "%S" test-name)
+ :type 'ert--test-name-button
+ 'ert-test-name test-name))
+
+(defun ert--results-format-expected-unexpected (expected unexpected)
+ "Return a string indicating EXPECTED expected results, UNEXPECTED unexpected."
+ (if (zerop unexpected)
+ (format "%s" expected)
+ (format "%s (%s unexpected)" (+ expected unexpected) unexpected)))
+
+(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-completed stats))
+ (results-buffer (current-buffer))
+ ;; Need to save buffer-local value.
+ (font-lock font-lock-mode))
+ (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\n"
+ "Failed: %s\n"
+ "Total: %s/%s\n\n")
+ (ert--results-format-expected-unexpected
+ (ert--stats-passed-expected stats)
+ (ert--stats-passed-unexpected stats))
+ (ert--results-format-expected-unexpected
+ (ert--stats-failed-expected stats)
+ (ert--stats-failed-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 progress-bar-string
+ :type 'ert--results-progress-bar-button
+ 'face (or (and font-lock
+ (ert-face-for-stats stats))
+ 'button))))
+ ;; The header gets copied verbatim to the results buffer,
+ ;; and all positions remain the same, so
+ ;; `progress-bar-button-begin' will be the right position
+ ;; even in the results buffer.
+ (with-current-buffer results-buffer
+ (set (make-local-variable 'ert--results-progress-bar-button-begin)
+ progress-bar-button-begin))))
+ (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. (It's possible
+ ;; that this bug has been fixed since this has been tested; we
+ ;; should test it again.)
+ "\n")))
+
+
+(defvar ert-test-run-redisplay-interval-secs .1
+ "How many seconds ERT should wait between redisplays while running tests.
+
+While running tests, ERT shows the current progress, and this variable
+determines how frequently the progress display is updated.")
+
+(defun ert--results-update-stats-display (ewoc stats)
+ "Update EWOC and the mode line to show data from STATS."
+ ;; TODO(ohler): investigate using `make-progress-reporter'.
+ (ert--results-update-ewoc-hf ewoc stats)
+ (force-mode-line-update)
+ (redisplay t)
+ (setf (ert--stats-next-redisplay stats)
+ (+ (float-time) ert-test-run-redisplay-interval-secs)))
+
+(defun ert--results-update-stats-display-maybe (ewoc stats)
+ "Call `ert--results-update-stats-display' if not called recently.
+
+EWOC and STATS are arguments for `ert--results-update-stats-display'."
+ (when (>= (float-time) (ert--stats-next-redisplay stats))
+ (ert--results-update-stats-display ewoc stats)))
+
+(defun ert--tests-running-mode-line-indicator ()
+ "Return a string for the mode line that shows the test run progress."
+ (let* ((stats ert--current-run-stats)
+ (tests-total (ert-stats-total stats))
+ (tests-completed (ert-stats-completed 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--make-xrefs-region (begin end)
+ "Attach cross-references to function names between BEGIN and END.
+
+BEGIN and END specify a region in the current buffer."
+ (save-excursion
+ (save-restriction
+ (narrow-to-region begin (point))
+ ;; Inhibit optimization in `debugger-make-xrefs' that would
+ ;; sometimes insert unrelated backtrace info into our buffer.
+ (let ((debugger-previous-backtrace nil))
+ (debugger-make-xrefs)))))
+
+(defun ert--string-first-line (s)
+ "Return the first line of S, or S if it contains no newlines.
+
+The return value does not include the line terminator."
+ (substring s 0 (ert--string-position ?\n s)))
+
+(defun ert-face-for-test-result (expectedp)
+ "Return a face that shows whether a test result was expected or unexpected.
+
+If EXPECTEDP is nil, returns the face for unexpected results; if
+non-nil, returns the face for expected results.."
+ (if expectedp 'ert-test-result-expected 'ert-test-result-unexpected))
+
+(defun ert-face-for-stats (stats)
+ "Return a face that represents STATS."
+ (cond ((ert--stats-aborted-p stats) 'nil)
+ ((plusp (ert-stats-completed-unexpected stats))
+ (ert-face-for-test-result nil))
+ ((eql (ert-stats-completed-expected stats) (ert-stats-total stats))
+ (ert-face-for-test-result t))
+ (t 'nil)))
+
+(defun ert--print-test-for-ewoc (entry)
+ "The ewoc print function for ewoc test entries. ENTRY is the entry to print."
+ (let* ((test (ert--ewoc-entry-test entry))
+ (stats ert--results-stats)
+ (result (let ((pos (ert--stats-test-pos stats test)))
+ (assert pos)
+ (aref (ert--stats-test-results stats) pos)))
+ (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
+ (let ((expectedp (ert-test-result-expected-p test result)))
+ (insert-text-button (format "%c" (ert-char-for-test-result
+ result expectedp))
+ :type 'ert--results-expand-collapse-button
+ 'face (or (and font-lock-mode
+ (ert-face-for-test-result
+ expectedp))
+ 'button)))
+ (insert " ")
+ (ert-insert-test-name-button (ert-test-name test))
+ (insert "\n")
+ (when (and expandedp (not (eql result 'nil)))
+ (when (ert-test-documentation test)
+ (insert " "
+ (propertize
+ (ert--string-first-line (ert-test-documentation test))
+ 'font-lock-face 'font-lock-doc-face)
+ "\n"))
+ (etypecase result
+ (ert-test-passed
+ (if (ert-test-result-expected-p test result)
+ (insert " passed\n")
+ (insert " passed unexpectedly\n"))
+ (insert ""))
+ (ert-test-result-with-condition
+ (ert--insert-infos result)
+ (let ((print-escape-newlines t)
+ (print-level (if extended-printer-limits-p 12 6))
+ (print-length (if extended-printer-limits-p 100 10)))
+ (insert " ")
+ (let ((begin (point)))
+ (ert--pp-with-indentation-and-newline
+ (ert-test-result-with-condition-condition result))
+ (ert--make-xrefs-region begin (point)))))
+ (ert-test-aborted-with-non-local-exit
+ (insert " aborted\n")))
+ (insert "\n")))))
+ nil)
+
+(defun ert--results-font-lock-function (enabledp)
+ "Redraw the ERT results buffer after font-lock-mode was switched on or off.
+
+ENABLEDP is true if font-lock-mode is switched on, false
+otherwise."
+ (ert--results-update-ewoc-hf ert--results-ewoc ert--results-stats)
+ (ewoc-refresh ert--results-ewoc)
+ (font-lock-default-function enabledp))
+
+(defun ert--setup-results-buffer (stats listener buffer-name)
+ "Set up a test results buffer.
+
+STATS is the stats object; LISTENER is the results listener;
+BUFFER-NAME, if non-nil, is the buffer name to use."
+ (unless buffer-name (setq buffer-name "*ert*"))
+ (let ((buffer (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)
+ ;; Erase buffer again in case switching out of the previous
+ ;; mode inserted anything. (This happens e.g. when switching
+ ;; from ert-results-mode to ert-results-mode when
+ ;; font-lock-mode turns itself off in change-major-mode-hook.)
+ (erase-buffer)
+ (set (make-local-variable 'font-lock-function)
+ 'ert--results-font-lock-function)
+ (let ((ewoc (ewoc-create 'ert--print-test-for-ewoc nil nil t)))
+ (set (make-local-variable 'ert--results-ewoc) ewoc)
+ (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)
+ (loop for test across (ert--stats-tests stats) do
+ (ewoc-enter-last ewoc
+ (make-ert--ewoc-entry :test test :hidden-p t)))
+ (ert--results-update-ewoc-hf ert--results-ewoc ert--results-stats)
+ (goto-char (1- (point-max)))
+ buffer)))))
+
+
+(defvar ert--selector-history nil
+ "List of recent test selectors read from terminal.")
+
+;; 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.
+
+SELECTOR works as described in `ert-select-tests'.
+OUTPUT-BUFFER-NAME and MESSAGE-FN should normally be nil; they
+are used for automated self-tests and specify which buffer to use
+and how to display message."
+ (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
+ default 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-completed-expected stats)
+ (let ((unexpected
+ (ert-stats-completed-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-pos stats test))
+ (node (ewoc-nth ewoc pos)))
+ (assert node)
+ (setf (ert--ewoc-entry-test (ewoc-data node)) test)
+ (aset ert--results-progress-bar-string pos
+ (ert-char-for-test-result nil t))
+ (ert--results-update-stats-display-maybe 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-pos stats test))
+ (node (ewoc-nth ewoc pos)))
+ (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-maybe ewoc stats)
+ (ewoc-invalidate ewoc node))))))))
+ (ert-run-tests
+ selector
+ listener)))
+;;;###autoload
+(defalias 'ert 'ert-run-tests-interactively)
+
+
+;;; Simple view mode for auxiliary information like stack traces or
+;;; messages. Mainly binds "q" for quit.
+
+(define-derived-mode ert-simple-view-mode fundamental-mode "ERT-View"
+ "Major mode for viewing auxiliary information in ERT.")
+
+(loop for (key binding) in
+ '(("q" quit-window)
+ )
+ do
+ (define-key ert-simple-view-mode-map key binding))
+
+
+;;; 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
+ '(;; Stuff that's not in the menu.
+ ("\t" forward-button)
+ ([backtab] backward-button)
+ ("j" ert-results-jump-between-summary-and-result)
+ ("q" quit-window)
+ ("L" ert-results-toggle-printer-limits-for-test-at-point)
+ ("n" ert-results-next-test)
+ ("p" ert-results-previous-test)
+ ;; Stuff that is in the menu.
+ ("R" ert-results-rerun-all-tests)
+ ("r" ert-results-rerun-test-at-point)
+ ("d" ert-results-rerun-test-at-point-debugging-errors)
+ ("." ert-results-find-test-at-point-other-window)
+ ("b" ert-results-pop-to-backtrace-for-test-at-point)
+ ("m" ert-results-pop-to-messages-for-test-at-point)
+ ("l" ert-results-pop-to-should-forms-for-test-at-point)
+ ("h" ert-results-describe-test-at-point)
+ ("D" ert-delete-test)
+ ("T" ert-results-pop-to-timings)
+ )
+ do
+ (define-key ert-results-mode-map key binding))
+
+(easy-menu-define ert-results-mode-menu ert-results-mode-map
+ "Menu for `ert-results-mode'."
+ '("ERT Results"
+ ["Re-run all tests" ert-results-rerun-all-tests]
+ "--"
+ ["Re-run test" ert-results-rerun-test-at-point]
+ ["Debug test" ert-results-rerun-test-at-point-debugging-errors]
+ ["Show test definition" ert-results-find-test-at-point-other-window]
+ "--"
+ ["Show backtrace" ert-results-pop-to-backtrace-for-test-at-point]
+ ["Show messages" ert-results-pop-to-messages-for-test-at-point]
+ ["Show `should' forms" ert-results-pop-to-should-forms-for-test-at-point]
+ ["Describe test" ert-results-describe-test-at-point]
+ "--"
+ ["Delete test" ert-delete-test]
+ "--"
+ ["Show execution time of each test" ert-results-pop-to-timings]
+ ))
+
+(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.
+ ;;
+ ;; Update: I'm seeing nil being returned in some cases now,
+ ;; perhaps this has been changed?
+ (if (and node
+ (>= (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-next-test ()
+ "Move point to the next test.
+
+To be used in the ERT results buffer."
+ (interactive)
+ (ert--results-move (ewoc-locate ert--results-ewoc) 'ewoc-next
+ "No tests below"))
+
+(defun ert-results-previous-test ()
+ "Move point to the previous test.
+
+To be used in the ERT results buffer."
+ (interactive)
+ (ert--results-move (ewoc-locate ert--results-ewoc) 'ewoc-prev
+ "No tests above"))
+
+(defun ert--results-move (node ewoc-fn error-message)
+ "Move point from NODE to the previous or next node.
+
+EWOC-FN specifies the direction and should be either `ewoc-prev'
+or `ewoc-next'. If there are no more nodes in that direction, an
+error is signalled with the message ERROR-MESSAGE."
+ (loop
+ (setq node (funcall ewoc-fn ert--results-ewoc node))
+ (when (null node)
+ (error "%s" error-message))
+ (unless (ert--ewoc-entry-hidden-p (ewoc-data node))
+ (goto-char (ewoc-location node))
+ (return))))
+
+(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 ((name (ert-test-at-point)))
+ (unless name
+ (error "No test at point"))
+ (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)
+ ;; checkdoc-order: nil
+ "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-test-at-point ()
+ "Return the name of the test at point as a symbol, or nil if none."
+ (or (and (eql major-mode 'ert-results-mode)
+ (let ((test (ert--results-test-at-point-no-redefinition)))
+ (and test (ert-test-name test))))
+ (let* ((thing (thing-at-point 'symbol))
+ (sym (intern-soft thing)))
+ (and (ert-test-boundp sym)
+ sym))))
+
+(defun ert--results-test-at-point-no-redefinition ()
+ "Return the test at point, or nil.
+
+To be used in the ERT results buffer."
+ (assert (eql major-mode 'ert-results-mode))
+ (if (ert--results-test-node-or-null-at-point)
+ (let* ((node (ert--results-test-node-at-point))
+ (test (ert--ewoc-entry-test (ewoc-data node))))
+ test)
+ (let ((progress-bar-begin ert--results-progress-bar-button-begin))
+ (when (and (<= progress-bar-begin (point))
+ (< (point) (button-end (button-at progress-bar-begin))))
+ (let* ((test-index (- (point) progress-bar-begin))
+ (test (aref (ert--stats-tests ert--results-stats)
+ test-index)))
+ test)))))
+
+(defun ert--results-test-at-point-allow-redefinition ()
+ "Look up the test at point, and check whether it has been redefined.
+
+To be used in the ERT results buffer.
+
+Returns a list of two elements: the test (or nil) and a symbol
+specifying whether the test has been redefined.
+
+If a new test has been defined with the same name as the test at
+point, replaces the test at point with the new test, and returns
+the new test and the symbol `redefined'.
+
+If the test has been deleted, returns the old test and the symbol
+`deleted'.
+
+If the test is still current, returns the test and the symbol nil.
+
+If there is no test at point, returns a list with two nils."
+ (let ((test (ert--results-test-at-point-no-redefinition)))
+ (cond ((null test)
+ `(nil nil))
+ ((null (ert-test-name test))
+ `(,test nil))
+ (t
+ (let* ((name (ert-test-name test))
+ (new-test (and (ert-test-boundp name)
+ (ert-get-test name))))
+ (cond ((eql test new-test)
+ `(,test nil))
+ ((null new-test)
+ `(,test deleted))
+ (t
+ (ert--results-update-after-test-redefinition
+ (ert--stats-test-pos ert--results-stats test)
+ new-test)
+ `(,new-test redefined))))))))
+
+(defun ert--results-update-after-test-redefinition (pos new-test)
+ "Update results buffer after the test at pos POS has been redefined.
+
+Also updates the stats object. NEW-TEST is the new test
+definition."
+ (let* ((stats ert--results-stats)
+ (ewoc ert--results-ewoc)
+ (node (ewoc-nth ewoc pos))
+ (entry (ewoc-data node)))
+ (ert--stats-set-test-and-result stats pos new-test nil)
+ (setf (ert--ewoc-entry-test entry) new-test
+ (aref ert--results-progress-bar-string pos) (ert-char-for-test-result
+ nil t))
+ (ewoc-invalidate ewoc node))
+ nil)
+
+(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)
+ "Jump to details for the test represented by the character clicked in BUTTON."
+ (goto-char (ert--button-action-position))
+ (ert-results-jump-between-summary-and-result))
+
+(defun ert-results-rerun-all-tests ()
+ "Re-run all tests, using the same selector.
+
+To be used in the ERT results buffer."
+ (interactive)
+ (assert (eql major-mode 'ert-results-mode))
+ (let ((selector (ert--stats-selector ert--results-stats)))
+ (ert-run-tests-interactively selector (buffer-name))))
+
+(defun ert-results-rerun-test-at-point ()
+ "Re-run the test at point.
+
+To be used in the ERT results buffer."
+ (interactive)
+ (destructuring-bind (test redefinition-state)
+ (ert--results-test-at-point-allow-redefinition)
+ (when (null test)
+ (error "No test at point"))
+ (let* ((stats ert--results-stats)
+ (progress-message (format "Running %stest %S"
+ (ecase redefinition-state
+ ((nil) "")
+ (redefined "new definition of ")
+ (deleted "deleted "))
+ (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 ert--results-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-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* ((test (ert--results-test-at-point-no-redefinition))
+ (stats ert--results-stats)
+ (pos (ert--stats-test-pos stats test))
+ (result (aref (ert--stats-test-results stats) pos)))
+ (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 (get-buffer-create "*ERT Backtrace*")))
+ (pop-to-buffer buffer)
+ (setq buffer-read-only t)
+ (let ((inhibit-read-only t))
+ (buffer-disable-undo)
+ (erase-buffer)
+ (ert-simple-view-mode)
+ ;; 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))
+ (insert "Backtrace for test `")
+ (ert-insert-test-name-button (ert-test-name test))
+ (insert "':\n")))))))
+
+(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* ((test (ert--results-test-at-point-no-redefinition))
+ (stats ert--results-stats)
+ (pos (ert--stats-test-pos stats test))
+ (result (aref (ert--stats-test-results stats) pos)))
+ (let ((buffer (get-buffer-create "*ERT Messages*")))
+ (pop-to-buffer buffer)
+ (setq buffer-read-only t)
+ (let ((inhibit-read-only t))
+ (buffer-disable-undo)
+ (erase-buffer)
+ (ert-simple-view-mode)
+ (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-pop-to-should-forms-for-test-at-point ()
+ "Display the list of `should' forms executed during the test at point.
+
+To be used in the ERT results buffer."
+ (interactive)
+ (let* ((test (ert--results-test-at-point-no-redefinition))
+ (stats ert--results-stats)
+ (pos (ert--stats-test-pos stats test))
+ (result (aref (ert--stats-test-results stats) pos)))
+ (let ((buffer (get-buffer-create "*ERT list of should forms*")))
+ (pop-to-buffer buffer)
+ (setq buffer-read-only t)
+ (let ((inhibit-read-only t))
+ (buffer-disable-undo)
+ (erase-buffer)
+ (ert-simple-view-mode)
+ (if (null (ert-test-result-should-forms result))
+ (insert "\n(No should forms during this test.)\n")
+ (loop for form-description in (ert-test-result-should-forms result)
+ for i from 1 do
+ (insert "\n")
+ (insert (format "%s: " i))
+ (let ((begin (point)))
+ (ert--pp-with-indentation-and-newline form-description)
+ (ert--make-xrefs-region begin (point)))))
+ (goto-char (point-min))
+ (insert "`should' forms executed during test `")
+ (ert-insert-test-name-button (ert-test-name test))
+ (insert "':\n")
+ (insert "\n")
+ (insert (concat "(Values are shallow copies and may have "
+ "looked different during the test if they\n"
+ "have been modified destructively.)\n"))
+ (forward-line 1)))))
+
+(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-results-pop-to-timings ()
+ "Display test timings for the last run.
+
+To be used in the ERT results buffer."
+ (interactive)
+ (let* ((stats ert--results-stats)
+ (start-times (ert--stats-test-start-times stats))
+ (end-times (ert--stats-test-end-times stats))
+ (buffer (get-buffer-create "*ERT timings*"))
+ (data (loop for test across (ert--stats-tests stats)
+ for start-time across (ert--stats-test-start-times stats)
+ for end-time across (ert--stats-test-end-times stats)
+ collect (list test
+ (float-time (subtract-time end-time
+ start-time))))))
+ (setq data (sort data (lambda (a b)
+ (> (second a) (second b)))))
+ (pop-to-buffer buffer)
+ (setq buffer-read-only t)
+ (let ((inhibit-read-only t))
+ (buffer-disable-undo)
+ (erase-buffer)
+ (ert-simple-view-mode)
+ (if (null data)
+ (insert "(No data)\n")
+ (insert (format "%-3s %8s %8s\n" "" "time" "cumul"))
+ (loop for (test time) in data
+ for cumul-time = time then (+ cumul-time time)
+ for i from 1 do
+ (let ((begin (point)))
+ (insert (format "%3s: %8.3f %8.3f " i time cumul-time))
+ (ert-insert-test-name-button (ert-test-name test))
+ (insert "\n"))))
+ (goto-char (point-min))
+ (insert "Tests by run time (seconds):\n\n")
+ (forward-line 1))))
+
+;;;###autoload
+(defun ert-describe-test (test-or-test-name)
+ "Display the documentation for TEST-OR-TEST-NAME (a symbol or ert-test)."
+ (interactive (list (ert-read-test-name-at-point "Describe test")))
+ (when (< emacs-major-version 24)
+ (error "Requires Emacs 24"))
+ (let (test-name
+ test-definition)
+ (etypecase test-or-test-name
+ (symbol (setq test-name test-or-test-name
+ test-definition (ert-get-test test-or-test-name)))
+ (ert-test (setq test-name (ert-test-name test-or-test-name)
+ test-definition test-or-test-name)))
+ (help-setup-xref (list #'ert-describe-test test-or-test-name)
+ (called-interactively-p 'interactive))
+ (save-excursion
+ (with-help-window (help-buffer)
+ (with-current-buffer (help-buffer)
+ (insert (if test-name (format "%S" test-name) "<anonymous test>"))
+ (insert " is a test")
+ (let ((file-name (and test-name
+ (symbol-file test-name 'ert-deftest))))
+ (when file-name
+ (insert " defined in `" (file-name-nondirectory file-name) "'")
+ (save-excursion
+ (re-search-backward "`\\([^`']+\\)'" nil t)
+ (help-xref-button 1 'help-function-def test-name file-name)))
+ (insert ".")
+ (fill-region-as-paragraph (point-min) (point))
+ (insert "\n\n")
+ (unless (and (ert-test-boundp test-name)
+ (eql (ert-get-test test-name) test-definition))
+ (let ((begin (point)))
+ (insert "Note: This test has been redefined or deleted, "
+ "this documentation refers to an old definition.")
+ (fill-region-as-paragraph begin (point)))
+ (insert "\n\n"))
+ (insert (or (ert-test-documentation test-definition)
+ "It is not documented.")
+ "\n")))))))
+
+(defun ert-results-describe-test-at-point ()
+ "Display the documentation of the test at point.
+
+To be used in the ERT results buffer."
+ (interactive)
+ (ert-describe-test (ert--results-test-at-point-no-redefinition)))
+
+
+;;; 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 ()
+ "Unload function to undo the side-effects of loading ert.el."
+ (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)
+
+
+(provide 'ert)
+
+;;; ert.el ends here
diff --git a/test/notmuch-test b/test/notmuch-test
index 43565e8..7c5fceb 100755
--- a/test/notmuch-test
+++ b/test/notmuch-test
@@ -24,7 +24,7 @@ trap 'die' 0
cd $(dirname "$0")
-TESTS="basic new search search-output json thread-naming raw reply dump-restore uuencode thread-order author-order from-guessing long-id encoding emacs maildir-sync"
+TESTS="basic new search search-output json thread-naming raw reply dump-restore uuencode thread-order author-order from-guessing long-id encoding emacs maildir-sync emacs-ert"
# Clean up any results from a previous run
rm -rf test-results >/dev/null 2>/dev/null
--
1.7.2.3
More information about the notmuch
mailing list