X-Git-Url: http://git.chise.org/gitweb/?p=chise%2Fxemacs-chise.git.1;a=blobdiff_plain;f=tests%2Fautomated%2Ftest-harness.el;h=ac318241177da319c412b369eeaaa5d3fe9b9abc;hp=e93046f14f2ac42fad99ffd60b01dfd30835d3d8;hb=8b2e8ef2dee7da2f0d4cea712b0fc55902c3cff7;hpb=dbf2768f7b146e97e37a27316f70bb313f1acf15 diff --git a/tests/automated/test-harness.el b/tests/automated/test-harness.el index e93046f..ac31824 100644 --- a/tests/automated/test-harness.el +++ b/tests/automated/test-harness.el @@ -1,8 +1,10 @@ ;; test-harness.el --- Run Emacs Lisp test suites. -;;; Copyright (C) 1998 Free Software Foundation, Inc. +;;; Copyright (C) 1998, 2002, 2003 Free Software Foundation, Inc. +;;; Copyright (C) 2002 Ben Wing. ;; Author: Martin Buchholz +;; Maintainer: Stephen J. Turnbull ;; Keywords: testing ;; This file is part of XEmacs. @@ -29,22 +31,80 @@ ;;; A test suite harness for testing XEmacs. ;;; The actual tests are in other files in this directory. ;;; Basically you just create files of emacs-lisp, and use the -;;; Assert, Check-Error, and Check-Message functions to create tests. +;;; Assert, Check-Error, Check-Message, and Check-Error-Message functions +;;; to create tests. See `test-harness-from-buffer' below. +;;; Don't suppress tests just because they're due to known bugs not yet +;;; fixed -- use the Known-Bug-Expect-Failure and +;;; Implementation-Incomplete-Expect-Failure wrapper macros to mark them. +;;; A lot of the tests we run push limits; suppress Ebola message with the +;;; Ignore-Ebola wrapper macro. +;;; Some noisy code will call `message'. Output from `message' can be +;;; suppressed with the Silence-Message macro. Functions that are known to +;;; issue messages include `write-region', `find-tag', `tag-loop-continue', +;;; `insert', and `mark-whole-buffer'. N.B. The Silence-Message macro +;;; currently does not suppress the newlines printed by `message'. +;;; Definitely do not use Silence-Message with Check-Message. +;;; In general it should probably only be used on code that prepares for a +;;; test, not on tests. +;;; ;;; You run the tests using M-x test-emacs-test-file, ;;; or $(EMACS) -batch -l .../test-harness.el -f batch-test-emacs file ... ;;; which is run for you by the `make check' target in the top-level Makefile. (require 'bytecomp) +(defvar unexpected-test-suite-failures 0 + "Cumulative number of unexpected failures since test-harness was loaded. + +\"Unexpected failures\" are those caught by a generic handler established +outside of the test context. As such they involve an abort of the test +suite for the file being tested. + +They often occur during preparation of a test or recording of the results. +For example, an executable used to generate test data might not be present +on the system, or a system error might occur while reading a data file.") + +(defvar unexpected-test-suite-failure-files nil + "List of test files causing unexpected failures.") + +;; Declared for dynamic scope; _do not_ initialize here. +(defvar unexpected-test-file-failures) + +(defvar test-harness-test-compiled nil + "Non-nil means the test code was compiled before execution.") + (defvar test-harness-verbose (and (not noninteractive) (> (device-baud-rate) search-slow-speed)) "*Non-nil means print messages describing progress of emacs-tester.") +(defvar test-harness-file-results-alist nil + "Each element is a list (FILE SUCCESSES TESTS). +The order is the reverse of the order in which tests are run. + +FILE is a string naming the test file. +SUCCESSES is a non-negative integer, the number of successes. +TESTS is a non-negative integer, the number of tests run.") + +(defvar test-harness-risk-infloops nil + "*Non-nil to run tests that may loop infinitely in buggy implementations.") + (defvar test-harness-current-file nil) (defvar emacs-lisp-file-regexp (purecopy "\\.el\\'") "*Regexp which matches Emacs Lisp source files.") +(defconst test-harness-file-summary-template + (format "%%-%ds %%%dd of %%%dd tests successful (%%3d%%%%)." + (length "byte-compiler-tests.el:") ; use the longest file name + 5 + 5) + "Format for summary lines printed after each file is run.") + +(defconst test-harness-null-summary-template + (format "%%-%ds No tests run." + (length "byte-compiler-tests.el:")) ; use the longest file name + "Format for \"No tests\" lines printed after a file is run.") + ;;;###autoload (defun test-emacs-test-file (filename) "Test a file of Lisp code named FILENAME. @@ -99,7 +159,9 @@ The output file's name is made by appending `c' to the end of FILENAME." (setq body (cons (read buffer) body))) (end-of-file nil) (error - (princ (format "Unexpected error %S reading forms from buffer\n" error-info)))) + (incf unexpected-test-file-failures) + (princ (format "Unexpected error %S reading forms from buffer\n" + error-info)))) `(lambda () (defvar passes) (defvar assertion-failures) @@ -108,7 +170,6 @@ The output file's name is made by appending `c' to the end of FILENAME." (defvar missing-message-failures) (defvar other-failures) - (defvar unexpected-test-suite-failure) (defvar trick-optimizer) ,@(nreverse body)))) @@ -122,23 +183,68 @@ The output file's name is made by appending `c' to the end of FILENAME." (wrong-error-failures 0) (missing-message-failures 0) (other-failures 0) + (unexpected-test-file-failures 0) + + ;; #### perhaps this should be a defvar, and output at the very end + ;; OTOH, this way AC types can use a null EMACSPACKAGEPATH to find + ;; what stuff is needed, and ways to avoid using them + (skipped-test-reasons (make-hash-table :test 'equal)) (trick-optimizer nil) - (unexpected-test-suite-failure nil) - (debug-on-error t)) + (debug-on-error t) + (pass-stream nil)) (with-output-to-temp-buffer "*Test-Log*" + (princ (format "Testing %s...\n\n" filename)) + + (defconst test-harness-failure-tag "FAIL") + (defconst test-harness-success-tag "PASS") + + (defmacro Known-Bug-Expect-Failure (&rest body) + `(let ((test-harness-failure-tag "KNOWN BUG") + (test-harness-success-tag "PASS (FAILURE EXPECTED)")) + ,@body)) + + (defmacro Implementation-Incomplete-Expect-Failure (&rest body) + `(let ((test-harness-failure-tag "IMPLEMENTATION INCOMPLETE") + (test-harness-success-tag "PASS (FAILURE EXPECTED)")) + ,@body)) + + (defun Print-Failure (fmt &rest args) + (setq fmt (format "%s: %s" test-harness-failure-tag fmt)) + (if (noninteractive) (apply #'message fmt args)) + (princ (concat (apply #'format fmt args) "\n"))) + + (defun Print-Pass (fmt &rest args) + (setq fmt (format "%s: %s" test-harness-success-tag fmt)) + (and test-harness-verbose + (princ (concat (apply #'format fmt args) "\n")))) + + (defun Print-Skip (test reason &optional fmt &rest args) + (setq fmt (concat "SKIP: %S BECAUSE %S" fmt)) + (princ (concat (apply #'format fmt test reason args) "\n"))) + + (defmacro Skip-Test-Unless (condition reason description &rest body) + "Unless CONDITION is satisfied, skip test BODY. +REASON is a description of the condition failure, and must be unique (it +is used as a hash key). DESCRIPTION describes the tests that were skipped. +BODY is a sequence of expressions and may contain several tests." + `(if (not ,condition) + (let ((count (gethash ,reason skipped-test-reasons))) + (puthash ,reason (if (null count) 1 (1+ count)) + skipped-test-reasons) + (Print-Skip ,description ,reason)) + ,@body)) (defmacro Assert (assertion) `(condition-case error-info (progn (assert ,assertion) - (princ (format "PASS: %S" (quote ,assertion))) - (terpri) + (Print-Pass "%S" (quote ,assertion)) (incf passes)) (cl-assertion-failed - (princ (format "FAIL: Assertion failed: %S\n" (quote ,assertion))) + (Print-Failure "Assertion failed: %S" (quote ,assertion)) (incf assertion-failures)) - (t (princ (format "FAIL: %S ==> error: %S\n" (quote ,assertion) error-info)) + (t (Print-Failure "%S ==> error: %S" (quote ,assertion) error-info) (incf other-failures) ))) @@ -148,70 +254,79 @@ The output file's name is made by appending `c' to the end of FILENAME." `(condition-case error-info (progn (setq trick-optimizer (progn ,@body)) - (princ (format "FAIL: %S executed successfully, but expected error %S\n" + (Print-Failure "%S executed successfully, but expected error %S" ,quoted-body - ',expected-error)) + ',expected-error) (incf no-error-failures)) (,expected-error - (princ (format "PASS: %S ==> error %S, as expected\n" - ,quoted-body ',expected-error)) + (Print-Pass "%S ==> error %S, as expected" + ,quoted-body ',expected-error) (incf passes)) (error - (princ (format "FAIL: %S ==> expected error %S, got error %S instead\n" - ,quoted-body ',expected-error error-info)) + (Print-Failure "%S ==> expected error %S, got error %S instead" + ,quoted-body ',expected-error error-info) (incf wrong-error-failures))))) - (defmacro Check-Error-Message (expected-error expected-error-regexp &rest body) + (defmacro Check-Error-Message (expected-error expected-error-regexp + &rest body) (let ((quoted-body (if (= 1 (length body)) `(quote ,(car body)) `(quote (progn ,@body))))) `(condition-case error-info (progn (setq trick-optimizer (progn ,@body)) - (princ (format "FAIL: %S executed successfully, but expected error %S\n" - ,quoted-body - ',expected-error)) + (Print-Failure "%S executed successfully, but expected error %S" + ,quoted-body ',expected-error) (incf no-error-failures)) (,expected-error (let ((error-message (second error-info))) (if (string-match ,expected-error-regexp error-message) (progn - (princ (format "PASS: %S ==> error %S %S, as expected\n" - ,quoted-body error-message ',expected-error)) + (Print-Pass "%S ==> error %S %S, as expected" + ,quoted-body error-message ',expected-error) (incf passes)) - (princ (format "FAIL: %S ==> got error %S as expected, but error message %S did not match regexp %S\n" - ,quoted-body ',expected-error error-message ,expected-error-regexp)) + (Print-Failure "%S ==> got error %S as expected, but error message %S did not match regexp %S" + ,quoted-body ',expected-error error-message ,expected-error-regexp) (incf wrong-error-failures)))) (error - (princ (format "FAIL: %S ==> expected error %S, got error %S instead\n" - ,quoted-body ',expected-error error-info)) + (Print-Failure "%S ==> expected error %S, got error %S instead" + ,quoted-body ',expected-error error-info) (incf wrong-error-failures))))) - + ;; Do not use this with Silence-Message. (defmacro Check-Message (expected-message-regexp &rest body) - (let ((quoted-body (if (= 1 (length body)) - `(quote ,(car body)) `(quote (progn ,@body))))) - `(let ((messages "")) - (defadvice message (around collect activate) - (defvar messages) - (let ((msg-string (apply 'format (ad-get-args 0)))) - (setq messages (concat messages msg-string)) - msg-string)) - (condition-case error-info - (progn - (setq trick-optimizer (progn ,@body)) - (if (string-match ,expected-message-regexp messages) - (progn - (princ (format "PASS: %S ==> value %S, message %S, matching %S, as expected\n" - ,quoted-body trick-optimizer messages ',expected-message-regexp)) - (incf passes)) - (princ (format "FAIL: %S ==> value %S, message %S, NOT matching expected %S\n" - ,quoted-body trick-optimizer messages ',expected-message-regexp)) - (incf missing-message-failures))) - (error - (princ (format "FAIL: %S ==> unexpected error %S\n" - ,quoted-body error-info)) - (incf other-failures))) - (ad-unadvise 'message)))) + (Skip-Test-Unless (fboundp 'defadvice) + "can't defadvice" + expected-message-regexp + (let ((quoted-body (if (= 1 (length body)) + `(quote ,(car body)) + `(quote (progn ,@body))))) + `(let ((messages "")) + (defadvice message (around collect activate) + (defvar messages) + (let ((msg-string (apply 'format (ad-get-args 0)))) + (setq messages (concat messages msg-string)) + msg-string)) + (condition-case error-info + (progn + (setq trick-optimizer (progn ,@body)) + (if (string-match ,expected-message-regexp messages) + (progn + (Print-Pass "%S ==> value %S, message %S, matching %S, as expected" + ,quoted-body trick-optimizer messages ',expected-message-regexp) + (incf passes)) + (Print-Failure "%S ==> value %S, message %S, NOT matching expected %S" + ,quoted-body trick-optimizer messages + ',expected-message-regexp) + (incf missing-message-failures))) + (error + (Print-Failure "%S ==> unexpected error %S" + ,quoted-body error-info) + (incf other-failures))) + (ad-unadvise 'message))))) + + ;; #### Perhaps this should override `message' itself, too? + (defmacro Silence-Message (&rest body) + `(flet ((append-message (&rest args) ())) ,@body)) (defmacro Ignore-Ebola (&rest body) `(let ((debug-issue-ebola-notices -42)) ,@body)) @@ -227,14 +342,15 @@ The output file's name is made by appending `c' to the end of FILENAME." (condition-case error-info (funcall (test-harness-read-from-buffer inbuffer)) (error - (setq unexpected-test-suite-failure t) + (incf unexpected-test-file-failures) (princ (format "Unexpected error %S while executing interpreted code\n" error-info)) (message "Unexpected error %S while executing interpreted code." error-info) (message "Test suite execution aborted." error-info) )) (princ "\nTesting Compiled Lisp\n\n") - (let (code) + (let (code + (test-harness-test-compiled t)) (condition-case error-info (setq code ;; our lisp code is often intentionally dubious, @@ -247,12 +363,13 @@ The output file's name is made by appending `c' to the end of FILENAME." (condition-case error-info (if code (funcall code)) (error + (incf unexpected-test-file-failures) (princ (format "Unexpected error %S while executing byte-compiled code\n" error-info)) (message "Unexpected error %S while executing byte-compiled code." error-info) (message "Test suite execution aborted." error-info) ))) - (princ "\nSUMMARY:\n") + (princ (format "\nSUMMARY for %s:\n" filename)) (princ (format "\t%5d passes\n" passes)) (princ (format "\t%5d assertion failures\n" assertion-failures)) (princ (format "\t%5d errors that should have been generated, but weren't\n" no-error-failures)) @@ -268,11 +385,32 @@ The output file's name is made by appending `c' to the end of FILENAME." (basename (file-name-nondirectory filename)) (summary-msg (if (> total 0) - (format "%s: %d of %d (%d%%) tests successful." - basename passes total (/ (* 100 passes) total)) - (format "%s: No tests run" basename)))) + (format test-harness-file-summary-template + (concat basename ":") + passes total (/ (* 100 passes) total)) + (format test-harness-null-summary-template + (concat basename ":")))) + (reasons "")) + (maphash (lambda (key value) + (setq reasons + (concat reasons + (format "\n %d tests skipped because %s." + value key)))) + skipped-test-reasons) + (when (> (length reasons) 1) + (setq summary-msg (concat summary-msg reasons " + Probably XEmacs cannot find your installed packages. Set EMACSPACKAGEPATH + to the package hierarchy root or configure with --package-path to enable + the skipped tests."))) + (setq test-harness-file-results-alist + (cons (list filename passes total) + test-harness-file-results-alist)) (message "%s" summary-msg)) - (when unexpected-test-suite-failure + (when (> unexpected-test-file-failures 0) + (setq unexpected-test-suite-failure-files + (cons filename unexpected-test-suite-failure-files)) + (setq unexpected-test-suite-failures + (+ unexpected-test-suite-failures unexpected-test-file-failures)) (message "Test suite execution failed unexpectedly.")) (fmakunbound 'Assert) (fmakunbound 'Check-Error) @@ -280,6 +418,9 @@ The output file's name is made by appending `c' to the end of FILENAME." (fmakunbound 'Check-Error-Message) (fmakunbound 'Ignore-Ebola) (fmakunbound 'Int-to-Marker) + (and noninteractive + (message "%s" (buffer-substring-no-properties + nil nil "*Test-Log*"))) ))) (defvar test-harness-results-point-max nil) @@ -359,8 +500,61 @@ For example, invoke \"xemacs -batch -f batch-test-emacs tests/*.el\"" (setq error t)))) (or (batch-test-emacs-1 file) (setq error t)))) - ;;(message "%s" (buffer-string nil nil "*Test-Log*")) - (message "Done") + (let ((namelen 0) + (succlen 0) + (testlen 0) + (results test-harness-file-results-alist)) + ;; compute maximum lengths of variable components of report + ;; probably should just use (length "byte-compiler-tests.el") + ;; and 5-place sizes -- this will also work for the file-by-file + ;; printing when Adrian's kludge gets reverted + (flet ((print-width (i) + (let ((x 10) (y 1)) + (while (>= i x) + (setq x (* 10 x) y (1+ y))) + y))) + (while results + (let* ((head (car results)) + (nn (length (file-name-nondirectory (first head)))) + (ss (print-width (second head))) + (tt (print-width (third head)))) + (when (> nn namelen) (setq namelen nn)) + (when (> ss succlen) (setq succlen ss)) + (when (> tt testlen) (setq testlen tt))) + (setq results (cdr results)))) + ;; create format and print + (let ((results (reverse test-harness-file-results-alist))) + (while results + (let* ((head (car results)) + (basename (file-name-nondirectory (first head))) + (nsucc (second head)) + (ntest (third head))) + (if (> ntest 0) + (message test-harness-file-summary-template + (concat basename ":") + nsucc + ntest + (/ (* 100 nsucc) ntest)) + (message test-harness-null-summary-template + (concat basename ":"))) + (setq results (cdr results))))) + (when (> unexpected-test-suite-failures 0) + (message "\n***** There %s %d unexpected test suite %s in %s:" + (if (= unexpected-test-suite-failures 1) "was" "were") + unexpected-test-suite-failures + (if (= unexpected-test-suite-failures 1) "failure" "failures") + (if (= (length unexpected-test-suite-failure-files) 1) + "file" + "files")) + (while unexpected-test-suite-failure-files + (let ((line (pop unexpected-test-suite-failure-files))) + (while (and (< (length line) 61) + unexpected-test-suite-failure-files) + (setq line + (concat line " " + (pop unexpected-test-suite-failure-files)))) + (message line))))) + (message "\nDone") (kill-emacs (if error 1 0)))) (provide 'test-harness)