Mercurial > hg > xemacs-beta

comparison tests/automated/test-harness.el @ 5118:e0db3c197671 ben-lisp-object

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
merge up to latest default branch, doesn't compile yet
author Ben Wing <ben@xemacs.org>
date Sat, 26 Dec 2009 21:18:49 -0600
parents 294a86d29f99
children a3c673c0720b
comparison
equal deleted inserted replaced
5117:3742ea8250b5 5118:e0db3c197671
36 ;;; Don't suppress tests just because they're due to known bugs not yet 36 ;;; Don't suppress tests just because they're due to known bugs not yet
37 ;;; fixed -- use the Known-Bug-Expect-Failure and 37 ;;; fixed -- use the Known-Bug-Expect-Failure and
38 ;;; Implementation-Incomplete-Expect-Failure wrapper macros to mark them. 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 39 ;;; A lot of the tests we run push limits; suppress Ebola message with the
40 ;;; Ignore-Ebola wrapper macro. 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.
41 ;;; 49 ;;;
42 ;;; You run the tests using M-x test-emacs-test-file, 50 ;;; You run the tests using M-x test-emacs-test-file,
43 ;;; or $(EMACS) -batch -l .../test-harness.el -f batch-test-emacs file ... 51 ;;; or $(EMACS) -batch -l .../test-harness.el -f batch-test-emacs file ...
44 ;;; which is run for you by the `make check' target in the top-level Makefile. 52 ;;; which is run for you by the `make check' target in the top-level Makefile.
45 53
46 (require 'bytecomp) 54 (require 'bytecomp)
47 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
48 (defvar test-harness-test-compiled nil 73 (defvar test-harness-test-compiled nil
49 "Non-nil means the test code was compiled before execution.") 74 "Non-nil means the test code was compiled before execution.
75
76 You probably should not make tests depend on compilation.
77 However, it can be useful to conditionally change messages based on whether
78 the code was compiled or not. For example, the case that motivated the
79 implementation of this variable:
80
81 \(when test-harness-test-compiled
82 ;; this ha-a-ack depends on the failing compiled test coming last
83 \(setq test-harness-failure-tag
84 \"KNOWN BUG - fix reverted; after 2003-10-31 notify stephen\n\"))")
50 85
51 (defvar test-harness-verbose 86 (defvar test-harness-verbose
52 (and (not noninteractive) (> (device-baud-rate) search-slow-speed)) 87 (and (not noninteractive) (> (device-baud-rate) search-slow-speed))
53 "*Non-nil means print messages describing progress of emacs-tester.") 88 "*Non-nil means print messages describing progress of emacs-tester.")
54 89
132 (condition-case error-info 167 (condition-case error-info
133 (while t 168 (while t
134 (setq body (cons (read buffer) body))) 169 (setq body (cons (read buffer) body)))
135 (end-of-file nil) 170 (end-of-file nil)
136 (error 171 (error
172 (incf unexpected-test-file-failures)
137 (princ (format "Unexpected error %S reading forms from buffer\n" 173 (princ (format "Unexpected error %S reading forms from buffer\n"
138 error-info)))) 174 error-info))))
139 `(lambda () 175 `(lambda ()
140 (defvar passes) 176 (defvar passes)
141 (defvar assertion-failures) 177 (defvar assertion-failures)
142 (defvar no-error-failures) 178 (defvar no-error-failures)
143 (defvar wrong-error-failures) 179 (defvar wrong-error-failures)
144 (defvar missing-message-failures) 180 (defvar missing-message-failures)
145 (defvar other-failures) 181 (defvar other-failures)
146 182
147 (defvar unexpected-test-suite-failure)
148 (defvar trick-optimizer) 183 (defvar trick-optimizer)
149 184
150 ,@(nreverse body)))) 185 ,@(nreverse body))))
151 186
152 (defun test-harness-from-buffer (inbuffer filename) 187 (defun test-harness-from-buffer (inbuffer filename)
156 (assertion-failures 0) 191 (assertion-failures 0)
157 (no-error-failures 0) 192 (no-error-failures 0)
158 (wrong-error-failures 0) 193 (wrong-error-failures 0)
159 (missing-message-failures 0) 194 (missing-message-failures 0)
160 (other-failures 0) 195 (other-failures 0)
196 (unexpected-test-file-failures 0)
161 197
162 ;; #### perhaps this should be a defvar, and output at the very end 198 ;; #### perhaps this should be a defvar, and output at the very end
163 ;; OTOH, this way AC types can use a null EMACSPACKAGEPATH to find 199 ;; OTOH, this way AC types can use a null EMACSPACKAGEPATH to find
164 ;; what stuff is needed, and ways to avoid using them 200 ;; what stuff is needed, and ways to avoid using them
165 (skipped-test-reasons (make-hash-table :test 'equal)) 201 (skipped-test-reasons (make-hash-table :test 'equal))
166 202
167 (trick-optimizer nil) 203 (trick-optimizer nil)
168 (unexpected-test-suite-failure nil)
169 (debug-on-error t) 204 (debug-on-error t)
170 (pass-stream nil)) 205 (pass-stream nil))
171 (with-output-to-temp-buffer "*Test-Log*" 206 (with-output-to-temp-buffer "*Test-Log*"
172 (princ (format "Testing %s...\n\n" filename)) 207 (princ (format "Testing %s...\n\n" filename))
173 208
176 211
177 (defmacro Known-Bug-Expect-Failure (&rest body) 212 (defmacro Known-Bug-Expect-Failure (&rest body)
178 `(let ((test-harness-failure-tag "KNOWN BUG") 213 `(let ((test-harness-failure-tag "KNOWN BUG")
179 (test-harness-success-tag "PASS (FAILURE EXPECTED)")) 214 (test-harness-success-tag "PASS (FAILURE EXPECTED)"))
180 ,@body)) 215 ,@body))
181 216
217 (defmacro Known-Bug-Expect-Error (expected-error &rest body)
218 (let ((quoted-body (if (= 1 (length body))
219 `(quote ,(car body)) `(quote (progn ,@body)))))
220 `(let ((test-harness-failure-tag "KNOWN BUG")
221 (test-harness-success-tag "PASS (FAILURE EXPECTED)"))
222 (condition-case error-info
223 (progn
224 (setq trick-optimizer (progn ,@body))
225 (Print-Pass
226 "%S executed successfully, but expected error %S"
227 ,quoted-body
228 ',expected-error)
229 (incf passes))
230 (,expected-error
231 (Print-Failure "%S ==> error %S, as expected"
232 ,quoted-body ',expected-error)
233 (incf no-error-failures))
234 (error
235 (Print-Failure "%S ==> expected error %S, got error %S instead"
236 ,quoted-body ',expected-error error-info)
237 (incf wrong-error-failures))))))
238
182 (defmacro Implementation-Incomplete-Expect-Failure (&rest body) 239 (defmacro Implementation-Incomplete-Expect-Failure (&rest body)
183 `(let ((test-harness-failure-tag "IMPLEMENTATION INCOMPLETE") 240 `(let ((test-harness-failure-tag "IMPLEMENTATION INCOMPLETE")
184 (test-harness-success-tag "PASS (FAILURE EXPECTED)")) 241 (test-harness-success-tag "PASS (FAILURE EXPECTED)"))
185 ,@body)) 242 ,@body))
186 243
208 (puthash ,reason (if (null count) 1 (1+ count)) 265 (puthash ,reason (if (null count) 1 (1+ count))
209 skipped-test-reasons) 266 skipped-test-reasons)
210 (Print-Skip ,description ,reason)) 267 (Print-Skip ,description ,reason))
211 ,@body)) 268 ,@body))
212 269
213 (defmacro Assert (assertion &optional failing-case) 270 (defmacro Assert (assertion &optional failing-case description)
271 "Test passes if ASSERTION is true.
272 Optional FAILING-CASE describes the particular failure.
273 Optional DESCRIPTION describes the assertion.
274 FAILING-CASE and DESCRIPTION are useful when Assert is used in a loop."
214 `(condition-case error-info 275 `(condition-case error-info
215 (progn 276 (progn
216 (assert ,assertion) 277 (assert ,assertion)
217 (Print-Pass "%S" (quote ,assertion)) 278 (Print-Pass "%S" (quote ,(or description assertion)))
218 (incf passes)) 279 (incf passes))
219 (cl-assertion-failed 280 (cl-assertion-failed
220 (Print-Failure (if ,failing-case 281 (Print-Failure (if ,failing-case
221 "Assertion failed: %S; failing case = %S" 282 "Assertion failed: %S; failing case = %S"
222 "Assertion failed: %S") 283 "Assertion failed: %S")
223 (quote ,assertion) ,failing-case) 284 (quote ,(or description assertion)) ,failing-case)
224 (incf assertion-failures)) 285 (incf assertion-failures))
225 (t (Print-Failure (if ,failing-case 286 (t (Print-Failure (if ,failing-case
226 "%S ==> error: %S; failing case = %S" 287 "%S ==> error: %S; failing case = %S"
227 "%S ==> error: %S") 288 "%S ==> error: %S")
228 (quote ,assertion) error-info ,failing-case) 289 (quote ,(or description assertion))
290 error-info ,failing-case)
229 (incf other-failures) 291 (incf other-failures)
230 ))) 292 )))
231 293
232 294
233 (defmacro Check-Error (expected-error &rest body) 295 (defmacro Check-Error (expected-error &rest body)
258 (setq trick-optimizer (progn ,@body)) 320 (setq trick-optimizer (progn ,@body))
259 (Print-Failure "%S executed successfully, but expected error %S" 321 (Print-Failure "%S executed successfully, but expected error %S"
260 ,quoted-body ',expected-error) 322 ,quoted-body ',expected-error)
261 (incf no-error-failures)) 323 (incf no-error-failures))
262 (,expected-error 324 (,expected-error
325 ;; #### Damn, this binding doesn't capture frobs, eg, for
326 ;; invalid_argument() ... you only get the REASON. And for
327 ;; wrong_type_argument(), there's no reason only FROBs.
328 ;; If this gets fixed, fix tests in regexp-tests.el.
263 (let ((error-message (second error-info))) 329 (let ((error-message (second error-info)))
264 (if (string-match ,expected-error-regexp error-message) 330 (if (string-match ,expected-error-regexp error-message)
265 (progn 331 (progn
266 (Print-Pass "%S ==> error %S %S, as expected" 332 (Print-Pass "%S ==> error %S %S, as expected"
267 ,quoted-body error-message ',expected-error) 333 ,quoted-body error-message ',expected-error)
272 (error 338 (error
273 (Print-Failure "%S ==> expected error %S, got error %S instead" 339 (Print-Failure "%S ==> expected error %S, got error %S instead"
274 ,quoted-body ',expected-error error-info) 340 ,quoted-body ',expected-error error-info)
275 (incf wrong-error-failures))))) 341 (incf wrong-error-failures)))))
276 342
277 343 ;; Do not use this with Silence-Message.
278 (defmacro Check-Message (expected-message-regexp &rest body) 344 (defmacro Check-Message (expected-message-regexp &rest body)
279 (Skip-Test-Unless (fboundp 'defadvice) 345 (Skip-Test-Unless (fboundp 'defadvice)
280 "can't defadvice" 346 "can't defadvice"
281 expected-message-regexp 347 expected-message-regexp
282 (let ((quoted-body (if (= 1 (length body)) 348 (let ((quoted-body (if (= 1 (length body))
304 (Print-Failure "%S ==> unexpected error %S" 370 (Print-Failure "%S ==> unexpected error %S"
305 ,quoted-body error-info) 371 ,quoted-body error-info)
306 (incf other-failures))) 372 (incf other-failures)))
307 (ad-unadvise 'message))))) 373 (ad-unadvise 'message)))))
308 374
375 ;; #### Perhaps this should override `message' itself, too?
376 (defmacro Silence-Message (&rest body)
377 `(flet ((append-message (&rest args) ())
378 (clear-message (&rest args) ()))
379 ,@body))
380
309 (defmacro Ignore-Ebola (&rest body) 381 (defmacro Ignore-Ebola (&rest body)
310 `(let ((debug-issue-ebola-notices -42)) ,@body)) 382 `(let ((debug-issue-ebola-notices -42)) ,@body))
311 383
312 (defun Int-to-Marker (pos) 384 (defun Int-to-Marker (pos)
313 (save-excursion 385 (save-excursion
318 390
319 (princ "Testing Interpreted Lisp\n\n") 391 (princ "Testing Interpreted Lisp\n\n")
320 (condition-case error-info 392 (condition-case error-info
321 (funcall (test-harness-read-from-buffer inbuffer)) 393 (funcall (test-harness-read-from-buffer inbuffer))
322 (error 394 (error
323 (setq unexpected-test-suite-failure t) 395 (incf unexpected-test-file-failures)
324 (princ (format "Unexpected error %S while executing interpreted code\n" 396 (princ (format "Unexpected error %S while executing interpreted code\n"
325 error-info)) 397 error-info))
326 (message "Unexpected error %S while executing interpreted code." error-info) 398 (message "Unexpected error %S while executing interpreted code." error-info)
327 (message "Test suite execution aborted." error-info) 399 (message "Test suite execution aborted." error-info)
328 )) 400 ))
339 (princ (format "Unexpected error %S while byte-compiling code\n" 411 (princ (format "Unexpected error %S while byte-compiling code\n"
340 error-info)))) 412 error-info))))
341 (condition-case error-info 413 (condition-case error-info
342 (if code (funcall code)) 414 (if code (funcall code))
343 (error 415 (error
416 (incf unexpected-test-file-failures)
344 (princ (format "Unexpected error %S while executing byte-compiled code\n" 417 (princ (format "Unexpected error %S while executing byte-compiled code\n"
345 error-info)) 418 error-info))
346 (message "Unexpected error %S while executing byte-compiled code." error-info) 419 (message "Unexpected error %S while executing byte-compiled code." error-info)
347 (message "Test suite execution aborted." error-info) 420 (message "Test suite execution aborted." error-info)
348 ))) 421 )))
374 (format "\n %d tests skipped because %s." 447 (format "\n %d tests skipped because %s."
375 value key)))) 448 value key))))
376 skipped-test-reasons) 449 skipped-test-reasons)
377 (when (> (length reasons) 1) 450 (when (> (length reasons) 1)
378 (setq summary-msg (concat summary-msg reasons " 451 (setq summary-msg (concat summary-msg reasons "
379 Probably XEmacs cannot find your installed packages. Set EMACSPACKAGEPATH 452 It may be that XEmacs cannot find your installed packages. Set
380 to the package hierarchy root or configure with --package-path to enable 453 EMACSPACKAGEPATH to the package hierarchy root or configure with
381 the skipped tests."))) 454 --package-path to enable the skipped tests.")))
382 (setq test-harness-file-results-alist 455 (setq test-harness-file-results-alist
383 (cons (list filename passes total) 456 (cons (list filename passes total)
384 test-harness-file-results-alist)) 457 test-harness-file-results-alist))
385 (message "%s" summary-msg)) 458 (message "%s" summary-msg))
386 (when unexpected-test-suite-failure 459 (when (> unexpected-test-file-failures 0)
460 (setq unexpected-test-suite-failure-files
461 (cons filename unexpected-test-suite-failure-files))
462 (setq unexpected-test-suite-failures
463 (+ unexpected-test-suite-failures unexpected-test-file-failures))
387 (message "Test suite execution failed unexpectedly.")) 464 (message "Test suite execution failed unexpectedly."))
388 (fmakunbound 'Assert) 465 (fmakunbound 'Assert)
389 (fmakunbound 'Check-Error) 466 (fmakunbound 'Check-Error)
390 (fmakunbound 'Check-Message) 467 (fmakunbound 'Check-Message)
391 (fmakunbound 'Check-Error-Message) 468 (fmakunbound 'Check-Error-Message)
508 nsucc 585 nsucc
509 ntest 586 ntest
510 (/ (* 100 nsucc) ntest)) 587 (/ (* 100 nsucc) ntest))
511 (message test-harness-null-summary-template 588 (message test-harness-null-summary-template
512 (concat basename ":"))) 589 (concat basename ":")))
513 (setq results (cdr results)))))) 590 (setq results (cdr results)))))
591 (when (> unexpected-test-suite-failures 0)
592 (message "\n***** There %s %d unexpected test suite %s in %s:"
593 (if (= unexpected-test-suite-failures 1) "was" "were")
594 unexpected-test-suite-failures
595 (if (= unexpected-test-suite-failures 1) "failure" "failures")
596 (if (= (length unexpected-test-suite-failure-files) 1)
597 "file"
598 "files"))
599 (while unexpected-test-suite-failure-files
600 (let ((line (pop unexpected-test-suite-failure-files)))
601 (while (and (< (length line) 61)
602 unexpected-test-suite-failure-files)
603 (setq line
604 (concat line " "
605 (pop unexpected-test-suite-failure-files))))
606 (message line)))))
514 (message "\nDone") 607 (message "\nDone")
515 (kill-emacs (if error 1 0)))) 608 (kill-emacs (if error 1 0))))
516 609
517 (provide 'test-harness) 610 (provide 'test-harness)
518 611