* ert.el --- Emacs Lisp Regression Testing
@ 2007-12-30 23:00 Christian Ohler
2007-12-30 23:28 ` Lennart Borgman (gmail)
` (2 more replies)
0 siblings, 3 replies; 12+ messages in thread
From: Christian Ohler @ 2007-12-30 23:00 UTC (permalink / raw)
To: emacs-devel
[-- Attachment #1: Type: text/plain, Size: 537 bytes --]
I'm a big fan of automated testing/unit testing. However, it seems that
there is no widely-used testing framework for Emacs Lisp yet. I've
tried various packages (regress.el, elunit.el, elk-test.el, XEmacs'
test-harness.el, the code in slime.el, and cc-mode's tests), but they're
all either too simplistic, very specialized, or not very Lispy.
Here's the code that I use at the moment. It requires Emacs 22.
Please try it out and let me know what you think. Something like this
really ought to be added to Emacs.
Christian.
[-- Attachment #2: ert.el --]
[-- Type: text/plain, Size: 88074 bytes --]
;;; ert.el --- Emacs Lisp Regression Testing
;; Copyright (C) 2007 Christian M. Ohler
;; 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 `deftest', which is similar to `defun'
;; but defines a test, and `ert-run-tests-interactively', which runs
;; tests and offers an interactive interface for inspecting results
;; and debugging. There is also `ert-run-tests-batch' for
;; non-interactive use.
;;
;; The body of `deftest' forms resembles a function body, but the
;; additional operators `should', `should-not' and `should-error' are
;; available. `should' is similar to cl's `assert', but signals a
;; different error when its condition is violated that is caught and
;; processed by ERT. In addition, it analyzes its argument form and
;; records information that helps debugging (`assert' tries to do
;; something similar when its second argument SHOW-ARGS is true, but
;; `should' is more sophisticated). For information on `should-not'
;; and `should-error', see their docstrings.
;;
;; For example,
;;
;; ;; Define a test named `foo'.
;; (deftest foo ()
;; (should (= (+ 1 2) 4)))
;;
;; ;; Run it.
;; (ert-run-tests-interactively 'foo)
;;
;; generates the following output (in addition to some statistics) in
;; the *ert* results buffer:
;;
;; F foo
;; (ert-test-failed
;; ((should
;; (=
;; (+ 1 2)
;; 4))
;; :form
;; (= 3 4)
;; :value nil))
;;
;; This indicates that the test failed. The `should' form that failed
;; was (should (= (+ 1 2) 4)), because its inner form, after
;; evaluation of its arguments, was the function call (= 3 4), which
;; returned nil.
;;
;; Obviously, this is a bug in the test case, not in the functions `+'
;; or `='. In the results buffer, with point on the test result, the
;; key "." can be used to jump to the definition of the test to modify
;; it to correct the bug. After evaluating the modified definition
;; and switching back to the results buffer, the key "r" will re-run
;; the test and show the new result.
;; Test selectors
;;
;; Functions like `ert-run-tests-interactively' accept a test
;; selector, which is a Lisp expression specifying a set of tests.
;; Each test name is a selector that refers to that test, the selector
;; `t' refers to all tests, and the selector `:failed' refers to all
;; tests that failed; but more complex selectors are available. Test
;; selector syntax is similar to cl's type specifier syntax. See the
;; docstring of `ert-select-tests' for details.
;; Comparison with other testing tools
;;
;; ERT allows test-driven development similar to *Unit frameworks for
;; other languages. However, two common *Unit features are notably
;; absent from ERT: fixtures and test suites.
;;
;; Fixtures, as used e.g. in SUnit or JUnit, have two main purposes:
;; Setting up (and tearing down) an environment for a set of test
;; cases, and making that environment accessible through object
;; attributes that can be used like local variables.
;;
;; While fixtures are a great syntactic simplification in other
;; languages, they are not very useful in Lisp, where higher-order
;; functions and `unwind-protect' are available. One way to implement
;; and use a fixture in ERT is
;;
;; (defun my-fixture (body)
;; (unwind-protect
;; (progn ...set up...
;; (funcall body))
;; ...tear down...))
;;
;; (deftest my-test ()
;; (my-fixture
;; (lambda ()
;; ...test code...)))
;;
;; (Another way would be a `with-my-fixture' macro.) This solves the
;; set-up and tear-down part, and additionally allows any test case to
;; use any combination of fixtures, so it is more general than what
;; other tools typically allow.
;;
;; If the test case needs access to the environment the fixture sets
;; up, the fixture can be modified to pass arguments to the body.
;;
;; These are standard Lisp idioms. Special syntax for them could be
;; added easily enough, but would provide only a minor simplification.
;;
;; (Note that splitting set-up and tear-down into separate functions,
;; like *Unit tools usually do, makes it impossible to establish
;; dynamic `let' bindings as part of the fixture. So, blindly
;; imitating the way fixtures are implemented in other languages would
;; be counter-productive in Lisp.)
;;
;;
;; The purpose of test suites is to group related test cases together.
;; The most common use of this is to run just the tests for one
;; particular module. Since symbol prefixes are the usual way of
;; separating module namespaces in Emacs Lisp, test selectors already
;; solve this by allowing regexp matching on test names; e.g., the
;; selector "^ert-" selects ERT's self-tests.
;;
;; If test suites containing arbitrary sets of tests are found to be
;; desirable, it would be easy to add a `define-test-selector'
;; mechanism that introduces a new selector, defined in terms of
;; existing ones; e.g.
;;
;; ;; Note that `define-test-selector' does not exist yet.
;; (define-test-selector my-test-suite () `(member foo-test bar-test))
;;
;; would define a test suite named `my-test-suite' consisting of
;; `foo-test' and `bar-test'. See also `deftype' in Common Lisp.
;;; Code:
(require 'cl)
(require 'ewoc)
(require 'find-func)
(require 'debug)
(defvar ert-debug-on-error nil
"Non-nil means enter debugger when a test fails or terminates with an error.")
;;; Defining and locating tests.
;; The data structure that represents a test case.
(defstruct ert-test
(name nil)
(documentation nil)
(body (assert nil))
(most-recent-result nil)
(expected-result-type 'ert-test-passed))
(defun ert-test-boundp (symbol)
"Return non-nil if SYMBOL names a test."
(and (get symbol 'ert-test) t))
(defun ert-get-test (symbol)
"If SYMBOL names a test, return that. Signal an error otherwise."
(assert (ert-test-boundp symbol) t)
(get symbol 'ert-test))
(defun ert-set-test (symbol definition)
"Make SYMBOL name the test DEFINITION, and return DEFINITION."
(put symbol 'ert-test definition)
definition)
(defun ert-make-test-unbound (symbol)
"Make SYMBOL name no test. Return SYMBOL."
(remprop symbol 'ert-test)
symbol)
(defun ert-test-result-expected-p (test result)
"Return non-nil if RESULT matches the expected result type for TEST."
(typep result (ert-test-expected-result-type test)))
(defvar ert-find-test-regexp
(concat "^\\s-*(deftest"
find-function-space-re
"%s\\(\\s-\\|$\\)")
"The regexp the `find-function' mechanisms use for locating test definitions.")
(eval-and-compile
(defun ert-parse-keys-and-body (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* deftest (name () &body keys-and-body)
"Define NAME (a symbol) as a test.
\(fn NAME () [:documentation DOCSTRING] [:expected-result TYPE] BODY...)"
(declare (debug (&define :name test name sexp
[&optional [":documentation" stringp]]
[&optional [":expected-result" sexp]]
def-body)))
(destructuring-bind ((&key (expected-result nil expected-result-supplied-p)
(documentation nil documentation-supplied-p))
body)
(ert-parse-keys-and-body keys-and-body)
`(progn
(ert-set-test ',name
(make-ert-test
:name ',name
:body (lambda () ,@body)
,@(when expected-result-supplied-p
`(:expected-result-type ,expected-result))
,@(when documentation-supplied-p
`(:documentation ,documentation))))
;; This hack allows `symbol-file' to associate `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 '(deftest . ,name) current-load-list)
',name)))
(defun ert-read-test-name (prompt &optional default-value history)
"Read the name of a test and return it as a symbol.
Prompt with PROMPT. By default, return DEFAULT-VALUE."
(when (symbolp default-value) (setq default-value (symbol-name default-value)))
(intern (completing-read prompt obarray #'ert-test-boundp
t nil history default-value nil)))
(defun ert-find-test-other-window (test-name)
"Find, in another window, the definition of TEST-NAME."
(interactive (list (ert-read-test-name "Find test definition: ")))
(find-function-do-it test-name 'deftest 'switch-to-buffer-other-window))
(defun ert-delete-test (test-name)
"An interactive interface to `ert-make-test-unbound'."
(interactive (list (let ((default (thing-at-point 'symbol)))
(when default
(set-text-properties 0 (length default) nil default)
(when (or (string= default "nil") (intern-soft default))
(setq default (intern default)))
(unless (ert-test-boundp default)
(setq default nil)))
(completing-read (if (null default)
"Delete test: "
(format "Delete test (default %s): "
default))
obarray #'ert-test-boundp
'really-require-match
nil nil default nil))))
(ert-make-test-unbound test-name))
(defun ert-delete-all-tests ()
"Make all symbols in `obarray' name no test."
(interactive)
(when (interactive-p)
(unless (y-or-n-p "Delete all tests? ")
(error "Aborted")))
(mapc #'ert-delete-test (mapcar #'ert-test-name (ert-select-tests t t)))
t)
;;; Test selectors.
(defun ert-select-tests (selector universe)
"Select, from UNIVERSE, a set of tests according to SELECTOR.
UNIVERSE should be a list of tests, or t, which refers to all
tests named by symbols in `obarray'.
Returns the set of tests as a list.
Valid selectors:
nil -- Selects the empty set.
t -- Selects UNIVERSE.
:new -- Selects all tests that have not been run yet.
:failed, :passed, :error -- Select tests according to their most recent result.
:expected, :unexpected -- Select tests according to their most recent result.
a string -- Selects all tests that have a name that matches the string, a regexp.
a test -- Selects that test.
a symbol -- Selects the test that the symbol names, errors if none.
\(member TESTS...\) -- Selects TESTS, a list of tests or symbols naming tests.
\(eql TEST\) -- Selects TEST, a test or a symbol naming a test.
\(and SELECTORS...\) -- Selects the tests that match all SELECTORS.
\(or SELECTORS...\) -- Selects the tests that match any SELECTOR.
\(not SELECTOR\) -- Selects all tests that do not match SELECTOR.
\(satisfies PREDICATE\) -- Selects all tests that satisfy PREDICATE.
Only selectors that require a superset of tests, such
as (satisfies ...), strings, :new, etc. make use of UNIVERSE.
Selectors that do not, such as \(member ...\), just return the
set implied by them without checking whether it is really
contained in UNIVERSE."
;; This code needs to match the etypecase in
;; `ert-insert-human-readable-selector'.
(etypecase selector
((member nil) nil)
((member t) (etypecase universe
(list universe)
((member t) (ert-select-tests "" universe))))
((member :new) (ert-select-tests
`(satisfies ,(lambda (test)
(typep (ert-test-most-recent-result test)
'null)))
universe))
((member :failed) (ert-select-tests
`(satisfies ,(lambda (test)
(typep (ert-test-most-recent-result test)
'ert-test-failed)))
universe))
((member :passed) (ert-select-tests
`(satisfies ,(lambda (test)
(typep (ert-test-most-recent-result test)
'ert-test-passed)))
universe))
((member :error) (ert-select-tests
`(satisfies ,(lambda (test)
(typep (ert-test-most-recent-result test)
'ert-test-error)))
universe))
((member :expected) (ert-select-tests
`(satisfies
,(lambda (test)
(ert-test-result-expected-p
test
(ert-test-most-recent-result test))))
universe))
((member :unexpected) (ert-select-tests `(not :expected) universe))
(string
(etypecase universe
((member t) (mapcar #'ert-get-test
(apropos-internal selector #'ert-test-boundp)))
(list (remove-if-not (lambda (test)
(and (ert-test-name test)
(string-match selector (ert-test-name test))))
universe))))
(ert-test (list selector))
(symbol
(assert (ert-test-boundp selector))
(list (ert-get-test selector)))
(cons
(destructuring-bind (operator &rest operands) selector
(ecase operator
(member
(mapcar (lambda (purported-test)
(etypecase purported-test
(symbol (assert (ert-test-boundp purported-test))
(ert-get-test purported-test))
(ert-test purported-test)))
operands))
(eql
(assert (eql (length operands) 1))
(ert-select-tests `(member ,@operands) universe))
(and
;; Do these definitions of AND, NOT and OR satisfy de
;; Morgan's rules? Should they?
(case (length operands)
(0 (ert-select-tests 't universe))
(t (ert-select-tests `(and ,@(rest operands))
(ert-select-tests (first operands) universe)))))
(not
(assert (eql (length operands) 1))
(set-difference (ert-select-tests 't universe)
(ert-select-tests (first operands) universe)))
(or
(case (length operands)
(0 (ert-select-tests 'nil universe))
(t (union (ert-select-tests (first operands) universe)
(ert-select-tests `(or ,@(rest operands)) universe)))))
(satisfies
(assert (eql (length operands) 1))
(remove-if-not (first operands) (ert-select-tests 't universe))))))))
(defun ert-insert-human-readable-selector (selector)
"Insert a human-readable presentation of SELECTOR into the current buffer."
;; This is needed to avoid printing the (huge) contents of the
;; `backtrace' slot of the result objects in the
;; `most-recent-result' slots of test case objects in (eql ...) or
;; (member ...) selectors.
(labels ((rec (selector)
;; This code needs to match the etypecase in `ert-select-tests'.
(etypecase selector
((or (member nil t
:new :failed :passed :error
:expected :unexpected)
string
symbol)
selector)
(ert-test
(if (ert-test-name selector)
(make-symbol (format "<%S>" (ert-test-name selector)))
(make-symbol "<unnamed test>")))
(cons
(destructuring-bind (operator &rest operands) selector
(ecase operator
((member eql and not or)
`(,operator ,@(mapcar #'rec operands)))
(satisfies
selector)))))))
(insert (format "%S" (rec selector)))))
;;; Running tests.
(put 'ert-test-failed 'error-conditions '(error ert-test-failed))
(put 'ert-test-failed 'error-message "Test failed")
(defun ert-pass ()
"Terminate the current test and mark it passed. Does not return."
(throw 'ert-pass nil))
(defun ert-fail (data)
"Terminate the current test and mark it failed. Does not return.
DATA is displayed to the user and should state the reason of the failure."
(signal 'ert-test-failed (list data)))
;; The data structures that represent the result of running a test.
(defstruct ert-test-result)
(defstruct (ert-test-passed (:include ert-test-result)))
(defstruct (ert-test-result-with-condition (:include ert-test-result)
(:conc-name ert-test-result-))
(condition (assert nil))
(backtrace (assert nil)))
(defstruct (ert-test-error (:include ert-test-result-with-condition)))
(defstruct (ert-test-quit (:include ert-test-result-with-condition)))
(defstruct (ert-test-failed (:include ert-test-result-with-condition)))
(defstruct (ert-test-aborted-with-non-local-exit (:include ert-test-result)))
(defun ert-record-backtrace ()
"Record the current backtrace (as a list) and return it."
;; Since the backtrace is stored in the result object, result
;; objects must only be printed with appropriate limits
;; (`print-level' and `print-length') in place. For interactive
;; use, the cost of ensuring this possibly outweighs the advantage
;; of storing the backtrace for
;; `ert-results-pop-to-backtrace-for-test-at-point' given that we
;; already have `ert-results-rerun-test-debugging-errors-at-point'.
;; For batch use, however, printing the backtrace may be useful.
(loop
;; 6 is the number of frames our own debugger adds (when
;; compiled; more when interpreted). FIXME: Need to describe a
;; procedure for determining this constant.
for i from 6
for frame = (backtrace-frame i)
while frame
collect frame))
;; A container for the state of the execution of a single test and
;; environment data needed during its execution.
(defstruct ert-test-execution-info
(test (assert nil))
(result (assert nil))
;; A thunk that may be called when RESULT has been set to its final
;; value and test execution should be terminated. Should not
;; return.
(exit-continuation (assert nil))
;; The binding of `debugger' outside of the execution of the test.
next-debugger
;; The binding of `ert-debug-on-error' that is in effect for the
;; execution of the current test. We store it to avoid being
;; affected by any new bindings the test itself may establish. (I
;; don't remember whether this feature is important.)
ert-debug-on-error)
(defun ert-run-test-debugger (info debugger-args)
"The function that `debugger' is bound to during the execution of tests.
Records failures and errors and either terminates the test
silently or calls the interactive debugger, as appropriate."
(destructuring-bind (first-debugger-arg &rest more-debugger-args) debugger-args
(ecase first-debugger-arg
((lambda debug t exit nil)
(apply (ert-test-execution-info-next-debugger info) debugger-args))
(error
(let* ((condition (first more-debugger-args))
(type (case (car condition)
((quit) 'quit)
((ert-test-failed) 'failed)
(otherwise 'error)))
(backtrace (ert-record-backtrace)))
(setf (ert-test-execution-info-result info)
(ecase type
(quit
(make-ert-test-quit :condition condition
:backtrace backtrace))
(failed
(make-ert-test-failed :condition condition
:backtrace backtrace))
(error
(make-ert-test-error :condition condition
:backtrace backtrace))))
;; Work around Emacs' heuristic (in eval.c) for detecting
;; errors in the debugger.
(incf num-nonmacro-input-events)
;; FIXME: We should probably implement more fine-grained
;; control a la non-t `debug-on-error' here.
(cond
((ert-test-execution-info-ert-debug-on-error info)
(apply (ert-test-execution-info-next-debugger info) debugger-args))
(t))
(funcall (ert-test-execution-info-exit-continuation info)))))))
(defun ert-run-test-internal (ert-test-execution-info)
(lexical-let ((info ert-test-execution-info))
(setf (ert-test-execution-info-next-debugger info) debugger
(ert-test-execution-info-ert-debug-on-error info) ert-debug-on-error)
(catch 'ert-pass
;; For now, each test gets its own temp buffer and its own
;; window excursion, just to be safe. If this turns out to be
;; too expensive, we can remove it.
(with-temp-buffer
(save-window-excursion
(let ((debugger (lambda (&rest debugger-args)
(ert-run-test-debugger info debugger-args)))
(debug-on-error t)
(debug-on-quit t)
;; FIXME: Do we need to store the old binding of this
;; and consider it in `ert-run-test-debugger'?
(debug-ignored-errors nil))
(funcall (ert-test-body (ert-test-execution-info-test info))))))
(ert-pass))
(setf (ert-test-execution-info-result info) (make-ert-test-passed))))
(defun ert-run-test (test)
"Runs TEST. Returns the result and records it in TEST's corresponding slot."
(setf (ert-test-most-recent-result test) nil)
(block error
(lexical-let ((info (make-ert-test-execution-info
:test test
:result (make-ert-test-aborted-with-non-local-exit)
:exit-continuation (lambda ()
(return-from error nil)))))
(unwind-protect
(ert-run-test-internal info)
(setf (ert-test-most-recent-result test)
(ert-test-execution-info-result info)))))
(ert-test-most-recent-result test))
;;; The `should' macros.
(eval-and-compile
(defun ert-special-operator-p (thing)
"Return non-nil if THING is a symbol naming a special operator."
(and (symbolp thing)
(fboundp thing)
(subrp (symbol-function thing))
(eql (cdr (subr-arity (symbol-function thing))) 'unevalled)))
(defun ert-expand-should (whole form env inner-expander)
"Helper function for the `should' macro and its variants.
Analyzes FORM and produces an expression that has the same
semantics under evaluation but records additional debugging
information. INNER-EXPANDER adds the actual checks specific to
the particular variant of `should'."
(let ((form (macroexpand form env)))
;; It's sort of a wart that `inner-expander' can't influence the
;; value the expansion returns.
(cond
((atom form)
(funcall inner-expander form `(list ',whole :form ',form :value ,form)))
((ert-special-operator-p (car form))
(let ((value (gensym "value-")))
`(let ((,value (make-symbol "ert-form-evaluation-aborted")))
,(funcall inner-expander
`(setq ,value ,form)
`(list ',whole :form ',form :value ,value))
,value)))
(t
(let ((fn-name (car form))
(arg-forms (cdr form)))
(assert (or (symbolp fn-name)
(and (consp fn-name)
(eql (car fn-name) 'lambda)
(listp (cdr fn-name)))))
(let ((fn (gensym "fn-"))
(args (gensym "args-"))
(value (gensym "value-"))
(default-value (gensym "ert-form-evaluation-aborted-")))
`(let ((,fn (function ,fn-name))
(,args (list ,@arg-forms)))
(let ((,value ',default-value))
,(funcall inner-expander
`(setq ,value (apply ,fn ,args))
`(nconc (list ',whole)
(list :form `(,,fn ,@,args))
(unless (eql ,value ',default-value)
(list :value ,value))
(let ((-explainer-
(and (symbolp ',fn-name)
(get ',fn-name
'ert-explainer))))
(when -explainer-
(list :explanation
(apply -explainer- ,args))))))
,value)))))))))
(defmacro* should (form &environment env)
"Evaluate FORM. If it returns nil, abort the current test as failed.
Returns the value of FORM."
(ert-expand-should `(should ,form) form env
(lambda (inner-form form-description-form)
`(unless ,inner-form
(ert-fail ,form-description-form)))))
(defmacro* should-not (form &environment env)
"Evaluate FORM. If it returns non-nil, abort the current test as failed.
Returns nil."
(ert-expand-should `(should-not ,form) form env
(lambda (inner-form form-description-form)
`(unless (not ,inner-form)
(ert-fail ,form-description-form)))))
(defun ert-should-error-handle-error (form-description-fn
condition type exclude-subtypes test)
"Helper function for `should-error'.
Determines whether CONDITION matches TYPE, EXCLUDE-SUBTYPES and
TEST, and aborts the current test as failed if it doesn't."
(let ((signalled-conditions (get (car condition) 'error-conditions))
(handled-conditions (etypecase type
(list type)
(symbol (list type)))))
(assert signalled-conditions)
(unless (intersection signalled-conditions handled-conditions)
(ert-fail (append
(funcall form-description-fn)
(list
:condition condition
:fail-reason (concat "the error signalled did not"
" have the expected type")))))
(when exclude-subtypes
(unless (member (car condition) handled-conditions)
(ert-fail (append
(funcall form-description-fn)
(list
:condition condition
:fail-reason (concat "the error signalled was a subtype"
" of the expected type"))))))
(unless (funcall test condition)
(ert-fail (append
(funcall form-description-fn)
(list
:condition condition
:fail-reason "the error signalled did not pass the test"))))))
;; FIXME: The expansion will evaluate the keyword args (if any) in
;; nonstandard order.
(defmacro* should-error (form &rest keys &key type exclude-subtypes test
&environment env)
"Evaluate FORM. Unless it signals an error, abort the current test as failed.
The error signalled additionally needs to match TYPE and satisfy
TEST. TYPE should be a condition name or a list of condition
names. If EXCLUDE-SUBTYPES is nil, the error matches TYPE if one
of its condition names is an element of TYPE. If
EXCLUDE-SUBTYPES is non-nil, the error matches TYPE if it is an
element of TYPE. TEST should be a predicate."
;; Returns a gensym named `ert-form-evaluation-aborted-XXX', but
;; that's a wart, so let's not document it.
(unless type (setq type ''error))
(unless test (setq test '(lambda (condition) t)))
(ert-expand-should
`(should-error ,form ,@keys)
form env
(lambda (inner-form form-description-form)
(let ((errorp (gensym "errorp"))
(form-description-fn (gensym "form-description-fn-")))
`(let ((,errorp nil)
(,form-description-fn (lambda () ,form-description-form)))
(condition-case -condition-
,inner-form
;; We can't use ,type here because we want to evaluate it.
(error
(setq ,errorp t)
(ert-should-error-handle-error ,form-description-fn
-condition-
,type ,exclude-subtypes ,test)
;; It would make sense to have the `should-error' form
;; return the error in this case, but `ert-expand-should'
;; doesn't allow that at the moment.
))
(unless ,errorp
(ert-fail (append
(funcall ,form-description-fn)
(list
:fail-reason "did not signal an error")))))))))
;;; Explanation of `should' failures.
(defun ert-proper-list-p (x)
"Returns non-nil if X is a proper list, nil otherwise."
(loop
for firstp = t then nil
for fast = x then (cddr fast)
for slow = x then (cdr slow) do
(when (null fast) (return t))
(when (not (consp fast)) (return nil))
(when (null (cdr fast)) (return t))
(when (not (consp (cdr fast))) (return nil))
(when (and (not firstp) (eq fast slow)) (return nil))))
(defun ert-explain-not-equal (a b)
"Return a programmer-readable explanation of why A and B are not `equal'.
Returns nil if they are equal."
(if (not (equal (type-of a) (type-of b)))
`(different-types ,a ,b)
(etypecase a
(cons
(let ((a-proper-p (ert-proper-list-p a))
(b-proper-p (ert-proper-list-p b)))
(if (not (eql (not a-proper-p) (not b-proper-p)))
`(one-list-proper-one-improper ,a ,b)
(if a-proper-p
(if (not (equal (length a) (length b)))
;; This would be even more helpful if it showed
;; something like what `set-difference' would
;; return.
`(proper-lists-of-different-length ,a ,b)
(loop for i from 0
for ai in a
for bi in b
for xi = (ert-explain-not-equal ai bi)
do (when xi (return `(list-elt ,i ,xi)))))
(let ((car-x (ert-explain-not-equal (car a) (car b))))
(if car-x
`(car ,car-x)
(let ((cdr-x (ert-explain-not-equal (cdr a) (cdr b))))
(if cdr-x
`(cdr ,cdr-x))
nil)))))))
(array (if (not (equal (length a) (length b)))
`(arrays-of-different-length ,a ,b)
(loop for i from 0
for ai across a
for bi across b
for xi = (ert-explain-not-equal ai bi)
do (when xi (return `(array-elt ,i ,xi))))))
(atom (if (not (equal a b))
`(different-atoms ,a ,b)
nil)))))
(put 'equal 'ert-explainer 'ert-explain-not-equal)
;;; Results display.
;; The data structure that contains the set of tests being executed
;; during one particular test run, their results, the state of the
;; execution, and some statistics.
;;
;; The data about results and expected results of tests may seem
;; redundant here, since the test objects also carry such information.
;; However, the information in the test objects may be more recent, it
;; may correspond to a different test run. We need the information
;; that corresponds to this run in order to be able to update the
;; statistics correctly when a test is re-run interactively and has a
;; different result than before.
(defstruct ert-stats
(selector (assert nil))
;; The tests, in order.
(tests (assert nil) :type vector)
;; A map of test names (or the test objects themselves for unnamed
;; tests) to indices into the `tests' vector.
(test-map (assert nil) :type hash-table)
;; The results of the tests during this run, in order.
(test-results (assert nil) :type vector)
;; The expected result types of the tests, in order.
(test-results-expected (assert nil) :type vector)
(total (assert nil))
(passed-expected 0)
(passed-unexpected 0)
(failed-expected 0)
(failed-unexpected 0)
(error-expected 0)
(error-unexpected 0)
(start-time (assert nil))
(end-time nil)
(aborted-p nil)
(current-test nil))
;; An entry in the results buffer ewoc. There is one entry per test.
(defstruct ert-ewoc-entry
(test (assert nil))
(result nil)
;; If the result of this test was expected, its ewoc entry is hidden
;; initially.
(hidden-p (assert nil))
;; An ewoc entry may be collapsed to hide details such as the error
;; condition.
;;
;; I'm not sure the ability to expand and collapse entries is still
;; a useful feature.
(expanded-p t)
;; By default, the ewoc entry presents the error condition with
;; certain limits on how much to print (`print-level',
;; `print-length'). The user can interactively switch to a set of
;; higher limits.
(extended-printer-limits-p nil))
;; Variables local to the results buffer.
;; The ewoc.
(defvar ert-results-ewoc)
;; The stats object.
(defvar ert-results-stats)
;; A string with one character per test. Each character represents
;; the result of the corresponding test. The string is displayed near
;; the top of the buffer and serves as a progress bar.
(defvar ert-results-progress-bar-string)
;; The position where the progress bar button begins.
(defvar ert-results-progress-bar-button-begin)
;; The test result listener that updates the buffer when tests are run.
(defvar ert-results-listener)
;; The same as `ert-results-stats', but dynamically bound. Used for
;; the mode line progress indicator.
(defvar ert-current-run-stats nil)
(defun ert-format-time-iso8601 (time)
"Format TIME in the particular variant of ISO 8601 used for timestamps in ERT."
(format-time-string "%Y-%m-%d %T%z" time))
(defun ert-results-update-ewoc-hf (ewoc stats)
"Update the header and footer of EWOC to show certain information from STATS.
Also sets `ert-results-progress-bar-button-begin'."
(let ((run-count (+ (ert-stats-passed-expected stats)
(ert-stats-passed-unexpected stats)
(ert-stats-failed-expected stats)
(ert-stats-failed-unexpected stats)
(ert-stats-error-expected stats)
(ert-stats-error-unexpected stats)))
(results-buffer (current-buffer)))
(ewoc-set-hf
ewoc
;; header
(with-temp-buffer
(insert "Selector: ")
(ert-insert-human-readable-selector (ert-stats-selector stats))
(insert "\n")
(insert
(format (concat "Passed: %s (%s unexpected)\n"
"Failed: %s (%s unexpected)\n"
"Error: %s (%s unexpected)\n"
"Total: %s/%s\n\n")
(+ (ert-stats-passed-expected stats)
(ert-stats-passed-unexpected stats))
(ert-stats-passed-unexpected stats)
(+ (ert-stats-failed-expected stats)
(ert-stats-failed-unexpected stats))
(ert-stats-failed-unexpected stats)
(+ (ert-stats-error-expected stats)
(ert-stats-error-unexpected stats))
(ert-stats-error-unexpected stats)
run-count
(ert-stats-total stats)))
(insert
(format "Started at: %s\n"
(ert-format-time-iso8601 (ert-stats-start-time stats))))
;; FIXME: This is ugly. Need to properly define invariants of
;; the `stats' data structure.
(let ((state (cond ((ert-stats-aborted-p stats)
'aborted)
((ert-stats-current-test stats)
'running)
((ert-stats-end-time stats)
'finished)
(t
'preparing))))
(ecase state
(preparing
(insert ""))
(aborted
(cond ((ert-stats-current-test stats)
(insert "Aborted during test: ")
(let ((test-name (ert-test-name
(ert-stats-current-test stats))))
(insert-text-button (format "%S" test-name)
:type 'ert-results-test-name-button
'ert-test-name test-name)))
(t
(insert "Aborted."))))
(running
(assert (ert-stats-current-test stats))
(insert "Running test: ")
(let ((test-name (ert-test-name (ert-stats-current-test stats))))
(insert-text-button (format "%S" test-name)
:type 'ert-results-test-name-button
'ert-test-name test-name)))
(finished
(assert (not (ert-stats-current-test stats)))
(insert "Finished.")))
(insert "\n")
(if (ert-stats-end-time stats)
(insert
(format "%s%s\n"
(if (ert-stats-aborted-p stats)
"Aborted at: "
"Finished at: ")
(ert-format-time-iso8601 (ert-stats-end-time stats))))
(insert "\n"))
(insert "\n"))
(let ((progress-bar-string (with-current-buffer results-buffer
ert-results-progress-bar-string)))
(let ((progress-bar-button-begin
(insert-text-button (substring progress-bar-string 0 run-count)
:type 'ert-results-progress-bar-button)))
(with-current-buffer results-buffer
(set (make-local-variable 'ert-results-progress-bar-button-begin)
progress-bar-button-begin)))
(insert (substring progress-bar-string run-count)))
(insert "\n\n")
(buffer-string))
;; footer
;;
;; We actually want an empty footer, but that would trigger a bug
;; in ewoc, sometimes clearing the entire buffer.
"\n")))
(defun ert-results-update-stats-display (ewoc stats)
"Update EWOC and the mode line to show data from STATS."
(ert-results-update-ewoc-hf ewoc stats)
(force-mode-line-update)
(redisplay t))
(defun ert-char-for-test-result (result expectedp)
"Return a character that represents the test result RESULT."
(let ((char
(etypecase result
(ert-test-passed ?.)
(ert-test-failed ?f)
(ert-test-error ?e)
(null ?-)
(ert-test-aborted-with-non-local-exit ?a))))
(if expectedp
char
(upcase char))))
(defun ert-string-for-test-result (result expectedp)
"Return a string that represents the test result RESULT."
(etypecase result
(ert-test-passed "passed")
(ert-test-failed "failed")
(ert-test-error "error")
(null "unknown")
(ert-test-aborted-with-non-local-exit "aborted")))
(defun ert-tests-running-mode-line-indicator ()
(let* ((stats ert-current-run-stats)
(tests-total (ert-stats-total stats))
(tests-completed (+ (ert-stats-passed-expected stats)
(ert-stats-passed-unexpected stats)
(ert-stats-failed-expected stats)
(ert-stats-failed-unexpected stats)
(ert-stats-error-expected stats)
(ert-stats-error-unexpected stats))))
(if (>= tests-completed tests-total)
(format " ERT(%s/%s,finished)" tests-completed tests-total)
(format " ERT(%s/%s):%s"
(1+ tests-completed)
tests-total
(if (null (ert-stats-current-test stats))
"?"
(format "%S"
(ert-test-name (ert-stats-current-test stats))))))))
(defun ert-pp-with-indentation-and-newline (object)
"Pretty-print OBJECT, indenting it to the current column of point.
Ensures a final newline is inserted."
(let ((begin (point)))
(pp object (current-buffer))
(unless (bolp) (insert "\n"))
(save-excursion
(goto-char begin)
(indent-sexp))))
(defun ert-print-test-for-ewoc (entry)
"The ewoc print function for ewoc test entries."
(let* ((test (ert-ewoc-entry-test entry))
(result (ert-ewoc-entry-result entry))
(hiddenp (ert-ewoc-entry-hidden-p entry))
(expandedp (ert-ewoc-entry-expanded-p entry))
(extended-printer-limits-p (ert-ewoc-entry-extended-printer-limits-p
entry)))
(cond (hiddenp)
(t
(insert-text-button (format "%c"
(ert-char-for-test-result
result
(ert-test-result-expected-p test
result)))
:type 'ert-results-expand-collapse-button)
(insert " ")
(insert-text-button (format "%S" (ert-test-name test))
:type 'ert-results-test-name-button
'ert-test-name (ert-test-name test))
(insert "\n")
(when (and expandedp (not (eql result 'nil)))
(etypecase result
(ert-test-passed
(insert " passed\n")
(insert ""))
(ert-test-result-with-condition
(insert " ")
(let ((print-escape-newlines t)
(print-level (if extended-printer-limits-p 10 5))
(print-length (if extended-printer-limits-p 100 10)))
(let ((begin (point)))
(ert-pp-with-indentation-and-newline
(ert-test-result-condition result))
(save-restriction
(narrow-to-region begin (point))
;; Inhibit optimization in `debugger-make-xrefs'
;; that sometimes inserts unrelated backtrace
;; info into our buffer.
(let ((debugger-previous-backtrace nil))
(debugger-make-xrefs))))))
(ert-test-aborted-with-non-local-exit
(insert " aborted\n")))
(insert "\n")))))
nil)
(defun ert-setup-results-buffer (stats listener buffer-name)
"Set up a test results buffer."
(unless buffer-name (setq buffer-name "*ert*"))
(let ((buffer (let ((default-major-mode 'fundamental-mode))
(get-buffer-create buffer-name))))
(with-current-buffer buffer
(setq buffer-read-only t)
(let ((inhibit-read-only t))
(buffer-disable-undo)
(erase-buffer)
(ert-results-mode)
(set (make-local-variable 'ert-results-ewoc)
(ewoc-create 'ert-print-test-for-ewoc nil nil t))
(set (make-local-variable 'ert-results-stats) stats)
(set (make-local-variable 'ert-results-progress-bar-string)
(make-string (ert-stats-total stats)
(ert-char-for-test-result nil t)))
(set (make-local-variable 'ert-results-listener) listener)
(ert-results-update-ewoc-hf ert-results-ewoc ert-results-stats)
(goto-char (1- (point-max)))
buffer))))
(defun ert-run-or-rerun-test (stats test listener)
"Run the single test TEST and record the result using STATS and LISTENER."
(let ((ert-current-run-stats stats)
(pos (ert-stats-test-index stats test))
(results (ert-stats-test-results stats))
(expected (ert-stats-test-results-expected stats)))
;; Adjust stats to remove previous result.
(if (aref expected pos)
(etypecase (aref results pos)
(ert-test-passed (decf (ert-stats-passed-expected stats)))
(ert-test-failed (decf (ert-stats-failed-expected stats)))
(ert-test-error (decf (ert-stats-error-expected stats)))
(null)
(ert-test-aborted-with-non-local-exit))
(etypecase (aref results pos)
(ert-test-passed (decf (ert-stats-passed-unexpected stats)))
(ert-test-failed (decf (ert-stats-failed-unexpected stats)))
(ert-test-error (decf (ert-stats-error-unexpected stats)))
(null)
(ert-test-aborted-with-non-local-exit)))
(setf (aref results pos) nil)
;; Call listener after setting/before resetting
;; (ert-stats-current-test stats); the listener might refresh the
;; mode line display, and if the value is not set yet/any more
;; during this refresh, the mode line will flicker unnecessarily.
(setf (ert-stats-current-test stats) test)
(funcall listener 'test-started stats test)
(setf (ert-test-most-recent-result test) nil)
(unwind-protect
(ert-run-test test)
(let* ((result (ert-test-most-recent-result test))
(expectedp (typep result (ert-test-expected-result-type test))))
;; Adjust stats to add new result.
(if expectedp
(etypecase result
(ert-test-passed (incf (ert-stats-passed-expected stats)))
(ert-test-failed (incf (ert-stats-failed-expected stats)))
(ert-test-error (incf (ert-stats-error-expected stats)))
(null)
(ert-test-aborted-with-non-local-exit))
(etypecase result
(ert-test-passed (incf (ert-stats-passed-unexpected stats)))
(ert-test-failed (incf (ert-stats-failed-unexpected stats)))
(ert-test-error (incf (ert-stats-error-unexpected stats)))
(null)
(ert-test-aborted-with-non-local-exit)))
(setf (aref results pos) result
(aref expected pos) expectedp)
(funcall listener 'test-ended stats test result))
(setf (ert-stats-current-test stats) nil))))
(defun ert-run-tests (selector listener)
"Run the tests specified by SELECTOR, sending progress updates to LISTENER."
(let* ((tests (coerce (ert-select-tests selector t) 'vector))
(map (let ((map (make-hash-table :size (length tests))))
(loop for i from 0
for test across tests
for key = (or (ert-test-name test) test) do
(assert (not (gethash key map)))
(setf (gethash key map) i))
map))
(stats (make-ert-stats :selector selector
:tests tests
:test-map map
:test-results (make-vector (length tests) nil)
:test-results-expected (make-vector
(length tests) nil)
:total (length tests)
:start-time (current-time))))
(funcall listener 'run-started stats)
(let ((abortedp t))
(let ((ert-current-run-stats stats))
(force-mode-line-update)
(unwind-protect
(progn
(loop for test across tests do
(ert-run-or-rerun-test stats test listener))
(setq abortedp nil))
(setf (ert-stats-aborted-p stats) abortedp)
(setf (ert-stats-end-time stats) (current-time))
(funcall listener 'run-ended stats abortedp)))
stats)))
(defun ert-stats-test-index (stats test)
"Return the index of TEST in the run represented by STATS."
(gethash (or (ert-test-name test) test) (ert-stats-test-map stats)))
(defvar ert-selector-history nil
"List of recent test selectors read from terminal.")
;; Should OUTPUT-BUFFER-NAME really be an argument here? It is 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)
"Run the tests specified by SELECTOR and display the results in a buffer."
(interactive
(list (let ((default (if ert-selector-history
(first ert-selector-history)
"t")))
(read-from-minibuffer (if (null default)
"Run tests: "
(format "Run tests (default %s): " default))
nil nil t 'ert-selector-history
default nil))
nil))
(lexical-let ((output-buffer-name output-buffer-name)
buffer
listener)
(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
(message "%sRan %s tests, %s results were as expected%s"
(if (not abortedp)
""
"Aborted: ")
(ert-stats-total stats)
(+ (ert-stats-passed-expected stats)
(ert-stats-failed-expected stats)
(ert-stats-error-expected stats))
(let ((unexpected
(+ (ert-stats-passed-unexpected stats)
(ert-stats-failed-unexpected stats)
(ert-stats-error-unexpected stats))))
(if (zerop unexpected)
""
(format ", %s unexpected" unexpected))))
(ert-results-update-stats-display (with-current-buffer buffer
ert-results-ewoc)
stats)))
(test-started
(destructuring-bind (stats test) event-args
(with-current-buffer buffer
(let* ((ewoc ert-results-ewoc)
(pos (ert-stats-test-index stats test))
(node (ewoc-nth ewoc pos)))
(unless node
;; FIXME: How expensive is this assertion?
(assert (or (zerop pos) (ewoc-nth ewoc (1- pos)))
t)
(setq node (ewoc-enter-last
ewoc
(make-ert-ewoc-entry :test test
:hidden-p t))))
(setf (ert-ewoc-entry-test (ewoc-data node)) test)
(setf (ert-ewoc-entry-result (ewoc-data node)) nil)
(aset ert-results-progress-bar-string pos
(ert-char-for-test-result nil t))
(ert-results-update-stats-display ewoc stats)
(ewoc-invalidate ewoc node)))))
(test-ended
(destructuring-bind (stats test result) event-args
(with-current-buffer buffer
(let* ((ewoc ert-results-ewoc)
(pos (ert-stats-test-index stats test))
(node (ewoc-nth ewoc pos)))
(setf (ert-ewoc-entry-result (ewoc-data node)) result)
(when (ert-ewoc-entry-hidden-p (ewoc-data node))
(setf (ert-ewoc-entry-hidden-p (ewoc-data node))
(ert-test-result-expected-p test result)))
(aset ert-results-progress-bar-string pos
(ert-char-for-test-result result
(ert-test-result-expected-p
test result)))
(ert-results-update-stats-display ewoc stats)
(ewoc-invalidate ewoc node))))))))
(ert-run-tests
selector
listener)))
(defvar ert-batch-backtrace-right-margin 70
"*The maximum line length for printing backtraces in `ert-run-tests-batch'.")
(defun ert-run-tests-batch (selector)
"Run the tests specified by SELECTOR, printing results to the terminal.
Returns the stats object."
(ert-run-tests
selector
(lambda (event-type &rest event-args)
(ecase event-type
(run-started
(destructuring-bind (stats) event-args
(message "Running %s tests (%s)"
(length (ert-stats-tests stats))
(ert-format-time-iso8601 (ert-stats-start-time stats)))))
(run-ended
(destructuring-bind (stats abortedp) event-args
(let ((unexpected (+ (ert-stats-passed-unexpected stats)
(ert-stats-failed-unexpected stats)
(ert-stats-error-unexpected stats))))
(message "\n%sRan %s tests, %s results were as expected%s (%s)\n"
(if (not abortedp)
""
"Aborted: ")
(ert-stats-total stats)
(+ (ert-stats-passed-expected stats)
(ert-stats-failed-expected stats)
(ert-stats-error-expected stats))
(if (zerop unexpected)
""
(format ", %s unexpected" unexpected))
(ert-format-time-iso8601 (ert-stats-end-time stats)))
(unless (zerop unexpected)
(message "%s unexpected results:" unexpected)
(loop for test across (ert-stats-tests stats)
for result = (ert-test-most-recent-result test) do
(when (not (ert-test-result-expected-p test result))
(message "%9s %S"
(ert-string-for-test-result result nil)
(ert-test-name test))))
(message "%s" "")))))
(test-started
)
(test-ended
(destructuring-bind (stats test result) event-args
(etypecase result
(ert-test-passed)
(ert-test-result-with-condition
(message "Test %S backtrace:" (ert-test-name test))
(with-temp-buffer
(ert-print-backtrace (ert-test-result-backtrace result))
(goto-char (point-min))
(while (not (eobp))
(let ((start (point))
(end (progn (end-of-line) (point))))
(setq end (min end
(+ start ert-batch-backtrace-right-margin)))
(message "%s" (buffer-substring-no-properties
start end)))
(forward-line 1)))
(with-temp-buffer
(insert " ")
(let ((print-escape-newlines t)
(print-level 5)
(print-length 10))
(let ((begin (point)))
(ert-pp-with-indentation-and-newline
(ert-test-result-condition result))))
(goto-char (1- (point-max)))
(assert (looking-at "\n"))
(delete-char 1)
(message "Test %S condition:" (ert-test-name test))
(message "%s" (buffer-string))))
(ert-test-aborted-with-non-local-exit))
(let* ((max (prin1-to-string (length (ert-stats-tests stats))))
(format-string (concat "%9s %"
(prin1-to-string (length max))
"s/" max " %S")))
(message format-string
(ert-string-for-test-result result
(ert-test-result-expected-p
test result))
(1+ (ert-stats-test-index stats test))
(ert-test-name test)))))))))
;;; Commands and button actions for the results buffer.
(define-derived-mode ert-results-mode fundamental-mode "ERT-Results"
"Major mode for viewing results of ERT test runs.")
(loop for (key binding) in
'(("j" ert-results-jump-between-summary-and-result)
("." ert-results-find-test-at-point-other-window)
("r" ert-results-rerun-test-at-point)
("d" ert-results-rerun-test-at-point-debugging-errors)
("b" ert-results-pop-to-backtrace-for-test-at-point)
("p" ert-results-toggle-printer-limits-for-test-at-point)
("D" ert-delete-test))
do
(define-key ert-results-mode-map key binding))
(define-button-type 'ert-results-progress-bar-button
'action #'ert-results-progress-bar-button-action
'help-echo "mouse-2, RET: Reveal test result")
(define-button-type 'ert-results-test-name-button
'action #'ert-results-test-name-button-action
'help-echo "mouse-2, RET: Find test definition")
(define-button-type 'ert-results-expand-collapse-button
'action #'ert-results-expand-collapse-button-action
'help-echo "mouse-2, RET: Expand/collapse test result")
(defun ert-results-test-node-or-null-at-point ()
"If point is on a valid ewoc node, return it; return nil otherwise.
To be used in the ERT results buffer."
(let* ((ewoc ert-results-ewoc)
(node (ewoc-locate ewoc)))
;; `ewoc-locate' will return an arbitrary node when point is on
;; header or footer, or when all nodes are invisible. So we need
;; to validate its return value here.
(if (and (>= (point) (ewoc-location node))
(not (ert-ewoc-entry-hidden-p (ewoc-data node))))
node
nil)))
(defun ert-results-test-node-at-point ()
"If point is on a valid ewoc node, return it; signal an error otherwise.
To be used in the ERT results buffer."
(or (ert-results-test-node-or-null-at-point)
(error "No test at point")))
(defun ert-results-expand-collapse-button-action (button)
"Expand or collapse the test node the button belongs to."
(let* ((ewoc ert-results-ewoc)
(node (save-excursion
(goto-char (ert-button-action-position))
(ert-results-test-node-at-point)))
(entry (ewoc-data node)))
(setf (ert-ewoc-entry-expanded-p entry)
(not (ert-ewoc-entry-expanded-p entry)))
(ewoc-invalidate ewoc node)))
(defun ert-results-find-test-at-point-other-window ()
"Find the definition of the test at point in another window.
To be used in the ERT results buffer."
(interactive)
(let* ((node (ert-results-test-node-at-point))
(entry (ewoc-data node))
(test (ert-ewoc-entry-test entry))
(name (ert-test-name test)))
(ert-find-test-other-window name)))
(defun ert-results-test-name-button-action (button)
"Find the definition of the test the button belongs to, in another window."
(let ((name (button-get button 'ert-test-name)))
(ert-find-test-other-window name)))
(defun ert-ewoc-position (ewoc node)
"Return the position of NODE in EWOC, or nil if NODE is not in EWOC."
(loop for i from 0
for node-here = (ewoc-nth ewoc 0) then (ewoc-next ewoc node-here)
do (when (eql node node-here)
(return i))
finally (return nil)))
(defun ert-results-jump-between-summary-and-result ()
"Jump back and forth between the test run summary and individual test results.
From an ewoc node, jumps to the character that represents the
same test in the progress bar, and vice versa.
To be used in the ERT results buffer."
;; Maybe this command isn't actually needed much, but if it is, it
;; seems like an indication that the UI design is not optimal. If
;; jumping back and forth between a summary at the top of the buffer
;; and the error log in the remainder of the buffer is useful, then
;; the summary apparently needs to be easily accessible from the
;; error log, and perhaps it would be better to have it in a
;; separate buffer to keep it visible.
(interactive)
(let ((ewoc ert-results-ewoc)
(progress-bar-begin ert-results-progress-bar-button-begin))
(cond ((ert-results-test-node-or-null-at-point)
(let* ((node (ert-results-test-node-at-point))
(pos (ert-ewoc-position ewoc node)))
(goto-char (+ progress-bar-begin pos))))
((and (<= progress-bar-begin (point))
(< (point) (button-end (button-at progress-bar-begin))))
(let* ((node (ewoc-nth ewoc (- (point) progress-bar-begin)))
(entry (ewoc-data node)))
(when (ert-ewoc-entry-hidden-p entry)
(setf (ert-ewoc-entry-hidden-p entry) nil)
(ewoc-invalidate ewoc node))
(ewoc-goto-node ewoc node)))
(t
(goto-char progress-bar-begin)))))
(defun ert-button-action-position ()
"The buffer position where the last button action was triggered."
(cond ((integerp last-command-event)
(point))
((eventp last-command-event)
(posn-point (event-start last-command-event)))
(t (assert nil))))
(defun ert-results-progress-bar-button-action (button)
"Find the ewoc node that represents the same test as the character clicked on."
(goto-char (ert-button-action-position))
(ert-results-jump-between-summary-and-result))
(defun ert-results-rerun-test-at-point ()
"Re-run the test at point.
To be used in the ERT results buffer."
(interactive)
(let* ((ewoc ert-results-ewoc)
(node (ert-results-test-node-at-point))
(entry (ewoc-data node))
(old-test (ert-ewoc-entry-test entry))
(test-name (ert-test-name old-test))
;; FIXME: Write a test for this lookup.
(test (if test-name
(if (ert-test-boundp test-name)
(ert-get-test test-name)
(error "No such test: %S" test-name))
old-test))
(stats ert-results-stats)
(pos (gethash test (ert-stats-test-map stats)))
(progress-message (format "Running test %S" (ert-test-name test))))
;; Need to save and restore point manually here: When point is on
;; the first visible ewoc entry while the header is updated, point
;; moves to the top of the buffer. This is undesirable, and a
;; simple `save-excursion' doesn't prevent it.
(let ((point (point)))
(unwind-protect
(unwind-protect
(progn
(message "%s..." progress-message)
(ert-run-or-rerun-test stats test
ert-results-listener))
(ert-results-update-stats-display ewoc stats)
(message "%s...%s"
progress-message
(let ((result (ert-test-most-recent-result test)))
(ert-string-for-test-result
result (ert-test-result-expected-p test result)))))
(goto-char point)))))
(defun ert-results-rerun-test-at-point-debugging-errors ()
"Re-run the test at point with `ert-debug-on-error' bound to t.
To be used in the ERT results buffer."
(interactive)
(let ((ert-debug-on-error t))
(ert-results-rerun-test-at-point)))
(defun ert-print-backtrace (backtrace)
"Format the backtrace BACKTRACE to the current buffer."
;; This is essentially a reimplementation of Fbacktrace
;; (src/eval.c), but for a saved backtrace, not the current one.
(let ((print-escape-newlines t)
(print-level 8)
(print-length 50))
(dolist (frame backtrace)
(ecase (first frame)
((nil)
;; Special operator.
(destructuring-bind (special-operator &rest arg-forms)
(cdr frame)
(insert
(format " %S\n" (list* special-operator arg-forms)))))
((t)
;; Function call.
(destructuring-bind (fn &rest args) (cdr frame)
(insert (format " %S(" fn))
(loop for firstp = t then nil
for arg in args do
(unless firstp
(insert " "))
(insert (format "%S" arg)))
(insert ")\n")))))))
(defun ert-results-pop-to-backtrace-for-test-at-point ()
"Display the backtrace for the test at point.
To be used in the ERT results buffer."
(interactive)
(let* ((node (ert-results-test-node-at-point))
(entry (ewoc-data node))
(test (ert-ewoc-entry-test entry))
(result (ert-ewoc-entry-result entry)))
(etypecase result
(ert-test-passed (error "Test passed, no backtrace available"))
(ert-test-result-with-condition
(let ((backtrace (ert-test-result-backtrace result))
(buffer
(let ((default-major-mode 'fundamental-mode))
(get-buffer-create "*ERT Backtrace*"))))
(pop-to-buffer buffer)
(setq buffer-read-only t)
(let ((inhibit-read-only t))
(erase-buffer)
(set-buffer-multibyte nil)
(setq truncate-lines t)
(ert-print-backtrace backtrace)
(debugger-make-xrefs)
(goto-char (point-min))))))))
(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)))
;;; Actions on load/unload.
(add-to-list 'find-function-regexp-alist '(deftest . ert-find-test-regexp))
(add-to-list 'minor-mode-alist '(ert-current-run-stats
(:eval
(ert-tests-running-mode-line-indicator))))
(defun ert-unload-function ()
(setq find-function-regexp-alist
(remove* 'deftest find-function-regexp-alist :key #'car))
(setq minor-mode-alist
(remove* 'ert-current-run-stats minor-mode-alist :key #'car))
nil)
(defvar ert-unload-hook '())
(add-hook 'ert-unload-hook 'ert-unload-function)
;;; Self-tests.
;; Test that test bodies are actually run.
(defvar ert-test-body-was-run)
(deftest ert-test-body-runs ()
(setq ert-test-body-was-run t))
;; Test that nested test bodies run.
(deftest ert-nested-test-body-runs ()
(lexical-let ((was-run nil))
(let ((test (make-ert-test :body (lambda ()
(setq was-run t)))))
(assert (not was-run))
(ert-run-test test)
(assert was-run))))
;; Test that pass/fail works.
(deftest ert-test-pass ()
(let ((test (make-ert-test :body (lambda ()))))
(let ((result (ert-run-test test)))
(assert (typep result 'ert-test-passed)))))
(deftest ert-test-fail ()
(let ((test (make-ert-test :body (lambda () (ert-fail "failure message")))))
(let ((result (let ((ert-debug-on-error nil))
(ert-run-test test))))
(assert (typep result 'ert-test-failed) t)
(assert (equal (ert-test-result-condition result)
'(ert-test-failed "failure message"))
t))))
(deftest ert-test-fail-debug-with-condition-case ()
(let ((test (make-ert-test :body (lambda () (ert-fail "failure message")))))
(condition-case condition
(progn
(let ((ert-debug-on-error t))
(ert-run-test test))
(assert nil))
((error)
(assert (equal condition '(ert-test-failed "failure message")) t)))))
(deftest ert-test-fail-debug-with-debugger-1 ()
(let ((test (make-ert-test :body (lambda () (ert-fail "failure message")))))
(let ((debugger (lambda (&rest debugger-args)
(assert nil))))
(let ((ert-debug-on-error nil))
(ert-run-test test)))))
(deftest ert-test-fail-debug-with-debugger-2 ()
(let ((test (make-ert-test :body (lambda () (ert-fail "failure message")))))
(block nil
(let ((debugger (lambda (&rest debugger-args)
(return-from nil nil))))
(let ((ert-debug-on-error t))
(ert-run-test test))
(assert nil)))))
(deftest ert-test-fail-debug-nested-with-debugger ()
(let ((test (make-ert-test :body (lambda ()
(let ((ert-debug-on-error t))
(ert-fail "failure message"))))))
(let ((debugger (lambda (&rest debugger-args)
(assert nil nil "Assertion a"))))
(let ((ert-debug-on-error nil))
(ert-run-test test))))
(let ((test (make-ert-test :body (lambda ()
(let ((ert-debug-on-error nil))
(ert-fail "failure message"))))))
(block nil
(let ((debugger (lambda (&rest debugger-args)
(return-from nil nil))))
(let ((ert-debug-on-error t))
(ert-run-test test))
(assert nil nil "Assertion b")))))
(deftest ert-test-error ()
(let ((test (make-ert-test :body (lambda () (error "error message")))))
(let ((result (let ((ert-debug-on-error nil))
(ert-run-test test))))
(assert (typep result 'ert-test-error) t)
(assert (equal (ert-test-result-condition result)
'(error "error message"))
t))))
(deftest ert-test-error-debug ()
(let ((test (make-ert-test :body (lambda () (error "error message")))))
(condition-case condition
(progn
(let ((ert-debug-on-error t))
(ert-run-test test))
(assert nil))
((error)
(assert (equal condition '(error "error message")) t)))))
;; Test that `should' works.
(deftest ert-test-should ()
(let ((test (make-ert-test :body (lambda () (should nil)))))
(let ((result (let ((ert-debug-on-error nil))
(ert-run-test test))))
(assert (typep result 'ert-test-failed) t)
(assert (equal (ert-test-result-condition result)
'(ert-test-failed ((should nil) :form nil :value nil)))
t)))
(let ((test (make-ert-test :body (lambda () (should t)))))
(let ((result (ert-run-test test)))
(assert (typep result 'ert-test-passed) t))))
(deftest ert-test-should-value ()
(should (eql (should 'foo) 'foo))
(should (eql (should 'bar) 'bar)))
(deftest ert-test-should-not ()
(let ((test (make-ert-test :body (lambda () (should-not t)))))
(let ((result (let ((ert-debug-on-error nil))
(ert-run-test test))))
(assert (typep result 'ert-test-failed) t)
(assert (equal (ert-test-result-condition result)
'(ert-test-failed ((should-not t) :form t :value t)))
t)))
(let ((test (make-ert-test :body (lambda () (should-not nil)))))
(let ((result (ert-run-test test)))
(assert (typep result 'ert-test-passed)))))
(deftest ert-test-should-error ()
;; No error.
(let ((test (make-ert-test :body (lambda () (should-error (progn))))))
(let ((result (let ((ert-debug-on-error nil))
(ert-run-test test))))
(should (typep result 'ert-test-failed))
(should (equal (ert-test-result-condition result)
'(ert-test-failed
((should-error (progn))
:form (progn)
:value nil
:fail-reason "did not signal an error"))))))
;; A simple error.
(let ((test (make-ert-test :body (lambda () (should-error (error "foo"))))))
(let ((result (ert-run-test test)))
(should (typep result 'ert-test-passed))))
;; Error of unexpected type, no test.
(let ((test (make-ert-test :body (lambda ()
(should-error (error "foo")
:type 'singularity-error)))))
(let ((result (ert-run-test test)))
(should (typep result 'ert-test-failed))
(should (equal
(ert-test-result-condition result)
'(ert-test-failed
((should-error (error "foo") :type 'singularity-error)
:form (error "foo")
:condition (error "foo")
:fail-reason
"the error signalled did not have the expected type"))))))
;; Error of the expected type, no test.
(let ((test (make-ert-test :body (lambda ()
(should-error (signal 'singularity-error
nil)
:type 'singularity-error)))))
(let ((result (ert-run-test test)))
(should (typep result 'ert-test-passed))))
;; Error that fails the test, no type.
(let ((test (make-ert-test :body (lambda ()
(should-error
(error "foo")
:test (lambda (error) nil))))))
(let ((result (ert-run-test test)))
(should (typep result 'ert-test-failed))
(should (equal (ert-test-result-condition result)
'(ert-test-failed
((should-error (error "foo") :test (lambda (error) nil))
:form (error "foo")
:condition (error "foo")
:fail-reason
"the error signalled did not pass the test"))))))
;; Error that passes the test, no type.
(let ((test (make-ert-test :body (lambda ()
(should-error (error "foo")
:test (lambda (error) t))))))
(let ((result (ert-run-test test)))
(should (typep result 'ert-test-passed))))
;; Error that has the expected type but fails the test.
(let ((test (make-ert-test :body (lambda ()
(should-error
(signal 'singularity-error nil)
:type 'singularity-error
:test (lambda (error) nil))))))
(let ((result (ert-run-test test)))
(should (typep result 'ert-test-failed))
(should (equal (ert-test-result-condition result)
'(ert-test-failed
((should-error (signal 'singularity-error nil)
:type 'singularity-error
:test (lambda (error) nil))
:form (signal singularity-error nil)
:condition (singularity-error)
:fail-reason
"the error signalled did not pass the test"))))))
;; Error that has the expected type and passes the test.
(let ((test (make-ert-test :body (lambda ()
(should-error
(signal 'singularity-error nil)
:type 'singularity-error
:test (lambda (error) t))))))
(let ((result (ert-run-test test)))
(should (typep result 'ert-test-passed))))
)
(deftest ert-test-should-error-subtypes ()
(let ((test (make-ert-test
:body (lambda ()
(should-error (signal 'singularity-error nil)
:type 'singularity-error
:exclude-subtypes t)))))
(let ((result (ert-run-test test)))
(should (typep result 'ert-test-passed))))
(let ((test (make-ert-test
:body (lambda ()
(should-error (signal 'arith-error nil)
:type 'singularity-error)))))
(let ((result (ert-run-test test)))
(should (typep result 'ert-test-failed))
(should (equal
(ert-test-result-condition result)
'(ert-test-failed
((should-error (signal 'arith-error nil)
:type 'singularity-error)
:form (signal arith-error nil)
:condition (arith-error)
:fail-reason
"the error signalled did not have the expected type"))))))
(let ((test (make-ert-test
:body (lambda ()
(should-error (signal 'arith-error nil)
:type 'singularity-error
:exclude-subtypes t)))))
(let ((result (ert-run-test test)))
(should (typep result 'ert-test-failed))
(should (equal
(ert-test-result-condition result)
'(ert-test-failed
((should-error (signal 'arith-error nil)
:type 'singularity-error
:exclude-subtypes t)
:form (signal arith-error nil)
:condition (arith-error)
:fail-reason
"the error signalled did not have the expected type"))))))
(let ((test (make-ert-test
:body (lambda ()
(should-error (signal 'singularity-error nil)
:type 'arith-error
:exclude-subtypes t)))))
(let ((result (ert-run-test test)))
(should (typep result 'ert-test-failed))
(should (equal
(ert-test-result-condition result)
'(ert-test-failed
((should-error (signal 'singularity-error nil)
:type 'arith-error
:exclude-subtypes t)
:form (signal singularity-error nil)
:condition (singularity-error)
:fail-reason
"the error signalled was a subtype of the expected type"))))))
)
;; Test that `should' errors contain the information we expect them to.
(defmacro ert-test-my-list (&rest args)
`(list ,@args))
(deftest ert-test-should-failure-debugging ()
(loop for (body expected-condition) in
`((,(lambda () (let ((x nil)) (should x)))
(ert-test-failed ((should x) :form x :value nil)))
(,(lambda () (let ((x t)) (should-not x)))
(ert-test-failed ((should-not x) :form x :value t)))
(,(lambda () (let ((x t)) (should (not x))))
(ert-test-failed ((should (not x)) :form (not t) :value nil)))
(,(lambda () (let ((x nil)) (should-not (not x))))
(ert-test-failed ((should-not (not x)) :form (not nil) :value t)))
(,(lambda () (let ((x t) (y nil)) (should-not (ert-test-my-list x y))))
(ert-test-failed
((should-not (ert-test-my-list x y))
:form (list t nil)
:value (t nil))))
(,(lambda () (let ((x t)) (should (error "foo"))))
(error "foo")))
do
(let ((test (make-ert-test :body body)))
(condition-case actual-condition
(progn
(let ((ert-debug-on-error t))
(ert-run-test test))
(assert nil))
((error)
(should (equal actual-condition expected-condition)))))))
;; Test `ert-select-tests'.
(deftest ert-test-select-regexp ()
(should (equal (ert-select-tests "^ert-test-select-regexp$" t)
(list (ert-get-test 'ert-test-select-regexp)))))
(deftest ert-test-test-boundp ()
(should (ert-test-boundp 'ert-test-test-boundp))
(should-not (ert-test-boundp (make-symbol "ert-not-a-test"))))
(deftest ert-test-select-member ()
(should (equal (ert-select-tests '(member ert-test-select-member) t)
(list (ert-get-test 'ert-test-select-member)))))
(deftest ert-test-select-test ()
(should (equal (ert-select-tests (ert-get-test 'ert-test-select-test) t)
(list (ert-get-test 'ert-test-select-test)))))
(deftest ert-test-select-symbol ()
(should (equal (ert-select-tests 'ert-test-select-symbol t)
(list (ert-get-test 'ert-test-select-symbol)))))
(deftest ert-test-select-and ()
(let ((test (make-ert-test
:name nil
:body nil
:most-recent-result (make-ert-test-failed
:condition nil
:backtrace nil))))
(should (equal (ert-select-tests `(and (member ,test) :failed) t)
(list test)))))
;; Test utility functions.
(deftest ert-proper-list-p ()
(should (ert-proper-list-p '()))
(should (ert-proper-list-p '(1)))
(should (ert-proper-list-p '(1 2)))
(should (ert-proper-list-p '(1 2 3)))
(should (ert-proper-list-p '(1 2 3 4)))
(should (not (ert-proper-list-p 'a)))
(should (not (ert-proper-list-p '(1 . a))))
(should (not (ert-proper-list-p '(1 2 . a))))
(should (not (ert-proper-list-p '(1 2 3 . a))))
(should (not (ert-proper-list-p '(1 2 3 4 . a))))
(let ((a (list 1)))
(setf (cdr (last a)) a)
(should (not (ert-proper-list-p a))))
(let ((a (list 1 2)))
(setf (cdr (last a)) a)
(should (not (ert-proper-list-p a))))
(let ((a (list 1 2 3)))
(setf (cdr (last a)) a)
(should (not (ert-proper-list-p a))))
(let ((a (list 1 2 3 4)))
(setf (cdr (last a)) a)
(should (not (ert-proper-list-p a))))
(let ((a (list 1 2)))
(setf (cdr (last a)) (cdr a))
(should (not (ert-proper-list-p a))))
(let ((a (list 1 2 3)))
(setf (cdr (last a)) (cdr a))
(should (not (ert-proper-list-p a))))
(let ((a (list 1 2 3 4)))
(setf (cdr (last a)) (cdr a))
(should (not (ert-proper-list-p a))))
(let ((a (list 1 2 3)))
(setf (cdr (last a)) (cddr a))
(should (not (ert-proper-list-p a))))
(let ((a (list 1 2 3 4)))
(setf (cdr (last a)) (cddr a))
(should (not (ert-proper-list-p a))))
(let ((a (list 1 2 3 4)))
(setf (cdr (last a)) (cdddr a))
(should (not (ert-proper-list-p a)))))
(deftest ert-parse-keys-and-body ()
(should (equal (ert-parse-keys-and-body '(foo)) '(nil (foo))))
(should (equal (ert-parse-keys-and-body '(:bar foo)) '((:bar foo) nil)))
(should (equal (ert-parse-keys-and-body '(:bar foo a (b))) '((:bar foo) (a (b)))))
(should (equal (ert-parse-keys-and-body '(:bar foo :a (b))) '((:bar foo :a (b)) nil)))
(should (equal (ert-parse-keys-and-body '(bar foo :a (b))) '(nil (bar foo :a (b)))))
(should-error (ert-parse-keys-and-body '(:bar foo :a))))
;; Test `ert-run-tests'.
(deftest ert-test-run-tests ()
(let ((passing-test (make-ert-test :name 'passing-test
:body (lambda () (ert-pass))))
(failing-test (make-ert-test :name 'failing-test
:body (lambda () (ert-fail
"failure message"))))
)
(let ((ert-debug-on-error nil))
(let ((buffer-name (generate-new-buffer-name " *ert-test-run-tests*")))
(save-window-excursion
(unwind-protect
(let ((case-fold-search nil))
(ert-run-tests-interactively
`(member ,passing-test ,failing-test) buffer-name)
(with-current-buffer buffer-name
(goto-char (point-min))
(should (equal
(buffer-substring (point-min)
(save-excursion
(forward-line 5)
(point)))
(concat
"Selector: (member <passing-test> <failing-test>)\n"
"Passed: 1 (0 unexpected)\n"
"Failed: 1 (1 unexpected)\n"
"Error: 0 (0 unexpected)\n"
"Total: 2/2\n")))))
(when (get-buffer buffer-name)
(kill-buffer buffer-name))))))))
;; Run tests and make sure they actually ran.
(let ((window-configuration (current-window-configuration)))
(let ((ert-test-body-was-run nil))
;; The buffer name chosen here should not compete with the default
;; results buffer name for completion in `switch-to-buffer'.
(let ((stats (ert-run-tests-interactively "^ert-" " *ert self-tests*")))
(assert ert-test-body-was-run)
(when (zerop (+ (ert-stats-passed-unexpected stats)
(ert-stats-failed-unexpected stats)
(ert-stats-error-unexpected stats)))
;; Hide results window only when everything went well.
(set-window-configuration window-configuration)))))
(provide 'ert)
;; ert.el ends here
[-- Attachment #3: Type: text/plain, Size: 142 bytes --]
_______________________________________________
Emacs-devel mailing list
Emacs-devel@gnu.org
http://lists.gnu.org/mailman/listinfo/emacs-devel
^ permalink raw reply [flat|nested] 12+ messages in thread
* Re: ert.el --- Emacs Lisp Regression Testing
2007-12-30 23:00 ert.el --- Emacs Lisp Regression Testing Christian Ohler
@ 2007-12-30 23:28 ` Lennart Borgman (gmail)
2008-01-05 11:32 ` Christian Ohler
2007-12-31 14:42 ` Richard Stallman
2008-01-03 18:48 ` Phil Hagelberg
2 siblings, 1 reply; 12+ messages in thread
From: Lennart Borgman (gmail) @ 2007-12-30 23:28 UTC (permalink / raw)
To: Christian Ohler; +Cc: emacs-devel
Christian Ohler wrote:
> I'm a big fan of automated testing/unit testing. However, it seems that
> there is no widely-used testing framework for Emacs Lisp yet. I've
> tried various packages (regress.el, elunit.el, elk-test.el, XEmacs'
> test-harness.el, the code in slime.el, and cc-mode's tests), but they're
> all either too simplistic, very specialized, or not very Lispy.
>
> Here's the code that I use at the moment. It requires Emacs 22.
>
> Please try it out and let me know what you think. Something like this
> really ought to be added to Emacs.
I will try to test it ;-)
One thing that might be handy is something that runs selected entries in
a new instance of Emacs, starting from either "emacs" or "emacs -Q". I
think that is one of the most common things I do when I am testing.
^ permalink raw reply [flat|nested] 12+ messages in thread
* Re: ert.el --- Emacs Lisp Regression Testing
2007-12-30 23:00 ert.el --- Emacs Lisp Regression Testing Christian Ohler
2007-12-30 23:28 ` Lennart Borgman (gmail)
@ 2007-12-31 14:42 ` Richard Stallman
2008-01-05 11:32 ` Christian Ohler
2008-01-03 18:48 ` Phil Hagelberg
2 siblings, 1 reply; 12+ messages in thread
From: Richard Stallman @ 2007-12-31 14:42 UTC (permalink / raw)
To: Christian Ohler; +Cc: emacs-devel
ert.el looks very useful. Would you like to contribute it to Emacs?
One of the things that has held us back from setting up a test suite
in the past is that only a minority of Emacs bugs concern Lisp progrmming.
Most Emacs bugs involve keyboard commands and/or redisplay.
It occurs to me that M-x term could be used to test for redisplay.
The idea is that you run a sub-Emacs, send it commands, and check what
it displayed (because what it displayed is now in a buffer).
It would be terribly slow to do this starting a new sub-Emacs for each
test. So the test framework ought to be designed to do many such tests
with the same sub-Emacs, clearing out whatever is necessary each time.
I think that an extension to ert.el, for sub-Emacs testing, might make
it easy to define those tests, much as ert.el makes it easy to define
tests of Lisp execution.
Interested?
^ permalink raw reply [flat|nested] 12+ messages in thread
* Re: ert.el --- Emacs Lisp Regression Testing
2007-12-30 23:00 ert.el --- Emacs Lisp Regression Testing Christian Ohler
2007-12-30 23:28 ` Lennart Borgman (gmail)
2007-12-31 14:42 ` Richard Stallman
@ 2008-01-03 18:48 ` Phil Hagelberg
2008-01-05 11:32 ` Christian Ohler
2 siblings, 1 reply; 12+ messages in thread
From: Phil Hagelberg @ 2008-01-03 18:48 UTC (permalink / raw)
To: Christian Ohler; +Cc: emacs-devel
Christian Ohler <ohler+emacs@fastmail.net> writes:
> I'm a big fan of automated testing/unit testing. However, it seems
> that there is no widely-used testing framework for Emacs Lisp yet.
> I've tried various packages (regress.el, elunit.el, elk-test.el,
> XEmacs' test-harness.el, the code in slime.el, and cc-mode's tests),
> but they're all either too simplistic, very specialized, or not very
> Lispy.
Your code looks very interesting.
I'm the author of elunit. I'm obviously very interested in unit testing
in Emacs Lisp (preferably test-driven development, but any tests are
good.) elunit has mostly been driven by my own needs, so it's no
surprise that it doesn't seem like a great fit for everyone, but I would
love to see unit testing get more traction in the Emacs community,
whether it's through elunit or ERT.
ERT looks several orders of magnitude more complicated than elunit, but
obviously it has a lot more functionality. I'm not so attached to elunit
that I think it's the only way to go. I'd love to play around with this
and see how it works. Perhaps we can merge our efforts.
Richard's idea of using a sub-emacs for testing sounds pretty promising
as well. I've beaten my head against the problem of testing with a fresh
instance, and it's always been rather awkward. Running it in a term
could make it easier to automate.
Phil
http://technomancy.us
^ permalink raw reply [flat|nested] 12+ messages in thread
* Re: ert.el --- Emacs Lisp Regression Testing
2008-01-03 18:48 ` Phil Hagelberg
@ 2008-01-05 11:32 ` Christian Ohler
0 siblings, 0 replies; 12+ messages in thread
From: Christian Ohler @ 2008-01-05 11:32 UTC (permalink / raw)
To: Phil Hagelberg; +Cc: emacs-devel
Phil Hagelberg, 2008-01-03:
> I'm the author of elunit. I'm obviously very interested in unit testing
> in Emacs Lisp (preferably test-driven development, but any tests are
> good.) elunit has mostly been driven by my own needs, so it's no
> surprise that it doesn't seem like a great fit for everyone, but I would
> love to see unit testing get more traction in the Emacs community,
> whether it's through elunit or ERT.
I'm familiar with (an earlier version of) elunit; I've used it for
writing a test suite for xmtn (a DVC backend for the distributed version
control system monotone). It served its purpose, but I wanted something
that offers an even better workflow for test-driven development. None
of the existing tools did that.
> ERT looks several orders of magnitude more complicated than elunit, but
> obviously it has a lot more functionality.
There are some parts in ERT that can be simplified, but the parts that
are really tricky (`ert-run-test-debugger' and friends and `should') are
inherently tricky. Other tools take simpler approaches but have less
functionality and are less general.
> I've beaten my head against the problem of testing with a fresh
> instance, and it's always been rather awkward.
Hmm, what do you mean here? What were your goals, what was your
approach, and why were you unhappy with the results?
I skimmed your page on behave.el ( http://dev.technomancy.us/Behave.el
). What are its main features? Adding tags and docstrings to ERT would
not be difficult. I think ERT's `should' is already more powerful than
behave.el's `expect'.
I would like to look at your code, but the command from
http://dev.technomancy.us/DotFiles ,
git clone http://git.caboo.se/technomancy.git
says
Cannot get remote repository information.
Perhaps git-update-server-info needs to be run there?
Christian.
^ permalink raw reply [flat|nested] 12+ messages in thread
* Re: ert.el --- Emacs Lisp Regression Testing
2007-12-30 23:28 ` Lennart Borgman (gmail)
@ 2008-01-05 11:32 ` Christian Ohler
0 siblings, 0 replies; 12+ messages in thread
From: Christian Ohler @ 2008-01-05 11:32 UTC (permalink / raw)
To: Lennart Borgman (gmail); +Cc: emacs-devel
Lennart Borgman (gmail), 2007-12-31:
> I will try to test it ;-)
Please do so -- perhaps by writing a few test cases for Emacs ;-)
> One thing that might be handy is something that runs selected entries in
> a new instance of Emacs, starting from either "emacs" or "emacs -Q". I
> think that is one of the most common things I do when I am testing.
ERT currently allows you to run your tests in a fresh emacs by running
emacs -Q --batch --load my-tests.el --eval '(ert-run-tests-batch t)'
in a terminal (or possibly under M-x compile, but I haven't tried that).
However, that would be an edit-compile-run development cycle. I am much
more productive programming and testing interactively in one single
Emacs instance.
I see two main reasons for running tests in a separate Emacs: For
testing without customizations (emacs -Q) or other Emacs versions, and
for long-running test suites that you don't want to block your main
Emacs instance with. So far, the above method was sufficient for me in
those situations (because tests that have already succeeded in my Emacs
rarely fail in a separate one, so I rarely missed ERT's interactive
debugging facilities).
Maybe IELM could be used to implement a convenient interface for running
an inferior Emacs that runs the tests (which could, in turn, involve
running another nested Emacs in M-x term). This even sounds like an
interesting project to implement. However, to get started building test
suites for Emacs or Elisp packages, the current options are probably
sufficient.
Christian.
^ permalink raw reply [flat|nested] 12+ messages in thread
* Re: ert.el --- Emacs Lisp Regression Testing
2007-12-31 14:42 ` Richard Stallman
@ 2008-01-05 11:32 ` Christian Ohler
2008-01-05 13:06 ` Eli Zaretskii
0 siblings, 1 reply; 12+ messages in thread
From: Christian Ohler @ 2008-01-05 11:32 UTC (permalink / raw)
To: rms; +Cc: emacs-devel
Richard Stallman, 2007-12-31:
> ert.el looks very useful. Would you like to contribute it to Emacs?
Yes.
> One of the things that has held us back from setting up a test suite
> in the past is that only a minority of Emacs bugs concern Lisp progrmming.
> Most Emacs bugs involve keyboard commands and/or redisplay.
This may be true of the core of Emacs, but testing is also important for
(third-party) Elisp packages, and they tend to be testable from Elisp.
Also, automated testing is not only about bugs. A comprehensive test
suite gives you the freedom to modify any part of the code without being
afraid that you'll break something without noticing. This makes it
easier to add new features or improve the implementation of existing
features and will be useful for Emacs, too, even if we only use it for
things that can be tested from Elisp.
But, yes, we should also try to automate tests that involve input and
redisplay.
> It occurs to me that M-x term could be used to test for redisplay.
> The idea is that you run a sub-Emacs, send it commands, and check what
> it displayed (because what it displayed is now in a buffer).
Does a significant share of the input/redisplay bugs that occur in a GUI
Emacs also occur on the terminal?
> It would be terribly slow to do this starting a new sub-Emacs for each
> test. So the test framework ought to be designed to do many such tests
> with the same sub-Emacs, clearing out whatever is necessary each time.
Yes.
> I think that an extension to ert.el, for sub-Emacs testing, might make
> it easy to define those tests, much as ert.el makes it easy to define
> tests of Lisp execution.
>
> Interested?
The first step would be to identify a few bug reports involving input
and redisplay that should be reproducible under M-x term and should make
good candidates for automation. Then we can look into automating them
and try to come up with a general design. I don't think I'm the right
person for that first step, though.
Christian.
^ permalink raw reply [flat|nested] 12+ messages in thread
* Re: ert.el --- Emacs Lisp Regression Testing
2008-01-05 11:32 ` Christian Ohler
@ 2008-01-05 13:06 ` Eli Zaretskii
2008-01-06 8:10 ` Richard Stallman
0 siblings, 1 reply; 12+ messages in thread
From: Eli Zaretskii @ 2008-01-05 13:06 UTC (permalink / raw)
To: Christian Ohler; +Cc: rms, emacs-devel
> Date: Sat, 05 Jan 2008 12:32:45 +0100
> From: Christian Ohler <ohler+emacs@fastmail.net>
> Cc: emacs-devel@gnu.org
>
> > It occurs to me that M-x term could be used to test for redisplay.
> > The idea is that you run a sub-Emacs, send it commands, and check what
> > it displayed (because what it displayed is now in a buffer).
>
> Does a significant share of the input/redisplay bugs that occur in a GUI
> Emacs also occur on the terminal?
To answer this question, one should analyze the ChangeLog entries for
display code and partition the bugfixes according to the display
backend. FWIW, I don't think this is a good way of using our
resources, since there's no easy way of knowing whether a given change
is a new feature or a bugfix.
More generally, I think each display backend has the same chance of
getting a bug as any other. I also think that all the backends we
currently support are of equal importance. If others agree, it means
that we need a way to detect bugs in all of the different display
backends.
> The first step would be to identify a few bug reports involving input
> and redisplay that should be reproducible under M-x term and should make
> good candidates for automation.
I think the first step is to design and implement infrastructure that
will allow us to compare actual display with the desired one; using
M-x term is just a partial hack that could work in some cases.
For a general-purpose display testing, we need to add code to the
display engine (both its high-level device-independent part, and
lower-level display backend) that would expose to a Lisp application
the glyphs that are produced by the display engine and the
backend-dependent display commands sent to the display API
(termcap/terminfo for text terminal, X for X Window system, etc.).
The lower-level part of the above is more important than the
high-level, because it's eventually the lower-level that is sent to
the underlying display system. But having the high-level part is also
important, because we sometimes change the translation between
high-level glyphs and the corresponding low-level commands, with the
intent that the displayed stuff remains the same.
In other words, we need a description language for describing the
stuff Emacs is about to display, code in the display engine that will
produce such a description as part of redisplay, and a Lisp interface
to that description.
^ permalink raw reply [flat|nested] 12+ messages in thread
* Re: ert.el --- Emacs Lisp Regression Testing
2008-01-05 13:06 ` Eli Zaretskii
@ 2008-01-06 8:10 ` Richard Stallman
2008-01-06 19:46 ` Eli Zaretskii
0 siblings, 1 reply; 12+ messages in thread
From: Richard Stallman @ 2008-01-06 8:10 UTC (permalink / raw)
To: Eli Zaretskii; +Cc: ohler+emacs, emacs-devel
For a general-purpose display testing, we need to add code to the
display engine (both its high-level device-independent part, and
lower-level display backend) that would expose to a Lisp application
the glyphs that are produced by the display engine and the
backend-dependent display commands sent to the display API
(termcap/terminfo for text terminal, X for X Window system, etc.).
That sounds like a big job, and most of it for no purpose other than
testing. I tend to doubt it would pay for itself in terms
of future effort saved.
^ permalink raw reply [flat|nested] 12+ messages in thread
* Re: ert.el --- Emacs Lisp Regression Testing
2008-01-06 8:10 ` Richard Stallman
@ 2008-01-06 19:46 ` Eli Zaretskii
2008-01-07 11:31 ` Richard Stallman
0 siblings, 1 reply; 12+ messages in thread
From: Eli Zaretskii @ 2008-01-06 19:46 UTC (permalink / raw)
To: rms; +Cc: ohler+emacs, emacs-devel
> From: Richard Stallman <rms@gnu.org>
> CC: ohler+emacs@fastmail.net, emacs-devel@gnu.org
> Date: Sun, 06 Jan 2008 03:10:01 -0500
>
> For a general-purpose display testing, we need to add code to the
> display engine (both its high-level device-independent part, and
> lower-level display backend) that would expose to a Lisp application
> the glyphs that are produced by the display engine and the
> backend-dependent display commands sent to the display API
> (termcap/terminfo for text terminal, X for X Window system, etc.).
>
> That sounds like a big job, and most of it for no purpose other than
> testing.
I don't see why it would be a big job. Describing an iterator
structure and the glyph objects it produces is not hard, and neither
is the sequence of display API calls we issue to draw.
Anyway, if we ever want to have a regression testing suite for Emacs,
this job is hardly avoidable. Without a good test suite, any
significant changes to core machinery runs a high risk of introducing
new and exciting bugs.
^ permalink raw reply [flat|nested] 12+ messages in thread
* Re: ert.el --- Emacs Lisp Regression Testing
2008-01-06 19:46 ` Eli Zaretskii
@ 2008-01-07 11:31 ` Richard Stallman
2008-01-07 13:00 ` Mike Mattie
0 siblings, 1 reply; 12+ messages in thread
From: Richard Stallman @ 2008-01-07 11:31 UTC (permalink / raw)
To: Eli Zaretskii; +Cc: ohler+emacs, emacs-devel
Anyway, if we ever want to have a regression testing suite for Emacs,
this job is hardly avoidable.
This job is unavoidable if we want to have a regression test suite
that covers the problems limited to graphical terminals. I am not
sure that goal is worth this much effort. A regression test suite
which doesn't cover the problems limited to graphical terminals could
nonetheless be quite useful.
^ permalink raw reply [flat|nested] 12+ messages in thread
* Re: ert.el --- Emacs Lisp Regression Testing
2008-01-07 11:31 ` Richard Stallman
@ 2008-01-07 13:00 ` Mike Mattie
0 siblings, 0 replies; 12+ messages in thread
From: Mike Mattie @ 2008-01-07 13:00 UTC (permalink / raw)
To: emacs-devel; +Cc: rms
[-- Attachment #1.1: Type: text/plain, Size: 837 bytes --]
On Mon, 07 Jan 2008 06:31:26 -0500
Richard Stallman <rms@gnu.org> wrote:
> Anyway, if we ever want to have a regression testing suite for
> Emacs, this job is hardly avoidable.
>
> This job is unavoidable if we want to have a regression test suite
> that covers the problems limited to graphical terminals. I am not
> sure that goal is worth this much effort. A regression test suite
> which doesn't cover the problems limited to graphical terminals could
> nonetheless be quite useful.
Is there a URL for the source that will be updated ? I can use it right now.
I am in the testing phase right now on some elisp well suited to this kind
of testing.
>
> _______________________________________________
> Emacs-devel mailing list
> Emacs-devel@gnu.org
> http://lists.gnu.org/mailman/listinfo/emacs-devel
[-- Attachment #1.2: signature.asc --]
[-- Type: application/pgp-signature, Size: 189 bytes --]
[-- Attachment #2: Type: text/plain, Size: 142 bytes --]
_______________________________________________
Emacs-devel mailing list
Emacs-devel@gnu.org
http://lists.gnu.org/mailman/listinfo/emacs-devel
^ permalink raw reply [flat|nested] 12+ messages in thread
end of thread, other threads:[~2008-01-07 13:00 UTC | newest]
Thread overview: 12+ messages (download: mbox.gz follow: Atom feed
-- links below jump to the message on this page --
2007-12-30 23:00 ert.el --- Emacs Lisp Regression Testing Christian Ohler
2007-12-30 23:28 ` Lennart Borgman (gmail)
2008-01-05 11:32 ` Christian Ohler
2007-12-31 14:42 ` Richard Stallman
2008-01-05 11:32 ` Christian Ohler
2008-01-05 13:06 ` Eli Zaretskii
2008-01-06 8:10 ` Richard Stallman
2008-01-06 19:46 ` Eli Zaretskii
2008-01-07 11:31 ` Richard Stallman
2008-01-07 13:00 ` Mike Mattie
2008-01-03 18:48 ` Phil Hagelberg
2008-01-05 11:32 ` Christian Ohler
Code repositories for project(s) associated with this public inbox
https://git.savannah.gnu.org/cgit/emacs.git
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).