ohler / ert

Emacs Lisp Regression Testing

This URL has Read+Write access

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