Mercurial > hg > xemacs-beta

comparison lisp/test-harness.el @ 5069:14f0dd1fabdb

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
move test-harness to lisp/ directory so it gets byte-compiled -------------------- ChangeLog entries follow: -------------------- etc/ChangeLog addition: 2010-02-22 Ben Wing <ben@xemacs.org> * dbxrc.in: test-harness.el is in lisp directory now. lisp/ChangeLog addition: 2010-02-22 Ben Wing <ben@xemacs.org> * test-harness.el: * test-harness.el (test-harness-from-buffer): * test-harness.el (batch-test-emacs): Move file from tests/automated into lisp/ so it gets byte-compiled. This significantly reduces the amount of extra crap in outputted backtraces. Delete hack in batch-test-emacs to look for test-harness.el in the test directory since it's not there any more. Also, in `Check-Message', incorporate call to `Skip-Test-Unless' in the macro output rather than its body, to avoid problems byte- compiling the file -- `Skip-Test-Unless' isn't available in the environment during byte-compilation so we can't call it then. src/ChangeLog addition: 2010-02-22 Ben Wing <ben@xemacs.org> * .gdbinit.in.in: * Makefile.in.in (batch_test_emacs): test-harness.el is in lisp directory now so change how we call it.
author Ben Wing <ben@xemacs.org>
date Mon, 22 Feb 2010 22:04:55 -0600
parents tests/automated/test-harness.el@501b5e84f5a7
children b24cf478a45e
comparison
equal deleted inserted replaced
5068:c673987f5f3d 5069:14f0dd1fabdb
1 ;; test-harness.el --- Run Emacs Lisp test suites.
2
3 ;;; Copyright (C) 1998, 2002, 2003 Free Software Foundation, Inc.
4 ;;; Copyright (C) 2002, 2010 Ben Wing.
5
6 ;; Author: Martin Buchholz
7 ;; Maintainer: Stephen J. Turnbull <stephen@xemacs.org>
8 ;; Keywords: testing
9
10 ;; This file is part of XEmacs.
11
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)
15 ;; any later version.
16
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.
21
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.
26
27 ;;; Synched up with: Not in FSF.
28
29 ;;; Commentary:
30
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.
49 ;;;
50 ;;; You run the tests using M-x test-emacs-test-file,
51 ;;; or $(EMACS) -batch -l test-harness -f batch-test-emacs file ...
52 ;;; which is run for you by the `make check' target in the top-level Makefile.
53
54 (require 'bytecomp)
55
56 (defvar unexpected-test-suite-failures 0
57 "Cumulative number of unexpected failures since test-harness was loaded.
58
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.
62
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.")
66
67 (defvar unexpected-test-suite-failure-files nil
68 "List of test files causing unexpected failures.")
69
70 ;; Declared for dynamic scope; _do not_ initialize here.
71 (defvar unexpected-test-file-failures)
72
73 (defvar test-harness-bug-expected nil
74 "Non-nil means a bug is expected; backtracing/debugging should not happen.")
75
76 (defvar test-harness-test-compiled nil
77 "Non-nil means the test code was compiled before execution.
78
79 You probably should not make tests depend on compilation.
80 However, it can be useful to conditionally change messages based on whether
81 the code was compiled or not. For example, the case that motivated the
82 implementation of this variable:
83
84 \(when test-harness-test-compiled
85 ;; this ha-a-ack depends on the failing compiled test coming last
86 \(setq test-harness-failure-tag
87 \"KNOWN BUG - fix reverted; after 2003-10-31 notify stephen\n\"))")
88
89 (defvar test-harness-verbose
90 (and (not noninteractive) (> (device-baud-rate) search-slow-speed))
91 "*Non-nil means print messages describing progress of emacs-tester.")
92
93 (defvar test-harness-unexpected-error-enter-debugger debug-on-error
94 "*Non-nil means enter debugger when an unexpected error occurs.
95 Only applies interactively. Normally true if `debug-on-error' has been set.
96 See also `test-harness-assertion-failure-enter-debugger' and
97 `test-harness-unexpected-error-show-backtrace'.")
98
99 (defvar test-harness-assertion-failure-enter-debugger debug-on-error
100 "*Non-nil means enter debugger when an assertion failure occurs.
101 Only applies interactively. Normally true if `debug-on-error' has been set.
102 See also `test-harness-unexpected-error-enter-debugger' and
103 `test-harness-assertion-failure-show-backtrace'.")
104
105 (defvar test-harness-unexpected-error-show-backtrace t
106 "*Non-nil means show backtrace upon unexpected error.
107 Only applies when debugger is not entered. Normally true by default. See also
108 `test-harness-unexpected-error-enter-debugger' and
109 `test-harness-assertion-failure-show-backtrace'.")
110
111 (defvar test-harness-assertion-failure-show-backtrace stack-trace-on-error
112 "*Non-nil means show backtrace upon assertion failure.
113 Only applies when debugger is not entered. Normally true if
114 `stack-trace-on-error' has been set. See also
115 `test-harness-assertion-failure-enter-debugger' and
116 `test-harness-unexpected-error-show-backtrace'.")
117
118 (defvar test-harness-file-results-alist nil
119 "Each element is a list (FILE SUCCESSES TESTS).
120 The order is the reverse of the order in which tests are run.
121
122 FILE is a string naming the test file.
123 SUCCESSES is a non-negative integer, the number of successes.
124 TESTS is a non-negative integer, the number of tests run.")
125
126 (defvar test-harness-risk-infloops nil
127 "*Non-nil to run tests that may loop infinitely in buggy implementations.")
128
129 (defvar test-harness-current-file nil)
130
131 (defvar emacs-lisp-file-regexp (purecopy "\\.el\\'")
132 "*Regexp which matches Emacs Lisp source files.")
133
134 (defconst test-harness-file-summary-template
135 (format "%%-%ds %%%dd of %%%dd tests successful (%%3d%%%%)."
136 (length "byte-compiler-tests.el:") ; use the longest file name
137 5
138 5)
139 "Format for summary lines printed after each file is run.")
140
141 (defconst test-harness-null-summary-template
142 (format "%%-%ds No tests run."
143 (length "byte-compiler-tests.el:")) ; use the longest file name
144 "Format for \"No tests\" lines printed after a file is run.")
145
146 (defconst test-harness-aborted-summary-template
147 (format "%%-%ds %%%dd tests completed (aborted)."
148 (length "byte-compiler-tests.el:") ; use the longest file name
149 5)
150 "Format for summary lines printed after a test run on a file was aborted.")
151
152 ;;;###autoload
153 (defun test-emacs-test-file (filename)
154 "Test a file of Lisp code named FILENAME.
155 The output file's name is made by appending `c' to the end of FILENAME."
156 (interactive
157 (let ((file buffer-file-name)
158 (file-name nil)
159 (file-dir nil))
160 (and file
161 (eq (cdr (assq 'major-mode (buffer-local-variables)))
162 'emacs-lisp-mode)
163 (setq file-name (file-name-nondirectory file)
164 file-dir (file-name-directory file)))
165 (list (read-file-name "Test file: " file-dir nil nil file-name))))
166 ;; Expand now so we get the current buffer's defaults
167 (setq filename (expand-file-name filename))
168
169 ;; If we're testing a file that's in a buffer and is modified, offer
170 ;; to save it first.
171 (or noninteractive
172 (let ((b (get-file-buffer (expand-file-name filename))))
173 (if (and b (buffer-modified-p b)
174 (y-or-n-p (format "save buffer %s first? " (buffer-name b))))
175 (save-excursion (set-buffer b) (save-buffer)))))
176
177 (if (or noninteractive test-harness-verbose)
178 (message "Testing %s..." filename))
179 (let ((test-harness-current-file filename)
180 input-buffer)
181 (save-excursion
182 (setq input-buffer (get-buffer-create " *Test Input*"))
183 (set-buffer input-buffer)
184 (erase-buffer)
185 (insert-file-contents filename)
186 ;; Run hooks including the uncompression hook.
187 ;; If they change the file name, then change it for the output also.
188 (let ((buffer-file-name filename)
189 (default-major-mode 'emacs-lisp-mode)
190 (enable-local-eval nil))
191 (normal-mode)
192 (setq filename buffer-file-name)))
193 (test-harness-from-buffer input-buffer filename)
194 (kill-buffer input-buffer)
195 ))
196
197 (defsubst test-harness-assertion-failure-do-debug (error-info)
198 "Maybe enter debugger or display a backtrace on assertion failure.
199 ERROR-INFO is a cons of the args (SIG . DATA) that were passed to `signal'.
200 The debugger will be entered if noninteractive and
201 `test-harness-unexpected-error-enter-debugger' is non-nil; else, a
202 backtrace will be displayed if `test-harness-unexpected-error-show-backtrace'
203 is non-nil."
204 (when (not test-harness-bug-expected)
205 (cond ((and (not noninteractive)
206 test-harness-assertion-failure-enter-debugger)
207 (funcall debugger 'error error-info))
208 (test-harness-assertion-failure-show-backtrace
209 (backtrace nil t)))))
210
211 (defsubst test-harness-unexpected-error-do-debug (error-info)
212 "Maybe enter debugger or display a backtrace on unexpected error.
213 ERROR-INFO is a cons of the args (SIG . DATA) that were passed to `signal'.
214 The debugger will be entered if noninteractive and
215 `test-harness-unexpected-error-enter-debugger' is non-nil; else, a
216 backtrace will be displayed if `test-harness-unexpected-error-show-backtrace'
217 is non-nil."
218 (when (not test-harness-bug-expected)
219 (cond ((and (not noninteractive)
220 test-harness-unexpected-error-enter-debugger)
221 (funcall debugger 'error error-info))
222 (test-harness-unexpected-error-show-backtrace
223 (backtrace nil t)))))
224
225 (defsubst test-harness-unexpected-error-condition-handler (error-info context-msg)
226 "Condition handler for when unexpected errors occur.
227 Useful in conjunction with `call-with-condition-handler'. ERROR-INFO is the
228 value passed to the condition handler. CONTEXT-MSG is a string indicating
229 the context in which the unexpected error occurred. A message is outputted
230 including CONTEXT-MSG in it, `unexpected-test-file-failures' is incremented,
231 and `test-harness-unexpected-error-do-debug' is called, which may enter the
232 debugger or output a backtrace, depending on the settings of
233 `test-harness-unexpected-error-enter-debugger' and
234 `test-harness-unexpected-error-show-backtrace'.
235
236 The function returns normally, which causes error-handling processing to
237 continue; if you want to catch the error, you also need to wrap everything
238 in `condition-case'. See also `test-harness-error-wrap', which does this
239 wrapping."
240 (incf unexpected-test-file-failures)
241 (princ (format "Unexpected error %S while %s\n"
242 error-info context-msg))
243 (message "Unexpected error %S while %s." error-info context-msg)
244 (test-harness-unexpected-error-do-debug error-info))
245
246 (defmacro test-harness-error-wrap (context-msg abort-msg &rest body)
247 "Wrap BODY so that unexpected errors are caught.
248 The debugger will be entered if noninteractive and
249 `test-harness-unexpected-error-enter-debugger' is non-nil; else, a backtrace
250 will be displayed if `test-harness-unexpected-error-show-backtrace' is
251 non-nil. CONTEXT-MSG is displayed as part of a message shown before entering
252 the debugger or showing a backtrace, and ABORT-MSG, if non-nil, is displayed
253 afterwards. See "
254 `(condition-case nil
255 (call-with-condition-handler
256 #'(lambda (error-info)
257 (test-harness-unexpected-error-condition-handler
258 error-info ,context-msg))
259 #'(lambda ()
260 ,@body))
261 (error ,(if abort-msg `(message ,abort-msg) nil))))
262
263 (defun test-harness-read-from-buffer (buffer)
264 "Read forms from BUFFER, and turn it into a lambda test form."
265 (let ((body nil))
266 (goto-char (point-min) buffer)
267 (condition-case nil
268 (call-with-condition-handler
269 #'(lambda (error-info)
270 ;; end-of-file is expected, so don't output error or backtrace
271 ;; or enter debugger in this case.
272 (unless (eq 'end-of-file (car error-info))
273 (test-harness-unexpected-error-condition-handler
274 error-info "reading forms from buffer")))
275 #'(lambda ()
276 (while t
277 (setq body (cons (read buffer) body)))))
278 (error nil))
279 `(lambda ()
280 (defvar passes)
281 (defvar assertion-failures)
282 (defvar no-error-failures)
283 (defvar wrong-error-failures)
284 (defvar missing-message-failures)
285 (defvar other-failures)
286
287 (defvar trick-optimizer)
288
289 ,@(nreverse body))))
290
291 (defun test-harness-from-buffer (inbuffer filename)
292 "Run tests in buffer INBUFFER, visiting FILENAME."
293 (defvar trick-optimizer)
294 (let ((passes 0)
295 (assertion-failures 0)
296 (no-error-failures 0)
297 (wrong-error-failures 0)
298 (missing-message-failures 0)
299 (other-failures 0)
300 (unexpected-test-file-failures 0)
301
302 ;; #### perhaps this should be a defvar, and output at the very end
303 ;; OTOH, this way AC types can use a null EMACSPACKAGEPATH to find
304 ;; what stuff is needed, and ways to avoid using them
305 (skipped-test-reasons (make-hash-table :test 'equal))
306
307 (trick-optimizer nil)
308 (debug-on-error t)
309 )
310 (with-output-to-temp-buffer "*Test-Log*"
311 (princ (format "Testing %s...\n\n" filename))
312
313 (defconst test-harness-failure-tag "FAIL")
314 (defconst test-harness-success-tag "PASS")
315
316 ;;;;; BEGIN DEFINITION OF MACROS USEFUL IN TEST CODE
317
318 (defmacro Known-Bug-Expect-Failure (&rest body)
319 "Wrap a BODY that consists of tests that are known to fail.
320 This causes messages to be printed on failure indicating that this is expected,
321 and on success indicating that this is unexpected."
322 `(let ((test-harness-bug-expected t)
323 (test-harness-failure-tag "KNOWN BUG")
324 (test-harness-success-tag "PASS (FAILURE EXPECTED)"))
325 ,@body))
326
327 (defmacro Known-Bug-Expect-Error (expected-error &rest body)
328 "Wrap a BODY that consists of tests that are known to trigger an error.
329 This causes messages to be printed on failure indicating that this is expected,
330 and on success indicating that this is unexpected."
331 (let ((quoted-body (if (= 1 (length body))
332 `(quote ,(car body)) `(quote (progn ,@body)))))
333 `(let ((test-harness-bug-expected t)
334 (test-harness-failure-tag "KNOWN BUG")
335 (test-harness-success-tag "PASS (FAILURE EXPECTED)"))
336 (condition-case error-info
337 (progn
338 (setq trick-optimizer (progn ,@body))
339 (Print-Pass
340 "%S executed successfully, but expected error %S"
341 ,quoted-body
342 ',expected-error)
343 (incf passes))
344 (,expected-error
345 (Print-Failure "%S ==> error %S, as expected"
346 ,quoted-body ',expected-error)
347 (incf no-error-failures))
348 (error
349 (Print-Failure "%S ==> expected error %S, got error %S instead"
350 ,quoted-body ',expected-error error-info)
351 (incf wrong-error-failures))))))
352
353 (defmacro Implementation-Incomplete-Expect-Failure (&rest body)
354 "Wrap a BODY containing tests that are known to fail due to incomplete code.
355 This causes messages to be printed on failure indicating that the
356 implementation is incomplete (and hence the failure is expected); and on
357 success indicating that this is unexpected."
358 `(let ((test-harness-bug-expected t)
359 (test-harness-failure-tag "IMPLEMENTATION INCOMPLETE")
360 (test-harness-success-tag "PASS (FAILURE EXPECTED)"))
361 ,@body))
362
363 (defun Print-Failure (fmt &rest args)
364 (setq fmt (format "%s: %s" test-harness-failure-tag fmt))
365 (if (noninteractive) (apply #'message fmt args))
366 (princ (concat (apply #'format fmt args) "\n")))
367
368 (defun Print-Pass (fmt &rest args)
369 (setq fmt (format "%s: %s" test-harness-success-tag fmt))
370 (and test-harness-verbose
371 (princ (concat (apply #'format fmt args) "\n"))))
372
373 (defun Print-Skip (test reason &optional fmt &rest args)
374 (setq fmt (concat "SKIP: %S BECAUSE %S" fmt))
375 (princ (concat (apply #'format fmt test reason args) "\n")))
376
377 (defmacro Skip-Test-Unless (condition reason description &rest body)
378 "Unless CONDITION is satisfied, skip test BODY.
379 REASON is a description of the condition failure, and must be unique (it
380 is used as a hash key). DESCRIPTION describes the tests that were skipped.
381 BODY is a sequence of expressions and may contain several tests."
382 `(if (not ,condition)
383 (let ((count (gethash ,reason skipped-test-reasons)))
384 (puthash ,reason (if (null count) 1 (1+ count))
385 skipped-test-reasons)
386 (Print-Skip ,description ,reason))
387 ,@body))
388
389 (defmacro Assert (assertion &optional failing-case description)
390 "Test passes if ASSERTION is true.
391 Optional FAILING-CASE describes the particular failure. Optional
392 DESCRIPTION describes the assertion; by default, the unevalated assertion
393 expression is given. FAILING-CASE and DESCRIPTION are useful when Assert
394 is used in a loop."
395 (let ((description
396 (or description `(quote ,assertion))))
397 `(condition-case nil
398 (call-with-condition-handler
399 #'(lambda (error-info)
400 (if (eq 'cl-assertion-failed (car error-info))
401 (progn
402 (Print-Failure
403 (if ,failing-case
404 "Assertion failed: %S; failing case = %S"
405 "Assertion failed: %S")
406 ,description ,failing-case)
407 (incf assertion-failures)
408 (test-harness-assertion-failure-do-debug error-info))
409 (Print-Failure
410 (if ,failing-case
411 "%S ==> error: %S; failing case = %S"
412 "%S ==> error: %S")
413 ,description error-info ,failing-case)
414 (incf other-failures)
415 (test-harness-unexpected-error-do-debug error-info)))
416 #'(lambda ()
417 (assert ,assertion)
418 (Print-Pass "%S" ,description)
419 (incf passes)))
420 (cl-assertion-failed nil))))
421
422 ;;;;; BEGIN DEFINITION OF SPECIFIC KINDS OF ASSERT MACROS
423
424 (defmacro Assert-test (test testval expected &optional failing-case
425 description)
426 "Test passes if TESTVAL compares correctly to EXPECTED using TEST.
427 TEST should be a two-argument predicate (i.e. a function of two arguments
428 that returns t or nil), such as `eq', `eql', `equal', `equalp', `=', `<=',
429 '>', 'file-newer-than-file-p' etc. Optional FAILING-CASE describes the
430 particular failure; any value given here will be concatenated with a phrase
431 describing the expected and actual values of the comparison. Optional
432 DESCRIPTION describes the assertion; by default, the unevalated comparison
433 expressions are given. FAILING-CASE and DESCRIPTION are useful when Assert
434 is used in a loop."
435 (let* ((assertion `(,test ,testval ,expected))
436 (failmsg `(format "%S should be `%s' to %S but isn't"
437 ,testval ',test ,expected))
438 (failmsg2 (if failing-case `(concat
439 (format "%S, " ,failing-case)
440 ,failmsg)
441 failmsg)))
442 `(Assert ,assertion ,failmsg2 ,description)))
443
444 (defmacro Assert-test-not (test testval expected &optional failing-case
445 description)
446 "Test passes if TESTVAL does not compare correctly to EXPECTED using TEST.
447 TEST should be a two-argument predicate (i.e. a function of two arguments
448 that returns t or nil), such as `eq', `eql', `equal', `equalp', `=', `<=',
449 '>', 'file-newer-than-file-p' etc. Optional FAILING-CASE describes the
450 particular failure; any value given here will be concatenated with a phrase
451 describing the expected and actual values of the comparison. Optional
452 DESCRIPTION describes the assertion; by default, the unevalated comparison
453 expressions are given. FAILING-CASE and DESCRIPTION are useful when Assert
454 is used in a loop."
455 (let* ((assertion `(not (,test ,testval ,expected)))
456 (failmsg `(format "%S shouldn't be `%s' to %S but is"
457 ,testval ',test ,expected))
458 (failmsg2 (if failing-case `(concat
459 (format "%S, " ,failing-case)
460 ,failmsg)
461 failmsg)))
462 `(Assert ,assertion ,failmsg2 ,description)))
463
464 ;; Specific versions of `Assert-test'. These are just convenience
465 ;; functions, functioning identically to `Assert-test', and duplicating
466 ;; the doc string for each would be too annoying.
467 (defmacro Assert-eq (testval expected &optional failing-case
468 description)
469 `(Assert-test eq ,testval ,expected ,failing-case ,description))
470 (defmacro Assert-eql (testval expected &optional failing-case
471 description)
472 `(Assert-test eql ,testval ,expected ,failing-case ,description))
473 (defmacro Assert-equal (testval expected &optional failing-case
474 description)
475 `(Assert-test equal ,testval ,expected ,failing-case ,description))
476 (defmacro Assert-equalp (testval expected &optional failing-case
477 description)
478 `(Assert-test equalp ,testval ,expected ,failing-case ,description))
479 (defmacro Assert-string= (testval expected &optional failing-case
480 description)
481 `(Assert-test string= ,testval ,expected ,failing-case ,description))
482 (defmacro Assert= (testval expected &optional failing-case
483 description)
484 `(Assert-test = ,testval ,expected ,failing-case ,description))
485 (defmacro Assert<= (testval expected &optional failing-case
486 description)
487 `(Assert-test <= ,testval ,expected ,failing-case ,description))
488
489 ;; Specific versions of `Assert-test-not'. These are just convenience
490 ;; functions, functioning identically to `Assert-test-not', and
491 ;; duplicating the doc string for each would be too annoying.
492 (defmacro Assert-not-eq (testval expected &optional failing-case
493 description)
494 `(Assert-test-not eq ,testval ,expected ,failing-case ,description))
495 (defmacro Assert-not-eql (testval expected &optional failing-case
496 description)
497 `(Assert-test-not eql ,testval ,expected ,failing-case ,description))
498 (defmacro Assert-not-equal (testval expected &optional failing-case
499 description)
500 `(Assert-test-not equal ,testval ,expected ,failing-case ,description))
501 (defmacro Assert-not-equalp (testval expected &optional failing-case
502 description)
503 `(Assert-test-not equalp ,testval ,expected ,failing-case ,description))
504 (defmacro Assert-not-string= (testval expected &optional failing-case
505 description)
506 `(Assert-test-not string= ,testval ,expected ,failing-case ,description))
507 (defmacro Assert-not= (testval expected &optional failing-case
508 description)
509 `(Assert-test-not = ,testval ,expected ,failing-case ,description))
510
511 (defmacro Check-Error (expected-error &rest body)
512 (let ((quoted-body (if (= 1 (length body))
513 `(quote ,(car body)) `(quote (progn ,@body)))))
514 `(condition-case error-info
515 (progn
516 (setq trick-optimizer (progn ,@body))
517 (Print-Failure "%S executed successfully, but expected error %S"
518 ,quoted-body
519 ',expected-error)
520 (incf no-error-failures))
521 (,expected-error
522 (Print-Pass "%S ==> error %S, as expected"
523 ,quoted-body ',expected-error)
524 (incf passes))
525 (error
526 (Print-Failure "%S ==> expected error %S, got error %S instead"
527 ,quoted-body ',expected-error error-info)
528 (incf wrong-error-failures)))))
529
530 (defmacro Check-Error-Message (expected-error expected-error-regexp
531 &rest body)
532 (let ((quoted-body (if (= 1 (length body))
533 `(quote ,(car body)) `(quote (progn ,@body)))))
534 `(condition-case error-info
535 (progn
536 (setq trick-optimizer (progn ,@body))
537 (Print-Failure "%S executed successfully, but expected error %S"
538 ,quoted-body ',expected-error)
539 (incf no-error-failures))
540 (,expected-error
541 ;; #### Damn, this binding doesn't capture frobs, eg, for
542 ;; invalid_argument() ... you only get the REASON. And for
543 ;; wrong_type_argument(), there's no reason only FROBs.
544 ;; If this gets fixed, fix tests in regexp-tests.el.
545 (let ((error-message (second error-info)))
546 (if (string-match ,expected-error-regexp error-message)
547 (progn
548 (Print-Pass "%S ==> error %S %S, as expected"
549 ,quoted-body error-message ',expected-error)
550 (incf passes))
551 (Print-Failure "%S ==> got error %S as expected, but error message %S did not match regexp %S"
552 ,quoted-body ',expected-error error-message ,expected-error-regexp)
553 (incf wrong-error-failures))))
554 (error
555 (Print-Failure "%S ==> expected error %S, got error %S instead"
556 ,quoted-body ',expected-error error-info)
557 (incf wrong-error-failures)))))
558
559 ;; Do not use this with Silence-Message.
560 (defmacro Check-Message (expected-message-regexp &rest body)
561 (let ((quoted-body (if (= 1 (length body))
562 `(quote ,(car body))
563 `(quote (progn ,@body)))))
564 `(Skip-Test-Unless (fboundp 'defadvice) "can't defadvice"
565 expected-message-regexp
566 (let ((messages ""))
567 (defadvice message (around collect activate)
568 (defvar messages)
569 (let ((msg-string (apply 'format (ad-get-args 0))))
570 (setq messages (concat messages msg-string))
571 msg-string))
572 (ignore-errors
573 (call-with-condition-handler
574 #'(lambda (error-info)
575 (Print-Failure "%S ==> unexpected error %S"
576 ,quoted-body error-info)
577 (incf other-failures)
578 (test-harness-unexpected-error-do-debug error-info))
579 #'(lambda ()
580 (setq trick-optimizer (progn ,@body))
581 (if (string-match ,expected-message-regexp messages)
582 (progn
583 (Print-Pass
584 "%S ==> value %S, message %S, matching %S, as expected"
585 ,quoted-body trick-optimizer messages
586 ',expected-message-regexp)
587 (incf passes))
588 (Print-Failure
589 "%S ==> value %S, message %S, NOT matching expected %S"
590 ,quoted-body trick-optimizer messages
591 ',expected-message-regexp)
592 (incf missing-message-failures)))))
593 (ad-unadvise 'message)))))
594
595 ;; #### Perhaps this should override `message' itself, too?
596 (defmacro Silence-Message (&rest body)
597 `(flet ((append-message (&rest args) ())
598 (clear-message (&rest args) ()))
599 ,@body))
600
601 (defmacro Ignore-Ebola (&rest body)
602 `(let ((debug-issue-ebola-notices -42)) ,@body))
603
604 (defun Int-to-Marker (pos)
605 (save-excursion
606 (set-buffer standard-output)
607 (save-excursion
608 (goto-char pos)
609 (point-marker))))
610
611 (princ "Testing Interpreted Lisp\n\n")
612
613 (test-harness-error-wrap
614 "executing interpreted code"
615 "Test suite execution aborted."
616 (funcall (test-harness-read-from-buffer inbuffer)))
617
618 (princ "\nTesting Compiled Lisp\n\n")
619
620 (let (code
621 (test-harness-test-compiled t))
622 (test-harness-error-wrap
623 "byte-compiling code" nil
624 (setq code
625 ;; our lisp code is often intentionally dubious,
626 ;; so throw away _all_ the byte compiler warnings.
627 (letf (((symbol-function 'byte-compile-warn)
628 'ignore))
629 (byte-compile (test-harness-read-from-buffer
630 inbuffer))))
631 )
632
633 (test-harness-error-wrap "executing byte-compiled code"
634 "Test suite execution aborted."
635 (if code (funcall code)))
636 )
637 (princ (format "\nSUMMARY for %s:\n" filename))
638 (princ (format "\t%5d passes\n" passes))
639 (princ (format "\t%5d assertion failures\n" assertion-failures))
640 (princ (format "\t%5d errors that should have been generated, but weren't\n" no-error-failures))
641 (princ (format "\t%5d wrong-error failures\n" wrong-error-failures))
642 (princ (format "\t%5d missing-message failures\n" missing-message-failures))
643 (princ (format "\t%5d other failures\n" other-failures))
644 (let* ((total (+ passes
645 assertion-failures
646 no-error-failures
647 wrong-error-failures
648 missing-message-failures
649 other-failures))
650 (basename (file-name-nondirectory filename))
651 (summary-msg
652 (cond ((> unexpected-test-file-failures 0)
653 (format test-harness-aborted-summary-template
654 (concat basename ":") total))
655 ((> total 0)
656 (format test-harness-file-summary-template
657 (concat basename ":")
658 passes total (/ (* 100 passes) total)))
659 (t
660 (format test-harness-null-summary-template
661 (concat basename ":")))))
662 (reasons ""))
663 (maphash (lambda (key value)
664 (setq reasons
665 (concat reasons
666 (format "\n %d tests skipped because %s."
667 value key))))
668 skipped-test-reasons)
669 (when (> (length reasons) 1)
670 (setq summary-msg (concat summary-msg reasons "
671 It may be that XEmacs cannot find your installed packages. Set
672 EMACSPACKAGEPATH to the package hierarchy root or configure with
673 --package-path to enable the skipped tests.")))
674 (setq test-harness-file-results-alist
675 (cons (list filename passes total)
676 test-harness-file-results-alist))
677 (message "%s" summary-msg))
678 (when (> unexpected-test-file-failures 0)
679 (setq unexpected-test-suite-failure-files
680 (cons filename unexpected-test-suite-failure-files))
681 (setq unexpected-test-suite-failures
682 (+ unexpected-test-suite-failures unexpected-test-file-failures))
683 (message "Test suite execution failed unexpectedly."))
684 (fmakunbound 'Assert)
685 (fmakunbound 'Check-Error)
686 (fmakunbound 'Check-Message)
687 (fmakunbound 'Check-Error-Message)
688 (fmakunbound 'Ignore-Ebola)
689 (fmakunbound 'Int-to-Marker)
690 (and noninteractive
691 (message "%s" (buffer-substring-no-properties
692 nil nil "*Test-Log*")))
693 )))
694
695 (defvar test-harness-results-point-max nil)
696 (defmacro displaying-emacs-test-results (&rest body)
697 `(let ((test-harness-results-point-max test-harness-results-point-max))
698 ;; Log the file name.
699 (test-harness-log-file)
700 ;; Record how much is logged now.
701 ;; We will display the log buffer if anything more is logged
702 ;; before the end of BODY.
703 (or test-harness-results-point-max
704 (save-excursion
705 (set-buffer (get-buffer-create "*Test-Log*"))
706 (setq test-harness-results-point-max (point-max))))
707 (unwind-protect
708 (condition-case error-info
709 (progn ,@body)
710 (error
711 (test-harness-report-error error-info)))
712 (save-excursion
713 ;; If there were compilation warnings, display them.
714 (set-buffer "*Test-Log*")
715 (if (= test-harness-results-point-max (point-max))
716 nil
717 (if temp-buffer-show-function
718 (let ((show-buffer (get-buffer-create "*Test-Log-Show*")))
719 (save-excursion
720 (set-buffer show-buffer)
721 (setq buffer-read-only nil)
722 (erase-buffer))
723 (copy-to-buffer show-buffer
724 (save-excursion
725 (goto-char test-harness-results-point-max)
726 (forward-line -1)
727 (point))
728 (point-max))
729 (funcall temp-buffer-show-function show-buffer))
730 (select-window
731 (prog1 (selected-window)
732 (select-window (display-buffer (current-buffer)))
733 (goto-char test-harness-results-point-max)
734 (recenter 1)))))))))
735
736 (defun batch-test-emacs-1 (file)
737 (condition-case error-info
738 (progn (test-emacs-test-file file) t)
739 (error
740 (princ ">>Error occurred processing ")
741 (princ file)
742 (princ ": ")
743 (display-error error-info nil)
744 (terpri)
745 nil)))
746
747 (defun batch-test-emacs ()
748 "Run `test-harness' on the files remaining on the command line.
749 Use this from the command line, with `-batch';
750 it won't work in an interactive Emacs.
751 Each file is processed even if an error occurred previously.
752 A directory can be given as well, and all files will be processed.
753 For example, invoke \"xemacs -batch -f batch-test-emacs tests\""
754 ;; command-line-args-left is what is left of the command line (from
755 ;; startup.el)
756 (defvar command-line-args-left) ;Avoid 'free variable' warning
757 (defvar debug-issue-ebola-notices)
758 (if (not noninteractive)
759 (error "`batch-test-emacs' is to be used only with -batch"))
760 (let ((error nil))
761 (dolist (file command-line-args-left)
762 (if (file-directory-p file)
763 (dolist (file-in-dir (directory-files file t))
764 (when (and (string-match emacs-lisp-file-regexp file-in-dir)
765 (not (or (auto-save-file-name-p file-in-dir)
766 (backup-file-name-p file-in-dir))))
767 (or (batch-test-emacs-1 file-in-dir)
768 (setq error t))))
769 (or (batch-test-emacs-1 file)
770 (setq error t))))
771 (let ((namelen 0)
772 (succlen 0)
773 (testlen 0)
774 (results test-harness-file-results-alist))
775 ;; compute maximum lengths of variable components of report
776 ;; probably should just use (length "byte-compiler-tests.el")
777 ;; and 5-place sizes -- this will also work for the file-by-file
778 ;; printing when Adrian's kludge gets reverted
779 (flet ((print-width (i)
780 (let ((x 10) (y 1))
781 (while (>= i x)
782 (setq x (* 10 x) y (1+ y)))
783 y)))
784 (while results
785 (let* ((head (car results))
786 (nn (length (file-name-nondirectory (first head))))
787 (ss (print-width (second head)))
788 (tt (print-width (third head))))
789 (when (> nn namelen) (setq namelen nn))
790 (when (> ss succlen) (setq succlen ss))
791 (when (> tt testlen) (setq testlen tt)))
792 (setq results (cdr results))))
793 ;; create format and print
794 (let ((results (reverse test-harness-file-results-alist)))
795 (while results
796 (let* ((head (car results))
797 (basename (file-name-nondirectory (first head)))
798 (nsucc (second head))
799 (ntest (third head)))
800 (cond ((member (first head) unexpected-test-suite-failure-files)
801 (message test-harness-aborted-summary-template
802 (concat basename ":")
803 ntest))
804 ((> ntest 0)
805 (message test-harness-file-summary-template
806 (concat basename ":")
807 nsucc
808 ntest
809 (/ (* 100 nsucc) ntest)))
810 (t
811 (message test-harness-null-summary-template
812 (concat basename ":"))))
813 (setq results (cdr results)))))
814 (when (> unexpected-test-suite-failures 0)
815 (message "\n***** There %s %d unexpected test suite %s in %s:"
816 (if (= unexpected-test-suite-failures 1) "was" "were")
817 unexpected-test-suite-failures
818 (if (= unexpected-test-suite-failures 1) "failure" "failures")
819 (if (= (length unexpected-test-suite-failure-files) 1)
820 "file"
821 "files"))
822 (while unexpected-test-suite-failure-files
823 (let ((line (pop unexpected-test-suite-failure-files)))
824 (while (and (< (length line) 61)
825 unexpected-test-suite-failure-files)
826 (setq line
827 (concat line " "
828 (pop unexpected-test-suite-failure-files))))
829 (message line)))))
830 (message "\nDone")
831 (kill-emacs (if error 1 0))))
832
833 (provide 'test-harness)
834
835 ;;; test-harness.el ends here