Return-Path: X-Original-To: notmuch@notmuchmail.org Delivered-To: notmuch@notmuchmail.org Received: from localhost (localhost [127.0.0.1]) by olra.theworths.org (Postfix) with ESMTP id 3D8F7431FB6 for ; Thu, 25 Nov 2010 03:03:52 -0800 (PST) X-Virus-Scanned: Debian amavisd-new at olra.theworths.org X-Spam-Flag: NO X-Spam-Score: 0 X-Spam-Level: X-Spam-Status: No, score=0 tagged_above=-999 required=5 tests=[RCVD_IN_DNSWL_NONE=-0.0001] autolearn=disabled Received: from olra.theworths.org ([127.0.0.1]) by localhost (olra.theworths.org [127.0.0.1]) (amavisd-new, port 10024) with ESMTP id JDfGCrIpMv1v for ; Thu, 25 Nov 2010 03:03:24 -0800 (PST) Received: from mail-wy0-f181.google.com (mail-wy0-f181.google.com [74.125.82.181]) by olra.theworths.org (Postfix) with ESMTP id 052B0431FB5 for ; Thu, 25 Nov 2010 03:03:22 -0800 (PST) Received: by wyf22 with SMTP id 22so827352wyf.26 for ; Thu, 25 Nov 2010 03:03:21 -0800 (PST) Received: by 10.227.145.136 with SMTP id d8mr630189wbv.172.1290683000441; Thu, 25 Nov 2010 03:03:20 -0800 (PST) Received: from ut.hh.sledj.net (host81-149-164-25.in-addr.btopenworld.com [81.149.164.25]) by mx.google.com with ESMTPS id x12sm253252weq.18.2010.11.25.03.03.17 (version=TLSv1/SSLv3 cipher=RC4-MD5); Thu, 25 Nov 2010 03:03:18 -0800 (PST) Received: by ut.hh.sledj.net (Postfix, from userid 1000) id E9D01594058; Thu, 25 Nov 2010 10:59:18 +0000 (GMT) From: David Edmondson To: notmuch@notmuchmail.org Subject: [PATCH 1/3] test: Add ERT for emacs testing. Date: Thu, 25 Nov 2010 10:59:08 +0000 Message-Id: <1290682750-30283-1-git-send-email-dme@dme.org> X-Mailer: git-send-email 1.7.2.3 In-Reply-To: <1290632444-10046-1-git-send-email-cworth@cworth.org> References: <1290632444-10046-1-git-send-email-cworth@cworth.org> X-Mailman-Approved-At: Thu, 25 Nov 2010 09:26:16 -0800 X-BeenThere: notmuch@notmuchmail.org X-Mailman-Version: 2.1.13 Precedence: list List-Id: "Use and development of the notmuch mail system." List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , X-List-Received-Date: Thu, 25 Nov 2010 11:03:52 -0000 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 ,@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 ""))) + (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) "")) + (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))) + "") + (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 () ,@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 () ,@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 () ,@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 ,@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 ,@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))) + ,@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 ,@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 ""))) + (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 + '(("(\\(\\\\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) "")) + (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