1 Return-Path: <dme@dme.org>
\r
2 X-Original-To: notmuch@notmuchmail.org
\r
3 Delivered-To: notmuch@notmuchmail.org
\r
4 Received: from localhost (localhost [127.0.0.1])
\r
5 by olra.theworths.org (Postfix) with ESMTP id 3D8F7431FB6
\r
6 for <notmuch@notmuchmail.org>; Thu, 25 Nov 2010 03:03:52 -0800 (PST)
\r
7 X-Virus-Scanned: Debian amavisd-new at olra.theworths.org
\r
11 X-Spam-Status: No, score=0 tagged_above=-999 required=5
\r
12 tests=[RCVD_IN_DNSWL_NONE=-0.0001] autolearn=disabled
\r
13 Received: from olra.theworths.org ([127.0.0.1])
\r
14 by localhost (olra.theworths.org [127.0.0.1]) (amavisd-new, port 10024)
\r
15 with ESMTP id JDfGCrIpMv1v for <notmuch@notmuchmail.org>;
\r
16 Thu, 25 Nov 2010 03:03:24 -0800 (PST)
\r
17 Received: from mail-wy0-f181.google.com (mail-wy0-f181.google.com
\r
19 by olra.theworths.org (Postfix) with ESMTP id 052B0431FB5
\r
20 for <notmuch@notmuchmail.org>; Thu, 25 Nov 2010 03:03:22 -0800 (PST)
\r
21 Received: by wyf22 with SMTP id 22so827352wyf.26
\r
22 for <notmuch@notmuchmail.org>; Thu, 25 Nov 2010 03:03:21 -0800 (PST)
\r
23 Received: by 10.227.145.136 with SMTP id d8mr630189wbv.172.1290683000441;
\r
24 Thu, 25 Nov 2010 03:03:20 -0800 (PST)
\r
25 Received: from ut.hh.sledj.net (host81-149-164-25.in-addr.btopenworld.com
\r
27 by mx.google.com with ESMTPS id x12sm253252weq.18.2010.11.25.03.03.17
\r
28 (version=TLSv1/SSLv3 cipher=RC4-MD5);
\r
29 Thu, 25 Nov 2010 03:03:18 -0800 (PST)
\r
30 Received: by ut.hh.sledj.net (Postfix, from userid 1000)
\r
31 id E9D01594058; Thu, 25 Nov 2010 10:59:18 +0000 (GMT)
\r
32 From: David Edmondson <dme@dme.org>
\r
33 To: notmuch@notmuchmail.org
\r
34 Subject: [PATCH 1/3] test: Add ERT for emacs testing.
\r
35 Date: Thu, 25 Nov 2010 10:59:08 +0000
\r
36 Message-Id: <1290682750-30283-1-git-send-email-dme@dme.org>
\r
37 X-Mailer: git-send-email 1.7.2.3
\r
38 In-Reply-To: <1290632444-10046-1-git-send-email-cworth@cworth.org>
\r
39 References: <1290632444-10046-1-git-send-email-cworth@cworth.org>
\r
40 X-Mailman-Approved-At: Thu, 25 Nov 2010 09:26:16 -0800
\r
41 X-BeenThere: notmuch@notmuchmail.org
\r
42 X-Mailman-Version: 2.1.13
\r
44 List-Id: "Use and development of the notmuch mail system."
\r
45 <notmuch.notmuchmail.org>
\r
46 List-Unsubscribe: <http://notmuchmail.org/mailman/options/notmuch>,
\r
47 <mailto:notmuch-request@notmuchmail.org?subject=unsubscribe>
\r
48 List-Archive: <http://notmuchmail.org/pipermail/notmuch>
\r
49 List-Post: <mailto:notmuch@notmuchmail.org>
\r
50 List-Help: <mailto:notmuch-request@notmuchmail.org?subject=help>
\r
51 List-Subscribe: <http://notmuchmail.org/mailman/listinfo/notmuch>,
\r
52 <mailto:notmuch-request@notmuchmail.org?subject=subscribe>
\r
53 X-List-Received-Date: Thu, 25 Nov 2010 11:03:52 -0000
\r
55 ERT is for Emacs Lisp Regression Testing, from
\r
56 https://github.com/ohler/ert.git.
\r
58 The ERT files added here were extracted from the ERT repository.
\r
60 The 'basic' test should ignore emacs backup files (*~).
\r
63 test/ert/ert-batch.el | 152 +++
\r
64 test/ert/ert-run.el | 687 +++++++++++++
\r
65 test/ert/ert-ui.el | 1047 ++++++++++++++++++++
\r
66 test/ert/ert-x.el | 290 ++++++
\r
67 test/ert/ert.el | 2539 +++++++++++++++++++++++++++++++++++++++++++++++++
\r
68 test/notmuch-test | 2 +-
\r
69 7 files changed, 4717 insertions(+), 2 deletions(-)
\r
70 create mode 100644 test/ert/ert-batch.el
\r
71 create mode 100644 test/ert/ert-run.el
\r
72 create mode 100644 test/ert/ert-ui.el
\r
73 create mode 100644 test/ert/ert-x.el
\r
74 create mode 100644 test/ert/ert.el
\r
76 diff --git a/test/basic b/test/basic
\r
77 index 309779c..b3597b9 100755
\r
80 @@ -52,7 +52,7 @@ test_expect_code 2 'failure to clean up causes the test to fail' '
\r
81 # Ensure that all tests are being run
\r
82 test_begin_subtest 'Ensure that all available tests will be run by notmuch-test'
\r
83 tests_in_suite=$(grep TESTS= ../notmuch-test | sed -e "s/TESTS=\"\(.*\)\"/\1/" | tr " " "\n" | sort)
\r
84 -available=$(ls -1 ../ | grep -v -E "^(aggregate-results.sh|Makefile|Makefile.local|notmuch-test|README|test-lib.sh|test-results|tmp.*|valgrind|corpus*|emacs.expected-output|smtp-dummy|smtp-dummy.c|test-verbose|test.expected-output)" | sort)
\r
85 +available=$(ls -1 ../ | grep -v -E "^(aggregate-results.sh|ert|Makefile|Makefile.local|notmuch-test|README|test-lib.sh|test-results|tmp.*|valgrind|corpus*|emacs.expected-output|smtp-dummy|smtp-dummy.c|test-verbose|test.expected-output|*~)" | sort)
\r
86 test_expect_equal "$tests_in_suite" "$available"
\r
88 EXPECTED=../test.expected-output
\r
89 diff --git a/test/ert/ert-batch.el b/test/ert/ert-batch.el
\r
90 new file mode 100644
\r
91 index 0000000..86424ba
\r
93 +++ b/test/ert/ert-batch.el
\r
95 +;;; ert-batch.el --- Functions for running ERT tests in batch mode
\r
97 +;; Copyright (C) 2007, 2008, 2010 Free Software Foundation, Inc.
\r
99 +;; Author: Christian M. Ohler
\r
101 +;; This file is NOT part of GNU Emacs.
\r
103 +;; This program is free software: you can redistribute it and/or
\r
104 +;; modify it under the terms of the GNU General Public License as
\r
105 +;; published by the Free Software Foundation, either version 3 of the
\r
106 +;; License, or (at your option) any later version.
\r
108 +;; This program is distributed in the hope that it will be useful, but
\r
109 +;; WITHOUT ANY WARRANTY; without even the implied warranty of
\r
110 +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
\r
111 +;; General Public License for more details.
\r
113 +;; You should have received a copy of the GNU General Public License
\r
114 +;; along with this program. If not, see `http://www.gnu.org/licenses/'.
\r
118 +;; This file is part of ERT, the Emacs Lisp Regression Testing tool.
\r
119 +;; See ert.el or the texinfo manual for more details.
\r
123 +(eval-when-compile
\r
125 +(require 'ert-run)
\r
127 +(defvar ert-batch-backtrace-right-margin 70
\r
128 + "*The maximum line length for printing backtraces in `ert-run-tests-batch'.")
\r
131 +(defun ert-run-tests-batch (&optional selector)
\r
132 + "Run the tests specified by SELECTOR, printing results to the terminal.
\r
134 +SELECTOR works as described in `ert-select-tests', except if
\r
135 +SELECTOR is nil, in which case all tests rather than none will be
\r
136 +run; this makes the command line \"emacs -batch -l my-tests.el -f
\r
137 +ert-run-tests-batch-and-exit\" useful.
\r
139 +Returns the stats object."
\r
140 + (unless selector (setq selector 't))
\r
143 + (lambda (event-type &rest event-args)
\r
144 + (ecase event-type
\r
146 + (destructuring-bind (stats) event-args
\r
147 + (message "Running %s tests (%s)"
\r
148 + (length (ert--stats-tests stats))
\r
149 + (ert--format-time-iso8601 (ert--stats-start-time stats)))))
\r
151 + (destructuring-bind (stats abortedp) event-args
\r
152 + (let ((unexpected (ert-stats-completed-unexpected stats))
\r
153 + (expected-failures (ert--stats-failed-expected stats)))
\r
154 + (message "\n%sRan %s tests, %s results as expected%s (%s)%s\n"
\r
155 + (if (not abortedp)
\r
158 + (ert-stats-total stats)
\r
159 + (ert-stats-completed-expected stats)
\r
160 + (if (zerop unexpected)
\r
162 + (format ", %s unexpected" unexpected))
\r
163 + (ert--format-time-iso8601 (ert--stats-end-time stats))
\r
164 + (if (zerop expected-failures)
\r
166 + (format "\n%s expected failures" expected-failures)))
\r
167 + (unless (zerop unexpected)
\r
168 + (message "%s unexpected results:" unexpected)
\r
169 + (loop for test across (ert--stats-tests stats)
\r
170 + for result = (ert-test-most-recent-result test) do
\r
171 + (when (not (ert-test-result-expected-p test result))
\r
172 + (message "%9s %S"
\r
173 + (ert-string-for-test-result result nil)
\r
174 + (ert-test-name test))))
\r
175 + (message "%s" "")))))
\r
179 + (destructuring-bind (stats test result) event-args
\r
180 + (unless (ert-test-result-expected-p test result)
\r
181 + (etypecase result
\r
183 + (message "Test %S passed unexpectedly" (ert-test-name test)))
\r
184 + (ert-test-result-with-condition
\r
185 + (message "Test %S backtrace:" (ert-test-name test))
\r
186 + (with-temp-buffer
\r
187 + (ert--print-backtrace (ert-test-result-with-condition-backtrace
\r
189 + (goto-char (point-min))
\r
190 + (while (not (eobp))
\r
191 + (let ((start (point))
\r
192 + (end (progn (end-of-line) (point))))
\r
193 + (setq end (min end
\r
194 + (+ start ert-batch-backtrace-right-margin)))
\r
195 + (message "%s" (buffer-substring-no-properties
\r
197 + (forward-line 1)))
\r
198 + (with-temp-buffer
\r
199 + (ert--insert-infos result)
\r
201 + (let ((print-escape-newlines t)
\r
203 + (print-length 10))
\r
204 + (let ((begin (point)))
\r
205 + (ert--pp-with-indentation-and-newline
\r
206 + (ert-test-result-with-condition-condition result))))
\r
207 + (goto-char (1- (point-max)))
\r
208 + (assert (looking-at "\n"))
\r
210 + (message "Test %S condition:" (ert-test-name test))
\r
211 + (message "%s" (buffer-string))))
\r
212 + (ert-test-aborted-with-non-local-exit
\r
213 + (message "Test %S aborted with non-local exit"
\r
214 + (ert-test-name test)))))
\r
215 + (let* ((max (prin1-to-string (length (ert--stats-tests stats))))
\r
216 + (format-string (concat "%9s %"
\r
217 + (prin1-to-string (length max))
\r
218 + "s/" max " %S")))
\r
219 + (message format-string
\r
220 + (ert-string-for-test-result result
\r
221 + (ert-test-result-expected-p
\r
223 + (1+ (ert--stats-test-pos stats test))
\r
224 + (ert-test-name test)))))))))
\r
227 +(defun ert-run-tests-batch-and-exit (&optional selector)
\r
228 + "Like `ert-run-tests-batch', but exits Emacs when done.
\r
230 +The exit status will be 0 if all test results were as expected, 1
\r
231 +on unexpected results, or 2 if the framework detected an error
\r
232 +outside of the tests (e.g. invalid SELECTOR or bug in the code
\r
233 +that runs the tests)."
\r
235 + (let ((stats (ert-run-tests-batch selector)))
\r
236 + (kill-emacs (if (zerop (ert-stats-completed-unexpected stats)) 0 1)))
\r
239 + (message "Error running tests")
\r
241 + (kill-emacs 2))))
\r
244 +(provide 'ert-batch)
\r
246 +;;; ert-batch.el ends here
\r
247 diff --git a/test/ert/ert-run.el b/test/ert/ert-run.el
\r
248 new file mode 100644
\r
249 index 0000000..7c91406
\r
251 +++ b/test/ert/ert-run.el
\r
253 +;;; ert-run.el --- ERT's internal infrastructure for running tests
\r
255 +;; Copyright (C) 2007, 2008, 2010 Free Software Foundation, Inc.
\r
257 +;; Author: Christian M. Ohler
\r
259 +;; This file is NOT part of GNU Emacs.
\r
261 +;; This program is free software: you can redistribute it and/or
\r
262 +;; modify it under the terms of the GNU General Public License as
\r
263 +;; published by the Free Software Foundation, either version 3 of the
\r
264 +;; License, or (at your option) any later version.
\r
266 +;; This program is distributed in the hope that it will be useful, but
\r
267 +;; WITHOUT ANY WARRANTY; without even the implied warranty of
\r
268 +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
\r
269 +;; General Public License for more details.
\r
271 +;; You should have received a copy of the GNU General Public License
\r
272 +;; along with this program. If not, see `http://www.gnu.org/licenses/'.
\r
276 +;; This file is part of ERT, the Emacs Lisp Regression Testing tool.
\r
277 +;; See ert.el or the texinfo manual for more details.
\r
281 +(eval-when-compile
\r
286 +(defvar ert-debug-on-error nil
\r
287 + "Non-nil means enter debugger when a test fails or terminates with an error.")
\r
289 +;;; Running tests.
\r
291 +;; The data structures that represent the result of running a test.
\r
292 +(defstruct ert-test-result
\r
294 + (should-forms nil)
\r
296 +(defstruct (ert-test-passed (:include ert-test-result)))
\r
297 +(defstruct (ert-test-result-with-condition (:include ert-test-result))
\r
298 + (condition (assert nil))
\r
299 + (backtrace (assert nil))
\r
300 + (infos (assert nil)))
\r
301 +(defstruct (ert-test-quit (:include ert-test-result-with-condition)))
\r
302 +(defstruct (ert-test-failed (:include ert-test-result-with-condition)))
\r
303 +(defstruct (ert-test-aborted-with-non-local-exit (:include ert-test-result)))
\r
306 +(defun ert--record-backtrace ()
\r
307 + "Record the current backtrace (as a list) and return it."
\r
308 + ;; Since the backtrace is stored in the result object, result
\r
309 + ;; objects must only be printed with appropriate limits
\r
310 + ;; (`print-level' and `print-length') in place. For interactive
\r
311 + ;; use, the cost of ensuring this possibly outweighs the advantage
\r
312 + ;; of storing the backtrace for
\r
313 + ;; `ert-results-pop-to-backtrace-for-test-at-point' given that we
\r
314 + ;; already have `ert-results-rerun-test-debugging-errors-at-point'.
\r
315 + ;; For batch use, however, printing the backtrace may be useful.
\r
317 + ;; 6 is the number of frames our own debugger adds (when
\r
318 + ;; compiled; more when interpreted). FIXME: Need to describe a
\r
319 + ;; procedure for determining this constant.
\r
321 + for frame = (backtrace-frame i)
\r
325 +(defun ert--print-backtrace (backtrace)
\r
326 + "Format the backtrace BACKTRACE to the current buffer."
\r
327 + ;; This is essentially a reimplementation of Fbacktrace
\r
328 + ;; (src/eval.c), but for a saved backtrace, not the current one.
\r
329 + (let ((print-escape-newlines t)
\r
331 + (print-length 50))
\r
332 + (dolist (frame backtrace)
\r
333 + (ecase (first frame)
\r
335 + ;; Special operator.
\r
336 + (destructuring-bind (special-operator &rest arg-forms)
\r
339 + (format " %S\n" (list* special-operator arg-forms)))))
\r
341 + ;; Function call.
\r
342 + (destructuring-bind (fn &rest args) (cdr frame)
\r
343 + (insert (format " %S(" fn))
\r
344 + (loop for firstp = t then nil
\r
345 + for arg in args do
\r
348 + (insert (format "%S" arg)))
\r
349 + (insert ")\n")))))))
\r
351 +;; A container for the state of the execution of a single test and
\r
352 +;; environment data needed during its execution.
\r
353 +(defstruct ert--test-execution-info
\r
354 + (test (assert nil))
\r
355 + (result (assert nil))
\r
356 + ;; A thunk that may be called when RESULT has been set to its final
\r
357 + ;; value and test execution should be terminated. Should not
\r
359 + (exit-continuation (assert nil))
\r
360 + ;; The binding of `debugger' outside of the execution of the test.
\r
362 + ;; The binding of `ert-debug-on-error' that is in effect for the
\r
363 + ;; execution of the current test. We store it to avoid being
\r
364 + ;; affected by any new bindings the test itself may establish. (I
\r
365 + ;; don't remember whether this feature is important.)
\r
366 + ert-debug-on-error)
\r
368 +(defun ert--run-test-debugger (info debugger-args)
\r
369 + "During a test run, `debugger' is bound to a closure that calls this function.
\r
371 +This function records failures and errors and either terminates
\r
372 +the test silently or calls the interactive debugger, as
\r
375 +INFO is the ert--test-execution-info corresponding to this test
\r
376 +run. DEBUGGER-ARGS are the arguments to `debugger'."
\r
377 + (destructuring-bind (first-debugger-arg &rest more-debugger-args)
\r
379 + (ecase first-debugger-arg
\r
380 + ((lambda debug t exit nil)
\r
381 + (apply (ert--test-execution-info-next-debugger info) debugger-args))
\r
383 + (let* ((condition (first more-debugger-args))
\r
384 + (type (case (car condition)
\r
386 + (otherwise 'failed)))
\r
387 + (backtrace (ert--record-backtrace))
\r
388 + (infos (reverse ert--infos)))
\r
389 + (setf (ert--test-execution-info-result info)
\r
392 + (make-ert-test-quit :condition condition
\r
393 + :backtrace backtrace
\r
396 + (make-ert-test-failed :condition condition
\r
397 + :backtrace backtrace
\r
399 + ;; Work around Emacs' heuristic (in eval.c) for detecting
\r
400 + ;; errors in the debugger.
\r
401 + (incf num-nonmacro-input-events)
\r
402 + ;; FIXME: We should probably implement more fine-grained
\r
403 + ;; control a la non-t `debug-on-error' here.
\r
405 + ((ert--test-execution-info-ert-debug-on-error info)
\r
406 + (apply (ert--test-execution-info-next-debugger info) debugger-args))
\r
408 + (funcall (ert--test-execution-info-exit-continuation info)))))))
\r
410 +(defun ert--run-test-internal (ert-test-execution-info)
\r
411 + "Low-level function to run a test according to ERT-TEST-EXECUTION-INFO.
\r
413 +This mainly sets up debugger-related bindings."
\r
414 + (lexical-let ((info ert-test-execution-info))
\r
415 + (setf (ert--test-execution-info-next-debugger info) debugger
\r
416 + (ert--test-execution-info-ert-debug-on-error info) ert-debug-on-error)
\r
417 + (catch 'ert--pass
\r
418 + ;; For now, each test gets its own temp buffer and its own
\r
419 + ;; window excursion, just to be safe. If this turns out to be
\r
420 + ;; too expensive, we can remove it.
\r
421 + (with-temp-buffer
\r
422 + (save-window-excursion
\r
423 + (let ((debugger (lambda (&rest debugger-args)
\r
424 + (ert--run-test-debugger info debugger-args)))
\r
425 + (debug-on-error t)
\r
426 + (debug-on-quit t)
\r
427 + ;; FIXME: Do we need to store the old binding of this
\r
428 + ;; and consider it in `ert--run-test-debugger'?
\r
429 + (debug-ignored-errors nil)
\r
430 + (ert--infos '()))
\r
431 + (funcall (ert-test-body (ert--test-execution-info-test info))))))
\r
433 + (setf (ert--test-execution-info-result info) (make-ert-test-passed)))
\r
436 +(defun ert--force-message-log-buffer-truncation ()
\r
437 + "Immediately truncate *Messages* buffer according to `message-log-max'.
\r
439 +This can be useful after reducing the value of `message-log-max'."
\r
440 + (with-current-buffer (get-buffer-create "*Messages*")
\r
441 + ;; This is a reimplementation of this part of message_dolog() in xdisp.c:
\r
442 + ;; if (NATNUMP (Vmessage_log_max))
\r
444 + ;; scan_newline (Z, Z_BYTE, BEG, BEG_BYTE,
\r
445 + ;; -XFASTINT (Vmessage_log_max) - 1, 0);
\r
446 + ;; del_range_both (BEG, BEG_BYTE, PT, PT_BYTE, 0);
\r
448 + (when (and (integerp message-log-max) (>= message-log-max 0))
\r
449 + (let ((begin (point-min))
\r
450 + (end (save-excursion
\r
451 + (goto-char (point-max))
\r
452 + (forward-line (- message-log-max))
\r
454 + (delete-region begin end)))))
\r
456 +(defvar ert--running-tests nil
\r
457 + "List of tests that are currently in execution.
\r
459 +This list is empty while no test is running, has one element
\r
460 +while a test is running, two elements while a test run from
\r
461 +inside a test is running, etc. The list is in order of nesting,
\r
462 +innermost test first.
\r
464 +The elements are of type `ert-test'.")
\r
466 +(defun ert-run-test (ert-test)
\r
469 +Returns the result and stores it in ERT-TEST's `most-recent-result' slot."
\r
470 + (setf (ert-test-most-recent-result ert-test) nil)
\r
472 + (lexical-let ((begin-marker
\r
473 + (with-current-buffer (get-buffer-create "*Messages*")
\r
474 + (set-marker (make-marker) (point-max)))))
\r
476 + (lexical-let ((info (make-ert--test-execution-info
\r
479 + (make-ert-test-aborted-with-non-local-exit)
\r
480 + :exit-continuation (lambda ()
\r
481 + (return-from error nil))))
\r
482 + (should-form-accu (list)))
\r
484 + (let ((ert--should-execution-observer
\r
485 + (lambda (form-description)
\r
486 + (push form-description should-form-accu)))
\r
487 + (message-log-max t)
\r
488 + (ert--running-tests (cons ert-test ert--running-tests)))
\r
489 + (ert--run-test-internal info))
\r
490 + (let ((result (ert--test-execution-info-result info)))
\r
491 + (setf (ert-test-result-messages result)
\r
492 + (with-current-buffer (get-buffer-create "*Messages*")
\r
493 + (buffer-substring begin-marker (point-max))))
\r
494 + (ert--force-message-log-buffer-truncation)
\r
495 + (setq should-form-accu (nreverse should-form-accu))
\r
496 + (setf (ert-test-result-should-forms result)
\r
497 + should-form-accu)
\r
498 + (setf (ert-test-most-recent-result ert-test) result))))
\r
499 + (set-marker begin-marker nil))))
\r
500 + (ert-test-most-recent-result ert-test))
\r
502 +(defun ert-running-test ()
\r
503 + "Return the top-level test currently executing."
\r
504 + (car (last ert--running-tests)))
\r
507 +;;; Test selectors.
\r
509 +;; Autoload since ert.el refers to it in the docstring of
\r
512 +(defun ert-test-result-type-p (result result-type)
\r
513 + "Return non-nil if RESULT matches type RESULT-TYPE.
\r
515 +Valid result types:
\r
517 +nil -- Never matches.
\r
518 +t -- Always matches.
\r
519 +:failed, :passed -- Matches corresponding results.
\r
520 +\(and TYPES...\) -- Matches if all TYPES match.
\r
521 +\(or TYPES...\) -- Matches if some TYPES match.
\r
522 +\(not TYPE\) -- Matches if TYPE does not match.
\r
523 +\(satisfies PREDICATE\) -- Matches if PREDICATE returns true when called with
\r
525 + ;; It would be easy to add `member' and `eql' types etc., but I
\r
526 + ;; haven't bothered yet.
\r
527 + (etypecase result-type
\r
528 + ((member nil) nil)
\r
530 + ((member :failed) (ert-test-failed-p result))
\r
531 + ((member :passed) (ert-test-passed-p result))
\r
533 + (destructuring-bind (operator &rest operands) result-type
\r
536 + (case (length operands)
\r
539 + (and (ert-test-result-type-p result (first operands))
\r
540 + (ert-test-result-type-p result `(and ,@(rest operands)))))))
\r
542 + (case (length operands)
\r
545 + (or (ert-test-result-type-p result (first operands))
\r
546 + (ert-test-result-type-p result `(or ,@(rest operands)))))))
\r
548 + (assert (eql (length operands) 1))
\r
549 + (not (ert-test-result-type-p result (first operands))))
\r
551 + (assert (eql (length operands) 1))
\r
552 + (funcall (first operands) result)))))))
\r
554 +(defun ert-test-result-expected-p (test result)
\r
555 + "Return non-nil if TEST's expected result type matches RESULT."
\r
556 + (ert-test-result-type-p result (ert-test-expected-result-type test)))
\r
558 +;; Autoload since ert-ui.el refers to it in the docstring of
\r
559 +;; `ert-run-tests-interactively'.
\r
561 +(defun ert-select-tests (selector universe)
\r
562 + "Return the tests that match SELECTOR.
\r
564 +UNIVERSE specifies the set of tests to select from; it should be
\r
565 +a list of tests, or t, which refers to all tests named by symbols
\r
568 +Returns the set of tests as a list.
\r
572 +nil -- Selects the empty set.
\r
573 +t -- Selects UNIVERSE.
\r
574 +:new -- Selects all tests that have not been run yet.
\r
575 +:failed, :passed -- Select tests according to their most recent result.
\r
576 +:expected, :unexpected -- Select tests according to their most recent result.
\r
577 +a string -- Selects all tests that have a name that matches the string,
\r
579 +a test -- Selects that test.
\r
580 +a symbol -- Selects the test that the symbol names, errors if none.
\r
581 +\(member TESTS...\) -- Selects TESTS, a list of tests or symbols naming tests.
\r
582 +\(eql TEST\) -- Selects TEST, a test or a symbol naming a test.
\r
583 +\(and SELECTORS...\) -- Selects the tests that match all SELECTORS.
\r
584 +\(or SELECTORS...\) -- Selects the tests that match any SELECTOR.
\r
585 +\(not SELECTOR\) -- Selects all tests that do not match SELECTOR.
\r
586 +\(tag TAG) -- Selects all tests that have TAG on their tags list.
\r
587 +\(satisfies PREDICATE\) -- Selects all tests that satisfy PREDICATE.
\r
589 +Only selectors that require a superset of tests, such
\r
590 +as (satisfies ...), strings, :new, etc. make use of UNIVERSE.
\r
591 +Selectors that do not, such as \(member ...\), just return the
\r
592 +set implied by them without checking whether it is really
\r
593 +contained in UNIVERSE."
\r
594 + ;; This code needs to match the etypecase in
\r
595 + ;; `ert-insert-human-readable-selector'.
\r
596 + (etypecase selector
\r
597 + ((member nil) nil)
\r
598 + ((member t) (etypecase universe
\r
600 + ((member t) (ert-select-tests "" universe))))
\r
601 + ((member :new) (ert-select-tests
\r
602 + `(satisfies ,(lambda (test)
\r
603 + (null (ert-test-most-recent-result test))))
\r
605 + ((member :failed) (ert-select-tests
\r
606 + `(satisfies ,(lambda (test)
\r
607 + (ert-test-result-type-p
\r
608 + (ert-test-most-recent-result test)
\r
611 + ((member :passed) (ert-select-tests
\r
612 + `(satisfies ,(lambda (test)
\r
613 + (ert-test-result-type-p
\r
614 + (ert-test-most-recent-result test)
\r
617 + ((member :expected) (ert-select-tests
\r
620 + (ert-test-result-expected-p
\r
622 + (ert-test-most-recent-result test))))
\r
624 + ((member :unexpected) (ert-select-tests `(not :expected) universe))
\r
626 + (etypecase universe
\r
627 + ((member t) (mapcar #'ert-get-test
\r
628 + (apropos-internal selector #'ert-test-boundp)))
\r
629 + (list (ert--remove-if-not (lambda (test)
\r
630 + (and (ert-test-name test)
\r
631 + (string-match selector
\r
632 + (ert-test-name test))))
\r
634 + (ert-test (list selector))
\r
636 + (assert (ert-test-boundp selector))
\r
637 + (list (ert-get-test selector)))
\r
639 + (destructuring-bind (operator &rest operands) selector
\r
642 + (mapcar (lambda (purported-test)
\r
643 + (etypecase purported-test
\r
644 + (symbol (assert (ert-test-boundp purported-test))
\r
645 + (ert-get-test purported-test))
\r
646 + (ert-test purported-test)))
\r
649 + (assert (eql (length operands) 1))
\r
650 + (ert-select-tests `(member ,@operands) universe))
\r
652 + ;; Do these definitions of AND, NOT and OR satisfy de
\r
653 + ;; Morgan's laws? Should they?
\r
654 + (case (length operands)
\r
655 + (0 (ert-select-tests 't universe))
\r
656 + (t (ert-select-tests `(and ,@(rest operands))
\r
657 + (ert-select-tests (first operands)
\r
660 + (assert (eql (length operands) 1))
\r
661 + (let ((all-tests (ert-select-tests 't universe)))
\r
662 + (ert--set-difference all-tests
\r
663 + (ert-select-tests (first operands) all-tests))))
\r
665 + (case (length operands)
\r
666 + (0 (ert-select-tests 'nil universe))
\r
667 + (t (ert--union (ert-select-tests (first operands) universe)
\r
668 + (ert-select-tests `(or ,@(rest operands))
\r
671 + (assert (eql (length operands) 1))
\r
672 + (let ((tag (first operands)))
\r
673 + (ert-select-tests `(satisfies
\r
675 + (member tag (ert-test-tags test))))
\r
678 + (assert (eql (length operands) 1))
\r
679 + (ert--remove-if-not (first operands)
\r
680 + (ert-select-tests 't universe))))))))
\r
682 +(defun ert--insert-human-readable-selector (selector)
\r
683 + "Insert a human-readable presentation of SELECTOR into the current buffer."
\r
684 + ;; This is needed to avoid printing the (huge) contents of the
\r
685 + ;; `backtrace' slot of the result objects in the
\r
686 + ;; `most-recent-result' slots of test case objects in (eql ...) or
\r
687 + ;; (member ...) selectors.
\r
688 + (labels ((rec (selector)
\r
689 + ;; This code needs to match the etypecase in `ert-select-tests'.
\r
690 + (etypecase selector
\r
691 + ((or (member nil t
\r
692 + :new :failed :passed
\r
693 + :expected :unexpected)
\r
698 + (if (ert-test-name selector)
\r
699 + (make-symbol (format "<%S>" (ert-test-name selector)))
\r
700 + (make-symbol "<unnamed test>")))
\r
702 + (destructuring-bind (operator &rest operands) selector
\r
704 + ((member eql and not or)
\r
705 + `(,operator ,@(mapcar #'rec operands)))
\r
706 + ((member tag satisfies)
\r
708 + (insert (format "%S" (rec selector)))))
\r
711 +;;; Facilities for running a whole set of tests.
\r
713 +;; The data structure that contains the set of tests being executed
\r
714 +;; during one particular test run, their results, the state of the
\r
715 +;; execution, and some statistics.
\r
717 +;; The data about results and expected results of tests may seem
\r
718 +;; redundant here, since the test objects also carry such information.
\r
719 +;; However, the information in the test objects may be more recent, it
\r
720 +;; may correspond to a different test run. We need the information
\r
721 +;; that corresponds to this run in order to be able to update the
\r
722 +;; statistics correctly when a test is re-run interactively and has a
\r
723 +;; different result than before.
\r
724 +(defstruct ert--stats
\r
725 + (selector (assert nil))
\r
726 + ;; The tests, in order.
\r
727 + (tests (assert nil) :type vector)
\r
728 + ;; A map of test names (or the test objects themselves for unnamed
\r
729 + ;; tests) to indices into the `tests' vector.
\r
730 + (test-map (assert nil) :type hash-table)
\r
731 + ;; The results of the tests during this run, in order.
\r
732 + (test-results (assert nil) :type vector)
\r
733 + ;; The start times of the tests, in order, as reported by
\r
734 + ;; `current-time'.
\r
735 + (test-start-times (assert nil) :type vector)
\r
736 + ;; The end times of the tests, in order, as reported by
\r
737 + ;; `current-time'.
\r
738 + (test-end-times (assert nil) :type vector)
\r
739 + (passed-expected 0)
\r
740 + (passed-unexpected 0)
\r
741 + (failed-expected 0)
\r
742 + (failed-unexpected 0)
\r
746 + (current-test nil)
\r
747 + ;; The time at or after which the next redisplay should occur, as a
\r
749 + (next-redisplay 0.0))
\r
751 +(defun ert-stats-completed-expected (stats)
\r
752 + "Return the number of tests in STATS that had expected results."
\r
753 + (+ (ert--stats-passed-expected stats)
\r
754 + (ert--stats-failed-expected stats)))
\r
756 +(defun ert-stats-completed-unexpected (stats)
\r
757 + "Return the number of tests in STATS that had unexpected results."
\r
758 + (+ (ert--stats-passed-unexpected stats)
\r
759 + (ert--stats-failed-unexpected stats)))
\r
761 +(defun ert-stats-completed (stats)
\r
762 + "Number of tests in STATS that have run so far."
\r
763 + (+ (ert-stats-completed-expected stats)
\r
764 + (ert-stats-completed-unexpected stats)))
\r
766 +(defun ert-stats-total (stats)
\r
767 + "Number of tests in STATS, regardless of whether they have run yet."
\r
768 + (length (ert--stats-tests stats)))
\r
770 +;; The stats object of the current run, dynamically bound. This is
\r
771 +;; used for the mode line progress indicator.
\r
772 +(defvar ert--current-run-stats nil)
\r
774 +(defun ert--stats-test-key (test)
\r
775 + "Return the key used for TEST in the test map of ert--stats objects.
\r
777 +Returns the name of TEST if it has one, or TEST itself otherwise."
\r
778 + (or (ert-test-name test) test))
\r
780 +(defun ert--stats-set-test-and-result (stats pos test result)
\r
781 + "Change STATS by replacing the test at position POS with TEST and RESULT.
\r
783 +Also changes the counters in STATS to match."
\r
784 + (let* ((tests (ert--stats-tests stats))
\r
785 + (results (ert--stats-test-results stats))
\r
786 + (old-test (aref tests pos))
\r
787 + (map (ert--stats-test-map stats)))
\r
788 + (flet ((update (d)
\r
789 + (if (ert-test-result-expected-p (aref tests pos) (aref results pos))
\r
790 + (etypecase (aref results pos)
\r
791 + (ert-test-passed (incf (ert--stats-passed-expected stats) d))
\r
792 + (ert-test-failed (incf (ert--stats-failed-expected stats) d))
\r
794 + (ert-test-aborted-with-non-local-exit))
\r
795 + (etypecase (aref results pos)
\r
796 + (ert-test-passed (incf (ert--stats-passed-unexpected stats) d))
\r
797 + (ert-test-failed (incf (ert--stats-failed-unexpected stats) d))
\r
799 + (ert-test-aborted-with-non-local-exit)))))
\r
800 + ;; Adjust counters to remove the result that is currently in stats.
\r
802 + ;; Put new test and result into stats.
\r
803 + (setf (aref tests pos) test
\r
804 + (aref results pos) result)
\r
805 + (remhash (ert--stats-test-key old-test) map)
\r
806 + (setf (gethash (ert--stats-test-key test) map) pos)
\r
807 + ;; Adjust counters to match new result.
\r
811 +(defun ert--make-stats (tests selector)
\r
812 + "Create a new `ert--stats' object for running TESTS.
\r
814 +SELECTOR is the selector that was used to select TESTS."
\r
815 + (setq tests (ert--coerce-to-vector tests))
\r
816 + (let ((map (make-hash-table :size (length tests))))
\r
817 + (loop for i from 0
\r
818 + for test across tests
\r
819 + for key = (ert--stats-test-key test) do
\r
820 + (assert (not (gethash key map)))
\r
821 + (setf (gethash key map) i))
\r
822 + (make-ert--stats :selector selector
\r
825 + :test-results (make-vector (length tests) nil)
\r
826 + :test-start-times (make-vector (length tests) nil)
\r
827 + :test-end-times (make-vector (length tests) nil))))
\r
829 +(defun ert-run-or-rerun-test (stats test listener)
\r
830 + ;; checkdoc-order: nil
\r
831 + "Run the single test TEST and record the result using STATS and LISTENER."
\r
832 + (let ((ert--current-run-stats stats)
\r
833 + (pos (ert--stats-test-pos stats test)))
\r
834 + (ert--stats-set-test-and-result stats pos test nil)
\r
835 + ;; Call listener after setting/before resetting
\r
836 + ;; (ert--stats-current-test stats); the listener might refresh the
\r
837 + ;; mode line display, and if the value is not set yet/any more
\r
838 + ;; during this refresh, the mode line will flicker unnecessarily.
\r
839 + (setf (ert--stats-current-test stats) test)
\r
840 + (funcall listener 'test-started stats test)
\r
841 + (setf (ert-test-most-recent-result test) nil)
\r
842 + (setf (aref (ert--stats-test-start-times stats) pos) (current-time))
\r
844 + (ert-run-test test)
\r
845 + (setf (aref (ert--stats-test-end-times stats) pos) (current-time))
\r
846 + (let ((result (ert-test-most-recent-result test)))
\r
847 + (ert--stats-set-test-and-result stats pos test result)
\r
848 + (funcall listener 'test-ended stats test result))
\r
849 + (setf (ert--stats-current-test stats) nil))))
\r
851 +(defun ert-run-tests (selector listener)
\r
852 + "Run the tests specified by SELECTOR, sending progress updates to LISTENER."
\r
853 + (let* ((tests (ert-select-tests selector t))
\r
854 + (stats (ert--make-stats tests selector)))
\r
855 + (setf (ert--stats-start-time stats) (current-time))
\r
856 + (funcall listener 'run-started stats)
\r
857 + (let ((abortedp t))
\r
858 + (let ((ert--current-run-stats stats))
\r
859 + (force-mode-line-update)
\r
862 + (loop for test in tests do
\r
863 + (ert-run-or-rerun-test stats test listener))
\r
864 + (setq abortedp nil))
\r
865 + (setf (ert--stats-aborted-p stats) abortedp)
\r
866 + (setf (ert--stats-end-time stats) (current-time))
\r
867 + (funcall listener 'run-ended stats abortedp)))
\r
870 +(defun ert--stats-test-pos (stats test)
\r
871 + ;; checkdoc-order: nil
\r
872 + "Return the position (index) of TEST in the run represented by STATS."
\r
873 + (gethash (ert--stats-test-key test) (ert--stats-test-map stats)))
\r
876 +;;; Formatting functions shared across UIs.
\r
878 +(defun ert--format-time-iso8601 (time)
\r
879 + "Format TIME in the variant of ISO 8601 used for timestamps in ERT."
\r
880 + (format-time-string "%Y-%m-%d %T%z" time))
\r
882 +(defun ert-char-for-test-result (result expectedp)
\r
883 + "Return a character that represents the test result RESULT.
\r
885 +EXPECTEDP specifies whether the result was expected."
\r
886 + (let ((s (etypecase result
\r
887 + (ert-test-passed ".P")
\r
888 + (ert-test-failed "fF")
\r
890 + (ert-test-aborted-with-non-local-exit "aA"))))
\r
891 + (elt s (if expectedp 0 1))))
\r
893 +(defun ert-string-for-test-result (result expectedp)
\r
894 + "Return a string that represents the test result RESULT.
\r
896 +EXPECTEDP specifies whether the result was expected."
\r
897 + (let ((s (etypecase result
\r
898 + (ert-test-passed '("passed" "PASSED"))
\r
899 + (ert-test-failed '("failed" "FAILED"))
\r
900 + (null '("unknown" "UNKNOWN"))
\r
901 + (ert-test-aborted-with-non-local-exit '("aborted" "ABORTED")))))
\r
902 + (elt s (if expectedp 0 1))))
\r
904 +(defun ert--pp-with-indentation-and-newline (object)
\r
905 + "Pretty-print OBJECT, indenting it to the current column of point.
\r
906 +Ensures a final newline is inserted."
\r
907 + (let ((begin (point)))
\r
908 + (pp object (current-buffer))
\r
909 + (unless (bolp) (insert "\n"))
\r
911 + (goto-char begin)
\r
914 +(defun ert--insert-infos (result)
\r
915 + "Insert `ert-info' infos from RESULT into current buffer.
\r
917 +RESULT must be an `ert-test-result-with-condition'."
\r
918 + (check-type result ert-test-result-with-condition)
\r
919 + (dolist (info (ert-test-result-with-condition-infos result))
\r
920 + (destructuring-bind (prefix . message) info
\r
921 + (let ((begin (point))
\r
922 + (indentation (make-string (+ (length prefix) 4) ?\s))
\r
926 + (insert message "\n")
\r
927 + (setq end (copy-marker (point)))
\r
928 + (goto-char begin)
\r
929 + (insert " " prefix)
\r
931 + (while (< (point) end)
\r
932 + (insert indentation)
\r
933 + (forward-line 1)))
\r
934 + (when end (set-marker end nil)))))))
\r
937 +(provide 'ert-run)
\r
939 +;;; ert-run.el ends here
\r
940 diff --git a/test/ert/ert-ui.el b/test/ert/ert-ui.el
\r
941 new file mode 100644
\r
942 index 0000000..bf58492
\r
944 +++ b/test/ert/ert-ui.el
\r
946 +;;; ert-ui.el --- ERT's interactive UI
\r
948 +;; Copyright (C) 2007, 2008, 2010 Free Software Foundation, Inc.
\r
950 +;; Author: Christian M. Ohler
\r
952 +;; This file is NOT part of GNU Emacs.
\r
954 +;; This program is free software: you can redistribute it and/or
\r
955 +;; modify it under the terms of the GNU General Public License as
\r
956 +;; published by the Free Software Foundation, either version 3 of the
\r
957 +;; License, or (at your option) any later version.
\r
959 +;; This program is distributed in the hope that it will be useful, but
\r
960 +;; WITHOUT ANY WARRANTY; without even the implied warranty of
\r
961 +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
\r
962 +;; General Public License for more details.
\r
964 +;; You should have received a copy of the GNU General Public License
\r
965 +;; along with this program. If not, see `http://www.gnu.org/licenses/'.
\r
969 +;; This file is part of ERT, the Emacs Lisp Regression Testing tool.
\r
970 +;; See ert.el or the texinfo manual for more details.
\r
974 +(eval-when-compile
\r
977 +(require 'ert-run)
\r
978 +(require 'easymenu)
\r
984 +;;; UI customization options.
\r
987 + "ERT, the Emacs Lisp regression testing tool."
\r
991 +(defface ert-test-result-expected '((((class color) (background light))
\r
992 + :background "green1")
\r
993 + (((class color) (background dark))
\r
994 + :background "green3"))
\r
995 + "Face used for expected results in the ERT results buffer."
\r
998 +(defface ert-test-result-unexpected '((((class color) (background light))
\r
999 + :background "red1")
\r
1000 + (((class color) (background dark))
\r
1001 + :background "red3"))
\r
1002 + "Face used for unexpected results in the ERT results buffer."
\r
1006 +;;; Some basic interactive functions.
\r
1008 +(defun ert-read-test-name (prompt &optional default history
\r
1009 + add-default-to-prompt)
\r
1010 + "Read the name of a test and return it as a symbol.
\r
1012 +Prompt with PROMPT. If DEFAULT is a valid test name, use it as a
\r
1013 +default. HISTORY is the history to use; see `completing-read'.
\r
1014 +If ADD-DEFAULT-TO-PROMPT is non-nil, PROMPT will be modified to
\r
1015 +include the default, if any.
\r
1017 +Signals an error if no test name was read."
\r
1018 + (etypecase default
\r
1019 + (string (let ((symbol (intern-soft default)))
\r
1020 + (unless (and symbol (ert-test-boundp symbol))
\r
1021 + (setq default nil))))
\r
1022 + (symbol (setq default
\r
1023 + (if (ert-test-boundp default)
\r
1024 + (symbol-name default)
\r
1026 + (ert-test (setq default (ert-test-name default))))
\r
1027 + (when add-default-to-prompt
\r
1028 + (setq prompt (if (null default)
\r
1029 + (format "%s: " prompt)
\r
1030 + (format "%s (default %s): " prompt default))))
\r
1031 + (let ((input (completing-read prompt obarray #'ert-test-boundp
\r
1032 + t nil history default nil)))
\r
1033 + ;; completing-read returns an empty string if default was nil and
\r
1034 + ;; the user just hit enter.
\r
1035 + (let ((sym (intern-soft input)))
\r
1036 + (if (ert-test-boundp sym)
\r
1038 + (error "Input does not name a test")))))
\r
1040 +(defun ert-read-test-name-at-point (prompt)
\r
1041 + "Read the name of a test and return it as a symbol.
\r
1042 +As a default, use the symbol at point, or the test at point if in
\r
1043 +the ERT results buffer. Prompt with PROMPT, augmented with the
\r
1044 +default (if any)."
\r
1045 + (ert-read-test-name prompt (ert-test-at-point) nil t))
\r
1047 +(defun ert-find-test-other-window (test-name)
\r
1048 + "Find, in another window, the definition of TEST-NAME."
\r
1049 + (interactive (list (ert-read-test-name-at-point "Find test definition: ")))
\r
1050 + (find-function-do-it test-name 'ert-deftest 'switch-to-buffer-other-window))
\r
1052 +(defun ert-delete-test (test-name)
\r
1053 + "Make the test TEST-NAME unbound.
\r
1055 +Nothing more than an interactive interface to `ert-make-test-unbound'."
\r
1056 + (interactive (list (ert-read-test-name-at-point "Delete test")))
\r
1057 + (ert-make-test-unbound test-name))
\r
1059 +(defun ert-delete-all-tests ()
\r
1060 + "Make all symbols in `obarray' name no test."
\r
1062 + (when (interactive-p)
\r
1063 + (unless (y-or-n-p "Delete all tests? ")
\r
1064 + (error "Aborted")))
\r
1065 + ;; We can't use `ert-select-tests' here since that gives us only
\r
1066 + ;; test objects, and going from them back to the test name symbols
\r
1067 + ;; can fail if the `ert-test' defstruct has been redefined.
\r
1068 + (mapc #'ert-make-test-unbound (apropos-internal "" #'ert-test-boundp))
\r
1072 +;;; Display of test progress and results.
\r
1074 +;; An entry in the results buffer ewoc. There is one entry per test.
\r
1075 +(defstruct ert--ewoc-entry
\r
1076 + (test (assert nil))
\r
1077 + ;; If the result of this test was expected, its ewoc entry is hidden
\r
1079 + (hidden-p (assert nil))
\r
1080 + ;; An ewoc entry may be collapsed to hide details such as the error
\r
1083 + ;; I'm not sure the ability to expand and collapse entries is still
\r
1084 + ;; a useful feature.
\r
1086 + ;; By default, the ewoc entry presents the error condition with
\r
1087 + ;; certain limits on how much to print (`print-level',
\r
1088 + ;; `print-length'). The user can interactively switch to a set of
\r
1089 + ;; higher limits.
\r
1090 + (extended-printer-limits-p nil))
\r
1092 +;; Variables local to the results buffer.
\r
1095 +(defvar ert--results-ewoc)
\r
1096 +;; The stats object.
\r
1097 +(defvar ert--results-stats)
\r
1098 +;; A string with one character per test. Each character represents
\r
1099 +;; the result of the corresponding test. The string is displayed near
\r
1100 +;; the top of the buffer and serves as a progress bar.
\r
1101 +(defvar ert--results-progress-bar-string)
\r
1102 +;; The position where the progress bar button begins.
\r
1103 +(defvar ert--results-progress-bar-button-begin)
\r
1104 +;; The test result listener that updates the buffer when tests are run.
\r
1105 +(defvar ert--results-listener)
\r
1107 +(defun ert-insert-test-name-button (test-name)
\r
1108 + "Insert a button that links to TEST-NAME."
\r
1109 + (insert-text-button (format "%S" test-name)
\r
1110 + :type 'ert--test-name-button
\r
1111 + 'ert-test-name test-name))
\r
1113 +(defun ert--results-format-expected-unexpected (expected unexpected)
\r
1114 + "Return a string indicating EXPECTED expected results, UNEXPECTED unexpected."
\r
1115 + (if (zerop unexpected)
\r
1116 + (format "%s" expected)
\r
1117 + (format "%s (%s unexpected)" (+ expected unexpected) unexpected)))
\r
1119 +(defun ert--results-update-ewoc-hf (ewoc stats)
\r
1120 + "Update the header and footer of EWOC to show certain information from STATS.
\r
1122 +Also sets `ert--results-progress-bar-button-begin'."
\r
1123 + (let ((run-count (ert-stats-completed stats))
\r
1124 + (results-buffer (current-buffer))
\r
1125 + ;; Need to save buffer-local value.
\r
1126 + (font-lock font-lock-mode))
\r
1130 + (with-temp-buffer
\r
1131 + (insert "Selector: ")
\r
1132 + (ert--insert-human-readable-selector (ert--stats-selector stats))
\r
1135 + (format (concat "Passed: %s\n"
\r
1137 + "Total: %s/%s\n\n")
\r
1138 + (ert--results-format-expected-unexpected
\r
1139 + (ert--stats-passed-expected stats)
\r
1140 + (ert--stats-passed-unexpected stats))
\r
1141 + (ert--results-format-expected-unexpected
\r
1142 + (ert--stats-failed-expected stats)
\r
1143 + (ert--stats-failed-unexpected stats))
\r
1145 + (ert-stats-total stats)))
\r
1147 + (format "Started at: %s\n"
\r
1148 + (ert--format-time-iso8601 (ert--stats-start-time stats))))
\r
1149 + ;; FIXME: This is ugly. Need to properly define invariants of
\r
1150 + ;; the `stats' data structure.
\r
1151 + (let ((state (cond ((ert--stats-aborted-p stats) 'aborted)
\r
1152 + ((ert--stats-current-test stats) 'running)
\r
1153 + ((ert--stats-end-time stats) 'finished)
\r
1154 + (t 'preparing))))
\r
1159 + (cond ((ert--stats-current-test stats)
\r
1160 + (insert "Aborted during test: ")
\r
1161 + (ert-insert-test-name-button
\r
1162 + (ert-test-name (ert--stats-current-test stats))))
\r
1164 + (insert "Aborted."))))
\r
1166 + (assert (ert--stats-current-test stats))
\r
1167 + (insert "Running test: ")
\r
1168 + (ert-insert-test-name-button (ert-test-name
\r
1169 + (ert--stats-current-test stats))))
\r
1171 + (assert (not (ert--stats-current-test stats)))
\r
1172 + (insert "Finished.")))
\r
1174 + (if (ert--stats-end-time stats)
\r
1176 + (format "%s%s\n"
\r
1177 + (if (ert--stats-aborted-p stats)
\r
1179 + "Finished at: ")
\r
1180 + (ert--format-time-iso8601 (ert--stats-end-time stats))))
\r
1183 + (let ((progress-bar-string (with-current-buffer results-buffer
\r
1184 + ert--results-progress-bar-string)))
\r
1185 + (let ((progress-bar-button-begin
\r
1186 + (insert-text-button progress-bar-string
\r
1187 + :type 'ert--results-progress-bar-button
\r
1188 + 'face (or (and font-lock
\r
1189 + (ert-face-for-stats stats))
\r
1191 + ;; The header gets copied verbatim to the results buffer,
\r
1192 + ;; and all positions remain the same, so
\r
1193 + ;; `progress-bar-button-begin' will be the right position
\r
1194 + ;; even in the results buffer.
\r
1195 + (with-current-buffer results-buffer
\r
1196 + (set (make-local-variable 'ert--results-progress-bar-button-begin)
\r
1197 + progress-bar-button-begin))))
\r
1199 + (buffer-string))
\r
1202 + ;; We actually want an empty footer, but that would trigger a bug
\r
1203 + ;; in ewoc, sometimes clearing the entire buffer. (It's possible
\r
1204 + ;; that this bug has been fixed since this has been tested; we
\r
1205 + ;; should test it again.)
\r
1209 +(defvar ert-test-run-redisplay-interval-secs .1
\r
1210 + "How many seconds ERT should wait between redisplays while running tests.
\r
1212 +While running tests, ERT shows the current progress, and this variable
\r
1213 +determines how frequently the progress display is updated.")
\r
1215 +(defun ert--results-update-stats-display (ewoc stats)
\r
1216 + "Update EWOC and the mode line to show data from STATS."
\r
1217 + ;; TODO(ohler): investigate using `make-progress-reporter'.
\r
1218 + (ert--results-update-ewoc-hf ewoc stats)
\r
1219 + (force-mode-line-update)
\r
1221 + (setf (ert--stats-next-redisplay stats)
\r
1222 + (+ (float-time) ert-test-run-redisplay-interval-secs)))
\r
1224 +(defun ert--results-update-stats-display-maybe (ewoc stats)
\r
1225 + "Call `ert--results-update-stats-display' if not called recently.
\r
1227 +EWOC and STATS are arguments for `ert--results-update-stats-display'."
\r
1228 + (when (>= (float-time) (ert--stats-next-redisplay stats))
\r
1229 + (ert--results-update-stats-display ewoc stats)))
\r
1231 +(defun ert--tests-running-mode-line-indicator ()
\r
1232 + "Return a string for the mode line that shows the test run progress."
\r
1233 + (let* ((stats ert--current-run-stats)
\r
1234 + (tests-total (ert-stats-total stats))
\r
1235 + (tests-completed (ert-stats-completed stats)))
\r
1236 + (if (>= tests-completed tests-total)
\r
1237 + (format " ERT(%s/%s,finished)" tests-completed tests-total)
\r
1238 + (format " ERT(%s/%s):%s"
\r
1239 + (1+ tests-completed)
\r
1241 + (if (null (ert--stats-current-test stats))
\r
1244 + (ert-test-name (ert--stats-current-test stats))))))))
\r
1246 +(defun ert--make-xrefs-region (begin end)
\r
1247 + "Attach cross-references to function names between BEGIN and END.
\r
1249 +BEGIN and END specify a region in the current buffer."
\r
1251 + (save-restriction
\r
1252 + (narrow-to-region begin (point))
\r
1253 + ;; Inhibit optimization in `debugger-make-xrefs' that would
\r
1254 + ;; sometimes insert unrelated backtrace info into our buffer.
\r
1255 + (let ((debugger-previous-backtrace nil))
\r
1256 + (debugger-make-xrefs)))))
\r
1258 +(defun ert--string-first-line (s)
\r
1259 + "Return the first line of S, or S if it contains no newlines.
\r
1261 +The return value does not include the line terminator."
\r
1262 + (substring s 0 (ert--string-position ?\n s)))
\r
1264 +(defun ert-face-for-test-result (expectedp)
\r
1265 + "Return a face that shows whether a test result was expected or unexpected.
\r
1267 +If EXPECTEDP is nil, returns the face for unexpected results; if
\r
1268 +non-nil, returns the face for expected results.."
\r
1269 + (if expectedp 'ert-test-result-expected 'ert-test-result-unexpected))
\r
1271 +(defun ert-face-for-stats (stats)
\r
1272 + "Return a face that represents STATS."
\r
1273 + (cond ((ert--stats-aborted-p stats) 'nil)
\r
1274 + ((plusp (ert-stats-completed-unexpected stats))
\r
1275 + (ert-face-for-test-result nil))
\r
1276 + ((eql (ert-stats-completed-expected stats) (ert-stats-total stats))
\r
1277 + (ert-face-for-test-result t))
\r
1280 +(defun ert--print-test-for-ewoc (entry)
\r
1281 + "The ewoc print function for ewoc test entries. ENTRY is the entry to print."
\r
1282 + (let* ((test (ert--ewoc-entry-test entry))
\r
1283 + (stats ert--results-stats)
\r
1284 + (result (let ((pos (ert--stats-test-pos stats test)))
\r
1286 + (aref (ert--stats-test-results stats) pos)))
\r
1287 + (hiddenp (ert--ewoc-entry-hidden-p entry))
\r
1288 + (expandedp (ert--ewoc-entry-expanded-p entry))
\r
1289 + (extended-printer-limits-p (ert--ewoc-entry-extended-printer-limits-p
\r
1293 + (let ((expectedp (ert-test-result-expected-p test result)))
\r
1294 + (insert-text-button (format "%c" (ert-char-for-test-result
\r
1295 + result expectedp))
\r
1296 + :type 'ert--results-expand-collapse-button
\r
1297 + 'face (or (and font-lock-mode
\r
1298 + (ert-face-for-test-result
\r
1302 + (ert-insert-test-name-button (ert-test-name test))
\r
1304 + (when (and expandedp (not (eql result 'nil)))
\r
1305 + (when (ert-test-documentation test)
\r
1308 + (ert--string-first-line (ert-test-documentation test))
\r
1309 + 'font-lock-face 'font-lock-doc-face)
\r
1311 + (etypecase result
\r
1312 + (ert-test-passed
\r
1313 + (if (ert-test-result-expected-p test result)
\r
1314 + (insert " passed\n")
\r
1315 + (insert " passed unexpectedly\n"))
\r
1317 + (ert-test-result-with-condition
\r
1318 + (ert--insert-infos result)
\r
1319 + (let ((print-escape-newlines t)
\r
1320 + (print-level (if extended-printer-limits-p 12 6))
\r
1321 + (print-length (if extended-printer-limits-p 100 10)))
\r
1323 + (let ((begin (point)))
\r
1324 + (ert--pp-with-indentation-and-newline
\r
1325 + (ert-test-result-with-condition-condition result))
\r
1326 + (ert--make-xrefs-region begin (point)))))
\r
1327 + (ert-test-aborted-with-non-local-exit
\r
1328 + (insert " aborted\n")))
\r
1329 + (insert "\n")))))
\r
1332 +(defun ert--results-font-lock-function (enabledp)
\r
1333 + "Redraw the ERT results buffer after font-lock-mode was switched on or off.
\r
1335 +ENABLEDP is true if font-lock-mode is switched on, false
\r
1337 + (ert--results-update-ewoc-hf ert--results-ewoc ert--results-stats)
\r
1338 + (ewoc-refresh ert--results-ewoc)
\r
1339 + (font-lock-default-function enabledp))
\r
1341 +(defun ert--setup-results-buffer (stats listener buffer-name)
\r
1342 + "Set up a test results buffer.
\r
1344 +STATS is the stats object; LISTENER is the results listener;
\r
1345 +BUFFER-NAME, if non-nil, is the buffer name to use."
\r
1346 + (unless buffer-name (setq buffer-name "*ert*"))
\r
1347 + (let ((buffer (get-buffer-create buffer-name)))
\r
1348 + (with-current-buffer buffer
\r
1349 + (setq buffer-read-only t)
\r
1350 + (let ((inhibit-read-only t))
\r
1351 + (buffer-disable-undo)
\r
1353 + (ert-results-mode)
\r
1354 + ;; Erase buffer again in case switching out of the previous
\r
1355 + ;; mode inserted anything. (This happens e.g. when switching
\r
1356 + ;; from ert-results-mode to ert-results-mode when
\r
1357 + ;; font-lock-mode turns itself off in change-major-mode-hook.)
\r
1359 + (set (make-local-variable 'font-lock-function)
\r
1360 + 'ert--results-font-lock-function)
\r
1361 + (let ((ewoc (ewoc-create 'ert--print-test-for-ewoc nil nil t)))
\r
1362 + (set (make-local-variable 'ert--results-ewoc) ewoc)
\r
1363 + (set (make-local-variable 'ert--results-stats) stats)
\r
1364 + (set (make-local-variable 'ert--results-progress-bar-string)
\r
1365 + (make-string (ert-stats-total stats)
\r
1366 + (ert-char-for-test-result nil t)))
\r
1367 + (set (make-local-variable 'ert--results-listener) listener)
\r
1368 + (loop for test across (ert--stats-tests stats) do
\r
1369 + (ewoc-enter-last ewoc
\r
1370 + (make-ert--ewoc-entry :test test :hidden-p t)))
\r
1371 + (ert--results-update-ewoc-hf ert--results-ewoc ert--results-stats)
\r
1372 + (goto-char (1- (point-max)))
\r
1376 +(defvar ert--selector-history nil
\r
1377 + "List of recent test selectors read from terminal.")
\r
1379 +;; Should OUTPUT-BUFFER-NAME and MESSAGE-FN really be arguments here?
\r
1380 +;; They are needed only for our automated self-tests at the moment.
\r
1381 +;; Or should there be some other mechanism?
\r
1383 +(defun ert-run-tests-interactively (selector
\r
1384 + &optional output-buffer-name message-fn)
\r
1385 + "Run the tests specified by SELECTOR and display the results in a buffer.
\r
1387 +SELECTOR works as described in `ert-select-tests'.
\r
1388 +OUTPUT-BUFFER-NAME and MESSAGE-FN should normally be nil; they
\r
1389 +are used for automated self-tests and specify which buffer to use
\r
1390 +and how to display message."
\r
1392 + (list (let ((default (if ert--selector-history
\r
1393 + (first ert--selector-history)
\r
1395 + (read-from-minibuffer (if (null default)
\r
1397 + (format "Run tests (default %s): " default))
\r
1398 + nil nil t 'ert--selector-history
\r
1401 + (unless message-fn (setq message-fn 'message))
\r
1402 + (lexical-let ((output-buffer-name output-buffer-name)
\r
1405 + (message-fn message-fn))
\r
1407 + (lambda (event-type &rest event-args)
\r
1408 + (ecase event-type
\r
1410 + (destructuring-bind (stats) event-args
\r
1411 + (setq buffer (ert--setup-results-buffer stats
\r
1413 + output-buffer-name))
\r
1414 + (pop-to-buffer buffer)))
\r
1416 + (destructuring-bind (stats abortedp) event-args
\r
1417 + (funcall message-fn
\r
1418 + "%sRan %s tests, %s results were as expected%s"
\r
1419 + (if (not abortedp)
\r
1422 + (ert-stats-total stats)
\r
1423 + (ert-stats-completed-expected stats)
\r
1424 + (let ((unexpected
\r
1425 + (ert-stats-completed-unexpected stats)))
\r
1426 + (if (zerop unexpected)
\r
1428 + (format ", %s unexpected" unexpected))))
\r
1429 + (ert--results-update-stats-display (with-current-buffer buffer
\r
1430 + ert--results-ewoc)
\r
1433 + (destructuring-bind (stats test) event-args
\r
1434 + (with-current-buffer buffer
\r
1435 + (let* ((ewoc ert--results-ewoc)
\r
1436 + (pos (ert--stats-test-pos stats test))
\r
1437 + (node (ewoc-nth ewoc pos)))
\r
1439 + (setf (ert--ewoc-entry-test (ewoc-data node)) test)
\r
1440 + (aset ert--results-progress-bar-string pos
\r
1441 + (ert-char-for-test-result nil t))
\r
1442 + (ert--results-update-stats-display-maybe ewoc stats)
\r
1443 + (ewoc-invalidate ewoc node)))))
\r
1445 + (destructuring-bind (stats test result) event-args
\r
1446 + (with-current-buffer buffer
\r
1447 + (let* ((ewoc ert--results-ewoc)
\r
1448 + (pos (ert--stats-test-pos stats test))
\r
1449 + (node (ewoc-nth ewoc pos)))
\r
1450 + (when (ert--ewoc-entry-hidden-p (ewoc-data node))
\r
1451 + (setf (ert--ewoc-entry-hidden-p (ewoc-data node))
\r
1452 + (ert-test-result-expected-p test result)))
\r
1453 + (aset ert--results-progress-bar-string pos
\r
1454 + (ert-char-for-test-result result
\r
1455 + (ert-test-result-expected-p
\r
1457 + (ert--results-update-stats-display-maybe ewoc stats)
\r
1458 + (ewoc-invalidate ewoc node))))))))
\r
1463 +(defalias 'ert 'ert-run-tests-interactively)
\r
1466 +;;; Simple view mode for auxiliary information like stack traces or
\r
1467 +;;; messages. Mainly binds "q" for quit.
\r
1469 +(define-derived-mode ert-simple-view-mode fundamental-mode "ERT-View"
\r
1470 + "Major mode for viewing auxiliary information in ERT.")
\r
1472 +(loop for (key binding) in
\r
1473 + '(("q" quit-window)
\r
1476 + (define-key ert-simple-view-mode-map key binding))
\r
1479 +;;; Commands and button actions for the results buffer.
\r
1481 +(define-derived-mode ert-results-mode fundamental-mode "ERT-Results"
\r
1482 + "Major mode for viewing results of ERT test runs.")
\r
1484 +(loop for (key binding) in
\r
1485 + '(;; Stuff that's not in the menu.
\r
1486 + ("\t" forward-button)
\r
1487 + ([backtab] backward-button)
\r
1488 + ("j" ert-results-jump-between-summary-and-result)
\r
1489 + ("q" quit-window)
\r
1490 + ("L" ert-results-toggle-printer-limits-for-test-at-point)
\r
1491 + ("n" ert-results-next-test)
\r
1492 + ("p" ert-results-previous-test)
\r
1493 + ;; Stuff that is in the menu.
\r
1494 + ("R" ert-results-rerun-all-tests)
\r
1495 + ("r" ert-results-rerun-test-at-point)
\r
1496 + ("d" ert-results-rerun-test-at-point-debugging-errors)
\r
1497 + ("." ert-results-find-test-at-point-other-window)
\r
1498 + ("b" ert-results-pop-to-backtrace-for-test-at-point)
\r
1499 + ("m" ert-results-pop-to-messages-for-test-at-point)
\r
1500 + ("l" ert-results-pop-to-should-forms-for-test-at-point)
\r
1501 + ("h" ert-results-describe-test-at-point)
\r
1502 + ("D" ert-delete-test)
\r
1503 + ("T" ert-results-pop-to-timings)
\r
1506 + (define-key ert-results-mode-map key binding))
\r
1508 +(easy-menu-define ert-results-mode-menu ert-results-mode-map
\r
1509 + "Menu for `ert-results-mode'."
\r
1511 + ["Re-run all tests" ert-results-rerun-all-tests]
\r
1513 + ["Re-run test" ert-results-rerun-test-at-point]
\r
1514 + ["Debug test" ert-results-rerun-test-at-point-debugging-errors]
\r
1515 + ["Show test definition" ert-results-find-test-at-point-other-window]
\r
1517 + ["Show backtrace" ert-results-pop-to-backtrace-for-test-at-point]
\r
1518 + ["Show messages" ert-results-pop-to-messages-for-test-at-point]
\r
1519 + ["Show `should' forms" ert-results-pop-to-should-forms-for-test-at-point]
\r
1520 + ["Describe test" ert-results-describe-test-at-point]
\r
1522 + ["Delete test" ert-delete-test]
\r
1524 + ["Show execution time of each test" ert-results-pop-to-timings]
\r
1527 +(define-button-type 'ert--results-progress-bar-button
\r
1528 + 'action #'ert--results-progress-bar-button-action
\r
1529 + 'help-echo "mouse-2, RET: Reveal test result")
\r
1531 +(define-button-type 'ert--test-name-button
\r
1532 + 'action #'ert--test-name-button-action
\r
1533 + 'help-echo "mouse-2, RET: Find test definition")
\r
1535 +(define-button-type 'ert--results-expand-collapse-button
\r
1536 + 'action #'ert--results-expand-collapse-button-action
\r
1537 + 'help-echo "mouse-2, RET: Expand/collapse test result")
\r
1539 +(defun ert--results-test-node-or-null-at-point ()
\r
1540 + "If point is on a valid ewoc node, return it; return nil otherwise.
\r
1542 +To be used in the ERT results buffer."
\r
1543 + (let* ((ewoc ert--results-ewoc)
\r
1544 + (node (ewoc-locate ewoc)))
\r
1545 + ;; `ewoc-locate' will return an arbitrary node when point is on
\r
1546 + ;; header or footer, or when all nodes are invisible. So we need
\r
1547 + ;; to validate its return value here.
\r
1549 + ;; Update: I'm seeing nil being returned in some cases now,
\r
1550 + ;; perhaps this has been changed?
\r
1552 + (>= (point) (ewoc-location node))
\r
1553 + (not (ert--ewoc-entry-hidden-p (ewoc-data node))))
\r
1557 +(defun ert--results-test-node-at-point ()
\r
1558 + "If point is on a valid ewoc node, return it; signal an error otherwise.
\r
1560 +To be used in the ERT results buffer."
\r
1561 + (or (ert--results-test-node-or-null-at-point)
\r
1562 + (error "No test at point")))
\r
1564 +(defun ert-results-next-test ()
\r
1565 + "Move point to the next test.
\r
1567 +To be used in the ERT results buffer."
\r
1569 + (ert--results-move (ewoc-locate ert--results-ewoc) 'ewoc-next
\r
1570 + "No tests below"))
\r
1572 +(defun ert-results-previous-test ()
\r
1573 + "Move point to the previous test.
\r
1575 +To be used in the ERT results buffer."
\r
1577 + (ert--results-move (ewoc-locate ert--results-ewoc) 'ewoc-prev
\r
1578 + "No tests above"))
\r
1580 +(defun ert--results-move (node ewoc-fn error-message)
\r
1581 + "Move point from NODE to the previous or next node.
\r
1583 +EWOC-FN specifies the direction and should be either `ewoc-prev'
\r
1584 +or `ewoc-next'. If there are no more nodes in that direction, an
\r
1585 +error is signalled with the message ERROR-MESSAGE."
\r
1587 + (setq node (funcall ewoc-fn ert--results-ewoc node))
\r
1588 + (when (null node)
\r
1589 + (error "%s" error-message))
\r
1590 + (unless (ert--ewoc-entry-hidden-p (ewoc-data node))
\r
1591 + (goto-char (ewoc-location node))
\r
1594 +(defun ert--results-expand-collapse-button-action (button)
\r
1595 + "Expand or collapse the test node BUTTON belongs to."
\r
1596 + (let* ((ewoc ert--results-ewoc)
\r
1597 + (node (save-excursion
\r
1598 + (goto-char (ert--button-action-position))
\r
1599 + (ert--results-test-node-at-point)))
\r
1600 + (entry (ewoc-data node)))
\r
1601 + (setf (ert--ewoc-entry-expanded-p entry)
\r
1602 + (not (ert--ewoc-entry-expanded-p entry)))
\r
1603 + (ewoc-invalidate ewoc node)))
\r
1605 +(defun ert-results-find-test-at-point-other-window ()
\r
1606 + "Find the definition of the test at point in another window.
\r
1608 +To be used in the ERT results buffer."
\r
1610 + (let ((name (ert-test-at-point)))
\r
1612 + (error "No test at point"))
\r
1613 + (ert-find-test-other-window name)))
\r
1615 +(defun ert--test-name-button-action (button)
\r
1616 + "Find the definition of the test BUTTON belongs to, in another window."
\r
1617 + (let ((name (button-get button 'ert-test-name)))
\r
1618 + (ert-find-test-other-window name)))
\r
1620 +(defun ert--ewoc-position (ewoc node)
\r
1621 + ;; checkdoc-order: nil
\r
1622 + "Return the position of NODE in EWOC, or nil if NODE is not in EWOC."
\r
1623 + (loop for i from 0
\r
1624 + for node-here = (ewoc-nth ewoc 0) then (ewoc-next ewoc node-here)
\r
1625 + do (when (eql node node-here)
\r
1627 + finally (return nil)))
\r
1629 +(defun ert-results-jump-between-summary-and-result ()
\r
1630 + "Jump back and forth between the test run summary and individual test results.
\r
1632 +From an ewoc node, jumps to the character that represents the
\r
1633 +same test in the progress bar, and vice versa.
\r
1635 +To be used in the ERT results buffer."
\r
1636 + ;; Maybe this command isn't actually needed much, but if it is, it
\r
1637 + ;; seems like an indication that the UI design is not optimal. If
\r
1638 + ;; jumping back and forth between a summary at the top of the buffer
\r
1639 + ;; and the error log in the remainder of the buffer is useful, then
\r
1640 + ;; the summary apparently needs to be easily accessible from the
\r
1641 + ;; error log, and perhaps it would be better to have it in a
\r
1642 + ;; separate buffer to keep it visible.
\r
1644 + (let ((ewoc ert--results-ewoc)
\r
1645 + (progress-bar-begin ert--results-progress-bar-button-begin))
\r
1646 + (cond ((ert--results-test-node-or-null-at-point)
\r
1647 + (let* ((node (ert--results-test-node-at-point))
\r
1648 + (pos (ert--ewoc-position ewoc node)))
\r
1649 + (goto-char (+ progress-bar-begin pos))))
\r
1650 + ((and (<= progress-bar-begin (point))
\r
1651 + (< (point) (button-end (button-at progress-bar-begin))))
\r
1652 + (let* ((node (ewoc-nth ewoc (- (point) progress-bar-begin)))
\r
1653 + (entry (ewoc-data node)))
\r
1654 + (when (ert--ewoc-entry-hidden-p entry)
\r
1655 + (setf (ert--ewoc-entry-hidden-p entry) nil)
\r
1656 + (ewoc-invalidate ewoc node))
\r
1657 + (ewoc-goto-node ewoc node)))
\r
1659 + (goto-char progress-bar-begin)))))
\r
1661 +(defun ert-test-at-point ()
\r
1662 + "Return the name of the test at point as a symbol, or nil if none."
\r
1663 + (or (and (eql major-mode 'ert-results-mode)
\r
1664 + (let ((test (ert--results-test-at-point-no-redefinition)))
\r
1665 + (and test (ert-test-name test))))
\r
1666 + (let* ((thing (thing-at-point 'symbol))
\r
1667 + (sym (intern-soft thing)))
\r
1668 + (and (ert-test-boundp sym)
\r
1671 +(defun ert--results-test-at-point-no-redefinition ()
\r
1672 + "Return the test at point, or nil.
\r
1674 +To be used in the ERT results buffer."
\r
1675 + (assert (eql major-mode 'ert-results-mode))
\r
1676 + (if (ert--results-test-node-or-null-at-point)
\r
1677 + (let* ((node (ert--results-test-node-at-point))
\r
1678 + (test (ert--ewoc-entry-test (ewoc-data node))))
\r
1680 + (let ((progress-bar-begin ert--results-progress-bar-button-begin))
\r
1681 + (when (and (<= progress-bar-begin (point))
\r
1682 + (< (point) (button-end (button-at progress-bar-begin))))
\r
1683 + (let* ((test-index (- (point) progress-bar-begin))
\r
1684 + (test (aref (ert--stats-tests ert--results-stats)
\r
1688 +(defun ert--results-test-at-point-allow-redefinition ()
\r
1689 + "Look up the test at point, and check whether it has been redefined.
\r
1691 +To be used in the ERT results buffer.
\r
1693 +Returns a list of two elements: the test (or nil) and a symbol
\r
1694 +specifying whether the test has been redefined.
\r
1696 +If a new test has been defined with the same name as the test at
\r
1697 +point, replaces the test at point with the new test, and returns
\r
1698 +the new test and the symbol `redefined'.
\r
1700 +If the test has been deleted, returns the old test and the symbol
\r
1703 +If the test is still current, returns the test and the symbol nil.
\r
1705 +If there is no test at point, returns a list with two nils."
\r
1706 + (let ((test (ert--results-test-at-point-no-redefinition)))
\r
1707 + (cond ((null test)
\r
1709 + ((null (ert-test-name test))
\r
1712 + (let* ((name (ert-test-name test))
\r
1713 + (new-test (and (ert-test-boundp name)
\r
1714 + (ert-get-test name))))
\r
1715 + (cond ((eql test new-test)
\r
1717 + ((null new-test)
\r
1718 + `(,test deleted))
\r
1720 + (ert--results-update-after-test-redefinition
\r
1721 + (ert--stats-test-pos ert--results-stats test)
\r
1723 + `(,new-test redefined))))))))
\r
1725 +(defun ert--results-update-after-test-redefinition (pos new-test)
\r
1726 + "Update results buffer after the test at pos POS has been redefined.
\r
1728 +Also updates the stats object. NEW-TEST is the new test
\r
1730 + (let* ((stats ert--results-stats)
\r
1731 + (ewoc ert--results-ewoc)
\r
1732 + (node (ewoc-nth ewoc pos))
\r
1733 + (entry (ewoc-data node)))
\r
1734 + (ert--stats-set-test-and-result stats pos new-test nil)
\r
1735 + (setf (ert--ewoc-entry-test entry) new-test
\r
1736 + (aref ert--results-progress-bar-string pos) (ert-char-for-test-result
\r
1738 + (ewoc-invalidate ewoc node))
\r
1741 +(defun ert--button-action-position ()
\r
1742 + "The buffer position where the last button action was triggered."
\r
1743 + (cond ((integerp last-command-event)
\r
1745 + ((eventp last-command-event)
\r
1746 + (posn-point (event-start last-command-event)))
\r
1747 + (t (assert nil))))
\r
1749 +(defun ert--results-progress-bar-button-action (button)
\r
1750 + "Jump to details for the test represented by the character clicked in BUTTON."
\r
1751 + (goto-char (ert--button-action-position))
\r
1752 + (ert-results-jump-between-summary-and-result))
\r
1754 +(defun ert-results-rerun-all-tests ()
\r
1755 + "Re-run all tests, using the same selector.
\r
1757 +To be used in the ERT results buffer."
\r
1759 + (assert (eql major-mode 'ert-results-mode))
\r
1760 + (let ((selector (ert--stats-selector ert--results-stats)))
\r
1761 + (ert-run-tests-interactively selector (buffer-name))))
\r
1763 +(defun ert-results-rerun-test-at-point ()
\r
1764 + "Re-run the test at point.
\r
1766 +To be used in the ERT results buffer."
\r
1768 + (destructuring-bind (test redefinition-state)
\r
1769 + (ert--results-test-at-point-allow-redefinition)
\r
1770 + (when (null test)
\r
1771 + (error "No test at point"))
\r
1772 + (let* ((stats ert--results-stats)
\r
1773 + (progress-message (format "Running %stest %S"
\r
1774 + (ecase redefinition-state
\r
1776 + (redefined "new definition of ")
\r
1777 + (deleted "deleted "))
\r
1778 + (ert-test-name test))))
\r
1779 + ;; Need to save and restore point manually here: When point is on
\r
1780 + ;; the first visible ewoc entry while the header is updated, point
\r
1781 + ;; moves to the top of the buffer. This is undesirable, and a
\r
1782 + ;; simple `save-excursion' doesn't prevent it.
\r
1783 + (let ((point (point)))
\r
1787 + (message "%s..." progress-message)
\r
1788 + (ert-run-or-rerun-test stats test
\r
1789 + ert--results-listener))
\r
1790 + (ert--results-update-stats-display ert--results-ewoc stats)
\r
1791 + (message "%s...%s"
\r
1792 + progress-message
\r
1793 + (let ((result (ert-test-most-recent-result test)))
\r
1794 + (ert-string-for-test-result
\r
1795 + result (ert-test-result-expected-p test result)))))
\r
1796 + (goto-char point))))))
\r
1798 +(defun ert-results-rerun-test-at-point-debugging-errors ()
\r
1799 + "Re-run the test at point with `ert-debug-on-error' bound to t.
\r
1801 +To be used in the ERT results buffer."
\r
1803 + (let ((ert-debug-on-error t))
\r
1804 + (ert-results-rerun-test-at-point)))
\r
1806 +(defun ert-results-pop-to-backtrace-for-test-at-point ()
\r
1807 + "Display the backtrace for the test at point.
\r
1809 +To be used in the ERT results buffer."
\r
1811 + (let* ((test (ert--results-test-at-point-no-redefinition))
\r
1812 + (stats ert--results-stats)
\r
1813 + (pos (ert--stats-test-pos stats test))
\r
1814 + (result (aref (ert--stats-test-results stats) pos)))
\r
1815 + (etypecase result
\r
1816 + (ert-test-passed (error "Test passed, no backtrace available"))
\r
1817 + (ert-test-result-with-condition
\r
1818 + (let ((backtrace (ert-test-result-with-condition-backtrace result))
\r
1819 + (buffer (get-buffer-create "*ERT Backtrace*")))
\r
1820 + (pop-to-buffer buffer)
\r
1821 + (setq buffer-read-only t)
\r
1822 + (let ((inhibit-read-only t))
\r
1823 + (buffer-disable-undo)
\r
1825 + (ert-simple-view-mode)
\r
1826 + ;; Use unibyte because `debugger-setup-buffer' also does so.
\r
1827 + (set-buffer-multibyte nil)
\r
1828 + (setq truncate-lines t)
\r
1829 + (ert--print-backtrace backtrace)
\r
1830 + (debugger-make-xrefs)
\r
1831 + (goto-char (point-min))
\r
1832 + (insert "Backtrace for test `")
\r
1833 + (ert-insert-test-name-button (ert-test-name test))
\r
1834 + (insert "':\n")))))))
\r
1836 +(defun ert-results-pop-to-messages-for-test-at-point ()
\r
1837 + "Display the part of the *Messages* buffer generated during the test at point.
\r
1839 +To be used in the ERT results buffer."
\r
1841 + (let* ((test (ert--results-test-at-point-no-redefinition))
\r
1842 + (stats ert--results-stats)
\r
1843 + (pos (ert--stats-test-pos stats test))
\r
1844 + (result (aref (ert--stats-test-results stats) pos)))
\r
1845 + (let ((buffer (get-buffer-create "*ERT Messages*")))
\r
1846 + (pop-to-buffer buffer)
\r
1847 + (setq buffer-read-only t)
\r
1848 + (let ((inhibit-read-only t))
\r
1849 + (buffer-disable-undo)
\r
1851 + (ert-simple-view-mode)
\r
1852 + (insert (ert-test-result-messages result))
\r
1853 + (goto-char (point-min))
\r
1854 + (insert "Messages for test `")
\r
1855 + (ert-insert-test-name-button (ert-test-name test))
\r
1856 + (insert "':\n")))))
\r
1858 +(defun ert-results-pop-to-should-forms-for-test-at-point ()
\r
1859 + "Display the list of `should' forms executed during the test at point.
\r
1861 +To be used in the ERT results buffer."
\r
1863 + (let* ((test (ert--results-test-at-point-no-redefinition))
\r
1864 + (stats ert--results-stats)
\r
1865 + (pos (ert--stats-test-pos stats test))
\r
1866 + (result (aref (ert--stats-test-results stats) pos)))
\r
1867 + (let ((buffer (get-buffer-create "*ERT list of should forms*")))
\r
1868 + (pop-to-buffer buffer)
\r
1869 + (setq buffer-read-only t)
\r
1870 + (let ((inhibit-read-only t))
\r
1871 + (buffer-disable-undo)
\r
1873 + (ert-simple-view-mode)
\r
1874 + (if (null (ert-test-result-should-forms result))
\r
1875 + (insert "\n(No should forms during this test.)\n")
\r
1876 + (loop for form-description in (ert-test-result-should-forms result)
\r
1879 + (insert (format "%s: " i))
\r
1880 + (let ((begin (point)))
\r
1881 + (ert--pp-with-indentation-and-newline form-description)
\r
1882 + (ert--make-xrefs-region begin (point)))))
\r
1883 + (goto-char (point-min))
\r
1884 + (insert "`should' forms executed during test `")
\r
1885 + (ert-insert-test-name-button (ert-test-name test))
\r
1888 + (insert (concat "(Values are shallow copies and may have "
\r
1889 + "looked different during the test if they\n"
\r
1890 + "have been modified destructively.)\n"))
\r
1891 + (forward-line 1)))))
\r
1893 +(defun ert-results-toggle-printer-limits-for-test-at-point ()
\r
1894 + "Toggle how much of the condition to print for the test at point.
\r
1896 +To be used in the ERT results buffer."
\r
1898 + (let* ((ewoc ert--results-ewoc)
\r
1899 + (node (ert--results-test-node-at-point))
\r
1900 + (entry (ewoc-data node)))
\r
1901 + (setf (ert--ewoc-entry-extended-printer-limits-p entry)
\r
1902 + (not (ert--ewoc-entry-extended-printer-limits-p entry)))
\r
1903 + (ewoc-invalidate ewoc node)))
\r
1905 +(defun ert-results-pop-to-timings ()
\r
1906 + "Display test timings for the last run.
\r
1908 +To be used in the ERT results buffer."
\r
1910 + (let* ((stats ert--results-stats)
\r
1911 + (start-times (ert--stats-test-start-times stats))
\r
1912 + (end-times (ert--stats-test-end-times stats))
\r
1913 + (buffer (get-buffer-create "*ERT timings*"))
\r
1914 + (data (loop for test across (ert--stats-tests stats)
\r
1915 + for start-time across (ert--stats-test-start-times stats)
\r
1916 + for end-time across (ert--stats-test-end-times stats)
\r
1917 + collect (list test
\r
1918 + (float-time (subtract-time end-time
\r
1919 + start-time))))))
\r
1920 + (setq data (sort data (lambda (a b)
\r
1921 + (> (second a) (second b)))))
\r
1922 + (pop-to-buffer buffer)
\r
1923 + (setq buffer-read-only t)
\r
1924 + (let ((inhibit-read-only t))
\r
1925 + (buffer-disable-undo)
\r
1927 + (ert-simple-view-mode)
\r
1929 + (insert "(No data)\n")
\r
1930 + (insert (format "%-3s %8s %8s\n" "" "time" "cumul"))
\r
1931 + (loop for (test time) in data
\r
1932 + for cumul-time = time then (+ cumul-time time)
\r
1934 + (let ((begin (point)))
\r
1935 + (insert (format "%3s: %8.3f %8.3f " i time cumul-time))
\r
1936 + (ert-insert-test-name-button (ert-test-name test))
\r
1937 + (insert "\n"))))
\r
1938 + (goto-char (point-min))
\r
1939 + (insert "Tests by run time (seconds):\n\n")
\r
1940 + (forward-line 1))))
\r
1943 +(defun ert-describe-test (test-or-test-name)
\r
1944 + "Display the documentation for TEST-OR-TEST-NAME (a symbol or ert-test)."
\r
1945 + (interactive (list (ert-read-test-name-at-point "Describe test")))
\r
1946 + (when (< emacs-major-version 24)
\r
1947 + (error "Requires Emacs 24"))
\r
1949 + test-definition)
\r
1950 + (etypecase test-or-test-name
\r
1951 + (symbol (setq test-name test-or-test-name
\r
1952 + test-definition (ert-get-test test-or-test-name)))
\r
1953 + (ert-test (setq test-name (ert-test-name test-or-test-name)
\r
1954 + test-definition test-or-test-name)))
\r
1955 + (help-setup-xref (list #'ert-describe-test test-or-test-name)
\r
1956 + (called-interactively-p 'interactive))
\r
1958 + (with-help-window (help-buffer)
\r
1959 + (with-current-buffer (help-buffer)
\r
1960 + (insert (if test-name (format "%S" test-name) "<anonymous test>"))
\r
1961 + (insert " is a test")
\r
1962 + (let ((file-name (and test-name
\r
1963 + (symbol-file test-name 'ert-deftest))))
\r
1965 + (insert " defined in `" (file-name-nondirectory file-name) "'")
\r
1967 + (re-search-backward "`\\([^`']+\\)'" nil t)
\r
1968 + (help-xref-button 1 'help-function-def test-name file-name)))
\r
1970 + (fill-region-as-paragraph (point-min) (point))
\r
1972 + (unless (and (ert-test-boundp test-name)
\r
1973 + (eql (ert-get-test test-name) test-definition))
\r
1974 + (let ((begin (point)))
\r
1975 + (insert "Note: This test has been redefined or deleted, "
\r
1976 + "this documentation refers to an old definition.")
\r
1977 + (fill-region-as-paragraph begin (point)))
\r
1978 + (insert "\n\n"))
\r
1979 + (insert (or (ert-test-documentation test-definition)
\r
1980 + "It is not documented.")
\r
1983 +(defun ert-results-describe-test-at-point ()
\r
1984 + "Display the documentation of the test at point.
\r
1986 +To be used in the ERT results buffer."
\r
1988 + (ert-describe-test (ert--results-test-at-point-no-redefinition)))
\r
1990 +(provide 'ert-ui)
\r
1992 +;;; ert-ui.el ends here
\r
1993 diff --git a/test/ert/ert-x.el b/test/ert/ert-x.el
\r
1994 new file mode 100644
\r
1995 index 0000000..692aad6
\r
1997 +++ b/test/ert/ert-x.el
\r
1999 +;;; ert-x.el --- Staging area for experimental extensions to ERT
\r
2001 +;; Copyright (C) 2008, 2010 Free Software Foundation, Inc.
\r
2003 +;; Author: Lennart Borgman (lennart O borgman A gmail O com)
\r
2004 +;; Author: Christian M. Ohler
\r
2006 +;; This file is NOT part of GNU Emacs.
\r
2008 +;; This program is free software: you can redistribute it and/or
\r
2009 +;; modify it under the terms of the GNU General Public License as
\r
2010 +;; published by the Free Software Foundation, either version 3 of the
\r
2011 +;; License, or (at your option) any later version.
\r
2013 +;; This program is distributed in the hope that it will be useful, but
\r
2014 +;; WITHOUT ANY WARRANTY; without even the implied warranty of
\r
2015 +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
\r
2016 +;; General Public License for more details.
\r
2018 +;; You should have received a copy of the GNU General Public License
\r
2019 +;; along with this program. If not, see `http://www.gnu.org/licenses/'.
\r
2023 +;; This file includes some extra helper functions to use while writing
\r
2024 +;; automated tests with ERT. These have been proposed as extensions
\r
2025 +;; to ERT but are not mature yet and likely to change.
\r
2029 +(eval-when-compile
\r
2034 +;;; Test buffers.
\r
2036 +(defun ert--text-button (string &rest properties)
\r
2037 + "Return a string containing STRING as a text button with PROPERTIES.
\r
2039 +See `make-text-button'."
\r
2040 + (with-temp-buffer
\r
2042 + (apply #'make-text-button (point-min) (point-max) properties)
\r
2043 + (buffer-string)))
\r
2045 +(defun ert--format-test-buffer-name (base-name)
\r
2046 + "Compute a test buffer name based on BASE-NAME.
\r
2048 +Helper function for `ert--test-buffers'."
\r
2049 + (format "*Test buffer (%s)%s*"
\r
2050 + (or (and (ert-running-test)
\r
2051 + (ert-test-name (ert-running-test)))
\r
2052 + "<anonymous test>")
\r
2054 + (format ": %s" base-name)
\r
2057 +(defvar ert--test-buffers (make-hash-table :weakness t)
\r
2058 + "Table of all test buffers. Keys are the buffer objects, values are t.
\r
2060 +The main use of this table is for `ert-kill-all-test-buffers'.
\r
2061 +Not all buffers in this table are necessarily live, but all live
\r
2062 +test buffers are in this table.")
\r
2064 +(define-button-type 'ert--test-buffer-button
\r
2065 + 'action #'ert--test-buffer-button-action
\r
2066 + 'help-echo "mouse-2, RET: Pop to test buffer")
\r
2068 +(defun ert--test-buffer-button-action (button)
\r
2069 + "Pop to the test buffer that BUTTON is associated with."
\r
2070 + (pop-to-buffer (button-get button 'ert--test-buffer)))
\r
2072 +(defun ert--call-with-test-buffer (ert--base-name ert--thunk)
\r
2073 + "Helper function for `ert-with-test-buffer'.
\r
2075 +Create a test buffer with a name based on ERT--BASE-NAME and run
\r
2076 +ERT--THUNK with that buffer as current."
\r
2077 + (let* ((ert--buffer (generate-new-buffer
\r
2078 + (ert--format-test-buffer-name ert--base-name)))
\r
2079 + (ert--button (ert--text-button (buffer-name ert--buffer)
\r
2080 + :type 'ert--test-buffer-button
\r
2081 + 'ert--test-buffer ert--buffer)))
\r
2082 + (puthash ert--buffer 't ert--test-buffers)
\r
2083 + ;; We don't use `unwind-protect' here since we want to kill the
\r
2084 + ;; buffer only on success.
\r
2085 + (prog1 (with-current-buffer ert--buffer
\r
2086 + (ert-info (ert--button :prefix "Buffer: ")
\r
2087 + (funcall ert--thunk)))
\r
2088 + (kill-buffer ert--buffer)
\r
2089 + (remhash ert--buffer ert--test-buffers))))
\r
2091 +(defmacro* ert-with-test-buffer ((&key ((:name name-form)))
\r
2093 + "Create a test buffer and run BODY in that buffer.
\r
2095 +To be used in ERT tests. If BODY finishes successfully, the test
\r
2096 +buffer is killed; if there is an error, the test buffer is kept
\r
2097 +around on error for further inspection. Its name is derived from
\r
2098 +the name of the test and the result of NAME-FORM."
\r
2099 + (declare (debug ((form) body))
\r
2101 + `(ert--call-with-test-buffer ,name-form (lambda () ,@body)))
\r
2103 +;; We use these `put' forms in addition to the (declare (indent)) in
\r
2104 +;; the defmacro form since the `declare' alone does not lead to
\r
2105 +;; correct indentation before the .el/.elc file is loaded.
\r
2106 +;; Autoloading these `put' forms solves this.
\r
2109 + ;; TODO(ohler): Figure out what these mean and make sure they are correct.
\r
2110 + (put 'ert-with-test-buffer 'lisp-indent-function 1))
\r
2113 +(defun ert-kill-all-test-buffers ()
\r
2114 + "Kill all test buffers that are still live."
\r
2116 + (let ((count 0))
\r
2117 + (maphash (lambda (buffer dummy)
\r
2118 + (when (or (not (buffer-live-p buffer))
\r
2119 + (kill-buffer buffer))
\r
2121 + ert--test-buffers)
\r
2122 + (message "%s out of %s test buffers killed"
\r
2123 + count (hash-table-count ert--test-buffers)))
\r
2124 + ;; It could be that some test buffers were actually kept alive
\r
2125 + ;; (e.g., due to `kill-buffer-query-functions'). I'm not sure what
\r
2126 + ;; to do about this. For now, let's just forget them.
\r
2127 + (clrhash ert--test-buffers)
\r
2131 +;;; Simulate commands.
\r
2133 +(defun ert-simulate-command (command)
\r
2134 + ;; FIXME: add unread-events
\r
2135 + "Simulate calling COMMAND the way the Emacs command loop would call it.
\r
2137 +This effectively executes
\r
2139 + \(apply (car COMMAND) (cdr COMMAND)\)
\r
2141 +and returns the same value, but additionally runs hooks like
\r
2142 +`pre-command-hook' and `post-command-hook', and sets variables
\r
2143 +like `this-command' and `last-command'.
\r
2145 +COMMAND should be a list where the car is the command symbol and
\r
2146 +the rest are arguments to the command.
\r
2148 +NOTE: Since the command is not called by `call-interactively'
\r
2149 +test for `called-interactively' in the command will fail."
\r
2150 + (assert (listp command) t)
\r
2151 + (assert (commandp (car command)) t)
\r
2152 + (assert (not unread-command-events) t)
\r
2153 + (let (return-value)
\r
2154 + ;; For the order of things here see command_loop_1 in keyboard.c.
\r
2156 + ;; The command loop will reset the command-related variables so
\r
2157 + ;; there is no reason to let-bind them. They are set here,
\r
2158 + ;; however, to be able to test several commands in a row and how
\r
2159 + ;; they affect each other.
\r
2160 + (setq deactivate-mark nil
\r
2161 + this-original-command (car command)
\r
2162 + ;; remap through active keymaps
\r
2163 + this-command (or (command-remapping this-original-command)
\r
2164 + this-original-command))
\r
2165 + (run-hooks 'pre-command-hook)
\r
2166 + (setq return-value (apply (car command) (cdr command)))
\r
2167 + (run-hooks 'post-command-hook)
\r
2168 + (when deferred-action-list
\r
2169 + (run-hooks 'deferred-action-function))
\r
2170 + (setq real-last-command (car command)
\r
2171 + last-command this-command)
\r
2172 + (when (boundp 'last-repeatable-command)
\r
2173 + (setq last-repeatable-command real-last-command))
\r
2174 + (when (and deactivate-mark transient-mark-mode) (deactivate-mark))
\r
2175 + (assert (not unread-command-events) t)
\r
2178 +(defun ert-run-idle-timers ()
\r
2179 + "Run all idle timers (from `timer-idle-list')."
\r
2180 + (dolist (timer (copy-sequence timer-idle-list))
\r
2181 + (timer-event-handler timer)))
\r
2184 +;;; Miscellaneous utilities.
\r
2186 +(defun ert-filter-string (s &rest regexps)
\r
2187 + "Return a copy of S with all matches of REGEXPS removed.
\r
2189 +Elements of REGEXPS may also be two-element lists \(REGEXP
\r
2190 +SUBEXP\), where SUBEXP is the number of a subexpression in
\r
2191 +REGEXP. In that case, only that subexpression will be removed
\r
2192 +rather than the entire match."
\r
2193 + ;; Use a temporary buffer since replace-match copies strings, which
\r
2194 + ;; would lead to N^2 runtime.
\r
2195 + (with-temp-buffer
\r
2197 + (dolist (x regexps)
\r
2198 + (destructuring-bind (regexp subexp) (if (listp x) x `(,x nil))
\r
2199 + (goto-char (point-min))
\r
2200 + (while (re-search-forward regexp nil t)
\r
2201 + (replace-match "" t t nil subexp))))
\r
2202 + (buffer-string)))
\r
2205 +(defun ert-propertized-string (&rest args)
\r
2206 + "Return a string with properties as specified by ARGS.
\r
2208 +ARGS is a list of strings and plists. The strings in ARGS are
\r
2209 +concatenated to produce an output string. In the output string,
\r
2210 +each string from ARGS will be have the preceding plist as its
\r
2211 +property list, or no properties if there is no plist before it.
\r
2213 +As a simple example,
\r
2215 +\(ert-propertized-string \"foo \" '(face italic) \"bar\" \" baz\" nil \
\r
2218 +would return the string \"foo bar baz quux\" where the substring
\r
2219 +\"bar baz\" has a `face' property with the value `italic'.
\r
2221 +None of the ARGS are modified, but the return value may share
\r
2222 +structure with the plists in ARGS."
\r
2223 + (with-temp-buffer
\r
2224 + (loop with current-plist = nil
\r
2225 + for x in args do
\r
2227 + (string (let ((begin (point)))
\r
2229 + (set-text-properties begin (point) current-plist)))
\r
2230 + (list (unless (zerop (mod (length x) 2))
\r
2231 + (error "Odd number of args in plist: %S" x))
\r
2232 + (setq current-plist x))))
\r
2233 + (buffer-string)))
\r
2236 +(defun ert-call-with-buffer-renamed (buffer-name thunk)
\r
2237 + "Protect the buffer named BUFFER-NAME from side-effects and run THUNK.
\r
2239 +Renames the buffer BUFFER-NAME to a new temporary name, creates a
\r
2240 +new buffer named BUFFER-NAME, executes THUNK, kills the new
\r
2241 +buffer, and renames the original buffer back to BUFFER-NAME.
\r
2243 +This is useful if THUNK has undesirable side-effects on an Emacs
\r
2244 +buffer with a fixed name such as *Messages*."
\r
2245 + (lexical-let ((new-buffer-name (generate-new-buffer-name
\r
2246 + (format "%s orig buffer" buffer-name))))
\r
2247 + (with-current-buffer (get-buffer-create buffer-name)
\r
2248 + (rename-buffer new-buffer-name))
\r
2251 + (get-buffer-create buffer-name)
\r
2252 + (funcall thunk))
\r
2253 + (when (get-buffer buffer-name)
\r
2254 + (kill-buffer buffer-name))
\r
2255 + (with-current-buffer new-buffer-name
\r
2256 + (rename-buffer buffer-name)))))
\r
2258 +(defmacro* ert-with-buffer-renamed ((buffer-name-form) &body body)
\r
2259 + "Protect the buffer named BUFFER-NAME from side-effects and run BODY.
\r
2261 +See `ert-call-with-buffer-renamed' for details."
\r
2262 + (declare (indent 1))
\r
2263 + `(ert-call-with-buffer-renamed ,buffer-name-form (lambda () ,@body)))
\r
2266 +(defun ert-buffer-string-reindented (&optional buffer)
\r
2267 + "Return the contents of BUFFER after reindentation.
\r
2269 +BUFFER defaults to current buffer. Does not modify BUFFER."
\r
2270 + (with-current-buffer (or buffer (current-buffer))
\r
2271 + (let ((clone nil))
\r
2274 + ;; `clone-buffer' doesn't work if `buffer-file-name' is non-nil.
\r
2275 + (let ((buffer-file-name nil))
\r
2276 + (setq clone (clone-buffer)))
\r
2277 + (with-current-buffer clone
\r
2278 + (let ((inhibit-read-only t))
\r
2279 + (indent-region (point-min) (point-max)))
\r
2280 + (buffer-string)))
\r
2282 + (let ((kill-buffer-query-functions nil))
\r
2283 + (kill-buffer clone)))))))
\r
2288 +;;; ert-x.el ends here
\r
2289 diff --git a/test/ert/ert.el b/test/ert/ert.el
\r
2290 new file mode 100644
\r
2291 index 0000000..997abfe
\r
2293 +++ b/test/ert/ert.el
\r
2294 @@ -0,0 +1,2539 @@
\r
2295 +;;; ert.el --- Emacs Lisp Regression Testing
\r
2297 +;; Copyright (C) 2007, 2008, 2010 Free Software Foundation, Inc.
\r
2299 +;; Author: Christian M. Ohler
\r
2300 +;; Keywords: lisp, tools
\r
2302 +;; This file is NOT part of GNU Emacs.
\r
2304 +;; This program is free software: you can redistribute it and/or
\r
2305 +;; modify it under the terms of the GNU General Public License as
\r
2306 +;; published by the Free Software Foundation, either version 3 of the
\r
2307 +;; License, or (at your option) any later version.
\r
2309 +;; This program is distributed in the hope that it will be useful, but
\r
2310 +;; WITHOUT ANY WARRANTY; without even the implied warranty of
\r
2311 +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
\r
2312 +;; General Public License for more details.
\r
2314 +;; You should have received a copy of the GNU General Public License
\r
2315 +;; along with this program. If not, see `http://www.gnu.org/licenses/'.
\r
2319 +;; ERT is a tool for automated testing in Emacs Lisp. Its main
\r
2320 +;; features are facilities for defining and running test cases and
\r
2321 +;; reporting the results as well as for debugging test failures
\r
2322 +;; interactively.
\r
2324 +;; The main entry points are `ert-deftest', which is similar to
\r
2325 +;; `defun' but defines a test, and `ert-run-tests-interactively',
\r
2326 +;; which runs tests and offers an interactive interface for inspecting
\r
2327 +;; results and debugging. There is also
\r
2328 +;; `ert-run-tests-batch-and-exit' for non-interactive use.
\r
2330 +;; The body of `ert-deftest' forms resembles a function body, but the
\r
2331 +;; additional operators `should', `should-not' and `should-error' are
\r
2332 +;; available. `should' is similar to cl's `assert', but signals a
\r
2333 +;; different error when its condition is violated that is caught and
\r
2334 +;; processed by ERT. In addition, it analyzes its argument form and
\r
2335 +;; records information that helps debugging (`assert' tries to do
\r
2336 +;; something similar when its second argument SHOW-ARGS is true, but
\r
2337 +;; `should' is more sophisticated). For information on `should-not'
\r
2338 +;; and `should-error', see their docstrings.
\r
2340 +;; See ERT's info manual as well as the docstrings for more details.
\r
2341 +;; To compile the manual, run `makeinfo ert.texinfo' in the ERT
\r
2342 +;; directory, then C-u M-x info ert.info in Emacs to view it.
\r
2344 +;; To see some examples of tests written in ERT, see its self-tests in
\r
2345 +;; ert-tests.el. Some of these are tricky due to the bootstrapping
\r
2346 +;; problem of writing tests for a testing tool, others test simple
\r
2347 +;; functions and are straightforward.
\r
2351 +(eval-when-compile
\r
2353 +(require 'button)
\r
2355 +(require 'easymenu)
\r
2357 +(require 'find-func)
\r
2361 +;;; UI customization options.
\r
2364 + "ERT, the Emacs Lisp regression testing tool."
\r
2368 +(defface ert-test-result-expected '((((class color) (background light))
\r
2369 + :background "green1")
\r
2370 + (((class color) (background dark))
\r
2371 + :background "green3"))
\r
2372 + "Face used for expected results in the ERT results buffer."
\r
2375 +(defface ert-test-result-unexpected '((((class color) (background light))
\r
2376 + :background "red1")
\r
2377 + (((class color) (background dark))
\r
2378 + :background "red3"))
\r
2379 + "Face used for unexpected results in the ERT results buffer."
\r
2383 +;;; Copies/reimplementations of cl functions.
\r
2385 +(defun ert--cl-do-remf (plist tag)
\r
2386 + "Copy of `cl-do-remf'. Modify PLIST by removing TAG."
\r
2387 + (let ((p (cdr plist)))
\r
2388 + (while (and (cdr p) (not (eq (car (cdr p)) tag))) (setq p (cdr (cdr p))))
\r
2389 + (and (cdr p) (progn (setcdr p (cdr (cdr (cdr p)))) t))))
\r
2391 +(defun ert--remprop (sym tag)
\r
2392 + "Copy of `cl-remprop'. Modify SYM's plist by removing TAG."
\r
2393 + (let ((plist (symbol-plist sym)))
\r
2394 + (if (and plist (eq tag (car plist)))
\r
2395 + (progn (setplist sym (cdr (cdr plist))) t)
\r
2396 + (ert--cl-do-remf plist tag))))
\r
2398 +(defun ert--remove-if-not (ert-pred ert-list)
\r
2399 + "A reimplementation of `remove-if-not'.
\r
2401 +ERT-PRED is a predicate, ERT-LIST is the input list."
\r
2402 + (loop for ert-x in ert-list
\r
2403 + if (funcall ert-pred ert-x)
\r
2406 +(defun ert--intersection (a b)
\r
2407 + "A reimplementation of `intersection'. Intersect the sets A and B.
\r
2409 +Elements are compared using `eql'."
\r
2410 + (loop for x in a
\r
2414 +(defun ert--set-difference (a b)
\r
2415 + "A reimplementation of `set-difference'. Subtract the set B from the set A.
\r
2417 +Elements are compared using `eql'."
\r
2418 + (loop for x in a
\r
2419 + unless (memql x b)
\r
2422 +(defun ert--set-difference-eq (a b)
\r
2423 + "A reimplementation of `set-difference'. Subtract the set B from the set A.
\r
2425 +Elements are compared using `eq'."
\r
2426 + (loop for x in a
\r
2427 + unless (memq x b)
\r
2430 +(defun ert--union (a b)
\r
2431 + "A reimplementation of `union'. Compute the union of the sets A and B.
\r
2433 +Elements are compared using `eql'."
\r
2434 + (append a (ert--set-difference b a)))
\r
2436 +(eval-and-compile
\r
2437 + (defvar ert--gensym-counter 0))
\r
2439 +(eval-and-compile
\r
2440 + (defun ert--gensym (&optional prefix)
\r
2441 + "Only allows string PREFIX, not compatible with CL."
\r
2442 + (unless prefix (setq prefix "G"))
\r
2443 + (make-symbol (format "%s%s"
\r
2445 + (prog1 ert--gensym-counter
\r
2446 + (incf ert--gensym-counter))))))
\r
2448 +(defun ert--coerce-to-vector (x)
\r
2449 + "Coerce X to a vector."
\r
2450 + (when (char-table-p x) (error "Not supported"))
\r
2455 +(defun* ert--remove* (x list &key key test)
\r
2456 + "Does not support all the keywords of remove*."
\r
2457 + (unless key (setq key #'identity))
\r
2458 + (unless test (setq test #'eql))
\r
2459 + (loop for y in list
\r
2460 + unless (funcall test x (funcall key y))
\r
2463 +(defun ert--string-position (c s)
\r
2464 + "Return the position of the first occurrence of C in S, or nil if none."
\r
2465 + (loop for i from 0
\r
2467 + when (eql x c) return i))
\r
2469 +(defun ert--mismatch (a b)
\r
2470 + "Return index of first element that differs between A and B.
\r
2472 +Like `mismatch'. Uses `equal' for comparison."
\r
2473 + (cond ((or (listp a) (listp b))
\r
2474 + (ert--mismatch (ert--coerce-to-vector a)
\r
2475 + (ert--coerce-to-vector b)))
\r
2476 + ((> (length a) (length b))
\r
2477 + (ert--mismatch b a))
\r
2479 + (let ((la (length a))
\r
2480 + (lb (length b)))
\r
2481 + (assert (arrayp a) t)
\r
2482 + (assert (arrayp b) t)
\r
2483 + (assert (<= la lb) t)
\r
2484 + (loop for i below la
\r
2485 + when (not (equal (aref a i) (aref b i))) return i
\r
2486 + finally (return (if (/= la lb)
\r
2488 + (assert (equal a b) t)
\r
2491 +(defun ert--subseq (seq start &optional end)
\r
2492 + "Return a subsequence of SEQ from START to END."
\r
2493 + (when (char-table-p seq) (error "Not supported"))
\r
2494 + (let ((vector (substring (ert--coerce-to-vector seq) start end)))
\r
2497 + (string (concat vector))
\r
2498 + (list (append vector nil))
\r
2499 + (bool-vector (loop with result = (make-bool-vector (length vector) nil)
\r
2500 + for i below (length vector) do
\r
2501 + (setf (aref result i) (aref vector i))
\r
2502 + finally (return result)))
\r
2503 + (char-table (assert nil)))))
\r
2505 +(defun ert-equal-including-properties (a b)
\r
2506 + "Return t if A and B have similar structure and contents.
\r
2508 +This is like `equal-including-properties' except that it compares
\r
2509 +the property values of text properties structurally (by
\r
2510 +recursing) rather than with `eq'. Perhaps this is what
\r
2511 +`equal-including-properties' should do in the first place; see
\r
2512 +Emacs bug 6581 at URL `http://debbugs.gnu.org/cgi/bugreport.cgi?bug=6581'."
\r
2513 + ;; This implementation is inefficient. Rather than making it
\r
2514 + ;; efficient, let's hope bug 6581 gets fixed so that we can delete
\r
2515 + ;; it altogether.
\r
2516 + (not (ert--explain-not-equal-including-properties a b)))
\r
2519 +;;; Defining and locating tests.
\r
2521 +;; The data structure that represents a test case.
\r
2522 +(defstruct ert-test
\r
2524 + (documentation nil)
\r
2525 + (body (assert nil))
\r
2526 + (most-recent-result nil)
\r
2527 + (expected-result-type ':passed)
\r
2530 +(defun ert-test-boundp (symbol)
\r
2531 + "Return non-nil if SYMBOL names a test."
\r
2532 + (and (get symbol 'ert--test) t))
\r
2534 +(defun ert-get-test (symbol)
\r
2535 + "If SYMBOL names a test, return that. Signal an error otherwise."
\r
2536 + (unless (ert-test-boundp symbol) (error "No test named `%S'" symbol))
\r
2537 + (get symbol 'ert--test))
\r
2539 +(defun ert-set-test (symbol definition)
\r
2540 + "Make SYMBOL name the test DEFINITION, and return DEFINITION."
\r
2541 + (when (eq symbol 'nil)
\r
2542 + ;; We disallow nil since `ert-test-at-point' and related functions
\r
2543 + ;; want to return a test name, but also need an out-of-band value
\r
2544 + ;; on failure. Nil is the most natural out-of-band value; using 0
\r
2545 + ;; or "" or signalling an error would be too awkward.
\r
2547 + ;; Note that nil is still a valid value for the `name' slot in
\r
2548 + ;; ert-test objects. It designates an anonymous test.
\r
2549 + (error "Attempt to define a test named nil"))
\r
2550 + (put symbol 'ert--test definition)
\r
2553 +(defun ert-make-test-unbound (symbol)
\r
2554 + "Make SYMBOL name no test. Return SYMBOL."
\r
2555 + (ert--remprop symbol 'ert--test)
\r
2558 +(defun ert--parse-keys-and-body (keys-and-body)
\r
2559 + "Split KEYS-AND-BODY into keyword-and-value pairs and the remaining body.
\r
2561 +KEYS-AND-BODY should have the form of a property list, with the
\r
2562 +exception that only keywords are permitted as keys and that the
\r
2563 +tail -- the body -- is a list of forms that does not start with a
\r
2566 +Returns a two-element list containing the keys-and-values plist
\r
2568 + (let ((extracted-key-accu '())
\r
2569 + (remaining keys-and-body))
\r
2570 + (while (and (consp remaining) (keywordp (first remaining)))
\r
2571 + (let ((keyword (pop remaining)))
\r
2572 + (unless (consp remaining)
\r
2573 + (error "Value expected after keyword %S in %S"
\r
2574 + keyword keys-and-body))
\r
2575 + (when (assoc keyword extracted-key-accu)
\r
2576 + (warn "Keyword %S appears more than once in %S" keyword
\r
2578 + (push (cons keyword (pop remaining)) extracted-key-accu)))
\r
2579 + (setq extracted-key-accu (nreverse extracted-key-accu))
\r
2580 + (list (loop for (key . value) in extracted-key-accu
\r
2586 +(defmacro* ert-deftest (name () &body docstring-keys-and-body)
\r
2587 + "Define NAME (a symbol) as a test.
\r
2589 +BODY is evaluated as a `progn' when the test is run. It should
\r
2590 +signal a condition on failure or just return if the test passes.
\r
2592 +`should', `should-not' and `should-error' are useful for
\r
2593 +assertions in BODY.
\r
2595 +Use `ert' to run tests interactively.
\r
2597 +Tests that are expected to fail can be marked as such
\r
2598 +using :expected-result. See `ert-test-result-type-p' for a
\r
2599 +description of valid values for RESULT-TYPE.
\r
2601 +\(fn NAME () [DOCSTRING] [:expected-result RESULT-TYPE] \
\r
2602 +\[:tags '(TAG...)] BODY...)"
\r
2603 + (declare (debug (&define :name test
\r
2604 + name sexp [&optional stringp]
\r
2605 + [&rest keywordp sexp] def-body))
\r
2608 + (let ((documentation nil)
\r
2609 + (documentation-supplied-p nil))
\r
2610 + (when (stringp (first docstring-keys-and-body))
\r
2611 + (setq documentation (pop docstring-keys-and-body)
\r
2612 + documentation-supplied-p t))
\r
2613 + (destructuring-bind ((&key (expected-result nil expected-result-supplied-p)
\r
2614 + (tags nil tags-supplied-p))
\r
2616 + (ert--parse-keys-and-body docstring-keys-and-body)
\r
2618 + (ert-set-test ',name
\r
2621 + ,@(when documentation-supplied-p
\r
2622 + `(:documentation ,documentation))
\r
2623 + ,@(when expected-result-supplied-p
\r
2624 + `(:expected-result-type ,expected-result))
\r
2625 + ,@(when tags-supplied-p
\r
2627 + :body (lambda () ,@body)))
\r
2628 + ;; This hack allows `symbol-file' to associate `ert-deftest'
\r
2629 + ;; forms with files, and therefore enables `find-function' to
\r
2630 + ;; work with tests. However, it leads to warnings in
\r
2631 + ;; `unload-feature', which doesn't know how to undefine tests
\r
2632 + ;; and has no mechanism for extension.
\r
2633 + (push '(ert-deftest . ,name) current-load-list)
\r
2636 +;; We use these `put' forms in addition to the (declare (indent)) in
\r
2637 +;; the defmacro form since the `declare' alone does not lead to
\r
2638 +;; correct indentation before the .el/.elc file is loaded.
\r
2639 +;; Autoloading these `put' forms solves this.
\r
2642 + ;; TODO(ohler): Figure out what these mean and make sure they are correct.
\r
2643 + (put 'ert-deftest 'lisp-indent-function 2)
\r
2644 + (put 'ert-info 'lisp-indent-function 1))
\r
2646 +(defvar ert--find-test-regexp
\r
2647 + (concat "^\\s-*(ert-deftest"
\r
2648 + find-function-space-re
\r
2649 + "%s\\(\\s-\\|$\\)")
\r
2650 + "The regexp the `find-function' mechanisms use for finding test definitions.")
\r
2653 +(put 'ert-test-failed 'error-conditions '(error ert-test-failed))
\r
2654 +(put 'ert-test-failed 'error-message "Test failed")
\r
2656 +(defun ert-pass ()
\r
2657 + "Terminate the current test and mark it passed. Does not return."
\r
2658 + (throw 'ert--pass nil))
\r
2660 +(defun ert-fail (data)
\r
2661 + "Terminate the current test and mark it failed. Does not return.
\r
2662 +DATA is displayed to the user and should state the reason of the failure."
\r
2663 + (signal 'ert-test-failed (list data)))
\r
2666 +;;; The `should' macros.
\r
2668 +(defvar ert--should-execution-observer nil)
\r
2670 +(defun ert--signal-should-execution (form-description)
\r
2671 + "Tell the current `should' form observer (if any) about FORM-DESCRIPTION."
\r
2672 + (when ert--should-execution-observer
\r
2673 + (funcall ert--should-execution-observer form-description)))
\r
2675 +(defun ert--special-operator-p (thing)
\r
2676 + "Return non-nil if THING is a symbol naming a special operator."
\r
2677 + (and (symbolp thing)
\r
2678 + (let ((definition (indirect-function thing t)))
\r
2679 + (and (subrp definition)
\r
2680 + (eql (cdr (subr-arity definition)) 'unevalled)))))
\r
2682 +(defun ert--expand-should-1 (whole form inner-expander)
\r
2683 + "Helper function for the `should' macro and its variants."
\r
2685 + ;; If `cl-macroexpand' isn't bound, the code that we're
\r
2686 + ;; compiling doesn't depend on cl and thus doesn't need an
\r
2687 + ;; environment arg for `macroexpand'.
\r
2688 + (if (fboundp 'cl-macroexpand)
\r
2689 + ;; Suppress warning about run-time call to cl funtion: we
\r
2690 + ;; only call it if it's fboundp.
\r
2691 + (with-no-warnings
\r
2692 + (cl-macroexpand form (and (boundp 'cl-macro-environment)
\r
2693 + cl-macro-environment)))
\r
2694 + (macroexpand form))))
\r
2696 + ((or (atom form) (ert--special-operator-p (car form)))
\r
2697 + (let ((value (ert--gensym "value-")))
\r
2698 + `(let ((,value (ert--gensym "ert-form-evaluation-aborted-")))
\r
2699 + ,(funcall inner-expander
\r
2700 + `(setq ,value ,form)
\r
2701 + `(list ',whole :form ',form :value ,value)
\r
2705 + (let ((fn-name (car form))
\r
2706 + (arg-forms (cdr form)))
\r
2707 + (assert (or (symbolp fn-name)
\r
2708 + (and (consp fn-name)
\r
2709 + (eql (car fn-name) 'lambda)
\r
2710 + (listp (cdr fn-name)))))
\r
2711 + (let ((fn (ert--gensym "fn-"))
\r
2712 + (args (ert--gensym "args-"))
\r
2713 + (value (ert--gensym "value-"))
\r
2714 + (default-value (ert--gensym "ert-form-evaluation-aborted-")))
\r
2715 + `(let ((,fn (function ,fn-name))
\r
2716 + (,args (list ,@arg-forms)))
\r
2717 + (let ((,value ',default-value))
\r
2718 + ,(funcall inner-expander
\r
2719 + `(setq ,value (apply ,fn ,args))
\r
2720 + `(nconc (list ',whole)
\r
2721 + (list :form `(,,fn ,@,args))
\r
2722 + (unless (eql ,value ',default-value)
\r
2723 + (list :value ,value))
\r
2724 + (let ((-explainer-
\r
2725 + (and (symbolp ',fn-name)
\r
2726 + (get ',fn-name 'ert-explainer))))
\r
2727 + (when -explainer-
\r
2728 + (list :explanation
\r
2729 + (apply -explainer- ,args)))))
\r
2733 +(defun ert--expand-should (whole form inner-expander)
\r
2734 + "Helper function for the `should' macro and its variants.
\r
2736 +Analyzes FORM and returns an expression that has the same
\r
2737 +semantics under evaluation but records additional debugging
\r
2740 +INNER-EXPANDER should be a function and is called with two
\r
2741 +arguments: INNER-FORM and FORM-DESCRIPTION-FORM, where INNER-FORM
\r
2742 +is an expression equivalent to FORM, and FORM-DESCRIPTION-FORM is
\r
2743 +an expression that returns a description of FORM. INNER-EXPANDER
\r
2744 +should return code that calls INNER-FORM and performs the checks
\r
2745 +and error signalling specific to the particular variant of
\r
2746 +`should'. The code that INNER-EXPANDER returns must not call
\r
2747 +FORM-DESCRIPTION-FORM before it has called INNER-FORM."
\r
2748 + (lexical-let ((inner-expander inner-expander))
\r
2749 + (ert--expand-should-1
\r
2751 + (lambda (inner-form form-description-form value-var)
\r
2752 + (let ((form-description (ert--gensym "form-description-")))
\r
2753 + `(let (,form-description)
\r
2754 + ,(funcall inner-expander
\r
2755 + `(unwind-protect
\r
2757 + (setq ,form-description ,form-description-form)
\r
2758 + (ert--signal-should-execution ,form-description))
\r
2759 + `,form-description
\r
2760 + value-var)))))))
\r
2762 +(defmacro* should (form)
\r
2763 + "Evaluate FORM. If it returns nil, abort the current test as failed.
\r
2765 +Returns the value of FORM."
\r
2766 + (ert--expand-should `(should ,form) form
\r
2767 + (lambda (inner-form form-description-form value-var)
\r
2768 + `(unless ,inner-form
\r
2769 + (ert-fail ,form-description-form)))))
\r
2771 +(defmacro* should-not (form)
\r
2772 + "Evaluate FORM. If it returns non-nil, abort the current test as failed.
\r
2775 + (ert--expand-should `(should-not ,form) form
\r
2776 + (lambda (inner-form form-description-form value-var)
\r
2777 + `(unless (not ,inner-form)
\r
2778 + (ert-fail ,form-description-form)))))
\r
2780 +(defun ert--should-error-handle-error (form-description-fn
\r
2781 + condition type exclude-subtypes)
\r
2782 + "Helper function for `should-error'.
\r
2784 +Determines whether CONDITION matches TYPE and EXCLUDE-SUBTYPES,
\r
2785 +and aborts the current test as failed if it doesn't."
\r
2786 + (let ((signalled-conditions (get (car condition) 'error-conditions))
\r
2787 + (handled-conditions (etypecase type
\r
2789 + (symbol (list type)))))
\r
2790 + (assert signalled-conditions)
\r
2791 + (unless (ert--intersection signalled-conditions handled-conditions)
\r
2792 + (ert-fail (append
\r
2793 + (funcall form-description-fn)
\r
2795 + :condition condition
\r
2796 + :fail-reason (concat "the error signalled did not"
\r
2797 + " have the expected type")))))
\r
2798 + (when exclude-subtypes
\r
2799 + (unless (member (car condition) handled-conditions)
\r
2800 + (ert-fail (append
\r
2801 + (funcall form-description-fn)
\r
2803 + :condition condition
\r
2804 + :fail-reason (concat "the error signalled was a subtype"
\r
2805 + " of the expected type"))))))))
\r
2807 +;; FIXME: The expansion will evaluate the keyword args (if any) in
\r
2808 +;; nonstandard order.
\r
2809 +(defmacro* should-error (form &rest keys &key type exclude-subtypes)
\r
2810 + "Evaluate FORM and check that it signals an error.
\r
2812 +The error signalled needs to match TYPE. TYPE should be a list
\r
2813 +of condition names. (It can also be a non-nil symbol, which is
\r
2814 +equivalent to a singleton list containing that symbol.) If
\r
2815 +EXCLUDE-SUBTYPES is nil, the error matches TYPE if one of its
\r
2816 +condition names is an element of TYPE. If EXCLUDE-SUBTYPES is
\r
2817 +non-nil, the error matches TYPE if it is an element of TYPE.
\r
2819 +If the error matches, returns (ERROR-SYMBOL . DATA) from the
\r
2820 +error. If not, or if no error was signalled, abort the test as
\r
2822 + (unless type (setq type ''error))
\r
2823 + (ert--expand-should
\r
2824 + `(should-error ,form ,@keys)
\r
2826 + (lambda (inner-form form-description-form value-var)
\r
2827 + (let ((errorp (ert--gensym "errorp"))
\r
2828 + (form-description-fn (ert--gensym "form-description-fn-")))
\r
2829 + `(let ((,errorp nil)
\r
2830 + (,form-description-fn (lambda () ,form-description-form)))
\r
2831 + (condition-case -condition-
\r
2833 + ;; We can't use ,type here because we want to evaluate it.
\r
2835 + (setq ,errorp t)
\r
2836 + (ert--should-error-handle-error ,form-description-fn
\r
2838 + ,type ,exclude-subtypes)
\r
2839 + (setq ,value-var -condition-)))
\r
2841 + (ert-fail (append
\r
2842 + (funcall ,form-description-fn)
\r
2844 + :fail-reason "did not signal an error")))))))))
\r
2847 +;;; Explanation of `should' failures.
\r
2849 +;; TODO(ohler): Rework explanations so that they are displayed in a
\r
2850 +;; similar way to `ert-info' messages; in particular, allow text
\r
2851 +;; buttons in explanations that give more detail or open an ediff
\r
2852 +;; buffer. Perhaps explanations should be reported through `ert-info'
\r
2853 +;; rather than as part of the condition.
\r
2855 +(defun ert--proper-list-p (x)
\r
2856 + "Return non-nil if X is a proper list, nil otherwise."
\r
2858 + for firstp = t then nil
\r
2859 + for fast = x then (cddr fast)
\r
2860 + for slow = x then (cdr slow) do
\r
2861 + (when (null fast) (return t))
\r
2862 + (when (not (consp fast)) (return nil))
\r
2863 + (when (null (cdr fast)) (return t))
\r
2864 + (when (not (consp (cdr fast))) (return nil))
\r
2865 + (when (and (not firstp) (eq fast slow)) (return nil))))
\r
2867 +(defun ert--explain-format-atom (x)
\r
2868 + "Format the atom X for `ert--explain-not-equal'."
\r
2870 + (fixnum (list x (format "#x%x" x) (format "?%c" x)))
\r
2873 +(defun ert--explain-not-equal (a b)
\r
2874 + "Explainer function for `equal'.
\r
2876 +Returns a programmer-readable explanation of why A and B are not
\r
2877 +`equal', or nil if they are."
\r
2878 + (if (not (equal (type-of a) (type-of b)))
\r
2879 + `(different-types ,a ,b)
\r
2882 + (let ((a-proper-p (ert--proper-list-p a))
\r
2883 + (b-proper-p (ert--proper-list-p b)))
\r
2884 + (if (not (eql (not a-proper-p) (not b-proper-p)))
\r
2885 + `(one-list-proper-one-improper ,a ,b)
\r
2887 + (if (not (equal (length a) (length b)))
\r
2888 + `(proper-lists-of-different-length ,(length a) ,(length b)
\r
2890 + first-mismatch-at
\r
2891 + ,(ert--mismatch a b))
\r
2892 + (loop for i from 0
\r
2895 + for xi = (ert--explain-not-equal ai bi)
\r
2896 + do (when xi (return `(list-elt ,i ,xi)))
\r
2897 + finally (assert (equal a b) t)))
\r
2898 + (let ((car-x (ert--explain-not-equal (car a) (car b))))
\r
2901 + (let ((cdr-x (ert--explain-not-equal (cdr a) (cdr b))))
\r
2904 + (assert (equal a b) t)
\r
2906 + (array (if (not (equal (length a) (length b)))
\r
2907 + `(arrays-of-different-length ,(length a) ,(length b)
\r
2909 + ,@(unless (char-table-p a)
\r
2910 + `(first-mismatch-at
\r
2911 + ,(ert--mismatch a b))))
\r
2912 + (loop for i from 0
\r
2915 + for xi = (ert--explain-not-equal ai bi)
\r
2916 + do (when xi (return `(array-elt ,i ,xi)))
\r
2917 + finally (assert (equal a b) t))))
\r
2918 + (atom (if (not (equal a b))
\r
2919 + (if (and (symbolp a) (symbolp b) (string= a b))
\r
2920 + `(different-symbols-with-the-same-name ,a ,b)
\r
2921 + `(different-atoms ,(ert--explain-format-atom a)
\r
2922 + ,(ert--explain-format-atom b)))
\r
2924 +(put 'equal 'ert-explainer 'ert--explain-not-equal)
\r
2926 +(defun ert--significant-plist-keys (plist)
\r
2927 + "Return the keys of PLIST that have non-null values, in order."
\r
2928 + (assert (zerop (mod (length plist) 2)) t)
\r
2929 + (loop for (key value . rest) on plist by #'cddr
\r
2930 + unless (or (null value) (memq key accu)) collect key into accu
\r
2931 + finally (return accu)))
\r
2933 +(defun ert--plist-difference-explanation (a b)
\r
2934 + "Return a programmer-readable explanation of why A and B are different plists.
\r
2936 +Returns nil if they are equivalent, i.e., have the same value for
\r
2937 +each key, where absent values are treated as nil. The order of
\r
2938 +key/value pairs in each list does not matter."
\r
2939 + (assert (zerop (mod (length a) 2)) t)
\r
2940 + (assert (zerop (mod (length b) 2)) t)
\r
2941 + ;; Normalizing the plists would be another way to do this but it
\r
2942 + ;; requires a total ordering on all lisp objects (since any object
\r
2943 + ;; is valid as a text property key). Perhaps defining such an
\r
2944 + ;; ordering is useful in other contexts, too, but it's a lot of
\r
2945 + ;; work, so let's punt on it for now.
\r
2946 + (let* ((keys-a (ert--significant-plist-keys a))
\r
2947 + (keys-b (ert--significant-plist-keys b))
\r
2948 + (keys-in-a-not-in-b (ert--set-difference-eq keys-a keys-b))
\r
2949 + (keys-in-b-not-in-a (ert--set-difference-eq keys-b keys-a)))
\r
2950 + (flet ((explain-with-key (key)
\r
2951 + (let ((value-a (plist-get a key))
\r
2952 + (value-b (plist-get b key)))
\r
2953 + (assert (not (equal value-a value-b)) t)
\r
2954 + `(different-properties-for-key
\r
2955 + ,key ,(ert--explain-not-equal-including-properties value-a
\r
2957 + (cond (keys-in-a-not-in-b
\r
2958 + (explain-with-key (first keys-in-a-not-in-b)))
\r
2959 + (keys-in-b-not-in-a
\r
2960 + (explain-with-key (first keys-in-b-not-in-a)))
\r
2962 + (loop for key in keys-a
\r
2963 + when (not (equal (plist-get a key) (plist-get b key)))
\r
2964 + return (explain-with-key key)))))))
\r
2966 +(defun ert--abbreviate-string (s len suffixp)
\r
2967 + "Shorten string S to at most LEN chars.
\r
2969 +If SUFFIXP is non-nil, returns a suffix of S, otherwise a prefix."
\r
2970 + (let ((n (length s)))
\r
2971 + (cond ((< n len)
\r
2974 + (substring s (- n len)))
\r
2976 + (substring s 0 len)))))
\r
2978 +(defun ert--explain-not-equal-including-properties (a b)
\r
2979 + "Explainer function for `ert-equal-including-properties'.
\r
2981 +Returns a programmer-readable explanation of why A and B are not
\r
2982 +`ert-equal-including-properties', or nil if they are."
\r
2983 + (if (not (equal a b))
\r
2984 + (ert--explain-not-equal a b)
\r
2985 + (assert (stringp a) t)
\r
2986 + (assert (stringp b) t)
\r
2987 + (assert (eql (length a) (length b)) t)
\r
2988 + (loop for i from 0 to (length a)
\r
2989 + for props-a = (text-properties-at i a)
\r
2990 + for props-b = (text-properties-at i b)
\r
2991 + for difference = (ert--plist-difference-explanation props-a props-b)
\r
2992 + do (when difference
\r
2993 + (return `(char ,i ,(substring-no-properties a i (1+ i))
\r
2996 + ,(ert--abbreviate-string
\r
2997 + (substring-no-properties a 0 i)
\r
3000 + ,(ert--abbreviate-string
\r
3001 + (substring-no-properties a (1+ i))
\r
3003 + ;; TODO(ohler): Get `equal-including-properties' fixed in
\r
3004 + ;; Emacs, delete `ert-equal-including-properties', and
\r
3005 + ;; re-enable this assertion.
\r
3006 + ;;finally (assert (equal-including-properties a b) t)
\r
3008 +(put 'ert-equal-including-properties
\r
3010 + 'ert--explain-not-equal-including-properties)
\r
3013 +;;; Implementation of `ert-info'.
\r
3015 +;; TODO(ohler): The name `info' clashes with
\r
3016 +;; `ert--test-execution-info'. One or both should be renamed.
\r
3017 +(defvar ert--infos '()
\r
3018 + "The stack of `ert-info' infos that currently apply.
\r
3020 +Bound dynamically. This is a list of (PREFIX . MESSAGE) pairs.")
\r
3022 +(defmacro* ert-info ((message-form &key ((:prefix prefix-form) "Info: "))
\r
3024 + "Evaluate MESSAGE-FORM and BODY, and report the message if BODY fails.
\r
3026 +To be used within ERT tests. MESSAGE-FORM should evaluate to a
\r
3027 +string that will be displayed together with the test result if
\r
3028 +the test fails. PREFIX-FORM should evaluate to a string as well
\r
3029 +and is displayed in front of the value of MESSAGE-FORM."
\r
3030 + (declare (debug ((form &rest [sexp form]) body))
\r
3032 + `(let ((ert--infos (cons (cons ,prefix-form ,message-form) ert--infos)))
\r
3037 +;;; Facilities for running a single test.
\r
3039 +(defvar ert-debug-on-error nil
\r
3040 + "Non-nil means enter debugger when a test fails or terminates with an error.")
\r
3042 +;; The data structures that represent the result of running a test.
\r
3043 +(defstruct ert-test-result
\r
3045 + (should-forms nil)
\r
3047 +(defstruct (ert-test-passed (:include ert-test-result)))
\r
3048 +(defstruct (ert-test-result-with-condition (:include ert-test-result))
\r
3049 + (condition (assert nil))
\r
3050 + (backtrace (assert nil))
\r
3051 + (infos (assert nil)))
\r
3052 +(defstruct (ert-test-quit (:include ert-test-result-with-condition)))
\r
3053 +(defstruct (ert-test-failed (:include ert-test-result-with-condition)))
\r
3054 +(defstruct (ert-test-aborted-with-non-local-exit (:include ert-test-result)))
\r
3057 +(defun ert--record-backtrace ()
\r
3058 + "Record the current backtrace (as a list) and return it."
\r
3059 + ;; Since the backtrace is stored in the result object, result
\r
3060 + ;; objects must only be printed with appropriate limits
\r
3061 + ;; (`print-level' and `print-length') in place. For interactive
\r
3062 + ;; use, the cost of ensuring this possibly outweighs the advantage
\r
3063 + ;; of storing the backtrace for
\r
3064 + ;; `ert-results-pop-to-backtrace-for-test-at-point' given that we
\r
3065 + ;; already have `ert-results-rerun-test-debugging-errors-at-point'.
\r
3066 + ;; For batch use, however, printing the backtrace may be useful.
\r
3068 + ;; 6 is the number of frames our own debugger adds (when
\r
3069 + ;; compiled; more when interpreted). FIXME: Need to describe a
\r
3070 + ;; procedure for determining this constant.
\r
3072 + for frame = (backtrace-frame i)
\r
3076 +(defun ert--print-backtrace (backtrace)
\r
3077 + "Format the backtrace BACKTRACE to the current buffer."
\r
3078 + ;; This is essentially a reimplementation of Fbacktrace
\r
3079 + ;; (src/eval.c), but for a saved backtrace, not the current one.
\r
3080 + (let ((print-escape-newlines t)
\r
3082 + (print-length 50))
\r
3083 + (dolist (frame backtrace)
\r
3084 + (ecase (first frame)
\r
3086 + ;; Special operator.
\r
3087 + (destructuring-bind (special-operator &rest arg-forms)
\r
3090 + (format " %S\n" (list* special-operator arg-forms)))))
\r
3092 + ;; Function call.
\r
3093 + (destructuring-bind (fn &rest args) (cdr frame)
\r
3094 + (insert (format " %S(" fn))
\r
3095 + (loop for firstp = t then nil
\r
3096 + for arg in args do
\r
3099 + (insert (format "%S" arg)))
\r
3100 + (insert ")\n")))))))
\r
3102 +;; A container for the state of the execution of a single test and
\r
3103 +;; environment data needed during its execution.
\r
3104 +(defstruct ert--test-execution-info
\r
3105 + (test (assert nil))
\r
3106 + (result (assert nil))
\r
3107 + ;; A thunk that may be called when RESULT has been set to its final
\r
3108 + ;; value and test execution should be terminated. Should not
\r
3110 + (exit-continuation (assert nil))
\r
3111 + ;; The binding of `debugger' outside of the execution of the test.
\r
3113 + ;; The binding of `ert-debug-on-error' that is in effect for the
\r
3114 + ;; execution of the current test. We store it to avoid being
\r
3115 + ;; affected by any new bindings the test itself may establish. (I
\r
3116 + ;; don't remember whether this feature is important.)
\r
3117 + ert-debug-on-error)
\r
3119 +(defun ert--run-test-debugger (info debugger-args)
\r
3120 + "During a test run, `debugger' is bound to a closure that calls this function.
\r
3122 +This function records failures and errors and either terminates
\r
3123 +the test silently or calls the interactive debugger, as
\r
3126 +INFO is the ert--test-execution-info corresponding to this test
\r
3127 +run. DEBUGGER-ARGS are the arguments to `debugger'."
\r
3128 + (destructuring-bind (first-debugger-arg &rest more-debugger-args)
\r
3130 + (ecase first-debugger-arg
\r
3131 + ((lambda debug t exit nil)
\r
3132 + (apply (ert--test-execution-info-next-debugger info) debugger-args))
\r
3134 + (let* ((condition (first more-debugger-args))
\r
3135 + (type (case (car condition)
\r
3137 + (otherwise 'failed)))
\r
3138 + (backtrace (ert--record-backtrace))
\r
3139 + (infos (reverse ert--infos)))
\r
3140 + (setf (ert--test-execution-info-result info)
\r
3143 + (make-ert-test-quit :condition condition
\r
3144 + :backtrace backtrace
\r
3147 + (make-ert-test-failed :condition condition
\r
3148 + :backtrace backtrace
\r
3149 + :infos infos))))
\r
3150 + ;; Work around Emacs' heuristic (in eval.c) for detecting
\r
3151 + ;; errors in the debugger.
\r
3152 + (incf num-nonmacro-input-events)
\r
3153 + ;; FIXME: We should probably implement more fine-grained
\r
3154 + ;; control a la non-t `debug-on-error' here.
\r
3156 + ((ert--test-execution-info-ert-debug-on-error info)
\r
3157 + (apply (ert--test-execution-info-next-debugger info) debugger-args))
\r
3159 + (funcall (ert--test-execution-info-exit-continuation info)))))))
\r
3161 +(defun ert--run-test-internal (ert-test-execution-info)
\r
3162 + "Low-level function to run a test according to ERT-TEST-EXECUTION-INFO.
\r
3164 +This mainly sets up debugger-related bindings."
\r
3165 + (lexical-let ((info ert-test-execution-info))
\r
3166 + (setf (ert--test-execution-info-next-debugger info) debugger
\r
3167 + (ert--test-execution-info-ert-debug-on-error info) ert-debug-on-error)
\r
3168 + (catch 'ert--pass
\r
3169 + ;; For now, each test gets its own temp buffer and its own
\r
3170 + ;; window excursion, just to be safe. If this turns out to be
\r
3171 + ;; too expensive, we can remove it.
\r
3172 + (with-temp-buffer
\r
3173 + (save-window-excursion
\r
3174 + (let ((debugger (lambda (&rest debugger-args)
\r
3175 + (ert--run-test-debugger info debugger-args)))
\r
3176 + (debug-on-error t)
\r
3177 + (debug-on-quit t)
\r
3178 + ;; FIXME: Do we need to store the old binding of this
\r
3179 + ;; and consider it in `ert--run-test-debugger'?
\r
3180 + (debug-ignored-errors nil)
\r
3181 + (ert--infos '()))
\r
3182 + (funcall (ert-test-body (ert--test-execution-info-test info))))))
\r
3184 + (setf (ert--test-execution-info-result info) (make-ert-test-passed)))
\r
3187 +(defun ert--force-message-log-buffer-truncation ()
\r
3188 + "Immediately truncate *Messages* buffer according to `message-log-max'.
\r
3190 +This can be useful after reducing the value of `message-log-max'."
\r
3191 + (with-current-buffer (get-buffer-create "*Messages*")
\r
3192 + ;; This is a reimplementation of this part of message_dolog() in xdisp.c:
\r
3193 + ;; if (NATNUMP (Vmessage_log_max))
\r
3195 + ;; scan_newline (Z, Z_BYTE, BEG, BEG_BYTE,
\r
3196 + ;; -XFASTINT (Vmessage_log_max) - 1, 0);
\r
3197 + ;; del_range_both (BEG, BEG_BYTE, PT, PT_BYTE, 0);
\r
3199 + (when (and (integerp message-log-max) (>= message-log-max 0))
\r
3200 + (let ((begin (point-min))
\r
3201 + (end (save-excursion
\r
3202 + (goto-char (point-max))
\r
3203 + (forward-line (- message-log-max))
\r
3205 + (delete-region begin end)))))
\r
3207 +(defvar ert--running-tests nil
\r
3208 + "List of tests that are currently in execution.
\r
3210 +This list is empty while no test is running, has one element
\r
3211 +while a test is running, two elements while a test run from
\r
3212 +inside a test is running, etc. The list is in order of nesting,
\r
3213 +innermost test first.
\r
3215 +The elements are of type `ert-test'.")
\r
3217 +(defun ert-run-test (ert-test)
\r
3220 +Returns the result and stores it in ERT-TEST's `most-recent-result' slot."
\r
3221 + (setf (ert-test-most-recent-result ert-test) nil)
\r
3223 + (lexical-let ((begin-marker
\r
3224 + (with-current-buffer (get-buffer-create "*Messages*")
\r
3225 + (set-marker (make-marker) (point-max)))))
\r
3227 + (lexical-let ((info (make-ert--test-execution-info
\r
3230 + (make-ert-test-aborted-with-non-local-exit)
\r
3231 + :exit-continuation (lambda ()
\r
3232 + (return-from error nil))))
\r
3233 + (should-form-accu (list)))
\r
3235 + (let ((ert--should-execution-observer
\r
3236 + (lambda (form-description)
\r
3237 + (push form-description should-form-accu)))
\r
3238 + (message-log-max t)
\r
3239 + (ert--running-tests (cons ert-test ert--running-tests)))
\r
3240 + (ert--run-test-internal info))
\r
3241 + (let ((result (ert--test-execution-info-result info)))
\r
3242 + (setf (ert-test-result-messages result)
\r
3243 + (with-current-buffer (get-buffer-create "*Messages*")
\r
3244 + (buffer-substring begin-marker (point-max))))
\r
3245 + (ert--force-message-log-buffer-truncation)
\r
3246 + (setq should-form-accu (nreverse should-form-accu))
\r
3247 + (setf (ert-test-result-should-forms result)
\r
3248 + should-form-accu)
\r
3249 + (setf (ert-test-most-recent-result ert-test) result))))
\r
3250 + (set-marker begin-marker nil))))
\r
3251 + (ert-test-most-recent-result ert-test))
\r
3253 +(defun ert-running-test ()
\r
3254 + "Return the top-level test currently executing."
\r
3255 + (car (last ert--running-tests)))
\r
3258 +;;; Test selectors.
\r
3260 +(defun ert-test-result-type-p (result result-type)
\r
3261 + "Return non-nil if RESULT matches type RESULT-TYPE.
\r
3263 +Valid result types:
\r
3265 +nil -- Never matches.
\r
3266 +t -- Always matches.
\r
3267 +:failed, :passed -- Matches corresponding results.
\r
3268 +\(and TYPES...\) -- Matches if all TYPES match.
\r
3269 +\(or TYPES...\) -- Matches if some TYPES match.
\r
3270 +\(not TYPE\) -- Matches if TYPE does not match.
\r
3271 +\(satisfies PREDICATE\) -- Matches if PREDICATE returns true when called with
\r
3273 + ;; It would be easy to add `member' and `eql' types etc., but I
\r
3274 + ;; haven't bothered yet.
\r
3275 + (etypecase result-type
\r
3276 + ((member nil) nil)
\r
3278 + ((member :failed) (ert-test-failed-p result))
\r
3279 + ((member :passed) (ert-test-passed-p result))
\r
3281 + (destructuring-bind (operator &rest operands) result-type
\r
3284 + (case (length operands)
\r
3287 + (and (ert-test-result-type-p result (first operands))
\r
3288 + (ert-test-result-type-p result `(and ,@(rest operands)))))))
\r
3290 + (case (length operands)
\r
3293 + (or (ert-test-result-type-p result (first operands))
\r
3294 + (ert-test-result-type-p result `(or ,@(rest operands)))))))
\r
3296 + (assert (eql (length operands) 1))
\r
3297 + (not (ert-test-result-type-p result (first operands))))
\r
3299 + (assert (eql (length operands) 1))
\r
3300 + (funcall (first operands) result)))))))
\r
3302 +(defun ert-test-result-expected-p (test result)
\r
3303 + "Return non-nil if TEST's expected result type matches RESULT."
\r
3304 + (ert-test-result-type-p result (ert-test-expected-result-type test)))
\r
3306 +(defun ert-select-tests (selector universe)
\r
3307 + "Return the tests that match SELECTOR.
\r
3309 +UNIVERSE specifies the set of tests to select from; it should be
\r
3310 +a list of tests, or t, which refers to all tests named by symbols
\r
3313 +Returns the set of tests as a list.
\r
3317 +nil -- Selects the empty set.
\r
3318 +t -- Selects UNIVERSE.
\r
3319 +:new -- Selects all tests that have not been run yet.
\r
3320 +:failed, :passed -- Select tests according to their most recent result.
\r
3321 +:expected, :unexpected -- Select tests according to their most recent result.
\r
3322 +a string -- Selects all tests that have a name that matches the string,
\r
3324 +a test -- Selects that test.
\r
3325 +a symbol -- Selects the test that the symbol names, errors if none.
\r
3326 +\(member TESTS...\) -- Selects TESTS, a list of tests or symbols naming tests.
\r
3327 +\(eql TEST\) -- Selects TEST, a test or a symbol naming a test.
\r
3328 +\(and SELECTORS...\) -- Selects the tests that match all SELECTORS.
\r
3329 +\(or SELECTORS...\) -- Selects the tests that match any SELECTOR.
\r
3330 +\(not SELECTOR\) -- Selects all tests that do not match SELECTOR.
\r
3331 +\(tag TAG) -- Selects all tests that have TAG on their tags list.
\r
3332 +\(satisfies PREDICATE\) -- Selects all tests that satisfy PREDICATE.
\r
3334 +Only selectors that require a superset of tests, such
\r
3335 +as (satisfies ...), strings, :new, etc. make use of UNIVERSE.
\r
3336 +Selectors that do not, such as \(member ...\), just return the
\r
3337 +set implied by them without checking whether it is really
\r
3338 +contained in UNIVERSE."
\r
3339 + ;; This code needs to match the etypecase in
\r
3340 + ;; `ert-insert-human-readable-selector'.
\r
3341 + (etypecase selector
\r
3342 + ((member nil) nil)
\r
3343 + ((member t) (etypecase universe
\r
3345 + ((member t) (ert-select-tests "" universe))))
\r
3346 + ((member :new) (ert-select-tests
\r
3347 + `(satisfies ,(lambda (test)
\r
3348 + (null (ert-test-most-recent-result test))))
\r
3350 + ((member :failed) (ert-select-tests
\r
3351 + `(satisfies ,(lambda (test)
\r
3352 + (ert-test-result-type-p
\r
3353 + (ert-test-most-recent-result test)
\r
3356 + ((member :passed) (ert-select-tests
\r
3357 + `(satisfies ,(lambda (test)
\r
3358 + (ert-test-result-type-p
\r
3359 + (ert-test-most-recent-result test)
\r
3362 + ((member :expected) (ert-select-tests
\r
3365 + (ert-test-result-expected-p
\r
3367 + (ert-test-most-recent-result test))))
\r
3369 + ((member :unexpected) (ert-select-tests `(not :expected) universe))
\r
3371 + (etypecase universe
\r
3372 + ((member t) (mapcar #'ert-get-test
\r
3373 + (apropos-internal selector #'ert-test-boundp)))
\r
3374 + (list (ert--remove-if-not (lambda (test)
\r
3375 + (and (ert-test-name test)
\r
3376 + (string-match selector
\r
3377 + (ert-test-name test))))
\r
3379 + (ert-test (list selector))
\r
3381 + (assert (ert-test-boundp selector))
\r
3382 + (list (ert-get-test selector)))
\r
3384 + (destructuring-bind (operator &rest operands) selector
\r
3387 + (mapcar (lambda (purported-test)
\r
3388 + (etypecase purported-test
\r
3389 + (symbol (assert (ert-test-boundp purported-test))
\r
3390 + (ert-get-test purported-test))
\r
3391 + (ert-test purported-test)))
\r
3394 + (assert (eql (length operands) 1))
\r
3395 + (ert-select-tests `(member ,@operands) universe))
\r
3397 + ;; Do these definitions of AND, NOT and OR satisfy de
\r
3398 + ;; Morgan's laws? Should they?
\r
3399 + (case (length operands)
\r
3400 + (0 (ert-select-tests 't universe))
\r
3401 + (t (ert-select-tests `(and ,@(rest operands))
\r
3402 + (ert-select-tests (first operands)
\r
3405 + (assert (eql (length operands) 1))
\r
3406 + (let ((all-tests (ert-select-tests 't universe)))
\r
3407 + (ert--set-difference all-tests
\r
3408 + (ert-select-tests (first operands)
\r
3411 + (case (length operands)
\r
3412 + (0 (ert-select-tests 'nil universe))
\r
3413 + (t (ert--union (ert-select-tests (first operands) universe)
\r
3414 + (ert-select-tests `(or ,@(rest operands))
\r
3417 + (assert (eql (length operands) 1))
\r
3418 + (let ((tag (first operands)))
\r
3419 + (ert-select-tests `(satisfies
\r
3421 + (member tag (ert-test-tags test))))
\r
3424 + (assert (eql (length operands) 1))
\r
3425 + (ert--remove-if-not (first operands)
\r
3426 + (ert-select-tests 't universe))))))))
\r
3428 +(defun ert--insert-human-readable-selector (selector)
\r
3429 + "Insert a human-readable presentation of SELECTOR into the current buffer."
\r
3430 + ;; This is needed to avoid printing the (huge) contents of the
\r
3431 + ;; `backtrace' slot of the result objects in the
\r
3432 + ;; `most-recent-result' slots of test case objects in (eql ...) or
\r
3433 + ;; (member ...) selectors.
\r
3434 + (labels ((rec (selector)
\r
3435 + ;; This code needs to match the etypecase in `ert-select-tests'.
\r
3436 + (etypecase selector
\r
3437 + ((or (member nil t
\r
3438 + :new :failed :passed
\r
3439 + :expected :unexpected)
\r
3444 + (if (ert-test-name selector)
\r
3445 + (make-symbol (format "<%S>" (ert-test-name selector)))
\r
3446 + (make-symbol "<unnamed test>")))
\r
3448 + (destructuring-bind (operator &rest operands) selector
\r
3450 + ((member eql and not or)
\r
3451 + `(,operator ,@(mapcar #'rec operands)))
\r
3452 + ((member tag satisfies)
\r
3454 + (insert (format "%S" (rec selector)))))
\r
3457 +;;; Facilities for running a whole set of tests.
\r
3459 +;; The data structure that contains the set of tests being executed
\r
3460 +;; during one particular test run, their results, the state of the
\r
3461 +;; execution, and some statistics.
\r
3463 +;; The data about results and expected results of tests may seem
\r
3464 +;; redundant here, since the test objects also carry such information.
\r
3465 +;; However, the information in the test objects may be more recent, it
\r
3466 +;; may correspond to a different test run. We need the information
\r
3467 +;; that corresponds to this run in order to be able to update the
\r
3468 +;; statistics correctly when a test is re-run interactively and has a
\r
3469 +;; different result than before.
\r
3470 +(defstruct ert--stats
\r
3471 + (selector (assert nil))
\r
3472 + ;; The tests, in order.
\r
3473 + (tests (assert nil) :type vector)
\r
3474 + ;; A map of test names (or the test objects themselves for unnamed
\r
3475 + ;; tests) to indices into the `tests' vector.
\r
3476 + (test-map (assert nil) :type hash-table)
\r
3477 + ;; The results of the tests during this run, in order.
\r
3478 + (test-results (assert nil) :type vector)
\r
3479 + ;; The start times of the tests, in order, as reported by
\r
3480 + ;; `current-time'.
\r
3481 + (test-start-times (assert nil) :type vector)
\r
3482 + ;; The end times of the tests, in order, as reported by
\r
3483 + ;; `current-time'.
\r
3484 + (test-end-times (assert nil) :type vector)
\r
3485 + (passed-expected 0)
\r
3486 + (passed-unexpected 0)
\r
3487 + (failed-expected 0)
\r
3488 + (failed-unexpected 0)
\r
3489 + (start-time nil)
\r
3492 + (current-test nil)
\r
3493 + ;; The time at or after which the next redisplay should occur, as a
\r
3495 + (next-redisplay 0.0))
\r
3497 +(defun ert-stats-completed-expected (stats)
\r
3498 + "Return the number of tests in STATS that had expected results."
\r
3499 + (+ (ert--stats-passed-expected stats)
\r
3500 + (ert--stats-failed-expected stats)))
\r
3502 +(defun ert-stats-completed-unexpected (stats)
\r
3503 + "Return the number of tests in STATS that had unexpected results."
\r
3504 + (+ (ert--stats-passed-unexpected stats)
\r
3505 + (ert--stats-failed-unexpected stats)))
\r
3507 +(defun ert-stats-completed (stats)
\r
3508 + "Number of tests in STATS that have run so far."
\r
3509 + (+ (ert-stats-completed-expected stats)
\r
3510 + (ert-stats-completed-unexpected stats)))
\r
3512 +(defun ert-stats-total (stats)
\r
3513 + "Number of tests in STATS, regardless of whether they have run yet."
\r
3514 + (length (ert--stats-tests stats)))
\r
3516 +;; The stats object of the current run, dynamically bound. This is
\r
3517 +;; used for the mode line progress indicator.
\r
3518 +(defvar ert--current-run-stats nil)
\r
3520 +(defun ert--stats-test-key (test)
\r
3521 + "Return the key used for TEST in the test map of ert--stats objects.
\r
3523 +Returns the name of TEST if it has one, or TEST itself otherwise."
\r
3524 + (or (ert-test-name test) test))
\r
3526 +(defun ert--stats-set-test-and-result (stats pos test result)
\r
3527 + "Change STATS by replacing the test at position POS with TEST and RESULT.
\r
3529 +Also changes the counters in STATS to match."
\r
3530 + (let* ((tests (ert--stats-tests stats))
\r
3531 + (results (ert--stats-test-results stats))
\r
3532 + (old-test (aref tests pos))
\r
3533 + (map (ert--stats-test-map stats)))
\r
3534 + (flet ((update (d)
\r
3535 + (if (ert-test-result-expected-p (aref tests pos)
\r
3536 + (aref results pos))
\r
3537 + (etypecase (aref results pos)
\r
3538 + (ert-test-passed (incf (ert--stats-passed-expected stats) d))
\r
3539 + (ert-test-failed (incf (ert--stats-failed-expected stats) d))
\r
3541 + (ert-test-aborted-with-non-local-exit))
\r
3542 + (etypecase (aref results pos)
\r
3543 + (ert-test-passed (incf (ert--stats-passed-unexpected stats) d))
\r
3544 + (ert-test-failed (incf (ert--stats-failed-unexpected stats) d))
\r
3546 + (ert-test-aborted-with-non-local-exit)))))
\r
3547 + ;; Adjust counters to remove the result that is currently in stats.
\r
3549 + ;; Put new test and result into stats.
\r
3550 + (setf (aref tests pos) test
\r
3551 + (aref results pos) result)
\r
3552 + (remhash (ert--stats-test-key old-test) map)
\r
3553 + (setf (gethash (ert--stats-test-key test) map) pos)
\r
3554 + ;; Adjust counters to match new result.
\r
3558 +(defun ert--make-stats (tests selector)
\r
3559 + "Create a new `ert--stats' object for running TESTS.
\r
3561 +SELECTOR is the selector that was used to select TESTS."
\r
3562 + (setq tests (ert--coerce-to-vector tests))
\r
3563 + (let ((map (make-hash-table :size (length tests))))
\r
3564 + (loop for i from 0
\r
3565 + for test across tests
\r
3566 + for key = (ert--stats-test-key test) do
\r
3567 + (assert (not (gethash key map)))
\r
3568 + (setf (gethash key map) i))
\r
3569 + (make-ert--stats :selector selector
\r
3572 + :test-results (make-vector (length tests) nil)
\r
3573 + :test-start-times (make-vector (length tests) nil)
\r
3574 + :test-end-times (make-vector (length tests) nil))))
\r
3576 +(defun ert-run-or-rerun-test (stats test listener)
\r
3577 + ;; checkdoc-order: nil
\r
3578 + "Run the single test TEST and record the result using STATS and LISTENER."
\r
3579 + (let ((ert--current-run-stats stats)
\r
3580 + (pos (ert--stats-test-pos stats test)))
\r
3581 + (ert--stats-set-test-and-result stats pos test nil)
\r
3582 + ;; Call listener after setting/before resetting
\r
3583 + ;; (ert--stats-current-test stats); the listener might refresh the
\r
3584 + ;; mode line display, and if the value is not set yet/any more
\r
3585 + ;; during this refresh, the mode line will flicker unnecessarily.
\r
3586 + (setf (ert--stats-current-test stats) test)
\r
3587 + (funcall listener 'test-started stats test)
\r
3588 + (setf (ert-test-most-recent-result test) nil)
\r
3589 + (setf (aref (ert--stats-test-start-times stats) pos) (current-time))
\r
3591 + (ert-run-test test)
\r
3592 + (setf (aref (ert--stats-test-end-times stats) pos) (current-time))
\r
3593 + (let ((result (ert-test-most-recent-result test)))
\r
3594 + (ert--stats-set-test-and-result stats pos test result)
\r
3595 + (funcall listener 'test-ended stats test result))
\r
3596 + (setf (ert--stats-current-test stats) nil))))
\r
3598 +(defun ert-run-tests (selector listener)
\r
3599 + "Run the tests specified by SELECTOR, sending progress updates to LISTENER."
\r
3600 + (let* ((tests (ert-select-tests selector t))
\r
3601 + (stats (ert--make-stats tests selector)))
\r
3602 + (setf (ert--stats-start-time stats) (current-time))
\r
3603 + (funcall listener 'run-started stats)
\r
3604 + (let ((abortedp t))
\r
3605 + (let ((ert--current-run-stats stats))
\r
3606 + (force-mode-line-update)
\r
3609 + (loop for test in tests do
\r
3610 + (ert-run-or-rerun-test stats test listener))
\r
3611 + (setq abortedp nil))
\r
3612 + (setf (ert--stats-aborted-p stats) abortedp)
\r
3613 + (setf (ert--stats-end-time stats) (current-time))
\r
3614 + (funcall listener 'run-ended stats abortedp)))
\r
3617 +(defun ert--stats-test-pos (stats test)
\r
3618 + ;; checkdoc-order: nil
\r
3619 + "Return the position (index) of TEST in the run represented by STATS."
\r
3620 + (gethash (ert--stats-test-key test) (ert--stats-test-map stats)))
\r
3623 +;;; Formatting functions shared across UIs.
\r
3625 +(defun ert--format-time-iso8601 (time)
\r
3626 + "Format TIME in the variant of ISO 8601 used for timestamps in ERT."
\r
3627 + (format-time-string "%Y-%m-%d %T%z" time))
\r
3629 +(defun ert-char-for-test-result (result expectedp)
\r
3630 + "Return a character that represents the test result RESULT.
\r
3632 +EXPECTEDP specifies whether the result was expected."
\r
3633 + (let ((s (etypecase result
\r
3634 + (ert-test-passed ".P")
\r
3635 + (ert-test-failed "fF")
\r
3637 + (ert-test-aborted-with-non-local-exit "aA"))))
\r
3638 + (elt s (if expectedp 0 1))))
\r
3640 +(defun ert-string-for-test-result (result expectedp)
\r
3641 + "Return a string that represents the test result RESULT.
\r
3643 +EXPECTEDP specifies whether the result was expected."
\r
3644 + (let ((s (etypecase result
\r
3645 + (ert-test-passed '("passed" "PASSED"))
\r
3646 + (ert-test-failed '("failed" "FAILED"))
\r
3647 + (null '("unknown" "UNKNOWN"))
\r
3648 + (ert-test-aborted-with-non-local-exit '("aborted" "ABORTED")))))
\r
3649 + (elt s (if expectedp 0 1))))
\r
3651 +(defun ert--pp-with-indentation-and-newline (object)
\r
3652 + "Pretty-print OBJECT, indenting it to the current column of point.
\r
3653 +Ensures a final newline is inserted."
\r
3654 + (let ((begin (point)))
\r
3655 + (pp object (current-buffer))
\r
3656 + (unless (bolp) (insert "\n"))
\r
3658 + (goto-char begin)
\r
3659 + (indent-sexp))))
\r
3661 +(defun ert--insert-infos (result)
\r
3662 + "Insert `ert-info' infos from RESULT into current buffer.
\r
3664 +RESULT must be an `ert-test-result-with-condition'."
\r
3665 + (check-type result ert-test-result-with-condition)
\r
3666 + (dolist (info (ert-test-result-with-condition-infos result))
\r
3667 + (destructuring-bind (prefix . message) info
\r
3668 + (let ((begin (point))
\r
3669 + (indentation (make-string (+ (length prefix) 4) ?\s))
\r
3673 + (insert message "\n")
\r
3674 + (setq end (copy-marker (point)))
\r
3675 + (goto-char begin)
\r
3676 + (insert " " prefix)
\r
3677 + (forward-line 1)
\r
3678 + (while (< (point) end)
\r
3679 + (insert indentation)
\r
3680 + (forward-line 1)))
\r
3681 + (when end (set-marker end nil)))))))
\r
3684 +;;; Running tests in batch mode.
\r
3686 +(defvar ert-batch-backtrace-right-margin 70
\r
3687 + "*The maximum line length for printing backtraces in `ert-run-tests-batch'.")
\r
3690 +(defun ert-run-tests-batch (&optional selector)
\r
3691 + "Run the tests specified by SELECTOR, printing results to the terminal.
\r
3693 +SELECTOR works as described in `ert-select-tests', except if
\r
3694 +SELECTOR is nil, in which case all tests rather than none will be
\r
3695 +run; this makes the command line \"emacs -batch -l my-tests.el -f
\r
3696 +ert-run-tests-batch-and-exit\" useful.
\r
3698 +Returns the stats object."
\r
3699 + (unless selector (setq selector 't))
\r
3702 + (lambda (event-type &rest event-args)
\r
3703 + (ecase event-type
\r
3705 + (destructuring-bind (stats) event-args
\r
3706 + (message "Running %s tests (%s)"
\r
3707 + (length (ert--stats-tests stats))
\r
3708 + (ert--format-time-iso8601 (ert--stats-start-time stats)))))
\r
3710 + (destructuring-bind (stats abortedp) event-args
\r
3711 + (let ((unexpected (ert-stats-completed-unexpected stats))
\r
3712 + (expected-failures (ert--stats-failed-expected stats)))
\r
3713 + (message "\n%sRan %s tests, %s results as expected%s (%s)%s\n"
\r
3714 + (if (not abortedp)
\r
3717 + (ert-stats-total stats)
\r
3718 + (ert-stats-completed-expected stats)
\r
3719 + (if (zerop unexpected)
\r
3721 + (format ", %s unexpected" unexpected))
\r
3722 + (ert--format-time-iso8601 (ert--stats-end-time stats))
\r
3723 + (if (zerop expected-failures)
\r
3725 + (format "\n%s expected failures" expected-failures)))
\r
3726 + (unless (zerop unexpected)
\r
3727 + (message "%s unexpected results:" unexpected)
\r
3728 + (loop for test across (ert--stats-tests stats)
\r
3729 + for result = (ert-test-most-recent-result test) do
\r
3730 + (when (not (ert-test-result-expected-p test result))
\r
3731 + (message "%9s %S"
\r
3732 + (ert-string-for-test-result result nil)
\r
3733 + (ert-test-name test))))
\r
3734 + (message "%s" "")))))
\r
3738 + (destructuring-bind (stats test result) event-args
\r
3739 + (unless (ert-test-result-expected-p test result)
\r
3740 + (etypecase result
\r
3741 + (ert-test-passed
\r
3742 + (message "Test %S passed unexpectedly" (ert-test-name test)))
\r
3743 + (ert-test-result-with-condition
\r
3744 + (message "Test %S backtrace:" (ert-test-name test))
\r
3745 + (with-temp-buffer
\r
3746 + (ert--print-backtrace (ert-test-result-with-condition-backtrace
\r
3748 + (goto-char (point-min))
\r
3749 + (while (not (eobp))
\r
3750 + (let ((start (point))
\r
3751 + (end (progn (end-of-line) (point))))
\r
3752 + (setq end (min end
\r
3753 + (+ start ert-batch-backtrace-right-margin)))
\r
3754 + (message "%s" (buffer-substring-no-properties
\r
3756 + (forward-line 1)))
\r
3757 + (with-temp-buffer
\r
3758 + (ert--insert-infos result)
\r
3760 + (let ((print-escape-newlines t)
\r
3762 + (print-length 10))
\r
3763 + (let ((begin (point)))
\r
3764 + (ert--pp-with-indentation-and-newline
\r
3765 + (ert-test-result-with-condition-condition result))))
\r
3766 + (goto-char (1- (point-max)))
\r
3767 + (assert (looking-at "\n"))
\r
3769 + (message "Test %S condition:" (ert-test-name test))
\r
3770 + (message "%s" (buffer-string))))
\r
3771 + (ert-test-aborted-with-non-local-exit
\r
3772 + (message "Test %S aborted with non-local exit"
\r
3773 + (ert-test-name test)))))
\r
3774 + (let* ((max (prin1-to-string (length (ert--stats-tests stats))))
\r
3775 + (format-string (concat "%9s %"
\r
3776 + (prin1-to-string (length max))
\r
3777 + "s/" max " %S")))
\r
3778 + (message format-string
\r
3779 + (ert-string-for-test-result result
\r
3780 + (ert-test-result-expected-p
\r
3782 + (1+ (ert--stats-test-pos stats test))
\r
3783 + (ert-test-name test)))))))))
\r
3786 +(defun ert-run-tests-batch-and-exit (&optional selector)
\r
3787 + "Like `ert-run-tests-batch', but exits Emacs when done.
\r
3789 +The exit status will be 0 if all test results were as expected, 1
\r
3790 +on unexpected results, or 2 if the framework detected an error
\r
3791 +outside of the tests (e.g. invalid SELECTOR or bug in the code
\r
3792 +that runs the tests)."
\r
3794 + (let ((stats (ert-run-tests-batch selector)))
\r
3795 + (kill-emacs (if (zerop (ert-stats-completed-unexpected stats)) 0 1)))
\r
3798 + (message "Error running tests")
\r
3800 + (kill-emacs 2))))
\r
3803 +;;; Utility functions for load/unload actions.
\r
3805 +(defun ert--activate-font-lock-keywords ()
\r
3806 + "Activate font-lock keywords for some of ERT's symbols."
\r
3807 + (font-lock-add-keywords
\r
3809 + '(("(\\(\\<ert-deftest\\)\\>\\s *\\(\\sw+\\)?"
\r
3810 + (1 font-lock-keyword-face nil t)
\r
3811 + (2 font-lock-function-name-face nil t)))))
\r
3813 +(defun* ert--remove-from-list (list-var element &key key test)
\r
3814 + "Remove ELEMENT from the value of LIST-VAR if present.
\r
3816 +This can be used as an inverse of `add-to-list'."
\r
3817 + (unless key (setq key #'identity))
\r
3818 + (unless test (setq test #'equal))
\r
3819 + (setf (symbol-value list-var)
\r
3820 + (ert--remove* element
\r
3821 + (symbol-value list-var)
\r
3826 +;;; Some basic interactive functions.
\r
3828 +(defun ert-read-test-name (prompt &optional default history
\r
3829 + add-default-to-prompt)
\r
3830 + "Read the name of a test and return it as a symbol.
\r
3832 +Prompt with PROMPT. If DEFAULT is a valid test name, use it as a
\r
3833 +default. HISTORY is the history to use; see `completing-read'.
\r
3834 +If ADD-DEFAULT-TO-PROMPT is non-nil, PROMPT will be modified to
\r
3835 +include the default, if any.
\r
3837 +Signals an error if no test name was read."
\r
3838 + (etypecase default
\r
3839 + (string (let ((symbol (intern-soft default)))
\r
3840 + (unless (and symbol (ert-test-boundp symbol))
\r
3841 + (setq default nil))))
\r
3842 + (symbol (setq default
\r
3843 + (if (ert-test-boundp default)
\r
3844 + (symbol-name default)
\r
3846 + (ert-test (setq default (ert-test-name default))))
\r
3847 + (when add-default-to-prompt
\r
3848 + (setq prompt (if (null default)
\r
3849 + (format "%s: " prompt)
\r
3850 + (format "%s (default %s): " prompt default))))
\r
3851 + (let ((input (completing-read prompt obarray #'ert-test-boundp
\r
3852 + t nil history default nil)))
\r
3853 + ;; completing-read returns an empty string if default was nil and
\r
3854 + ;; the user just hit enter.
\r
3855 + (let ((sym (intern-soft input)))
\r
3856 + (if (ert-test-boundp sym)
\r
3858 + (error "Input does not name a test")))))
\r
3860 +(defun ert-read-test-name-at-point (prompt)
\r
3861 + "Read the name of a test and return it as a symbol.
\r
3862 +As a default, use the symbol at point, or the test at point if in
\r
3863 +the ERT results buffer. Prompt with PROMPT, augmented with the
\r
3864 +default (if any)."
\r
3865 + (ert-read-test-name prompt (ert-test-at-point) nil t))
\r
3867 +(defun ert-find-test-other-window (test-name)
\r
3868 + "Find, in another window, the definition of TEST-NAME."
\r
3869 + (interactive (list (ert-read-test-name-at-point "Find test definition: ")))
\r
3870 + (find-function-do-it test-name 'ert-deftest 'switch-to-buffer-other-window))
\r
3872 +(defun ert-delete-test (test-name)
\r
3873 + "Make the test TEST-NAME unbound.
\r
3875 +Nothing more than an interactive interface to `ert-make-test-unbound'."
\r
3876 + (interactive (list (ert-read-test-name-at-point "Delete test")))
\r
3877 + (ert-make-test-unbound test-name))
\r
3879 +(defun ert-delete-all-tests ()
\r
3880 + "Make all symbols in `obarray' name no test."
\r
3882 + (when (interactive-p)
\r
3883 + (unless (y-or-n-p "Delete all tests? ")
\r
3884 + (error "Aborted")))
\r
3885 + ;; We can't use `ert-select-tests' here since that gives us only
\r
3886 + ;; test objects, and going from them back to the test name symbols
\r
3887 + ;; can fail if the `ert-test' defstruct has been redefined.
\r
3888 + (mapc #'ert-make-test-unbound (apropos-internal "" #'ert-test-boundp))
\r
3892 +;;; Display of test progress and results.
\r
3894 +;; An entry in the results buffer ewoc. There is one entry per test.
\r
3895 +(defstruct ert--ewoc-entry
\r
3896 + (test (assert nil))
\r
3897 + ;; If the result of this test was expected, its ewoc entry is hidden
\r
3899 + (hidden-p (assert nil))
\r
3900 + ;; An ewoc entry may be collapsed to hide details such as the error
\r
3903 + ;; I'm not sure the ability to expand and collapse entries is still
\r
3904 + ;; a useful feature.
\r
3906 + ;; By default, the ewoc entry presents the error condition with
\r
3907 + ;; certain limits on how much to print (`print-level',
\r
3908 + ;; `print-length'). The user can interactively switch to a set of
\r
3909 + ;; higher limits.
\r
3910 + (extended-printer-limits-p nil))
\r
3912 +;; Variables local to the results buffer.
\r
3915 +(defvar ert--results-ewoc)
\r
3916 +;; The stats object.
\r
3917 +(defvar ert--results-stats)
\r
3918 +;; A string with one character per test. Each character represents
\r
3919 +;; the result of the corresponding test. The string is displayed near
\r
3920 +;; the top of the buffer and serves as a progress bar.
\r
3921 +(defvar ert--results-progress-bar-string)
\r
3922 +;; The position where the progress bar button begins.
\r
3923 +(defvar ert--results-progress-bar-button-begin)
\r
3924 +;; The test result listener that updates the buffer when tests are run.
\r
3925 +(defvar ert--results-listener)
\r
3927 +(defun ert-insert-test-name-button (test-name)
\r
3928 + "Insert a button that links to TEST-NAME."
\r
3929 + (insert-text-button (format "%S" test-name)
\r
3930 + :type 'ert--test-name-button
\r
3931 + 'ert-test-name test-name))
\r
3933 +(defun ert--results-format-expected-unexpected (expected unexpected)
\r
3934 + "Return a string indicating EXPECTED expected results, UNEXPECTED unexpected."
\r
3935 + (if (zerop unexpected)
\r
3936 + (format "%s" expected)
\r
3937 + (format "%s (%s unexpected)" (+ expected unexpected) unexpected)))
\r
3939 +(defun ert--results-update-ewoc-hf (ewoc stats)
\r
3940 + "Update the header and footer of EWOC to show certain information from STATS.
\r
3942 +Also sets `ert--results-progress-bar-button-begin'."
\r
3943 + (let ((run-count (ert-stats-completed stats))
\r
3944 + (results-buffer (current-buffer))
\r
3945 + ;; Need to save buffer-local value.
\r
3946 + (font-lock font-lock-mode))
\r
3950 + (with-temp-buffer
\r
3951 + (insert "Selector: ")
\r
3952 + (ert--insert-human-readable-selector (ert--stats-selector stats))
\r
3955 + (format (concat "Passed: %s\n"
\r
3957 + "Total: %s/%s\n\n")
\r
3958 + (ert--results-format-expected-unexpected
\r
3959 + (ert--stats-passed-expected stats)
\r
3960 + (ert--stats-passed-unexpected stats))
\r
3961 + (ert--results-format-expected-unexpected
\r
3962 + (ert--stats-failed-expected stats)
\r
3963 + (ert--stats-failed-unexpected stats))
\r
3965 + (ert-stats-total stats)))
\r
3967 + (format "Started at: %s\n"
\r
3968 + (ert--format-time-iso8601 (ert--stats-start-time stats))))
\r
3969 + ;; FIXME: This is ugly. Need to properly define invariants of
\r
3970 + ;; the `stats' data structure.
\r
3971 + (let ((state (cond ((ert--stats-aborted-p stats) 'aborted)
\r
3972 + ((ert--stats-current-test stats) 'running)
\r
3973 + ((ert--stats-end-time stats) 'finished)
\r
3974 + (t 'preparing))))
\r
3979 + (cond ((ert--stats-current-test stats)
\r
3980 + (insert "Aborted during test: ")
\r
3981 + (ert-insert-test-name-button
\r
3982 + (ert-test-name (ert--stats-current-test stats))))
\r
3984 + (insert "Aborted."))))
\r
3986 + (assert (ert--stats-current-test stats))
\r
3987 + (insert "Running test: ")
\r
3988 + (ert-insert-test-name-button (ert-test-name
\r
3989 + (ert--stats-current-test stats))))
\r
3991 + (assert (not (ert--stats-current-test stats)))
\r
3992 + (insert "Finished.")))
\r
3994 + (if (ert--stats-end-time stats)
\r
3996 + (format "%s%s\n"
\r
3997 + (if (ert--stats-aborted-p stats)
\r
3999 + "Finished at: ")
\r
4000 + (ert--format-time-iso8601 (ert--stats-end-time stats))))
\r
4003 + (let ((progress-bar-string (with-current-buffer results-buffer
\r
4004 + ert--results-progress-bar-string)))
\r
4005 + (let ((progress-bar-button-begin
\r
4006 + (insert-text-button progress-bar-string
\r
4007 + :type 'ert--results-progress-bar-button
\r
4008 + 'face (or (and font-lock
\r
4009 + (ert-face-for-stats stats))
\r
4011 + ;; The header gets copied verbatim to the results buffer,
\r
4012 + ;; and all positions remain the same, so
\r
4013 + ;; `progress-bar-button-begin' will be the right position
\r
4014 + ;; even in the results buffer.
\r
4015 + (with-current-buffer results-buffer
\r
4016 + (set (make-local-variable 'ert--results-progress-bar-button-begin)
\r
4017 + progress-bar-button-begin))))
\r
4019 + (buffer-string))
\r
4022 + ;; We actually want an empty footer, but that would trigger a bug
\r
4023 + ;; in ewoc, sometimes clearing the entire buffer. (It's possible
\r
4024 + ;; that this bug has been fixed since this has been tested; we
\r
4025 + ;; should test it again.)
\r
4029 +(defvar ert-test-run-redisplay-interval-secs .1
\r
4030 + "How many seconds ERT should wait between redisplays while running tests.
\r
4032 +While running tests, ERT shows the current progress, and this variable
\r
4033 +determines how frequently the progress display is updated.")
\r
4035 +(defun ert--results-update-stats-display (ewoc stats)
\r
4036 + "Update EWOC and the mode line to show data from STATS."
\r
4037 + ;; TODO(ohler): investigate using `make-progress-reporter'.
\r
4038 + (ert--results-update-ewoc-hf ewoc stats)
\r
4039 + (force-mode-line-update)
\r
4041 + (setf (ert--stats-next-redisplay stats)
\r
4042 + (+ (float-time) ert-test-run-redisplay-interval-secs)))
\r
4044 +(defun ert--results-update-stats-display-maybe (ewoc stats)
\r
4045 + "Call `ert--results-update-stats-display' if not called recently.
\r
4047 +EWOC and STATS are arguments for `ert--results-update-stats-display'."
\r
4048 + (when (>= (float-time) (ert--stats-next-redisplay stats))
\r
4049 + (ert--results-update-stats-display ewoc stats)))
\r
4051 +(defun ert--tests-running-mode-line-indicator ()
\r
4052 + "Return a string for the mode line that shows the test run progress."
\r
4053 + (let* ((stats ert--current-run-stats)
\r
4054 + (tests-total (ert-stats-total stats))
\r
4055 + (tests-completed (ert-stats-completed stats)))
\r
4056 + (if (>= tests-completed tests-total)
\r
4057 + (format " ERT(%s/%s,finished)" tests-completed tests-total)
\r
4058 + (format " ERT(%s/%s):%s"
\r
4059 + (1+ tests-completed)
\r
4061 + (if (null (ert--stats-current-test stats))
\r
4064 + (ert-test-name (ert--stats-current-test stats))))))))
\r
4066 +(defun ert--make-xrefs-region (begin end)
\r
4067 + "Attach cross-references to function names between BEGIN and END.
\r
4069 +BEGIN and END specify a region in the current buffer."
\r
4071 + (save-restriction
\r
4072 + (narrow-to-region begin (point))
\r
4073 + ;; Inhibit optimization in `debugger-make-xrefs' that would
\r
4074 + ;; sometimes insert unrelated backtrace info into our buffer.
\r
4075 + (let ((debugger-previous-backtrace nil))
\r
4076 + (debugger-make-xrefs)))))
\r
4078 +(defun ert--string-first-line (s)
\r
4079 + "Return the first line of S, or S if it contains no newlines.
\r
4081 +The return value does not include the line terminator."
\r
4082 + (substring s 0 (ert--string-position ?\n s)))
\r
4084 +(defun ert-face-for-test-result (expectedp)
\r
4085 + "Return a face that shows whether a test result was expected or unexpected.
\r
4087 +If EXPECTEDP is nil, returns the face for unexpected results; if
\r
4088 +non-nil, returns the face for expected results.."
\r
4089 + (if expectedp 'ert-test-result-expected 'ert-test-result-unexpected))
\r
4091 +(defun ert-face-for-stats (stats)
\r
4092 + "Return a face that represents STATS."
\r
4093 + (cond ((ert--stats-aborted-p stats) 'nil)
\r
4094 + ((plusp (ert-stats-completed-unexpected stats))
\r
4095 + (ert-face-for-test-result nil))
\r
4096 + ((eql (ert-stats-completed-expected stats) (ert-stats-total stats))
\r
4097 + (ert-face-for-test-result t))
\r
4100 +(defun ert--print-test-for-ewoc (entry)
\r
4101 + "The ewoc print function for ewoc test entries. ENTRY is the entry to print."
\r
4102 + (let* ((test (ert--ewoc-entry-test entry))
\r
4103 + (stats ert--results-stats)
\r
4104 + (result (let ((pos (ert--stats-test-pos stats test)))
\r
4106 + (aref (ert--stats-test-results stats) pos)))
\r
4107 + (hiddenp (ert--ewoc-entry-hidden-p entry))
\r
4108 + (expandedp (ert--ewoc-entry-expanded-p entry))
\r
4109 + (extended-printer-limits-p (ert--ewoc-entry-extended-printer-limits-p
\r
4113 + (let ((expectedp (ert-test-result-expected-p test result)))
\r
4114 + (insert-text-button (format "%c" (ert-char-for-test-result
\r
4115 + result expectedp))
\r
4116 + :type 'ert--results-expand-collapse-button
\r
4117 + 'face (or (and font-lock-mode
\r
4118 + (ert-face-for-test-result
\r
4122 + (ert-insert-test-name-button (ert-test-name test))
\r
4124 + (when (and expandedp (not (eql result 'nil)))
\r
4125 + (when (ert-test-documentation test)
\r
4128 + (ert--string-first-line (ert-test-documentation test))
\r
4129 + 'font-lock-face 'font-lock-doc-face)
\r
4131 + (etypecase result
\r
4132 + (ert-test-passed
\r
4133 + (if (ert-test-result-expected-p test result)
\r
4134 + (insert " passed\n")
\r
4135 + (insert " passed unexpectedly\n"))
\r
4137 + (ert-test-result-with-condition
\r
4138 + (ert--insert-infos result)
\r
4139 + (let ((print-escape-newlines t)
\r
4140 + (print-level (if extended-printer-limits-p 12 6))
\r
4141 + (print-length (if extended-printer-limits-p 100 10)))
\r
4143 + (let ((begin (point)))
\r
4144 + (ert--pp-with-indentation-and-newline
\r
4145 + (ert-test-result-with-condition-condition result))
\r
4146 + (ert--make-xrefs-region begin (point)))))
\r
4147 + (ert-test-aborted-with-non-local-exit
\r
4148 + (insert " aborted\n")))
\r
4149 + (insert "\n")))))
\r
4152 +(defun ert--results-font-lock-function (enabledp)
\r
4153 + "Redraw the ERT results buffer after font-lock-mode was switched on or off.
\r
4155 +ENABLEDP is true if font-lock-mode is switched on, false
\r
4157 + (ert--results-update-ewoc-hf ert--results-ewoc ert--results-stats)
\r
4158 + (ewoc-refresh ert--results-ewoc)
\r
4159 + (font-lock-default-function enabledp))
\r
4161 +(defun ert--setup-results-buffer (stats listener buffer-name)
\r
4162 + "Set up a test results buffer.
\r
4164 +STATS is the stats object; LISTENER is the results listener;
\r
4165 +BUFFER-NAME, if non-nil, is the buffer name to use."
\r
4166 + (unless buffer-name (setq buffer-name "*ert*"))
\r
4167 + (let ((buffer (get-buffer-create buffer-name)))
\r
4168 + (with-current-buffer buffer
\r
4169 + (setq buffer-read-only t)
\r
4170 + (let ((inhibit-read-only t))
\r
4171 + (buffer-disable-undo)
\r
4173 + (ert-results-mode)
\r
4174 + ;; Erase buffer again in case switching out of the previous
\r
4175 + ;; mode inserted anything. (This happens e.g. when switching
\r
4176 + ;; from ert-results-mode to ert-results-mode when
\r
4177 + ;; font-lock-mode turns itself off in change-major-mode-hook.)
\r
4179 + (set (make-local-variable 'font-lock-function)
\r
4180 + 'ert--results-font-lock-function)
\r
4181 + (let ((ewoc (ewoc-create 'ert--print-test-for-ewoc nil nil t)))
\r
4182 + (set (make-local-variable 'ert--results-ewoc) ewoc)
\r
4183 + (set (make-local-variable 'ert--results-stats) stats)
\r
4184 + (set (make-local-variable 'ert--results-progress-bar-string)
\r
4185 + (make-string (ert-stats-total stats)
\r
4186 + (ert-char-for-test-result nil t)))
\r
4187 + (set (make-local-variable 'ert--results-listener) listener)
\r
4188 + (loop for test across (ert--stats-tests stats) do
\r
4189 + (ewoc-enter-last ewoc
\r
4190 + (make-ert--ewoc-entry :test test :hidden-p t)))
\r
4191 + (ert--results-update-ewoc-hf ert--results-ewoc ert--results-stats)
\r
4192 + (goto-char (1- (point-max)))
\r
4196 +(defvar ert--selector-history nil
\r
4197 + "List of recent test selectors read from terminal.")
\r
4199 +;; Should OUTPUT-BUFFER-NAME and MESSAGE-FN really be arguments here?
\r
4200 +;; They are needed only for our automated self-tests at the moment.
\r
4201 +;; Or should there be some other mechanism?
\r
4203 +(defun ert-run-tests-interactively (selector
\r
4204 + &optional output-buffer-name message-fn)
\r
4205 + "Run the tests specified by SELECTOR and display the results in a buffer.
\r
4207 +SELECTOR works as described in `ert-select-tests'.
\r
4208 +OUTPUT-BUFFER-NAME and MESSAGE-FN should normally be nil; they
\r
4209 +are used for automated self-tests and specify which buffer to use
\r
4210 +and how to display message."
\r
4212 + (list (let ((default (if ert--selector-history
\r
4213 + (first ert--selector-history)
\r
4215 + (read-from-minibuffer (if (null default)
\r
4217 + (format "Run tests (default %s): " default))
\r
4218 + nil nil t 'ert--selector-history
\r
4221 + (unless message-fn (setq message-fn 'message))
\r
4222 + (lexical-let ((output-buffer-name output-buffer-name)
\r
4225 + (message-fn message-fn))
\r
4227 + (lambda (event-type &rest event-args)
\r
4228 + (ecase event-type
\r
4230 + (destructuring-bind (stats) event-args
\r
4231 + (setq buffer (ert--setup-results-buffer stats
\r
4233 + output-buffer-name))
\r
4234 + (pop-to-buffer buffer)))
\r
4236 + (destructuring-bind (stats abortedp) event-args
\r
4237 + (funcall message-fn
\r
4238 + "%sRan %s tests, %s results were as expected%s"
\r
4239 + (if (not abortedp)
\r
4242 + (ert-stats-total stats)
\r
4243 + (ert-stats-completed-expected stats)
\r
4244 + (let ((unexpected
\r
4245 + (ert-stats-completed-unexpected stats)))
\r
4246 + (if (zerop unexpected)
\r
4248 + (format ", %s unexpected" unexpected))))
\r
4249 + (ert--results-update-stats-display (with-current-buffer buffer
\r
4250 + ert--results-ewoc)
\r
4253 + (destructuring-bind (stats test) event-args
\r
4254 + (with-current-buffer buffer
\r
4255 + (let* ((ewoc ert--results-ewoc)
\r
4256 + (pos (ert--stats-test-pos stats test))
\r
4257 + (node (ewoc-nth ewoc pos)))
\r
4259 + (setf (ert--ewoc-entry-test (ewoc-data node)) test)
\r
4260 + (aset ert--results-progress-bar-string pos
\r
4261 + (ert-char-for-test-result nil t))
\r
4262 + (ert--results-update-stats-display-maybe ewoc stats)
\r
4263 + (ewoc-invalidate ewoc node)))))
\r
4265 + (destructuring-bind (stats test result) event-args
\r
4266 + (with-current-buffer buffer
\r
4267 + (let* ((ewoc ert--results-ewoc)
\r
4268 + (pos (ert--stats-test-pos stats test))
\r
4269 + (node (ewoc-nth ewoc pos)))
\r
4270 + (when (ert--ewoc-entry-hidden-p (ewoc-data node))
\r
4271 + (setf (ert--ewoc-entry-hidden-p (ewoc-data node))
\r
4272 + (ert-test-result-expected-p test result)))
\r
4273 + (aset ert--results-progress-bar-string pos
\r
4274 + (ert-char-for-test-result result
\r
4275 + (ert-test-result-expected-p
\r
4277 + (ert--results-update-stats-display-maybe ewoc stats)
\r
4278 + (ewoc-invalidate ewoc node))))))))
\r
4283 +(defalias 'ert 'ert-run-tests-interactively)
\r
4286 +;;; Simple view mode for auxiliary information like stack traces or
\r
4287 +;;; messages. Mainly binds "q" for quit.
\r
4289 +(define-derived-mode ert-simple-view-mode fundamental-mode "ERT-View"
\r
4290 + "Major mode for viewing auxiliary information in ERT.")
\r
4292 +(loop for (key binding) in
\r
4293 + '(("q" quit-window)
\r
4296 + (define-key ert-simple-view-mode-map key binding))
\r
4299 +;;; Commands and button actions for the results buffer.
\r
4301 +(define-derived-mode ert-results-mode fundamental-mode "ERT-Results"
\r
4302 + "Major mode for viewing results of ERT test runs.")
\r
4304 +(loop for (key binding) in
\r
4305 + '(;; Stuff that's not in the menu.
\r
4306 + ("\t" forward-button)
\r
4307 + ([backtab] backward-button)
\r
4308 + ("j" ert-results-jump-between-summary-and-result)
\r
4309 + ("q" quit-window)
\r
4310 + ("L" ert-results-toggle-printer-limits-for-test-at-point)
\r
4311 + ("n" ert-results-next-test)
\r
4312 + ("p" ert-results-previous-test)
\r
4313 + ;; Stuff that is in the menu.
\r
4314 + ("R" ert-results-rerun-all-tests)
\r
4315 + ("r" ert-results-rerun-test-at-point)
\r
4316 + ("d" ert-results-rerun-test-at-point-debugging-errors)
\r
4317 + ("." ert-results-find-test-at-point-other-window)
\r
4318 + ("b" ert-results-pop-to-backtrace-for-test-at-point)
\r
4319 + ("m" ert-results-pop-to-messages-for-test-at-point)
\r
4320 + ("l" ert-results-pop-to-should-forms-for-test-at-point)
\r
4321 + ("h" ert-results-describe-test-at-point)
\r
4322 + ("D" ert-delete-test)
\r
4323 + ("T" ert-results-pop-to-timings)
\r
4326 + (define-key ert-results-mode-map key binding))
\r
4328 +(easy-menu-define ert-results-mode-menu ert-results-mode-map
\r
4329 + "Menu for `ert-results-mode'."
\r
4331 + ["Re-run all tests" ert-results-rerun-all-tests]
\r
4333 + ["Re-run test" ert-results-rerun-test-at-point]
\r
4334 + ["Debug test" ert-results-rerun-test-at-point-debugging-errors]
\r
4335 + ["Show test definition" ert-results-find-test-at-point-other-window]
\r
4337 + ["Show backtrace" ert-results-pop-to-backtrace-for-test-at-point]
\r
4338 + ["Show messages" ert-results-pop-to-messages-for-test-at-point]
\r
4339 + ["Show `should' forms" ert-results-pop-to-should-forms-for-test-at-point]
\r
4340 + ["Describe test" ert-results-describe-test-at-point]
\r
4342 + ["Delete test" ert-delete-test]
\r
4344 + ["Show execution time of each test" ert-results-pop-to-timings]
\r
4347 +(define-button-type 'ert--results-progress-bar-button
\r
4348 + 'action #'ert--results-progress-bar-button-action
\r
4349 + 'help-echo "mouse-2, RET: Reveal test result")
\r
4351 +(define-button-type 'ert--test-name-button
\r
4352 + 'action #'ert--test-name-button-action
\r
4353 + 'help-echo "mouse-2, RET: Find test definition")
\r
4355 +(define-button-type 'ert--results-expand-collapse-button
\r
4356 + 'action #'ert--results-expand-collapse-button-action
\r
4357 + 'help-echo "mouse-2, RET: Expand/collapse test result")
\r
4359 +(defun ert--results-test-node-or-null-at-point ()
\r
4360 + "If point is on a valid ewoc node, return it; return nil otherwise.
\r
4362 +To be used in the ERT results buffer."
\r
4363 + (let* ((ewoc ert--results-ewoc)
\r
4364 + (node (ewoc-locate ewoc)))
\r
4365 + ;; `ewoc-locate' will return an arbitrary node when point is on
\r
4366 + ;; header or footer, or when all nodes are invisible. So we need
\r
4367 + ;; to validate its return value here.
\r
4369 + ;; Update: I'm seeing nil being returned in some cases now,
\r
4370 + ;; perhaps this has been changed?
\r
4372 + (>= (point) (ewoc-location node))
\r
4373 + (not (ert--ewoc-entry-hidden-p (ewoc-data node))))
\r
4377 +(defun ert--results-test-node-at-point ()
\r
4378 + "If point is on a valid ewoc node, return it; signal an error otherwise.
\r
4380 +To be used in the ERT results buffer."
\r
4381 + (or (ert--results-test-node-or-null-at-point)
\r
4382 + (error "No test at point")))
\r
4384 +(defun ert-results-next-test ()
\r
4385 + "Move point to the next test.
\r
4387 +To be used in the ERT results buffer."
\r
4389 + (ert--results-move (ewoc-locate ert--results-ewoc) 'ewoc-next
\r
4390 + "No tests below"))
\r
4392 +(defun ert-results-previous-test ()
\r
4393 + "Move point to the previous test.
\r
4395 +To be used in the ERT results buffer."
\r
4397 + (ert--results-move (ewoc-locate ert--results-ewoc) 'ewoc-prev
\r
4398 + "No tests above"))
\r
4400 +(defun ert--results-move (node ewoc-fn error-message)
\r
4401 + "Move point from NODE to the previous or next node.
\r
4403 +EWOC-FN specifies the direction and should be either `ewoc-prev'
\r
4404 +or `ewoc-next'. If there are no more nodes in that direction, an
\r
4405 +error is signalled with the message ERROR-MESSAGE."
\r
4407 + (setq node (funcall ewoc-fn ert--results-ewoc node))
\r
4408 + (when (null node)
\r
4409 + (error "%s" error-message))
\r
4410 + (unless (ert--ewoc-entry-hidden-p (ewoc-data node))
\r
4411 + (goto-char (ewoc-location node))
\r
4414 +(defun ert--results-expand-collapse-button-action (button)
\r
4415 + "Expand or collapse the test node BUTTON belongs to."
\r
4416 + (let* ((ewoc ert--results-ewoc)
\r
4417 + (node (save-excursion
\r
4418 + (goto-char (ert--button-action-position))
\r
4419 + (ert--results-test-node-at-point)))
\r
4420 + (entry (ewoc-data node)))
\r
4421 + (setf (ert--ewoc-entry-expanded-p entry)
\r
4422 + (not (ert--ewoc-entry-expanded-p entry)))
\r
4423 + (ewoc-invalidate ewoc node)))
\r
4425 +(defun ert-results-find-test-at-point-other-window ()
\r
4426 + "Find the definition of the test at point in another window.
\r
4428 +To be used in the ERT results buffer."
\r
4430 + (let ((name (ert-test-at-point)))
\r
4432 + (error "No test at point"))
\r
4433 + (ert-find-test-other-window name)))
\r
4435 +(defun ert--test-name-button-action (button)
\r
4436 + "Find the definition of the test BUTTON belongs to, in another window."
\r
4437 + (let ((name (button-get button 'ert-test-name)))
\r
4438 + (ert-find-test-other-window name)))
\r
4440 +(defun ert--ewoc-position (ewoc node)
\r
4441 + ;; checkdoc-order: nil
\r
4442 + "Return the position of NODE in EWOC, or nil if NODE is not in EWOC."
\r
4443 + (loop for i from 0
\r
4444 + for node-here = (ewoc-nth ewoc 0) then (ewoc-next ewoc node-here)
\r
4445 + do (when (eql node node-here)
\r
4447 + finally (return nil)))
\r
4449 +(defun ert-results-jump-between-summary-and-result ()
\r
4450 + "Jump back and forth between the test run summary and individual test results.
\r
4452 +From an ewoc node, jumps to the character that represents the
\r
4453 +same test in the progress bar, and vice versa.
\r
4455 +To be used in the ERT results buffer."
\r
4456 + ;; Maybe this command isn't actually needed much, but if it is, it
\r
4457 + ;; seems like an indication that the UI design is not optimal. If
\r
4458 + ;; jumping back and forth between a summary at the top of the buffer
\r
4459 + ;; and the error log in the remainder of the buffer is useful, then
\r
4460 + ;; the summary apparently needs to be easily accessible from the
\r
4461 + ;; error log, and perhaps it would be better to have it in a
\r
4462 + ;; separate buffer to keep it visible.
\r
4464 + (let ((ewoc ert--results-ewoc)
\r
4465 + (progress-bar-begin ert--results-progress-bar-button-begin))
\r
4466 + (cond ((ert--results-test-node-or-null-at-point)
\r
4467 + (let* ((node (ert--results-test-node-at-point))
\r
4468 + (pos (ert--ewoc-position ewoc node)))
\r
4469 + (goto-char (+ progress-bar-begin pos))))
\r
4470 + ((and (<= progress-bar-begin (point))
\r
4471 + (< (point) (button-end (button-at progress-bar-begin))))
\r
4472 + (let* ((node (ewoc-nth ewoc (- (point) progress-bar-begin)))
\r
4473 + (entry (ewoc-data node)))
\r
4474 + (when (ert--ewoc-entry-hidden-p entry)
\r
4475 + (setf (ert--ewoc-entry-hidden-p entry) nil)
\r
4476 + (ewoc-invalidate ewoc node))
\r
4477 + (ewoc-goto-node ewoc node)))
\r
4479 + (goto-char progress-bar-begin)))))
\r
4481 +(defun ert-test-at-point ()
\r
4482 + "Return the name of the test at point as a symbol, or nil if none."
\r
4483 + (or (and (eql major-mode 'ert-results-mode)
\r
4484 + (let ((test (ert--results-test-at-point-no-redefinition)))
\r
4485 + (and test (ert-test-name test))))
\r
4486 + (let* ((thing (thing-at-point 'symbol))
\r
4487 + (sym (intern-soft thing)))
\r
4488 + (and (ert-test-boundp sym)
\r
4491 +(defun ert--results-test-at-point-no-redefinition ()
\r
4492 + "Return the test at point, or nil.
\r
4494 +To be used in the ERT results buffer."
\r
4495 + (assert (eql major-mode 'ert-results-mode))
\r
4496 + (if (ert--results-test-node-or-null-at-point)
\r
4497 + (let* ((node (ert--results-test-node-at-point))
\r
4498 + (test (ert--ewoc-entry-test (ewoc-data node))))
\r
4500 + (let ((progress-bar-begin ert--results-progress-bar-button-begin))
\r
4501 + (when (and (<= progress-bar-begin (point))
\r
4502 + (< (point) (button-end (button-at progress-bar-begin))))
\r
4503 + (let* ((test-index (- (point) progress-bar-begin))
\r
4504 + (test (aref (ert--stats-tests ert--results-stats)
\r
4508 +(defun ert--results-test-at-point-allow-redefinition ()
\r
4509 + "Look up the test at point, and check whether it has been redefined.
\r
4511 +To be used in the ERT results buffer.
\r
4513 +Returns a list of two elements: the test (or nil) and a symbol
\r
4514 +specifying whether the test has been redefined.
\r
4516 +If a new test has been defined with the same name as the test at
\r
4517 +point, replaces the test at point with the new test, and returns
\r
4518 +the new test and the symbol `redefined'.
\r
4520 +If the test has been deleted, returns the old test and the symbol
\r
4523 +If the test is still current, returns the test and the symbol nil.
\r
4525 +If there is no test at point, returns a list with two nils."
\r
4526 + (let ((test (ert--results-test-at-point-no-redefinition)))
\r
4527 + (cond ((null test)
\r
4529 + ((null (ert-test-name test))
\r
4532 + (let* ((name (ert-test-name test))
\r
4533 + (new-test (and (ert-test-boundp name)
\r
4534 + (ert-get-test name))))
\r
4535 + (cond ((eql test new-test)
\r
4537 + ((null new-test)
\r
4538 + `(,test deleted))
\r
4540 + (ert--results-update-after-test-redefinition
\r
4541 + (ert--stats-test-pos ert--results-stats test)
\r
4543 + `(,new-test redefined))))))))
\r
4545 +(defun ert--results-update-after-test-redefinition (pos new-test)
\r
4546 + "Update results buffer after the test at pos POS has been redefined.
\r
4548 +Also updates the stats object. NEW-TEST is the new test
\r
4550 + (let* ((stats ert--results-stats)
\r
4551 + (ewoc ert--results-ewoc)
\r
4552 + (node (ewoc-nth ewoc pos))
\r
4553 + (entry (ewoc-data node)))
\r
4554 + (ert--stats-set-test-and-result stats pos new-test nil)
\r
4555 + (setf (ert--ewoc-entry-test entry) new-test
\r
4556 + (aref ert--results-progress-bar-string pos) (ert-char-for-test-result
\r
4558 + (ewoc-invalidate ewoc node))
\r
4561 +(defun ert--button-action-position ()
\r
4562 + "The buffer position where the last button action was triggered."
\r
4563 + (cond ((integerp last-command-event)
\r
4565 + ((eventp last-command-event)
\r
4566 + (posn-point (event-start last-command-event)))
\r
4567 + (t (assert nil))))
\r
4569 +(defun ert--results-progress-bar-button-action (button)
\r
4570 + "Jump to details for the test represented by the character clicked in BUTTON."
\r
4571 + (goto-char (ert--button-action-position))
\r
4572 + (ert-results-jump-between-summary-and-result))
\r
4574 +(defun ert-results-rerun-all-tests ()
\r
4575 + "Re-run all tests, using the same selector.
\r
4577 +To be used in the ERT results buffer."
\r
4579 + (assert (eql major-mode 'ert-results-mode))
\r
4580 + (let ((selector (ert--stats-selector ert--results-stats)))
\r
4581 + (ert-run-tests-interactively selector (buffer-name))))
\r
4583 +(defun ert-results-rerun-test-at-point ()
\r
4584 + "Re-run the test at point.
\r
4586 +To be used in the ERT results buffer."
\r
4588 + (destructuring-bind (test redefinition-state)
\r
4589 + (ert--results-test-at-point-allow-redefinition)
\r
4590 + (when (null test)
\r
4591 + (error "No test at point"))
\r
4592 + (let* ((stats ert--results-stats)
\r
4593 + (progress-message (format "Running %stest %S"
\r
4594 + (ecase redefinition-state
\r
4596 + (redefined "new definition of ")
\r
4597 + (deleted "deleted "))
\r
4598 + (ert-test-name test))))
\r
4599 + ;; Need to save and restore point manually here: When point is on
\r
4600 + ;; the first visible ewoc entry while the header is updated, point
\r
4601 + ;; moves to the top of the buffer. This is undesirable, and a
\r
4602 + ;; simple `save-excursion' doesn't prevent it.
\r
4603 + (let ((point (point)))
\r
4607 + (message "%s..." progress-message)
\r
4608 + (ert-run-or-rerun-test stats test
\r
4609 + ert--results-listener))
\r
4610 + (ert--results-update-stats-display ert--results-ewoc stats)
\r
4611 + (message "%s...%s"
\r
4612 + progress-message
\r
4613 + (let ((result (ert-test-most-recent-result test)))
\r
4614 + (ert-string-for-test-result
\r
4615 + result (ert-test-result-expected-p test result)))))
\r
4616 + (goto-char point))))))
\r
4618 +(defun ert-results-rerun-test-at-point-debugging-errors ()
\r
4619 + "Re-run the test at point with `ert-debug-on-error' bound to t.
\r
4621 +To be used in the ERT results buffer."
\r
4623 + (let ((ert-debug-on-error t))
\r
4624 + (ert-results-rerun-test-at-point)))
\r
4626 +(defun ert-results-pop-to-backtrace-for-test-at-point ()
\r
4627 + "Display the backtrace for the test at point.
\r
4629 +To be used in the ERT results buffer."
\r
4631 + (let* ((test (ert--results-test-at-point-no-redefinition))
\r
4632 + (stats ert--results-stats)
\r
4633 + (pos (ert--stats-test-pos stats test))
\r
4634 + (result (aref (ert--stats-test-results stats) pos)))
\r
4635 + (etypecase result
\r
4636 + (ert-test-passed (error "Test passed, no backtrace available"))
\r
4637 + (ert-test-result-with-condition
\r
4638 + (let ((backtrace (ert-test-result-with-condition-backtrace result))
\r
4639 + (buffer (get-buffer-create "*ERT Backtrace*")))
\r
4640 + (pop-to-buffer buffer)
\r
4641 + (setq buffer-read-only t)
\r
4642 + (let ((inhibit-read-only t))
\r
4643 + (buffer-disable-undo)
\r
4645 + (ert-simple-view-mode)
\r
4646 + ;; Use unibyte because `debugger-setup-buffer' also does so.
\r
4647 + (set-buffer-multibyte nil)
\r
4648 + (setq truncate-lines t)
\r
4649 + (ert--print-backtrace backtrace)
\r
4650 + (debugger-make-xrefs)
\r
4651 + (goto-char (point-min))
\r
4652 + (insert "Backtrace for test `")
\r
4653 + (ert-insert-test-name-button (ert-test-name test))
\r
4654 + (insert "':\n")))))))
\r
4656 +(defun ert-results-pop-to-messages-for-test-at-point ()
\r
4657 + "Display the part of the *Messages* buffer generated during the test at point.
\r
4659 +To be used in the ERT results buffer."
\r
4661 + (let* ((test (ert--results-test-at-point-no-redefinition))
\r
4662 + (stats ert--results-stats)
\r
4663 + (pos (ert--stats-test-pos stats test))
\r
4664 + (result (aref (ert--stats-test-results stats) pos)))
\r
4665 + (let ((buffer (get-buffer-create "*ERT Messages*")))
\r
4666 + (pop-to-buffer buffer)
\r
4667 + (setq buffer-read-only t)
\r
4668 + (let ((inhibit-read-only t))
\r
4669 + (buffer-disable-undo)
\r
4671 + (ert-simple-view-mode)
\r
4672 + (insert (ert-test-result-messages result))
\r
4673 + (goto-char (point-min))
\r
4674 + (insert "Messages for test `")
\r
4675 + (ert-insert-test-name-button (ert-test-name test))
\r
4676 + (insert "':\n")))))
\r
4678 +(defun ert-results-pop-to-should-forms-for-test-at-point ()
\r
4679 + "Display the list of `should' forms executed during the test at point.
\r
4681 +To be used in the ERT results buffer."
\r
4683 + (let* ((test (ert--results-test-at-point-no-redefinition))
\r
4684 + (stats ert--results-stats)
\r
4685 + (pos (ert--stats-test-pos stats test))
\r
4686 + (result (aref (ert--stats-test-results stats) pos)))
\r
4687 + (let ((buffer (get-buffer-create "*ERT list of should forms*")))
\r
4688 + (pop-to-buffer buffer)
\r
4689 + (setq buffer-read-only t)
\r
4690 + (let ((inhibit-read-only t))
\r
4691 + (buffer-disable-undo)
\r
4693 + (ert-simple-view-mode)
\r
4694 + (if (null (ert-test-result-should-forms result))
\r
4695 + (insert "\n(No should forms during this test.)\n")
\r
4696 + (loop for form-description in (ert-test-result-should-forms result)
\r
4699 + (insert (format "%s: " i))
\r
4700 + (let ((begin (point)))
\r
4701 + (ert--pp-with-indentation-and-newline form-description)
\r
4702 + (ert--make-xrefs-region begin (point)))))
\r
4703 + (goto-char (point-min))
\r
4704 + (insert "`should' forms executed during test `")
\r
4705 + (ert-insert-test-name-button (ert-test-name test))
\r
4708 + (insert (concat "(Values are shallow copies and may have "
\r
4709 + "looked different during the test if they\n"
\r
4710 + "have been modified destructively.)\n"))
\r
4711 + (forward-line 1)))))
\r
4713 +(defun ert-results-toggle-printer-limits-for-test-at-point ()
\r
4714 + "Toggle how much of the condition to print for the test at point.
\r
4716 +To be used in the ERT results buffer."
\r
4718 + (let* ((ewoc ert--results-ewoc)
\r
4719 + (node (ert--results-test-node-at-point))
\r
4720 + (entry (ewoc-data node)))
\r
4721 + (setf (ert--ewoc-entry-extended-printer-limits-p entry)
\r
4722 + (not (ert--ewoc-entry-extended-printer-limits-p entry)))
\r
4723 + (ewoc-invalidate ewoc node)))
\r
4725 +(defun ert-results-pop-to-timings ()
\r
4726 + "Display test timings for the last run.
\r
4728 +To be used in the ERT results buffer."
\r
4730 + (let* ((stats ert--results-stats)
\r
4731 + (start-times (ert--stats-test-start-times stats))
\r
4732 + (end-times (ert--stats-test-end-times stats))
\r
4733 + (buffer (get-buffer-create "*ERT timings*"))
\r
4734 + (data (loop for test across (ert--stats-tests stats)
\r
4735 + for start-time across (ert--stats-test-start-times stats)
\r
4736 + for end-time across (ert--stats-test-end-times stats)
\r
4737 + collect (list test
\r
4738 + (float-time (subtract-time end-time
\r
4739 + start-time))))))
\r
4740 + (setq data (sort data (lambda (a b)
\r
4741 + (> (second a) (second b)))))
\r
4742 + (pop-to-buffer buffer)
\r
4743 + (setq buffer-read-only t)
\r
4744 + (let ((inhibit-read-only t))
\r
4745 + (buffer-disable-undo)
\r
4747 + (ert-simple-view-mode)
\r
4749 + (insert "(No data)\n")
\r
4750 + (insert (format "%-3s %8s %8s\n" "" "time" "cumul"))
\r
4751 + (loop for (test time) in data
\r
4752 + for cumul-time = time then (+ cumul-time time)
\r
4754 + (let ((begin (point)))
\r
4755 + (insert (format "%3s: %8.3f %8.3f " i time cumul-time))
\r
4756 + (ert-insert-test-name-button (ert-test-name test))
\r
4757 + (insert "\n"))))
\r
4758 + (goto-char (point-min))
\r
4759 + (insert "Tests by run time (seconds):\n\n")
\r
4760 + (forward-line 1))))
\r
4763 +(defun ert-describe-test (test-or-test-name)
\r
4764 + "Display the documentation for TEST-OR-TEST-NAME (a symbol or ert-test)."
\r
4765 + (interactive (list (ert-read-test-name-at-point "Describe test")))
\r
4766 + (when (< emacs-major-version 24)
\r
4767 + (error "Requires Emacs 24"))
\r
4769 + test-definition)
\r
4770 + (etypecase test-or-test-name
\r
4771 + (symbol (setq test-name test-or-test-name
\r
4772 + test-definition (ert-get-test test-or-test-name)))
\r
4773 + (ert-test (setq test-name (ert-test-name test-or-test-name)
\r
4774 + test-definition test-or-test-name)))
\r
4775 + (help-setup-xref (list #'ert-describe-test test-or-test-name)
\r
4776 + (called-interactively-p 'interactive))
\r
4778 + (with-help-window (help-buffer)
\r
4779 + (with-current-buffer (help-buffer)
\r
4780 + (insert (if test-name (format "%S" test-name) "<anonymous test>"))
\r
4781 + (insert " is a test")
\r
4782 + (let ((file-name (and test-name
\r
4783 + (symbol-file test-name 'ert-deftest))))
\r
4785 + (insert " defined in `" (file-name-nondirectory file-name) "'")
\r
4787 + (re-search-backward "`\\([^`']+\\)'" nil t)
\r
4788 + (help-xref-button 1 'help-function-def test-name file-name)))
\r
4790 + (fill-region-as-paragraph (point-min) (point))
\r
4792 + (unless (and (ert-test-boundp test-name)
\r
4793 + (eql (ert-get-test test-name) test-definition))
\r
4794 + (let ((begin (point)))
\r
4795 + (insert "Note: This test has been redefined or deleted, "
\r
4796 + "this documentation refers to an old definition.")
\r
4797 + (fill-region-as-paragraph begin (point)))
\r
4798 + (insert "\n\n"))
\r
4799 + (insert (or (ert-test-documentation test-definition)
\r
4800 + "It is not documented.")
\r
4803 +(defun ert-results-describe-test-at-point ()
\r
4804 + "Display the documentation of the test at point.
\r
4806 +To be used in the ERT results buffer."
\r
4808 + (ert-describe-test (ert--results-test-at-point-no-redefinition)))
\r
4811 +;;; Actions on load/unload.
\r
4813 +(add-to-list 'find-function-regexp-alist '(ert-deftest . ert--find-test-regexp))
\r
4814 +(add-to-list 'minor-mode-alist '(ert--current-run-stats
\r
4816 + (ert--tests-running-mode-line-indicator))))
\r
4817 +(add-to-list 'emacs-lisp-mode-hook 'ert--activate-font-lock-keywords)
\r
4819 +(defun ert--unload-function ()
\r
4820 + "Unload function to undo the side-effects of loading ert.el."
\r
4821 + (ert--remove-from-list 'find-function-regexp-alist 'ert-deftest :key #'car)
\r
4822 + (ert--remove-from-list 'minor-mode-alist 'ert--current-run-stats :key #'car)
\r
4823 + (ert--remove-from-list 'emacs-lisp-mode-hook
\r
4824 + 'ert--activate-font-lock-keywords)
\r
4827 +(defvar ert-unload-hook '())
\r
4828 +(add-hook 'ert-unload-hook 'ert--unload-function)
\r
4833 +;;; ert.el ends here
\r
4834 diff --git a/test/notmuch-test b/test/notmuch-test
\r
4835 index 43565e8..7c5fceb 100755
\r
4836 --- a/test/notmuch-test
\r
4837 +++ b/test/notmuch-test
\r
4838 @@ -24,7 +24,7 @@ trap 'die' 0
\r
4840 cd $(dirname "$0")
\r
4842 -TESTS="basic new search search-output json thread-naming raw reply dump-restore uuencode thread-order author-order from-guessing long-id encoding emacs maildir-sync"
\r
4843 +TESTS="basic new search search-output json thread-naming raw reply dump-restore uuencode thread-order author-order from-guessing long-id encoding emacs maildir-sync emacs-ert"
\r
4845 # Clean up any results from a previous run
\r
4846 rm -rf test-results >/dev/null 2>/dev/null
\r
projects / notmuch-archives.git / blob