1 ;; test-harness.el --- Run Emacs Lisp test suites.
3 ;;; Copyright (C) 1998, 2002, 2003 Free Software Foundation, Inc.
4 ;;; Copyright (C) 2002 Ben Wing.
6 ;; Author: Martin Buchholz
7 ;; Maintainer: Stephen J. Turnbull <stephen@xemacs.org>
10 ;; This file is part of XEmacs.
12 ;; XEmacs is free software; you can redistribute it and/or modify it
13 ;; under the terms of the GNU General Public License as published by
14 ;; the Free Software Foundation; either version 2, or (at your option)
17 ;; XEmacs is distributed in the hope that it will be useful, but
18 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
20 ;; General Public License for more details.
22 ;; You should have received a copy of the GNU General Public License
23 ;; along with XEmacs; see the file COPYING. If not, write to the
24 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
25 ;; Boston, MA 02111-1307, USA.
27 ;;; Synched up with: Not in FSF.
31 ;;; A test suite harness for testing XEmacs.
32 ;;; The actual tests are in other files in this directory.
33 ;;; Basically you just create files of emacs-lisp, and use the
34 ;;; Assert, Check-Error, Check-Message, and Check-Error-Message functions
35 ;;; to create tests. See `test-harness-from-buffer' below.
36 ;;; Don't suppress tests just because they're due to known bugs not yet
37 ;;; fixed -- use the Known-Bug-Expect-Failure and
38 ;;; Implementation-Incomplete-Expect-Failure wrapper macros to mark them.
39 ;;; A lot of the tests we run push limits; suppress Ebola message with the
40 ;;; Ignore-Ebola wrapper macro.
41 ;;; Some noisy code will call `message'. Output from `message' can be
42 ;;; suppressed with the Silence-Message macro. Functions that are known to
43 ;;; issue messages include `write-region', `find-tag', `tag-loop-continue',
44 ;;; `insert', and `mark-whole-buffer'. N.B. The Silence-Message macro
45 ;;; currently does not suppress the newlines printed by `message'.
46 ;;; Definitely do not use Silence-Message with Check-Message.
47 ;;; In general it should probably only be used on code that prepares for a
48 ;;; test, not on tests.
50 ;;; You run the tests using M-x test-emacs-test-file,
51 ;;; or $(EMACS) -batch -l .../test-harness.el -f batch-test-emacs file ...
52 ;;; which is run for you by the `make check' target in the top-level Makefile.
56 (defvar unexpected-test-suite-failures 0
57 "Cumulative number of unexpected failures since test-harness was loaded.
59 \"Unexpected failures\" are those caught by a generic handler established
60 outside of the test context. As such they involve an abort of the test
61 suite for the file being tested.
63 They often occur during preparation of a test or recording of the results.
64 For example, an executable used to generate test data might not be present
65 on the system, or a system error might occur while reading a data file.")
67 (defvar unexpected-test-suite-failure-files nil
68 "List of test files causing unexpected failures.")
70 ;; Declared for dynamic scope; _do not_ initialize here.
71 (defvar unexpected-test-file-failures)
73 (defvar test-harness-test-compiled nil
74 "Non-nil means the test code was compiled before execution.")
76 (defvar test-harness-verbose
77 (and (not noninteractive) (> (device-baud-rate) search-slow-speed))
78 "*Non-nil means print messages describing progress of emacs-tester.")
80 (defvar test-harness-file-results-alist nil
81 "Each element is a list (FILE SUCCESSES TESTS).
82 The order is the reverse of the order in which tests are run.
84 FILE is a string naming the test file.
85 SUCCESSES is a non-negative integer, the number of successes.
86 TESTS is a non-negative integer, the number of tests run.")
88 (defvar test-harness-risk-infloops nil
89 "*Non-nil to run tests that may loop infinitely in buggy implementations.")
91 (defvar test-harness-current-file nil)
93 (defvar emacs-lisp-file-regexp (purecopy "\\.el\\'")
94 "*Regexp which matches Emacs Lisp source files.")
96 (defconst test-harness-file-summary-template
97 (format "%%-%ds %%%dd of %%%dd tests successful (%%3d%%%%)."
98 (length "byte-compiler-tests.el:") ; use the longest file name
101 "Format for summary lines printed after each file is run.")
103 (defconst test-harness-null-summary-template
104 (format "%%-%ds No tests run."
105 (length "byte-compiler-tests.el:")) ; use the longest file name
106 "Format for \"No tests\" lines printed after a file is run.")
109 (defun test-emacs-test-file (filename)
110 "Test a file of Lisp code named FILENAME.
111 The output file's name is made by appending `c' to the end of FILENAME."
113 (let ((file buffer-file-name)
117 (eq (cdr (assq 'major-mode (buffer-local-variables)))
119 (setq file-name (file-name-nondirectory file)
120 file-dir (file-name-directory file)))
121 (list (read-file-name "Test file: " file-dir nil nil file-name))))
122 ;; Expand now so we get the current buffer's defaults
123 (setq filename (expand-file-name filename))
125 ;; If we're testing a file that's in a buffer and is modified, offer
128 (let ((b (get-file-buffer (expand-file-name filename))))
129 (if (and b (buffer-modified-p b)
130 (y-or-n-p (format "save buffer %s first? " (buffer-name b))))
131 (save-excursion (set-buffer b) (save-buffer)))))
133 (if (or noninteractive test-harness-verbose)
134 (message "Testing %s..." filename))
135 (let ((test-harness-current-file filename)
138 (setq input-buffer (get-buffer-create " *Test Input*"))
139 (set-buffer input-buffer)
141 (insert-file-contents filename)
142 ;; Run hooks including the uncompression hook.
143 ;; If they change the file name, then change it for the output also.
144 (let ((buffer-file-name filename)
145 (default-major-mode 'emacs-lisp-mode)
146 (enable-local-eval nil))
148 (setq filename buffer-file-name)))
149 (test-harness-from-buffer input-buffer filename)
150 (kill-buffer input-buffer)
153 (defun test-harness-read-from-buffer (buffer)
154 "Read forms from BUFFER, and turn it into a lambda test form."
156 (goto-char (point-min) buffer)
157 (condition-case error-info
159 (setq body (cons (read buffer) body)))
162 (incf unexpected-test-file-failures)
163 (princ (format "Unexpected error %S reading forms from buffer\n"
167 (defvar assertion-failures)
168 (defvar no-error-failures)
169 (defvar wrong-error-failures)
170 (defvar missing-message-failures)
171 (defvar other-failures)
173 (defvar trick-optimizer)
177 (defun test-harness-from-buffer (inbuffer filename)
178 "Run tests in buffer INBUFFER, visiting FILENAME."
179 (defvar trick-optimizer)
181 (assertion-failures 0)
182 (no-error-failures 0)
183 (wrong-error-failures 0)
184 (missing-message-failures 0)
186 (unexpected-test-file-failures 0)
188 ;; #### perhaps this should be a defvar, and output at the very end
189 ;; OTOH, this way AC types can use a null EMACSPACKAGEPATH to find
190 ;; what stuff is needed, and ways to avoid using them
191 (skipped-test-reasons (make-hash-table :test 'equal))
193 (trick-optimizer nil)
196 (with-output-to-temp-buffer "*Test-Log*"
197 (princ (format "Testing %s...\n\n" filename))
199 (defconst test-harness-failure-tag "FAIL")
200 (defconst test-harness-success-tag "PASS")
202 (defmacro Known-Bug-Expect-Failure (&rest body)
203 `(let ((test-harness-failure-tag "KNOWN BUG")
204 (test-harness-success-tag "PASS (FAILURE EXPECTED)"))
207 (defmacro Implementation-Incomplete-Expect-Failure (&rest body)
208 `(let ((test-harness-failure-tag "IMPLEMENTATION INCOMPLETE")
209 (test-harness-success-tag "PASS (FAILURE EXPECTED)"))
212 (defun Print-Failure (fmt &rest args)
213 (setq fmt (format "%s: %s" test-harness-failure-tag fmt))
214 (if (noninteractive) (apply #'message fmt args))
215 (princ (concat (apply #'format fmt args) "\n")))
217 (defun Print-Pass (fmt &rest args)
218 (setq fmt (format "%s: %s" test-harness-success-tag fmt))
219 (and test-harness-verbose
220 (princ (concat (apply #'format fmt args) "\n"))))
222 (defun Print-Skip (test reason &optional fmt &rest args)
223 (setq fmt (concat "SKIP: %S BECAUSE %S" fmt))
224 (princ (concat (apply #'format fmt test reason args) "\n")))
226 (defmacro Skip-Test-Unless (condition reason description &rest body)
227 "Unless CONDITION is satisfied, skip test BODY.
228 REASON is a description of the condition failure, and must be unique (it
229 is used as a hash key). DESCRIPTION describes the tests that were skipped.
230 BODY is a sequence of expressions and may contain several tests."
231 `(if (not ,condition)
232 (let ((count (gethash ,reason skipped-test-reasons)))
233 (puthash ,reason (if (null count) 1 (1+ count))
234 skipped-test-reasons)
235 (Print-Skip ,description ,reason))
238 (defmacro Assert (assertion)
239 `(condition-case error-info
242 (Print-Pass "%S" (quote ,assertion))
245 (Print-Failure "Assertion failed: %S" (quote ,assertion))
246 (incf assertion-failures))
247 (t (Print-Failure "%S ==> error: %S" (quote ,assertion) error-info)
248 (incf other-failures)
251 (defmacro Check-Error (expected-error &rest body)
252 (let ((quoted-body (if (= 1 (length body))
253 `(quote ,(car body)) `(quote (progn ,@body)))))
254 `(condition-case error-info
256 (setq trick-optimizer (progn ,@body))
257 (Print-Failure "%S executed successfully, but expected error %S"
260 (incf no-error-failures))
262 (Print-Pass "%S ==> error %S, as expected"
263 ,quoted-body ',expected-error)
266 (Print-Failure "%S ==> expected error %S, got error %S instead"
267 ,quoted-body ',expected-error error-info)
268 (incf wrong-error-failures)))))
270 (defmacro Check-Error-Message (expected-error expected-error-regexp
272 (let ((quoted-body (if (= 1 (length body))
273 `(quote ,(car body)) `(quote (progn ,@body)))))
274 `(condition-case error-info
276 (setq trick-optimizer (progn ,@body))
277 (Print-Failure "%S executed successfully, but expected error %S"
278 ,quoted-body ',expected-error)
279 (incf no-error-failures))
281 (let ((error-message (second error-info)))
282 (if (string-match ,expected-error-regexp error-message)
284 (Print-Pass "%S ==> error %S %S, as expected"
285 ,quoted-body error-message ',expected-error)
287 (Print-Failure "%S ==> got error %S as expected, but error message %S did not match regexp %S"
288 ,quoted-body ',expected-error error-message ,expected-error-regexp)
289 (incf wrong-error-failures))))
291 (Print-Failure "%S ==> expected error %S, got error %S instead"
292 ,quoted-body ',expected-error error-info)
293 (incf wrong-error-failures)))))
295 ;; Do not use this with Silence-Message.
296 (defmacro Check-Message (expected-message-regexp &rest body)
297 (Skip-Test-Unless (fboundp 'defadvice)
299 expected-message-regexp
300 (let ((quoted-body (if (= 1 (length body))
302 `(quote (progn ,@body)))))
303 `(let ((messages ""))
304 (defadvice message (around collect activate)
306 (let ((msg-string (apply 'format (ad-get-args 0))))
307 (setq messages (concat messages msg-string))
309 (condition-case error-info
311 (setq trick-optimizer (progn ,@body))
312 (if (string-match ,expected-message-regexp messages)
314 (Print-Pass "%S ==> value %S, message %S, matching %S, as expected"
315 ,quoted-body trick-optimizer messages ',expected-message-regexp)
317 (Print-Failure "%S ==> value %S, message %S, NOT matching expected %S"
318 ,quoted-body trick-optimizer messages
319 ',expected-message-regexp)
320 (incf missing-message-failures)))
322 (Print-Failure "%S ==> unexpected error %S"
323 ,quoted-body error-info)
324 (incf other-failures)))
325 (ad-unadvise 'message)))))
327 ;; #### Perhaps this should override `message' itself, too?
328 (defmacro Silence-Message (&rest body)
329 `(flet ((append-message (&rest args) ())) ,@body))
331 (defmacro Ignore-Ebola (&rest body)
332 `(let ((debug-issue-ebola-notices -42)) ,@body))
334 (defun Int-to-Marker (pos)
336 (set-buffer standard-output)
341 (princ "Testing Interpreted Lisp\n\n")
342 (condition-case error-info
343 (funcall (test-harness-read-from-buffer inbuffer))
345 (incf unexpected-test-file-failures)
346 (princ (format "Unexpected error %S while executing interpreted code\n"
348 (message "Unexpected error %S while executing interpreted code." error-info)
349 (message "Test suite execution aborted." error-info)
351 (princ "\nTesting Compiled Lisp\n\n")
353 (test-harness-test-compiled t))
354 (condition-case error-info
356 ;; our lisp code is often intentionally dubious,
357 ;; so throw away _all_ the byte compiler warnings.
358 (letf (((symbol-function 'byte-compile-warn) 'ignore))
359 (byte-compile (test-harness-read-from-buffer inbuffer))))
361 (princ (format "Unexpected error %S while byte-compiling code\n"
363 (condition-case error-info
364 (if code (funcall code))
366 (incf unexpected-test-file-failures)
367 (princ (format "Unexpected error %S while executing byte-compiled code\n"
369 (message "Unexpected error %S while executing byte-compiled code." error-info)
370 (message "Test suite execution aborted." error-info)
372 (princ (format "\nSUMMARY for %s:\n" filename))
373 (princ (format "\t%5d passes\n" passes))
374 (princ (format "\t%5d assertion failures\n" assertion-failures))
375 (princ (format "\t%5d errors that should have been generated, but weren't\n" no-error-failures))
376 (princ (format "\t%5d wrong-error failures\n" wrong-error-failures))
377 (princ (format "\t%5d missing-message failures\n" missing-message-failures))
378 (princ (format "\t%5d other failures\n" other-failures))
379 (let* ((total (+ passes
383 missing-message-failures
385 (basename (file-name-nondirectory filename))
388 (format test-harness-file-summary-template
389 (concat basename ":")
390 passes total (/ (* 100 passes) total))
391 (format test-harness-null-summary-template
392 (concat basename ":"))))
394 (maphash (lambda (key value)
397 (format "\n %d tests skipped because %s."
399 skipped-test-reasons)
400 (when (> (length reasons) 1)
401 (setq summary-msg (concat summary-msg reasons "
402 Probably XEmacs cannot find your installed packages. Set EMACSPACKAGEPATH
403 to the package hierarchy root or configure with --package-path to enable
404 the skipped tests.")))
405 (setq test-harness-file-results-alist
406 (cons (list filename passes total)
407 test-harness-file-results-alist))
408 (message "%s" summary-msg))
409 (when (> unexpected-test-file-failures 0)
410 (setq unexpected-test-suite-failure-files
411 (cons filename unexpected-test-suite-failure-files))
412 (setq unexpected-test-suite-failures
413 (+ unexpected-test-suite-failures unexpected-test-file-failures))
414 (message "Test suite execution failed unexpectedly."))
415 (fmakunbound 'Assert)
416 (fmakunbound 'Check-Error)
417 (fmakunbound 'Check-Message)
418 (fmakunbound 'Check-Error-Message)
419 (fmakunbound 'Ignore-Ebola)
420 (fmakunbound 'Int-to-Marker)
422 (message "%s" (buffer-substring-no-properties
423 nil nil "*Test-Log*")))
426 (defvar test-harness-results-point-max nil)
427 (defmacro displaying-emacs-test-results (&rest body)
428 `(let ((test-harness-results-point-max test-harness-results-point-max))
429 ;; Log the file name.
430 (test-harness-log-file)
431 ;; Record how much is logged now.
432 ;; We will display the log buffer if anything more is logged
433 ;; before the end of BODY.
434 (or test-harness-results-point-max
436 (set-buffer (get-buffer-create "*Test-Log*"))
437 (setq test-harness-results-point-max (point-max))))
439 (condition-case error-info
442 (test-harness-report-error error-info)))
444 ;; If there were compilation warnings, display them.
445 (set-buffer "*Test-Log*")
446 (if (= test-harness-results-point-max (point-max))
448 (if temp-buffer-show-function
449 (let ((show-buffer (get-buffer-create "*Test-Log-Show*")))
451 (set-buffer show-buffer)
452 (setq buffer-read-only nil)
454 (copy-to-buffer show-buffer
456 (goto-char test-harness-results-point-max)
460 (funcall temp-buffer-show-function show-buffer))
462 (prog1 (selected-window)
463 (select-window (display-buffer (current-buffer)))
464 (goto-char test-harness-results-point-max)
467 (defun batch-test-emacs-1 (file)
468 (condition-case error-info
469 (progn (test-emacs-test-file file) t)
471 (princ ">>Error occurred processing ")
474 (display-error error-info nil)
478 (defun batch-test-emacs ()
479 "Run `test-harness' on the files remaining on the command line.
480 Use this from the command line, with `-batch';
481 it won't work in an interactive Emacs.
482 Each file is processed even if an error occurred previously.
483 For example, invoke \"xemacs -batch -f batch-test-emacs tests/*.el\""
484 ;; command-line-args-left is what is left of the command line (from
486 (defvar command-line-args-left) ;Avoid 'free variable' warning
487 (defvar debug-issue-ebola-notices)
488 (if (not noninteractive)
489 (error "`batch-test-emacs' is to be used only with -batch"))
491 (dolist (file command-line-args-left)
492 (if (file-directory-p file)
493 (dolist (file-in-dir (directory-files file t))
494 (when (and (string-match emacs-lisp-file-regexp file-in-dir)
495 (not (or (auto-save-file-name-p file-in-dir)
496 (backup-file-name-p file-in-dir)
497 (equal (file-name-nondirectory file-in-dir)
498 "test-harness.el"))))
499 (or (batch-test-emacs-1 file-in-dir)
501 (or (batch-test-emacs-1 file)
506 (results test-harness-file-results-alist))
507 ;; compute maximum lengths of variable components of report
508 ;; probably should just use (length "byte-compiler-tests.el")
509 ;; and 5-place sizes -- this will also work for the file-by-file
510 ;; printing when Adrian's kludge gets reverted
511 (flet ((print-width (i)
514 (setq x (* 10 x) y (1+ y)))
517 (let* ((head (car results))
518 (nn (length (file-name-nondirectory (first head))))
519 (ss (print-width (second head)))
520 (tt (print-width (third head))))
521 (when (> nn namelen) (setq namelen nn))
522 (when (> ss succlen) (setq succlen ss))
523 (when (> tt testlen) (setq testlen tt)))
524 (setq results (cdr results))))
525 ;; create format and print
526 (let ((results (reverse test-harness-file-results-alist)))
528 (let* ((head (car results))
529 (basename (file-name-nondirectory (first head)))
530 (nsucc (second head))
531 (ntest (third head)))
533 (message test-harness-file-summary-template
534 (concat basename ":")
537 (/ (* 100 nsucc) ntest))
538 (message test-harness-null-summary-template
539 (concat basename ":")))
540 (setq results (cdr results)))))
541 (when (> unexpected-test-suite-failures 0)
542 (message "\n***** There %s %d unexpected test suite %s in %s:"
543 (if (= unexpected-test-suite-failures 1) "was" "were")
544 unexpected-test-suite-failures
545 (if (= unexpected-test-suite-failures 1) "failure" "failures")
546 (if (= (length unexpected-test-suite-failure-files) 1)
549 (while unexpected-test-suite-failure-files
550 (let ((line (pop unexpected-test-suite-failure-files)))
551 (while (and (< (length line) 61)
552 unexpected-test-suite-failure-files)
555 (pop unexpected-test-suite-failure-files))))
558 (kill-emacs (if error 1 0))))
560 (provide 'test-harness)
562 ;;; test-harness.el ends here