Mercurial > hg > xemacs-beta

comparison tests/automated/test-harness.el @ 5125:b5df3737028a ben-lisp-object

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
merge
author Ben Wing <ben@xemacs.org>
date Wed, 24 Feb 2010 01:58:04 -0600
parents e813cf16c015
children 3daf9fc57cd4
comparison
equal deleted inserted replaced
5124:623d57b7fbe8 5125:b5df3737028a
1 ;; test-harness.el --- Run Emacs Lisp test suites. 1 ;; test-harness.el --- Run Emacs Lisp test suites.
2 2
3 ;;; Copyright (C) 1998, 2002, 2003 Free Software Foundation, Inc. 3 ;;; Copyright (C) 1998, 2002, 2003 Free Software Foundation, Inc.
4 ;;; Copyright (C) 2002 Ben Wing. 4 ;;; Copyright (C) 2002, 2010 Ben Wing.
5 5
6 ;; Author: Martin Buchholz 6 ;; Author: Martin Buchholz
7 ;; Maintainer: Stephen J. Turnbull <stephen@xemacs.org> 7 ;; Maintainer: Stephen J. Turnbull <stephen@xemacs.org>
8 ;; Keywords: testing 8 ;; Keywords: testing
9 9
113 (defconst test-harness-null-summary-template 113 (defconst test-harness-null-summary-template
114 (format "%%-%ds No tests run." 114 (format "%%-%ds No tests run."
115 (length "byte-compiler-tests.el:")) ; use the longest file name 115 (length "byte-compiler-tests.el:")) ; use the longest file name
116 "Format for \"No tests\" lines printed after a file is run.") 116 "Format for \"No tests\" lines printed after a file is run.")
117 117
118 (defconst test-harness-aborted-summary-template
119 (format "%%-%ds %%%dd tests completed (aborted)."
120 (length "byte-compiler-tests.el:") ; use the longest file name
121 5)
122 "Format for summary lines printed after a test run on a file was aborted.")
123
118 ;;;###autoload 124 ;;;###autoload
119 (defun test-emacs-test-file (filename) 125 (defun test-emacs-test-file (filename)
120 "Test a file of Lisp code named FILENAME. 126 "Test a file of Lisp code named FILENAME.
121 The output file's name is made by appending `c' to the end of FILENAME." 127 The output file's name is made by appending `c' to the end of FILENAME."
122 (interactive 128 (interactive
207 (princ (format "Testing %s...\n\n" filename)) 213 (princ (format "Testing %s...\n\n" filename))
208 214
209 (defconst test-harness-failure-tag "FAIL") 215 (defconst test-harness-failure-tag "FAIL")
210 (defconst test-harness-success-tag "PASS") 216 (defconst test-harness-success-tag "PASS")
211 217
218 ;;;;; BEGIN DEFINITION OF MACROS USEFUL IN TEST CODE
219
212 (defmacro Known-Bug-Expect-Failure (&rest body) 220 (defmacro Known-Bug-Expect-Failure (&rest body)
221 "Wrap a BODY that consists of tests that are known to fail.
222 This causes messages to be printed on failure indicating that this is expected,
223 and on success indicating that this is unexpected."
213 `(let ((test-harness-failure-tag "KNOWN BUG") 224 `(let ((test-harness-failure-tag "KNOWN BUG")
214 (test-harness-success-tag "PASS (FAILURE EXPECTED)")) 225 (test-harness-success-tag "PASS (FAILURE EXPECTED)"))
215 ,@body)) 226 ,@body))
216 227
217 (defmacro Known-Bug-Expect-Error (expected-error &rest body) 228 (defmacro Known-Bug-Expect-Error (expected-error &rest body)
229 "Wrap a BODY that consists of tests that are known to trigger an error.
230 This causes messages to be printed on failure indicating that this is expected,
231 and on success indicating that this is unexpected."
218 (let ((quoted-body (if (= 1 (length body)) 232 (let ((quoted-body (if (= 1 (length body))
219 `(quote ,(car body)) `(quote (progn ,@body))))) 233 `(quote ,(car body)) `(quote (progn ,@body)))))
220 `(let ((test-harness-failure-tag "KNOWN BUG") 234 `(let ((test-harness-failure-tag "KNOWN BUG")
221 (test-harness-success-tag "PASS (FAILURE EXPECTED)")) 235 (test-harness-success-tag "PASS (FAILURE EXPECTED)"))
222 (condition-case error-info 236 (condition-case error-info
235 (Print-Failure "%S ==> expected error %S, got error %S instead" 249 (Print-Failure "%S ==> expected error %S, got error %S instead"
236 ,quoted-body ',expected-error error-info) 250 ,quoted-body ',expected-error error-info)
237 (incf wrong-error-failures)))))) 251 (incf wrong-error-failures))))))
238 252
239 (defmacro Implementation-Incomplete-Expect-Failure (&rest body) 253 (defmacro Implementation-Incomplete-Expect-Failure (&rest body)
254 "Wrap a BODY containing tests that are known to fail due to incomplete code.
255 This causes messages to be printed on failure indicating that the
256 implementation is incomplete (and hence the failure is expected); and on
257 success indicating that this is unexpected."
240 `(let ((test-harness-failure-tag "IMPLEMENTATION INCOMPLETE") 258 `(let ((test-harness-failure-tag "IMPLEMENTATION INCOMPLETE")
241 (test-harness-success-tag "PASS (FAILURE EXPECTED)")) 259 (test-harness-success-tag "PASS (FAILURE EXPECTED)"))
242 ,@body)) 260 ,@body))
243 261
244 (defun Print-Failure (fmt &rest args) 262 (defun Print-Failure (fmt &rest args)
267 (Print-Skip ,description ,reason)) 285 (Print-Skip ,description ,reason))
268 ,@body)) 286 ,@body))
269 287
270 (defmacro Assert (assertion &optional failing-case description) 288 (defmacro Assert (assertion &optional failing-case description)
271 "Test passes if ASSERTION is true. 289 "Test passes if ASSERTION is true.
272 Optional FAILING-CASE describes the particular failure. 290 Optional FAILING-CASE describes the particular failure. Optional
273 Optional DESCRIPTION describes the assertion. 291 DESCRIPTION describes the assertion; by default, the unevalated assertion
274 FAILING-CASE and DESCRIPTION are useful when Assert is used in a loop." 292 expression is given. FAILING-CASE and DESCRIPTION are useful when Assert
275 `(condition-case error-info 293 is used in a loop."
276 (progn 294 (let ((description
277 (assert ,assertion) 295 (or description `(quote ,assertion))))
278 (Print-Pass "%S" (quote ,(or description assertion))) 296 `(condition-case error-info
279 (incf passes)) 297 (progn
280 (cl-assertion-failed 298 (assert ,assertion)
281 (Print-Failure (if ,failing-case 299 (Print-Pass "%S" ,description)
282 "Assertion failed: %S; failing case = %S" 300 (incf passes))
283 "Assertion failed: %S") 301 (cl-assertion-failed
284 (quote ,(or description assertion)) ,failing-case) 302 (Print-Failure (if ,failing-case
285 (incf assertion-failures)) 303 "Assertion failed: %S; failing case = %S"
286 (t (Print-Failure (if ,failing-case 304 "Assertion failed: %S")
287 "%S ==> error: %S; failing case = %S" 305 ,description ,failing-case)
288 "%S ==> error: %S") 306 (incf assertion-failures))
289 (quote ,(or description assertion)) 307 (t (Print-Failure (if ,failing-case
290 error-info ,failing-case) 308 "%S ==> error: %S; failing case = %S"
291 (incf other-failures) 309 "%S ==> error: %S")
292 ))) 310 ,description error-info ,failing-case)
293 311 (incf other-failures)
312 ))))
313
314 ;;;;; BEGIN DEFINITION OF SPECIFIC KINDS OF ASSERT MACROS
315
316 (defmacro Assert-test (test testval expected &optional failing-case
317 description)
318 "Test passes if TESTVAL compares correctly to EXPECTED using TEST.
319 TEST should be a two-argument predicate (i.e. a function of two arguments
320 that returns t or nil), such as `eq', `eql', `equal', `equalp', `=', `<=',
321 '>', 'file-newer-than-file-p' etc. Optional FAILING-CASE describes the
322 particular failure; any value given here will be concatenated with a phrase
323 describing the expected and actual values of the comparison. Optional
324 DESCRIPTION describes the assertion; by default, the unevalated comparison
325 expressions are given. FAILING-CASE and DESCRIPTION are useful when Assert
326 is used in a loop."
327 (let* ((assertion `(,test ,testval ,expected))
328 (failmsg `(format "%S should be `%s' to %S but isn't"
329 ,testval ',test ,expected))
330 (failmsg2 (if failing-case `(concat
331 (format "%S, " ,failing-case)
332 ,failmsg)
333 failmsg)))
334 `(Assert ,assertion ,failmsg2 ,description)))
335
336 (defmacro Assert-test-not (test testval expected &optional failing-case
337 description)
338 "Test passes if TESTVAL does not compare correctly to EXPECTED using TEST.
339 TEST should be a two-argument predicate (i.e. a function of two arguments
340 that returns t or nil), such as `eq', `eql', `equal', `equalp', `=', `<=',
341 '>', 'file-newer-than-file-p' etc. Optional FAILING-CASE describes the
342 particular failure; any value given here will be concatenated with a phrase
343 describing the expected and actual values of the comparison. Optional
344 DESCRIPTION describes the assertion; by default, the unevalated comparison
345 expressions are given. FAILING-CASE and DESCRIPTION are useful when Assert
346 is used in a loop."
347 (let* ((assertion `(not (,test ,testval ,expected)))
348 (failmsg `(format "%S shouldn't be `%s' to %S but is"
349 ,testval ',test ,expected))
350 (failmsg2 (if failing-case `(concat
351 (format "%S, " ,failing-case)
352 ,failmsg)
353 failmsg)))
354 `(Assert ,assertion ,failmsg2 ,description)))
355
356 ;; Specific versions of `Assert-test'. These are just convenience
357 ;; functions, functioning identically to `Assert-test', and duplicating
358 ;; the doc string for each would be too annoying.
359 (defmacro Assert-eq (testval expected &optional failing-case
360 description)
361 `(Assert-test eq ,testval ,expected ,failing-case ,description))
362 (defmacro Assert-eql (testval expected &optional failing-case
363 description)
364 `(Assert-test eql ,testval ,expected ,failing-case ,description))
365 (defmacro Assert-equal (testval expected &optional failing-case
366 description)
367 `(Assert-test equal ,testval ,expected ,failing-case ,description))
368 (defmacro Assert-equalp (testval expected &optional failing-case
369 description)
370 `(Assert-test equalp ,testval ,expected ,failing-case ,description))
371 (defmacro Assert-string= (testval expected &optional failing-case
372 description)
373 `(Assert-test string= ,testval ,expected ,failing-case ,description))
374 (defmacro Assert= (testval expected &optional failing-case
375 description)
376 `(Assert-test = ,testval ,expected ,failing-case ,description))
377 (defmacro Assert<= (testval expected &optional failing-case
378 description)
379 `(Assert-test <= ,testval ,expected ,failing-case ,description))
380
381 ;; Specific versions of `Assert-test-not'. These are just convenience
382 ;; functions, functioning identically to `Assert-test-not', and
383 ;; duplicating the doc string for each would be too annoying.
384 (defmacro Assert-not-eq (testval expected &optional failing-case
385 description)
386 `(Assert-test-not eq ,testval ,expected ,failing-case ,description))
387 (defmacro Assert-not-eql (testval expected &optional failing-case
388 description)
389 `(Assert-test-not eql ,testval ,expected ,failing-case ,description))
390 (defmacro Assert-not-equal (testval expected &optional failing-case
391 description)
392 `(Assert-test-not equal ,testval ,expected ,failing-case ,description))
393 (defmacro Assert-not-equalp (testval expected &optional failing-case
394 description)
395 `(Assert-test-not equalp ,testval ,expected ,failing-case ,description))
396 (defmacro Assert-not-string= (testval expected &optional failing-case
397 description)
398 `(Assert-test-not string= ,testval ,expected ,failing-case ,description))
399 (defmacro Assert-not= (testval expected &optional failing-case
400 description)
401 `(Assert-test-not = ,testval ,expected ,failing-case ,description))
294 402
295 (defmacro Check-Error (expected-error &rest body) 403 (defmacro Check-Error (expected-error &rest body)
296 (let ((quoted-body (if (= 1 (length body)) 404 (let ((quoted-body (if (= 1 (length body))
297 `(quote ,(car body)) `(quote (progn ,@body))))) 405 `(quote ,(car body)) `(quote (progn ,@body)))))
298 `(condition-case error-info 406 `(condition-case error-info
394 (error 502 (error
395 (incf unexpected-test-file-failures) 503 (incf unexpected-test-file-failures)
396 (princ (format "Unexpected error %S while executing interpreted code\n" 504 (princ (format "Unexpected error %S while executing interpreted code\n"
397 error-info)) 505 error-info))
398 (message "Unexpected error %S while executing interpreted code." error-info) 506 (message "Unexpected error %S while executing interpreted code." error-info)
399 (message "Test suite execution aborted." error-info) 507 (message "Test suite execution aborted.")
400 )) 508 ))
401 (princ "\nTesting Compiled Lisp\n\n") 509 (princ "\nTesting Compiled Lisp\n\n")
402 (let (code 510 (let (code
403 (test-harness-test-compiled t)) 511 (test-harness-test-compiled t))
404 (condition-case error-info 512 (condition-case error-info
415 (error 523 (error
416 (incf unexpected-test-file-failures) 524 (incf unexpected-test-file-failures)
417 (princ (format "Unexpected error %S while executing byte-compiled code\n" 525 (princ (format "Unexpected error %S while executing byte-compiled code\n"
418 error-info)) 526 error-info))
419 (message "Unexpected error %S while executing byte-compiled code." error-info) 527 (message "Unexpected error %S while executing byte-compiled code." error-info)
420 (message "Test suite execution aborted." error-info) 528 (message "Test suite execution aborted.")
421 ))) 529 )))
422 (princ (format "\nSUMMARY for %s:\n" filename)) 530 (princ (format "\nSUMMARY for %s:\n" filename))
423 (princ (format "\t%5d passes\n" passes)) 531 (princ (format "\t%5d passes\n" passes))
424 (princ (format "\t%5d assertion failures\n" assertion-failures)) 532 (princ (format "\t%5d assertion failures\n" assertion-failures))
425 (princ (format "\t%5d errors that should have been generated, but weren't\n" no-error-failures)) 533 (princ (format "\t%5d errors that should have been generated, but weren't\n" no-error-failures))
432 wrong-error-failures 540 wrong-error-failures
433 missing-message-failures 541 missing-message-failures
434 other-failures)) 542 other-failures))
435 (basename (file-name-nondirectory filename)) 543 (basename (file-name-nondirectory filename))
436 (summary-msg 544 (summary-msg
437 (if (> total 0) 545 (cond ((> unexpected-test-file-failures 0)
438 (format test-harness-file-summary-template 546 (format test-harness-aborted-summary-template
439 (concat basename ":") 547 (concat basename ":") total))
440 passes total (/ (* 100 passes) total)) 548 ((> total 0)
441 (format test-harness-null-summary-template 549 (format test-harness-file-summary-template
442 (concat basename ":")))) 550 (concat basename ":")
551 passes total (/ (* 100 passes) total)))
552 (t
553 (format test-harness-null-summary-template
554 (concat basename ":")))))
443 (reasons "")) 555 (reasons ""))
444 (maphash (lambda (key value) 556 (maphash (lambda (key value)
445 (setq reasons 557 (setq reasons
446 (concat reasons 558 (concat reasons
447 (format "\n %d tests skipped because %s." 559 (format "\n %d tests skipped because %s."
528 (defun batch-test-emacs () 640 (defun batch-test-emacs ()
529 "Run `test-harness' on the files remaining on the command line. 641 "Run `test-harness' on the files remaining on the command line.
530 Use this from the command line, with `-batch'; 642 Use this from the command line, with `-batch';
531 it won't work in an interactive Emacs. 643 it won't work in an interactive Emacs.
532 Each file is processed even if an error occurred previously. 644 Each file is processed even if an error occurred previously.
533 For example, invoke \"xemacs -batch -f batch-test-emacs tests/*.el\"" 645 A directory can be given as well, and all files will be processed --
646 however, the file test-harness.el, which implements the test harness,
647 will be skipped.
648 For example, invoke \"xemacs -batch -f batch-test-emacs tests\""
534 ;; command-line-args-left is what is left of the command line (from 649 ;; command-line-args-left is what is left of the command line (from
535 ;; startup.el) 650 ;; startup.el)
536 (defvar command-line-args-left) ;Avoid 'free variable' warning 651 (defvar command-line-args-left) ;Avoid 'free variable' warning
537 (defvar debug-issue-ebola-notices) 652 (defvar debug-issue-ebola-notices)
538 (if (not noninteractive) 653 (if (not noninteractive)
577 (while results 692 (while results
578 (let* ((head (car results)) 693 (let* ((head (car results))
579 (basename (file-name-nondirectory (first head))) 694 (basename (file-name-nondirectory (first head)))
580 (nsucc (second head)) 695 (nsucc (second head))
581 (ntest (third head))) 696 (ntest (third head)))
582 (if (> ntest 0) 697 (cond ((member (first head) unexpected-test-suite-failure-files)
583 (message test-harness-file-summary-template 698 (message test-harness-aborted-summary-template
584 (concat basename ":") 699 (concat basename ":")
585 nsucc 700 ntest))
586 ntest 701 ((> ntest 0)
587 (/ (* 100 nsucc) ntest)) 702 (message test-harness-file-summary-template
588 (message test-harness-null-summary-template 703 (concat basename ":")
589 (concat basename ":"))) 704 nsucc
705 ntest
706 (/ (* 100 nsucc) ntest)))
707 (t
708 (message test-harness-null-summary-template
709 (concat basename ":"))))
590 (setq results (cdr results))))) 710 (setq results (cdr results)))))
591 (when (> unexpected-test-suite-failures 0) 711 (when (> unexpected-test-suite-failures 0)
592 (message "\n***** There %s %d unexpected test suite %s in %s:" 712 (message "\n***** There %s %d unexpected test suite %s in %s:"
593 (if (= unexpected-test-suite-failures 1) "was" "were") 713 (if (= unexpected-test-suite-failures 1) "was" "were")
594 unexpected-test-suite-failures 714 unexpected-test-suite-failures