Mercurial > hg > xemacs-beta
annotate lisp/test-harness.el @ 5541:ebd367b82ccd
Improve treatment of expected bugs.
* * *
Simplify Known-Bug-Expect-Error to produce cleaner output.
| author | Stephen J. Turnbull <stephen@xemacs.org> |
|---|---|
| date | Mon, 08 Aug 2011 13:57:19 +0900 |
| parents | ac37a5f7e5be |
| children | 3bc58dc9d688 |
| rev | line source |
|---|---|
| 428 | 1 ;; test-harness.el --- Run Emacs Lisp test suites. |
| 2 | |
| 1751 | 3 ;;; Copyright (C) 1998, 2002, 2003 Free Software Foundation, Inc. |
| 4856 | 4 ;;; Copyright (C) 2002, 2010 Ben Wing. |
| 428 | 5 |
| 6 ;; Author: Martin Buchholz | |
| 1761 | 7 ;; Maintainer: Stephen J. Turnbull <stephen@xemacs.org> |
| 428 | 8 ;; Keywords: testing |
| 9 | |
| 10 ;; This file is part of XEmacs. | |
| 11 | |
|
5402
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
5274
diff
changeset
|
12 ;; XEmacs is free software: you can redistribute it and/or modify it |
|
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
5274
diff
changeset
|
13 ;; under the terms of the GNU General Public License as published by the |
|
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
5274
diff
changeset
|
14 ;; Free Software Foundation, either version 3 of the License, or (at your |
|
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
5274
diff
changeset
|
15 ;; option) any later version. |
| 428 | 16 |
|
5402
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
5274
diff
changeset
|
17 ;; XEmacs is distributed in the hope that it will be useful, but WITHOUT |
|
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
5274
diff
changeset
|
18 ;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or |
|
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
5274
diff
changeset
|
19 ;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License |
|
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
5274
diff
changeset
|
20 ;; for more details. |
| 428 | 21 |
| 22 ;; You should have received a copy of the GNU General Public License | |
|
5402
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
5274
diff
changeset
|
23 ;; along with XEmacs. If not, see <http://www.gnu.org/licenses/>. |
| 428 | 24 |
| 25 ;;; Synched up with: Not in FSF. | |
| 26 | |
| 27 ;;; Commentary: | |
| 28 | |
| 29 ;;; A test suite harness for testing XEmacs. | |
| 30 ;;; The actual tests are in other files in this directory. | |
| 31 ;;; Basically you just create files of emacs-lisp, and use the | |
| 1095 | 32 ;;; Assert, Check-Error, Check-Message, and Check-Error-Message functions |
| 33 ;;; to create tests. See `test-harness-from-buffer' below. | |
| 34 ;;; Don't suppress tests just because they're due to known bugs not yet | |
| 1413 | 35 ;;; fixed -- use the Known-Bug-Expect-Failure and |
| 36 ;;; Implementation-Incomplete-Expect-Failure wrapper macros to mark them. | |
| 1095 | 37 ;;; A lot of the tests we run push limits; suppress Ebola message with the |
| 38 ;;; Ignore-Ebola wrapper macro. | |
| 3472 | 39 ;;; Some noisy code will call `message'. Output from `message' can be |
| 40 ;;; suppressed with the Silence-Message macro. Functions that are known to | |
| 41 ;;; issue messages include `write-region', `find-tag', `tag-loop-continue', | |
| 42 ;;; `insert', and `mark-whole-buffer'. N.B. The Silence-Message macro | |
| 43 ;;; currently does not suppress the newlines printed by `message'. | |
| 44 ;;; Definitely do not use Silence-Message with Check-Message. | |
| 45 ;;; In general it should probably only be used on code that prepares for a | |
| 46 ;;; test, not on tests. | |
| 1095 | 47 ;;; |
| 428 | 48 ;;; You run the tests using M-x test-emacs-test-file, |
|
5069
14f0dd1fabdb
move test-harness to lisp/ directory so it gets byte-compiled
Ben Wing <ben@xemacs.org>
parents:
5064
diff
changeset
|
49 ;;; or $(EMACS) -batch -l test-harness -f batch-test-emacs file ... |
| 428 | 50 ;;; which is run for you by the `make check' target in the top-level Makefile. |
| 51 | |
| 52 (require 'bytecomp) | |
| 53 | |
| 3471 | 54 (defvar unexpected-test-suite-failures 0 |
| 55 "Cumulative number of unexpected failures since test-harness was loaded. | |
| 56 | |
| 57 \"Unexpected failures\" are those caught by a generic handler established | |
| 58 outside of the test context. As such they involve an abort of the test | |
| 59 suite for the file being tested. | |
| 60 | |
| 61 They often occur during preparation of a test or recording of the results. | |
| 62 For example, an executable used to generate test data might not be present | |
| 63 on the system, or a system error might occur while reading a data file.") | |
| 64 | |
| 65 (defvar unexpected-test-suite-failure-files nil | |
| 66 "List of test files causing unexpected failures.") | |
| 67 | |
| 68 ;; Declared for dynamic scope; _do not_ initialize here. | |
| 69 (defvar unexpected-test-file-failures) | |
| 70 | |
|
5040
3daf9fc57cd4
fixes to test harness to allow backtracing/debugging of failures
Ben Wing <ben@xemacs.org>
parents:
4962
diff
changeset
|
71 (defvar test-harness-bug-expected nil |
|
5541
ebd367b82ccd
Improve treatment of expected bugs.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
5473
diff
changeset
|
72 "Non-nil means a bug is expected; backtracing/debugging should not happen. |
|
ebd367b82ccd
Improve treatment of expected bugs.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
5473
diff
changeset
|
73 However, the individual test summary should be printed.") |
|
5040
3daf9fc57cd4
fixes to test harness to allow backtracing/debugging of failures
Ben Wing <ben@xemacs.org>
parents:
4962
diff
changeset
|
74 |
| 1758 | 75 (defvar test-harness-test-compiled nil |
|
4366
7b628daa39d4
Move debugging code to usage example.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
4323
diff
changeset
|
76 "Non-nil means the test code was compiled before execution. |
|
7b628daa39d4
Move debugging code to usage example.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
4323
diff
changeset
|
77 |
|
7b628daa39d4
Move debugging code to usage example.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
4323
diff
changeset
|
78 You probably should not make tests depend on compilation. |
|
7b628daa39d4
Move debugging code to usage example.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
4323
diff
changeset
|
79 However, it can be useful to conditionally change messages based on whether |
|
7b628daa39d4
Move debugging code to usage example.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
4323
diff
changeset
|
80 the code was compiled or not. For example, the case that motivated the |
|
7b628daa39d4
Move debugging code to usage example.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
4323
diff
changeset
|
81 implementation of this variable: |
|
7b628daa39d4
Move debugging code to usage example.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
4323
diff
changeset
|
82 |
|
7b628daa39d4
Move debugging code to usage example.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
4323
diff
changeset
|
83 \(when test-harness-test-compiled |
|
7b628daa39d4
Move debugging code to usage example.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
4323
diff
changeset
|
84 ;; this ha-a-ack depends on the failing compiled test coming last |
|
7b628daa39d4
Move debugging code to usage example.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
4323
diff
changeset
|
85 \(setq test-harness-failure-tag |
|
7b628daa39d4
Move debugging code to usage example.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
4323
diff
changeset
|
86 \"KNOWN BUG - fix reverted; after 2003-10-31 notify stephen\n\"))") |
| 1758 | 87 |
| 428 | 88 (defvar test-harness-verbose |
| 89 (and (not noninteractive) (> (device-baud-rate) search-slow-speed)) | |
| 90 "*Non-nil means print messages describing progress of emacs-tester.") | |
| 91 | |
|
5040
3daf9fc57cd4
fixes to test harness to allow backtracing/debugging of failures
Ben Wing <ben@xemacs.org>
parents:
4962
diff
changeset
|
92 (defvar test-harness-unexpected-error-enter-debugger debug-on-error |
|
3daf9fc57cd4
fixes to test harness to allow backtracing/debugging of failures
Ben Wing <ben@xemacs.org>
parents:
4962
diff
changeset
|
93 "*Non-nil means enter debugger when an unexpected error occurs. |
|
3daf9fc57cd4
fixes to test harness to allow backtracing/debugging of failures
Ben Wing <ben@xemacs.org>
parents:
4962
diff
changeset
|
94 Only applies interactively. Normally true if `debug-on-error' has been set. |
|
3daf9fc57cd4
fixes to test harness to allow backtracing/debugging of failures
Ben Wing <ben@xemacs.org>
parents:
4962
diff
changeset
|
95 See also `test-harness-assertion-failure-enter-debugger' and |
|
3daf9fc57cd4
fixes to test harness to allow backtracing/debugging of failures
Ben Wing <ben@xemacs.org>
parents:
4962
diff
changeset
|
96 `test-harness-unexpected-error-show-backtrace'.") |
|
3daf9fc57cd4
fixes to test harness to allow backtracing/debugging of failures
Ben Wing <ben@xemacs.org>
parents:
4962
diff
changeset
|
97 |
|
3daf9fc57cd4
fixes to test harness to allow backtracing/debugging of failures
Ben Wing <ben@xemacs.org>
parents:
4962
diff
changeset
|
98 (defvar test-harness-assertion-failure-enter-debugger debug-on-error |
|
3daf9fc57cd4
fixes to test harness to allow backtracing/debugging of failures
Ben Wing <ben@xemacs.org>
parents:
4962
diff
changeset
|
99 "*Non-nil means enter debugger when an assertion failure occurs. |
|
3daf9fc57cd4
fixes to test harness to allow backtracing/debugging of failures
Ben Wing <ben@xemacs.org>
parents:
4962
diff
changeset
|
100 Only applies interactively. Normally true if `debug-on-error' has been set. |
|
3daf9fc57cd4
fixes to test harness to allow backtracing/debugging of failures
Ben Wing <ben@xemacs.org>
parents:
4962
diff
changeset
|
101 See also `test-harness-unexpected-error-enter-debugger' and |
|
3daf9fc57cd4
fixes to test harness to allow backtracing/debugging of failures
Ben Wing <ben@xemacs.org>
parents:
4962
diff
changeset
|
102 `test-harness-assertion-failure-show-backtrace'.") |
|
3daf9fc57cd4
fixes to test harness to allow backtracing/debugging of failures
Ben Wing <ben@xemacs.org>
parents:
4962
diff
changeset
|
103 |
|
3daf9fc57cd4
fixes to test harness to allow backtracing/debugging of failures
Ben Wing <ben@xemacs.org>
parents:
4962
diff
changeset
|
104 (defvar test-harness-unexpected-error-show-backtrace t |
|
3daf9fc57cd4
fixes to test harness to allow backtracing/debugging of failures
Ben Wing <ben@xemacs.org>
parents:
4962
diff
changeset
|
105 "*Non-nil means show backtrace upon unexpected error. |
|
3daf9fc57cd4
fixes to test harness to allow backtracing/debugging of failures
Ben Wing <ben@xemacs.org>
parents:
4962
diff
changeset
|
106 Only applies when debugger is not entered. Normally true by default. See also |
|
3daf9fc57cd4
fixes to test harness to allow backtracing/debugging of failures
Ben Wing <ben@xemacs.org>
parents:
4962
diff
changeset
|
107 `test-harness-unexpected-error-enter-debugger' and |
|
3daf9fc57cd4
fixes to test harness to allow backtracing/debugging of failures
Ben Wing <ben@xemacs.org>
parents:
4962
diff
changeset
|
108 `test-harness-assertion-failure-show-backtrace'.") |
|
3daf9fc57cd4
fixes to test harness to allow backtracing/debugging of failures
Ben Wing <ben@xemacs.org>
parents:
4962
diff
changeset
|
109 |
|
3daf9fc57cd4
fixes to test harness to allow backtracing/debugging of failures
Ben Wing <ben@xemacs.org>
parents:
4962
diff
changeset
|
110 (defvar test-harness-assertion-failure-show-backtrace stack-trace-on-error |
|
3daf9fc57cd4
fixes to test harness to allow backtracing/debugging of failures
Ben Wing <ben@xemacs.org>
parents:
4962
diff
changeset
|
111 "*Non-nil means show backtrace upon assertion failure. |
|
3daf9fc57cd4
fixes to test harness to allow backtracing/debugging of failures
Ben Wing <ben@xemacs.org>
parents:
4962
diff
changeset
|
112 Only applies when debugger is not entered. Normally true if |
|
3daf9fc57cd4
fixes to test harness to allow backtracing/debugging of failures
Ben Wing <ben@xemacs.org>
parents:
4962
diff
changeset
|
113 `stack-trace-on-error' has been set. See also |
|
3daf9fc57cd4
fixes to test harness to allow backtracing/debugging of failures
Ben Wing <ben@xemacs.org>
parents:
4962
diff
changeset
|
114 `test-harness-assertion-failure-enter-debugger' and |
|
3daf9fc57cd4
fixes to test harness to allow backtracing/debugging of failures
Ben Wing <ben@xemacs.org>
parents:
4962
diff
changeset
|
115 `test-harness-unexpected-error-show-backtrace'.") |
|
3daf9fc57cd4
fixes to test harness to allow backtracing/debugging of failures
Ben Wing <ben@xemacs.org>
parents:
4962
diff
changeset
|
116 |
| 1719 | 117 (defvar test-harness-file-results-alist nil |
| 118 "Each element is a list (FILE SUCCESSES TESTS). | |
| 119 The order is the reverse of the order in which tests are run. | |
| 120 | |
| 121 FILE is a string naming the test file. | |
| 122 SUCCESSES is a non-negative integer, the number of successes. | |
| 123 TESTS is a non-negative integer, the number of tests run.") | |
| 124 | |
| 1425 | 125 (defvar test-harness-risk-infloops nil |
| 126 "*Non-nil to run tests that may loop infinitely in buggy implementations.") | |
| 127 | |
| 428 | 128 (defvar test-harness-current-file nil) |
| 129 | |
|
5369
4141aeddc55b
Eliminate byte-compile warnings, core Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5366
diff
changeset
|
130 (defvar emacs-lisp-file-regexp "\\.el\\'" |
| 428 | 131 "*Regexp which matches Emacs Lisp source files.") |
| 132 | |
| 1751 | 133 (defconst test-harness-file-summary-template |
| 134 (format "%%-%ds %%%dd of %%%dd tests successful (%%3d%%%%)." | |
| 135 (length "byte-compiler-tests.el:") ; use the longest file name | |
| 136 5 | |
| 137 5) | |
| 138 "Format for summary lines printed after each file is run.") | |
| 139 | |
| 140 (defconst test-harness-null-summary-template | |
| 141 (format "%%-%ds No tests run." | |
| 142 (length "byte-compiler-tests.el:")) ; use the longest file name | |
| 143 "Format for \"No tests\" lines printed after a file is run.") | |
| 144 | |
|
4906
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4891
diff
changeset
|
145 (defconst test-harness-aborted-summary-template |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4891
diff
changeset
|
146 (format "%%-%ds %%%dd tests completed (aborted)." |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4891
diff
changeset
|
147 (length "byte-compiler-tests.el:") ; use the longest file name |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4891
diff
changeset
|
148 5) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4891
diff
changeset
|
149 "Format for summary lines printed after a test run on a file was aborted.") |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4891
diff
changeset
|
150 |
| 428 | 151 ;;;###autoload |
| 152 (defun test-emacs-test-file (filename) | |
| 153 "Test a file of Lisp code named FILENAME. | |
| 154 The output file's name is made by appending `c' to the end of FILENAME." | |
| 155 (interactive | |
| 156 (let ((file buffer-file-name) | |
| 157 (file-name nil) | |
| 158 (file-dir nil)) | |
| 159 (and file | |
| 160 (eq (cdr (assq 'major-mode (buffer-local-variables))) | |
| 161 'emacs-lisp-mode) | |
| 162 (setq file-name (file-name-nondirectory file) | |
| 163 file-dir (file-name-directory file))) | |
| 164 (list (read-file-name "Test file: " file-dir nil nil file-name)))) | |
| 165 ;; Expand now so we get the current buffer's defaults | |
| 166 (setq filename (expand-file-name filename)) | |
| 167 | |
| 168 ;; If we're testing a file that's in a buffer and is modified, offer | |
| 169 ;; to save it first. | |
| 170 (or noninteractive | |
| 171 (let ((b (get-file-buffer (expand-file-name filename)))) | |
| 172 (if (and b (buffer-modified-p b) | |
| 173 (y-or-n-p (format "save buffer %s first? " (buffer-name b)))) | |
| 174 (save-excursion (set-buffer b) (save-buffer))))) | |
| 175 | |
| 176 (if (or noninteractive test-harness-verbose) | |
| 177 (message "Testing %s..." filename)) | |
| 178 (let ((test-harness-current-file filename) | |
| 179 input-buffer) | |
| 180 (save-excursion | |
| 181 (setq input-buffer (get-buffer-create " *Test Input*")) | |
| 182 (set-buffer input-buffer) | |
| 183 (erase-buffer) | |
| 184 (insert-file-contents filename) | |
| 185 ;; Run hooks including the uncompression hook. | |
| 186 ;; If they change the file name, then change it for the output also. | |
| 187 (let ((buffer-file-name filename) | |
| 188 (default-major-mode 'emacs-lisp-mode) | |
| 189 (enable-local-eval nil)) | |
| 190 (normal-mode) | |
| 191 (setq filename buffer-file-name))) | |
| 192 (test-harness-from-buffer input-buffer filename) | |
| 193 (kill-buffer input-buffer) | |
| 194 )) | |
| 195 | |
| 5110 | 196 (defsubst test-harness-backtrace () |
| 197 "Display a reasonable-size backtrace." | |
| 198 (let ((print-escape-newlines t) | |
| 199 (print-length 50)) | |
| 200 (backtrace nil t))) | |
| 201 | |
|
5040
3daf9fc57cd4
fixes to test harness to allow backtracing/debugging of failures
Ben Wing <ben@xemacs.org>
parents:
4962
diff
changeset
|
202 (defsubst test-harness-assertion-failure-do-debug (error-info) |
|
3daf9fc57cd4
fixes to test harness to allow backtracing/debugging of failures
Ben Wing <ben@xemacs.org>
parents:
4962
diff
changeset
|
203 "Maybe enter debugger or display a backtrace on assertion failure. |
|
3daf9fc57cd4
fixes to test harness to allow backtracing/debugging of failures
Ben Wing <ben@xemacs.org>
parents:
4962
diff
changeset
|
204 ERROR-INFO is a cons of the args (SIG . DATA) that were passed to `signal'. |
|
3daf9fc57cd4
fixes to test harness to allow backtracing/debugging of failures
Ben Wing <ben@xemacs.org>
parents:
4962
diff
changeset
|
205 The debugger will be entered if noninteractive and |
|
3daf9fc57cd4
fixes to test harness to allow backtracing/debugging of failures
Ben Wing <ben@xemacs.org>
parents:
4962
diff
changeset
|
206 `test-harness-unexpected-error-enter-debugger' is non-nil; else, a |
|
3daf9fc57cd4
fixes to test harness to allow backtracing/debugging of failures
Ben Wing <ben@xemacs.org>
parents:
4962
diff
changeset
|
207 backtrace will be displayed if `test-harness-unexpected-error-show-backtrace' |
|
3daf9fc57cd4
fixes to test harness to allow backtracing/debugging of failures
Ben Wing <ben@xemacs.org>
parents:
4962
diff
changeset
|
208 is non-nil." |
|
3daf9fc57cd4
fixes to test harness to allow backtracing/debugging of failures
Ben Wing <ben@xemacs.org>
parents:
4962
diff
changeset
|
209 (when (not test-harness-bug-expected) |
|
3daf9fc57cd4
fixes to test harness to allow backtracing/debugging of failures
Ben Wing <ben@xemacs.org>
parents:
4962
diff
changeset
|
210 (cond ((and (not noninteractive) |
|
3daf9fc57cd4
fixes to test harness to allow backtracing/debugging of failures
Ben Wing <ben@xemacs.org>
parents:
4962
diff
changeset
|
211 test-harness-assertion-failure-enter-debugger) |
|
3daf9fc57cd4
fixes to test harness to allow backtracing/debugging of failures
Ben Wing <ben@xemacs.org>
parents:
4962
diff
changeset
|
212 (funcall debugger 'error error-info)) |
|
3daf9fc57cd4
fixes to test harness to allow backtracing/debugging of failures
Ben Wing <ben@xemacs.org>
parents:
4962
diff
changeset
|
213 (test-harness-assertion-failure-show-backtrace |
| 5110 | 214 (test-harness-backtrace))))) |
|
5040
3daf9fc57cd4
fixes to test harness to allow backtracing/debugging of failures
Ben Wing <ben@xemacs.org>
parents:
4962
diff
changeset
|
215 |
|
3daf9fc57cd4
fixes to test harness to allow backtracing/debugging of failures
Ben Wing <ben@xemacs.org>
parents:
4962
diff
changeset
|
216 (defsubst test-harness-unexpected-error-do-debug (error-info) |
|
3daf9fc57cd4
fixes to test harness to allow backtracing/debugging of failures
Ben Wing <ben@xemacs.org>
parents:
4962
diff
changeset
|
217 "Maybe enter debugger or display a backtrace on unexpected error. |
|
3daf9fc57cd4
fixes to test harness to allow backtracing/debugging of failures
Ben Wing <ben@xemacs.org>
parents:
4962
diff
changeset
|
218 ERROR-INFO is a cons of the args (SIG . DATA) that were passed to `signal'. |
|
3daf9fc57cd4
fixes to test harness to allow backtracing/debugging of failures
Ben Wing <ben@xemacs.org>
parents:
4962
diff
changeset
|
219 The debugger will be entered if noninteractive and |
|
3daf9fc57cd4
fixes to test harness to allow backtracing/debugging of failures
Ben Wing <ben@xemacs.org>
parents:
4962
diff
changeset
|
220 `test-harness-unexpected-error-enter-debugger' is non-nil; else, a |
|
3daf9fc57cd4
fixes to test harness to allow backtracing/debugging of failures
Ben Wing <ben@xemacs.org>
parents:
4962
diff
changeset
|
221 backtrace will be displayed if `test-harness-unexpected-error-show-backtrace' |
|
3daf9fc57cd4
fixes to test harness to allow backtracing/debugging of failures
Ben Wing <ben@xemacs.org>
parents:
4962
diff
changeset
|
222 is non-nil." |
|
3daf9fc57cd4
fixes to test harness to allow backtracing/debugging of failures
Ben Wing <ben@xemacs.org>
parents:
4962
diff
changeset
|
223 (when (not test-harness-bug-expected) |
|
3daf9fc57cd4
fixes to test harness to allow backtracing/debugging of failures
Ben Wing <ben@xemacs.org>
parents:
4962
diff
changeset
|
224 (cond ((and (not noninteractive) |
|
3daf9fc57cd4
fixes to test harness to allow backtracing/debugging of failures
Ben Wing <ben@xemacs.org>
parents:
4962
diff
changeset
|
225 test-harness-unexpected-error-enter-debugger) |
|
3daf9fc57cd4
fixes to test harness to allow backtracing/debugging of failures
Ben Wing <ben@xemacs.org>
parents:
4962
diff
changeset
|
226 (funcall debugger 'error error-info)) |
|
3daf9fc57cd4
fixes to test harness to allow backtracing/debugging of failures
Ben Wing <ben@xemacs.org>
parents:
4962
diff
changeset
|
227 (test-harness-unexpected-error-show-backtrace |
| 5110 | 228 (test-harness-backtrace))))) |
|
5040
3daf9fc57cd4
fixes to test harness to allow backtracing/debugging of failures
Ben Wing <ben@xemacs.org>
parents:
4962
diff
changeset
|
229 |
|
3daf9fc57cd4
fixes to test harness to allow backtracing/debugging of failures
Ben Wing <ben@xemacs.org>
parents:
4962
diff
changeset
|
230 (defsubst test-harness-unexpected-error-condition-handler (error-info context-msg) |
|
3daf9fc57cd4
fixes to test harness to allow backtracing/debugging of failures
Ben Wing <ben@xemacs.org>
parents:
4962
diff
changeset
|
231 "Condition handler for when unexpected errors occur. |
|
3daf9fc57cd4
fixes to test harness to allow backtracing/debugging of failures
Ben Wing <ben@xemacs.org>
parents:
4962
diff
changeset
|
232 Useful in conjunction with `call-with-condition-handler'. ERROR-INFO is the |
|
3daf9fc57cd4
fixes to test harness to allow backtracing/debugging of failures
Ben Wing <ben@xemacs.org>
parents:
4962
diff
changeset
|
233 value passed to the condition handler. CONTEXT-MSG is a string indicating |
|
3daf9fc57cd4
fixes to test harness to allow backtracing/debugging of failures
Ben Wing <ben@xemacs.org>
parents:
4962
diff
changeset
|
234 the context in which the unexpected error occurred. A message is outputted |
|
3daf9fc57cd4
fixes to test harness to allow backtracing/debugging of failures
Ben Wing <ben@xemacs.org>
parents:
4962
diff
changeset
|
235 including CONTEXT-MSG in it, `unexpected-test-file-failures' is incremented, |
|
3daf9fc57cd4
fixes to test harness to allow backtracing/debugging of failures
Ben Wing <ben@xemacs.org>
parents:
4962
diff
changeset
|
236 and `test-harness-unexpected-error-do-debug' is called, which may enter the |
|
3daf9fc57cd4
fixes to test harness to allow backtracing/debugging of failures
Ben Wing <ben@xemacs.org>
parents:
4962
diff
changeset
|
237 debugger or output a backtrace, depending on the settings of |
|
3daf9fc57cd4
fixes to test harness to allow backtracing/debugging of failures
Ben Wing <ben@xemacs.org>
parents:
4962
diff
changeset
|
238 `test-harness-unexpected-error-enter-debugger' and |
|
3daf9fc57cd4
fixes to test harness to allow backtracing/debugging of failures
Ben Wing <ben@xemacs.org>
parents:
4962
diff
changeset
|
239 `test-harness-unexpected-error-show-backtrace'. |
|
3daf9fc57cd4
fixes to test harness to allow backtracing/debugging of failures
Ben Wing <ben@xemacs.org>
parents:
4962
diff
changeset
|
240 |
|
3daf9fc57cd4
fixes to test harness to allow backtracing/debugging of failures
Ben Wing <ben@xemacs.org>
parents:
4962
diff
changeset
|
241 The function returns normally, which causes error-handling processing to |
|
3daf9fc57cd4
fixes to test harness to allow backtracing/debugging of failures
Ben Wing <ben@xemacs.org>
parents:
4962
diff
changeset
|
242 continue; if you want to catch the error, you also need to wrap everything |
|
3daf9fc57cd4
fixes to test harness to allow backtracing/debugging of failures
Ben Wing <ben@xemacs.org>
parents:
4962
diff
changeset
|
243 in `condition-case'. See also `test-harness-error-wrap', which does this |
|
3daf9fc57cd4
fixes to test harness to allow backtracing/debugging of failures
Ben Wing <ben@xemacs.org>
parents:
4962
diff
changeset
|
244 wrapping." |
|
3daf9fc57cd4
fixes to test harness to allow backtracing/debugging of failures
Ben Wing <ben@xemacs.org>
parents:
4962
diff
changeset
|
245 (incf unexpected-test-file-failures) |
|
3daf9fc57cd4
fixes to test harness to allow backtracing/debugging of failures
Ben Wing <ben@xemacs.org>
parents:
4962
diff
changeset
|
246 (princ (format "Unexpected error %S while %s\n" |
|
3daf9fc57cd4
fixes to test harness to allow backtracing/debugging of failures
Ben Wing <ben@xemacs.org>
parents:
4962
diff
changeset
|
247 error-info context-msg)) |
|
3daf9fc57cd4
fixes to test harness to allow backtracing/debugging of failures
Ben Wing <ben@xemacs.org>
parents:
4962
diff
changeset
|
248 (message "Unexpected error %S while %s." error-info context-msg) |
|
3daf9fc57cd4
fixes to test harness to allow backtracing/debugging of failures
Ben Wing <ben@xemacs.org>
parents:
4962
diff
changeset
|
249 (test-harness-unexpected-error-do-debug error-info)) |
|
3daf9fc57cd4
fixes to test harness to allow backtracing/debugging of failures
Ben Wing <ben@xemacs.org>
parents:
4962
diff
changeset
|
250 |
|
3daf9fc57cd4
fixes to test harness to allow backtracing/debugging of failures
Ben Wing <ben@xemacs.org>
parents:
4962
diff
changeset
|
251 (defmacro test-harness-error-wrap (context-msg abort-msg &rest body) |
|
3daf9fc57cd4
fixes to test harness to allow backtracing/debugging of failures
Ben Wing <ben@xemacs.org>
parents:
4962
diff
changeset
|
252 "Wrap BODY so that unexpected errors are caught. |
|
3daf9fc57cd4
fixes to test harness to allow backtracing/debugging of failures
Ben Wing <ben@xemacs.org>
parents:
4962
diff
changeset
|
253 The debugger will be entered if noninteractive and |
|
3daf9fc57cd4
fixes to test harness to allow backtracing/debugging of failures
Ben Wing <ben@xemacs.org>
parents:
4962
diff
changeset
|
254 `test-harness-unexpected-error-enter-debugger' is non-nil; else, a backtrace |
|
3daf9fc57cd4
fixes to test harness to allow backtracing/debugging of failures
Ben Wing <ben@xemacs.org>
parents:
4962
diff
changeset
|
255 will be displayed if `test-harness-unexpected-error-show-backtrace' is |
|
3daf9fc57cd4
fixes to test harness to allow backtracing/debugging of failures
Ben Wing <ben@xemacs.org>
parents:
4962
diff
changeset
|
256 non-nil. CONTEXT-MSG is displayed as part of a message shown before entering |
|
3daf9fc57cd4
fixes to test harness to allow backtracing/debugging of failures
Ben Wing <ben@xemacs.org>
parents:
4962
diff
changeset
|
257 the debugger or showing a backtrace, and ABORT-MSG, if non-nil, is displayed |
|
3daf9fc57cd4
fixes to test harness to allow backtracing/debugging of failures
Ben Wing <ben@xemacs.org>
parents:
4962
diff
changeset
|
258 afterwards. See " |
|
3daf9fc57cd4
fixes to test harness to allow backtracing/debugging of failures
Ben Wing <ben@xemacs.org>
parents:
4962
diff
changeset
|
259 `(condition-case nil |
|
3daf9fc57cd4
fixes to test harness to allow backtracing/debugging of failures
Ben Wing <ben@xemacs.org>
parents:
4962
diff
changeset
|
260 (call-with-condition-handler |
|
3daf9fc57cd4
fixes to test harness to allow backtracing/debugging of failures
Ben Wing <ben@xemacs.org>
parents:
4962
diff
changeset
|
261 #'(lambda (error-info) |
|
3daf9fc57cd4
fixes to test harness to allow backtracing/debugging of failures
Ben Wing <ben@xemacs.org>
parents:
4962
diff
changeset
|
262 (test-harness-unexpected-error-condition-handler |
|
3daf9fc57cd4
fixes to test harness to allow backtracing/debugging of failures
Ben Wing <ben@xemacs.org>
parents:
4962
diff
changeset
|
263 error-info ,context-msg)) |
|
3daf9fc57cd4
fixes to test harness to allow backtracing/debugging of failures
Ben Wing <ben@xemacs.org>
parents:
4962
diff
changeset
|
264 #'(lambda () |
|
3daf9fc57cd4
fixes to test harness to allow backtracing/debugging of failures
Ben Wing <ben@xemacs.org>
parents:
4962
diff
changeset
|
265 ,@body)) |
|
3daf9fc57cd4
fixes to test harness to allow backtracing/debugging of failures
Ben Wing <ben@xemacs.org>
parents:
4962
diff
changeset
|
266 (error ,(if abort-msg `(message ,abort-msg) nil)))) |
|
3daf9fc57cd4
fixes to test harness to allow backtracing/debugging of failures
Ben Wing <ben@xemacs.org>
parents:
4962
diff
changeset
|
267 |
| 428 | 268 (defun test-harness-read-from-buffer (buffer) |
| 269 "Read forms from BUFFER, and turn it into a lambda test form." | |
| 270 (let ((body nil)) | |
| 271 (goto-char (point-min) buffer) | |
|
5040
3daf9fc57cd4
fixes to test harness to allow backtracing/debugging of failures
Ben Wing <ben@xemacs.org>
parents:
4962
diff
changeset
|
272 (condition-case nil |
|
3daf9fc57cd4
fixes to test harness to allow backtracing/debugging of failures
Ben Wing <ben@xemacs.org>
parents:
4962
diff
changeset
|
273 (call-with-condition-handler |
|
3daf9fc57cd4
fixes to test harness to allow backtracing/debugging of failures
Ben Wing <ben@xemacs.org>
parents:
4962
diff
changeset
|
274 #'(lambda (error-info) |
|
3daf9fc57cd4
fixes to test harness to allow backtracing/debugging of failures
Ben Wing <ben@xemacs.org>
parents:
4962
diff
changeset
|
275 ;; end-of-file is expected, so don't output error or backtrace |
|
3daf9fc57cd4
fixes to test harness to allow backtracing/debugging of failures
Ben Wing <ben@xemacs.org>
parents:
4962
diff
changeset
|
276 ;; or enter debugger in this case. |
|
3daf9fc57cd4
fixes to test harness to allow backtracing/debugging of failures
Ben Wing <ben@xemacs.org>
parents:
4962
diff
changeset
|
277 (unless (eq 'end-of-file (car error-info)) |
|
3daf9fc57cd4
fixes to test harness to allow backtracing/debugging of failures
Ben Wing <ben@xemacs.org>
parents:
4962
diff
changeset
|
278 (test-harness-unexpected-error-condition-handler |
|
3daf9fc57cd4
fixes to test harness to allow backtracing/debugging of failures
Ben Wing <ben@xemacs.org>
parents:
4962
diff
changeset
|
279 error-info "reading forms from buffer"))) |
|
3daf9fc57cd4
fixes to test harness to allow backtracing/debugging of failures
Ben Wing <ben@xemacs.org>
parents:
4962
diff
changeset
|
280 #'(lambda () |
|
3daf9fc57cd4
fixes to test harness to allow backtracing/debugging of failures
Ben Wing <ben@xemacs.org>
parents:
4962
diff
changeset
|
281 (while t |
|
3daf9fc57cd4
fixes to test harness to allow backtracing/debugging of failures
Ben Wing <ben@xemacs.org>
parents:
4962
diff
changeset
|
282 (setq body (cons (read buffer) body))))) |
|
3daf9fc57cd4
fixes to test harness to allow backtracing/debugging of failures
Ben Wing <ben@xemacs.org>
parents:
4962
diff
changeset
|
283 (error nil)) |
| 428 | 284 `(lambda () |
| 285 (defvar passes) | |
| 286 (defvar assertion-failures) | |
| 287 (defvar no-error-failures) | |
| 288 (defvar wrong-error-failures) | |
| 289 (defvar missing-message-failures) | |
| 290 (defvar other-failures) | |
| 291 | |
| 292 (defvar trick-optimizer) | |
| 293 | |
| 294 ,@(nreverse body)))) | |
| 295 | |
| 296 (defun test-harness-from-buffer (inbuffer filename) | |
| 297 "Run tests in buffer INBUFFER, visiting FILENAME." | |
| 298 (defvar trick-optimizer) | |
| 299 (let ((passes 0) | |
| 300 (assertion-failures 0) | |
| 301 (no-error-failures 0) | |
| 302 (wrong-error-failures 0) | |
| 303 (missing-message-failures 0) | |
| 304 (other-failures 0) | |
| 3471 | 305 (unexpected-test-file-failures 0) |
| 428 | 306 |
| 973 | 307 ;; #### perhaps this should be a defvar, and output at the very end |
| 308 ;; OTOH, this way AC types can use a null EMACSPACKAGEPATH to find | |
| 309 ;; what stuff is needed, and ways to avoid using them | |
| 310 (skipped-test-reasons (make-hash-table :test 'equal)) | |
| 311 | |
| 428 | 312 (trick-optimizer nil) |
| 826 | 313 (debug-on-error t) |
|
5064
501b5e84f5a7
remove unused var in test-harness
Ben Wing <ben@xemacs.org>
parents:
5040
diff
changeset
|
314 ) |
| 428 | 315 (with-output-to-temp-buffer "*Test-Log*" |
| 826 | 316 (princ (format "Testing %s...\n\n" filename)) |
| 1095 | 317 |
| 1413 | 318 (defconst test-harness-failure-tag "FAIL") |
| 319 (defconst test-harness-success-tag "PASS") | |
| 1095 | 320 |
|
4891
732c35cdded8
fix failing-case output of Assert-test, add Assert-test-not
Ben Wing <ben@xemacs.org>
parents:
4856
diff
changeset
|
321 ;;;;; BEGIN DEFINITION OF MACROS USEFUL IN TEST CODE |
|
732c35cdded8
fix failing-case output of Assert-test, add Assert-test-not
Ben Wing <ben@xemacs.org>
parents:
4856
diff
changeset
|
322 |
| 1095 | 323 (defmacro Known-Bug-Expect-Failure (&rest body) |
|
4891
732c35cdded8
fix failing-case output of Assert-test, add Assert-test-not
Ben Wing <ben@xemacs.org>
parents:
4856
diff
changeset
|
324 "Wrap a BODY that consists of tests that are known to fail. |
|
732c35cdded8
fix failing-case output of Assert-test, add Assert-test-not
Ben Wing <ben@xemacs.org>
parents:
4856
diff
changeset
|
325 This causes messages to be printed on failure indicating that this is expected, |
|
732c35cdded8
fix failing-case output of Assert-test, add Assert-test-not
Ben Wing <ben@xemacs.org>
parents:
4856
diff
changeset
|
326 and on success indicating that this is unexpected." |
|
5040
3daf9fc57cd4
fixes to test harness to allow backtracing/debugging of failures
Ben Wing <ben@xemacs.org>
parents:
4962
diff
changeset
|
327 `(let ((test-harness-bug-expected t) |
|
3daf9fc57cd4
fixes to test harness to allow backtracing/debugging of failures
Ben Wing <ben@xemacs.org>
parents:
4962
diff
changeset
|
328 (test-harness-failure-tag "KNOWN BUG") |
|
5541
ebd367b82ccd
Improve treatment of expected bugs.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
5473
diff
changeset
|
329 (test-harness-success-tag "PASS (FAIL EXPECTED: was bug fixed?)")) |
| 1413 | 330 ,@body)) |
|
4323
94509abd0ef0
Commit a forgotten chunk of 4d0f773d5e21.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4199
diff
changeset
|
331 |
|
94509abd0ef0
Commit a forgotten chunk of 4d0f773d5e21.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4199
diff
changeset
|
332 (defmacro Known-Bug-Expect-Error (expected-error &rest body) |
|
5541
ebd367b82ccd
Improve treatment of expected bugs.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
5473
diff
changeset
|
333 "Wrap a BODY containing a test known to trigger an error it shouldn't. |
|
ebd367b82ccd
Improve treatment of expected bugs.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
5473
diff
changeset
|
334 This causes messages to be printed on failure indicating that this is expected |
|
ebd367b82ccd
Improve treatment of expected bugs.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
5473
diff
changeset
|
335 of the bug, and on success indicating that this is unexpected." |
|
ebd367b82ccd
Improve treatment of expected bugs.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
5473
diff
changeset
|
336 `(let ((test-harness-bug-expected t) |
|
ebd367b82ccd
Improve treatment of expected bugs.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
5473
diff
changeset
|
337 (test-harness-failure-tag "KNOWN BUG") |
|
ebd367b82ccd
Improve treatment of expected bugs.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
5473
diff
changeset
|
338 (test-harness-success-tag |
|
ebd367b82ccd
Improve treatment of expected bugs.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
5473
diff
changeset
|
339 (format "PASS (EXPECTED ERROR %S due to bug: fixed?)" |
|
ebd367b82ccd
Improve treatment of expected bugs.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
5473
diff
changeset
|
340 (quote ,expected-error)))) |
|
ebd367b82ccd
Improve treatment of expected bugs.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
5473
diff
changeset
|
341 (condition-case err |
|
ebd367b82ccd
Improve treatment of expected bugs.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
5473
diff
changeset
|
342 (progn ,@body) |
|
ebd367b82ccd
Improve treatment of expected bugs.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
5473
diff
changeset
|
343 (,expected-error) |
|
ebd367b82ccd
Improve treatment of expected bugs.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
5473
diff
changeset
|
344 (error |
|
ebd367b82ccd
Improve treatment of expected bugs.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
5473
diff
changeset
|
345 (let ((m (format " Expected %S due to bug, got %S: mutated?\n" |
|
ebd367b82ccd
Improve treatment of expected bugs.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
5473
diff
changeset
|
346 (quote ,expected-error) err))) |
|
ebd367b82ccd
Improve treatment of expected bugs.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
5473
diff
changeset
|
347 (if (noninteractive) (message m)) |
|
ebd367b82ccd
Improve treatment of expected bugs.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
5473
diff
changeset
|
348 (princ m)))))) |
|
4323
94509abd0ef0
Commit a forgotten chunk of 4d0f773d5e21.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4199
diff
changeset
|
349 |
| 1413 | 350 (defmacro Implementation-Incomplete-Expect-Failure (&rest body) |
|
4891
732c35cdded8
fix failing-case output of Assert-test, add Assert-test-not
Ben Wing <ben@xemacs.org>
parents:
4856
diff
changeset
|
351 "Wrap a BODY containing tests that are known to fail due to incomplete code. |
|
732c35cdded8
fix failing-case output of Assert-test, add Assert-test-not
Ben Wing <ben@xemacs.org>
parents:
4856
diff
changeset
|
352 This causes messages to be printed on failure indicating that the |
|
732c35cdded8
fix failing-case output of Assert-test, add Assert-test-not
Ben Wing <ben@xemacs.org>
parents:
4856
diff
changeset
|
353 implementation is incomplete (and hence the failure is expected); and on |
|
732c35cdded8
fix failing-case output of Assert-test, add Assert-test-not
Ben Wing <ben@xemacs.org>
parents:
4856
diff
changeset
|
354 success indicating that this is unexpected." |
|
5040
3daf9fc57cd4
fixes to test harness to allow backtracing/debugging of failures
Ben Wing <ben@xemacs.org>
parents:
4962
diff
changeset
|
355 `(let ((test-harness-bug-expected t) |
|
3daf9fc57cd4
fixes to test harness to allow backtracing/debugging of failures
Ben Wing <ben@xemacs.org>
parents:
4962
diff
changeset
|
356 (test-harness-failure-tag "IMPLEMENTATION INCOMPLETE") |
|
5541
ebd367b82ccd
Improve treatment of expected bugs.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
5473
diff
changeset
|
357 (test-harness-success-tag |
|
ebd367b82ccd
Improve treatment of expected bugs.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
5473
diff
changeset
|
358 "PASS (FAILURE EXPECTED: feature implemented?)")) |
| 1413 | 359 ,@body)) |
| 826 | 360 |
| 361 (defun Print-Failure (fmt &rest args) | |
| 1413 | 362 (setq fmt (format "%s: %s" test-harness-failure-tag fmt)) |
| 826 | 363 (if (noninteractive) (apply #'message fmt args)) |
| 364 (princ (concat (apply #'format fmt args) "\n"))) | |
| 365 | |
| 366 (defun Print-Pass (fmt &rest args) | |
| 1413 | 367 (setq fmt (format "%s: %s" test-harness-success-tag fmt)) |
|
5541
ebd367b82ccd
Improve treatment of expected bugs.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
5473
diff
changeset
|
368 (and (or test-harness-verbose test-harness-bug-expected) |
|
ebd367b82ccd
Improve treatment of expected bugs.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
5473
diff
changeset
|
369 (if (and noninteractive test-harness-bug-expected) |
|
ebd367b82ccd
Improve treatment of expected bugs.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
5473
diff
changeset
|
370 (apply #'message fmt args)) |
| 826 | 371 (princ (concat (apply #'format fmt args) "\n")))) |
| 372 | |
| 973 | 373 (defun Print-Skip (test reason &optional fmt &rest args) |
| 1095 | 374 (setq fmt (concat "SKIP: %S BECAUSE %S" fmt)) |
| 973 | 375 (princ (concat (apply #'format fmt test reason args) "\n"))) |
| 376 | |
| 1095 | 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)) | |
| 428 | 388 |
|
4747
294a86d29f99
Eliminate C asserts from c-tests.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
4415
diff
changeset
|
389 (defmacro Assert (assertion &optional failing-case description) |
|
294a86d29f99
Eliminate C asserts from c-tests.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
4415
diff
changeset
|
390 "Test passes if ASSERTION is true. |
| 4856 | 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." | |
|
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5110
diff
changeset
|
395 (let ((test-assertion assertion) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5110
diff
changeset
|
396 (negated nil)) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5110
diff
changeset
|
397 (when (and (listp test-assertion) |
|
5366
f00192e1cd49
Examining the result of #'length: `eql', not `=', it's better style & cheaper
Aidan Kehoe <kehoea@parhasard.net>
parents:
5274
diff
changeset
|
398 (eql 2 (length test-assertion)) |
|
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5110
diff
changeset
|
399 (memq (car test-assertion) '(not null))) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5110
diff
changeset
|
400 (setq test-assertion (cadr test-assertion)) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5110
diff
changeset
|
401 (setq negated t)) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5110
diff
changeset
|
402 (when (and (listp test-assertion) |
|
5366
f00192e1cd49
Examining the result of #'length: `eql', not `=', it's better style & cheaper
Aidan Kehoe <kehoea@parhasard.net>
parents:
5274
diff
changeset
|
403 (eql 3 (length test-assertion)) |
|
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5110
diff
changeset
|
404 (member (car test-assertion) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5110
diff
changeset
|
405 '(eq eql equal equalp = string= < <= > >=))) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5110
diff
changeset
|
406 (let* ((test (car test-assertion)) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5110
diff
changeset
|
407 (testval (second test-assertion)) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5110
diff
changeset
|
408 (expected (third test-assertion)) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5110
diff
changeset
|
409 (failmsg `(format ,(if negated |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5110
diff
changeset
|
410 "%S shouldn't be `%s' to %S but is" |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5110
diff
changeset
|
411 "%S should be `%s' to %S but isn't") |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5110
diff
changeset
|
412 ,testval ',test ,expected))) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5110
diff
changeset
|
413 (setq failing-case (if failing-case |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5110
diff
changeset
|
414 `(concat |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5110
diff
changeset
|
415 (format "%S, " ,failing-case) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5110
diff
changeset
|
416 ,failmsg) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5110
diff
changeset
|
417 failmsg))))) |
| 4856 | 418 (let ((description |
| 419 (or description `(quote ,assertion)))) | |
|
5040
3daf9fc57cd4
fixes to test harness to allow backtracing/debugging of failures
Ben Wing <ben@xemacs.org>
parents:
4962
diff
changeset
|
420 `(condition-case nil |
|
3daf9fc57cd4
fixes to test harness to allow backtracing/debugging of failures
Ben Wing <ben@xemacs.org>
parents:
4962
diff
changeset
|
421 (call-with-condition-handler |
|
3daf9fc57cd4
fixes to test harness to allow backtracing/debugging of failures
Ben Wing <ben@xemacs.org>
parents:
4962
diff
changeset
|
422 #'(lambda (error-info) |
|
3daf9fc57cd4
fixes to test harness to allow backtracing/debugging of failures
Ben Wing <ben@xemacs.org>
parents:
4962
diff
changeset
|
423 (if (eq 'cl-assertion-failed (car error-info)) |
|
3daf9fc57cd4
fixes to test harness to allow backtracing/debugging of failures
Ben Wing <ben@xemacs.org>
parents:
4962
diff
changeset
|
424 (progn |
|
3daf9fc57cd4
fixes to test harness to allow backtracing/debugging of failures
Ben Wing <ben@xemacs.org>
parents:
4962
diff
changeset
|
425 (Print-Failure |
|
3daf9fc57cd4
fixes to test harness to allow backtracing/debugging of failures
Ben Wing <ben@xemacs.org>
parents:
4962
diff
changeset
|
426 (if ,failing-case |
|
3daf9fc57cd4
fixes to test harness to allow backtracing/debugging of failures
Ben Wing <ben@xemacs.org>
parents:
4962
diff
changeset
|
427 "Assertion failed: %S; failing case = %S" |
|
3daf9fc57cd4
fixes to test harness to allow backtracing/debugging of failures
Ben Wing <ben@xemacs.org>
parents:
4962
diff
changeset
|
428 "Assertion failed: %S") |
|
3daf9fc57cd4
fixes to test harness to allow backtracing/debugging of failures
Ben Wing <ben@xemacs.org>
parents:
4962
diff
changeset
|
429 ,description ,failing-case) |
|
3daf9fc57cd4
fixes to test harness to allow backtracing/debugging of failures
Ben Wing <ben@xemacs.org>
parents:
4962
diff
changeset
|
430 (incf assertion-failures) |
|
5541
ebd367b82ccd
Improve treatment of expected bugs.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
5473
diff
changeset
|
431 (test-harness-assertion-failure-do-debug error-info) |
|
ebd367b82ccd
Improve treatment of expected bugs.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
5473
diff
changeset
|
432 nil) |
|
5040
3daf9fc57cd4
fixes to test harness to allow backtracing/debugging of failures
Ben Wing <ben@xemacs.org>
parents:
4962
diff
changeset
|
433 (Print-Failure |
|
3daf9fc57cd4
fixes to test harness to allow backtracing/debugging of failures
Ben Wing <ben@xemacs.org>
parents:
4962
diff
changeset
|
434 (if ,failing-case |
|
3daf9fc57cd4
fixes to test harness to allow backtracing/debugging of failures
Ben Wing <ben@xemacs.org>
parents:
4962
diff
changeset
|
435 "%S ==> error: %S; failing case = %S" |
|
3daf9fc57cd4
fixes to test harness to allow backtracing/debugging of failures
Ben Wing <ben@xemacs.org>
parents:
4962
diff
changeset
|
436 "%S ==> error: %S") |
|
3daf9fc57cd4
fixes to test harness to allow backtracing/debugging of failures
Ben Wing <ben@xemacs.org>
parents:
4962
diff
changeset
|
437 ,description error-info ,failing-case) |
|
3daf9fc57cd4
fixes to test harness to allow backtracing/debugging of failures
Ben Wing <ben@xemacs.org>
parents:
4962
diff
changeset
|
438 (incf other-failures) |
|
5541
ebd367b82ccd
Improve treatment of expected bugs.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
5473
diff
changeset
|
439 (test-harness-unexpected-error-do-debug error-info) |
|
ebd367b82ccd
Improve treatment of expected bugs.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
5473
diff
changeset
|
440 nil)) |
|
5040
3daf9fc57cd4
fixes to test harness to allow backtracing/debugging of failures
Ben Wing <ben@xemacs.org>
parents:
4962
diff
changeset
|
441 #'(lambda () |
|
3daf9fc57cd4
fixes to test harness to allow backtracing/debugging of failures
Ben Wing <ben@xemacs.org>
parents:
4962
diff
changeset
|
442 (assert ,assertion) |
|
3daf9fc57cd4
fixes to test harness to allow backtracing/debugging of failures
Ben Wing <ben@xemacs.org>
parents:
4962
diff
changeset
|
443 (Print-Pass "%S" ,description) |
|
5541
ebd367b82ccd
Improve treatment of expected bugs.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
5473
diff
changeset
|
444 (incf passes) |
|
ebd367b82ccd
Improve treatment of expected bugs.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
5473
diff
changeset
|
445 t)) |
|
5040
3daf9fc57cd4
fixes to test harness to allow backtracing/debugging of failures
Ben Wing <ben@xemacs.org>
parents:
4962
diff
changeset
|
446 (cl-assertion-failed nil)))) |
| 2056 | 447 |
| 428 | 448 (defmacro Check-Error (expected-error &rest body) |
|
5366
f00192e1cd49
Examining the result of #'length: `eql', not `=', it's better style & cheaper
Aidan Kehoe <kehoea@parhasard.net>
parents:
5274
diff
changeset
|
449 (let ((quoted-body (if (eql 1 (length body)) |
| 428 | 450 `(quote ,(car body)) `(quote (progn ,@body))))) |
| 451 `(condition-case error-info | |
| 452 (progn | |
| 453 (setq trick-optimizer (progn ,@body)) | |
| 826 | 454 (Print-Failure "%S executed successfully, but expected error %S" |
| 428 | 455 ,quoted-body |
| 826 | 456 ',expected-error) |
| 428 | 457 (incf no-error-failures)) |
| 458 (,expected-error | |
| 826 | 459 (Print-Pass "%S ==> error %S, as expected" |
| 460 ,quoted-body ',expected-error) | |
| 428 | 461 (incf passes)) |
| 462 (error | |
| 826 | 463 (Print-Failure "%S ==> expected error %S, got error %S instead" |
| 464 ,quoted-body ',expected-error error-info) | |
| 428 | 465 (incf wrong-error-failures))))) |
| 466 | |
| 826 | 467 (defmacro Check-Error-Message (expected-error expected-error-regexp |
| 468 &rest body) | |
|
5366
f00192e1cd49
Examining the result of #'length: `eql', not `=', it's better style & cheaper
Aidan Kehoe <kehoea@parhasard.net>
parents:
5274
diff
changeset
|
469 (let ((quoted-body (if (eql 1 (length body)) |
| 428 | 470 `(quote ,(car body)) `(quote (progn ,@body))))) |
| 471 `(condition-case error-info | |
| 472 (progn | |
| 473 (setq trick-optimizer (progn ,@body)) | |
| 826 | 474 (Print-Failure "%S executed successfully, but expected error %S" |
| 475 ,quoted-body ',expected-error) | |
| 428 | 476 (incf no-error-failures)) |
| 477 (,expected-error | |
| 4199 | 478 ;; #### Damn, this binding doesn't capture frobs, eg, for |
| 479 ;; invalid_argument() ... you only get the REASON. And for | |
| 480 ;; wrong_type_argument(), there's no reason only FROBs. | |
| 481 ;; If this gets fixed, fix tests in regexp-tests.el. | |
| 428 | 482 (let ((error-message (second error-info))) |
| 483 (if (string-match ,expected-error-regexp error-message) | |
| 484 (progn | |
| 826 | 485 (Print-Pass "%S ==> error %S %S, as expected" |
| 486 ,quoted-body error-message ',expected-error) | |
| 428 | 487 (incf passes)) |
| 826 | 488 (Print-Failure "%S ==> got error %S as expected, but error message %S did not match regexp %S" |
| 489 ,quoted-body ',expected-error error-message ,expected-error-regexp) | |
| 428 | 490 (incf wrong-error-failures)))) |
| 491 (error | |
| 826 | 492 (Print-Failure "%S ==> expected error %S, got error %S instead" |
| 493 ,quoted-body ',expected-error error-info) | |
| 428 | 494 (incf wrong-error-failures))))) |
| 495 | |
| 3472 | 496 ;; Do not use this with Silence-Message. |
| 428 | 497 (defmacro Check-Message (expected-message-regexp &rest body) |
|
5366
f00192e1cd49
Examining the result of #'length: `eql', not `=', it's better style & cheaper
Aidan Kehoe <kehoea@parhasard.net>
parents:
5274
diff
changeset
|
498 (let ((quoted-body (if (eql 1 (length body)) |
|
5069
14f0dd1fabdb
move test-harness to lisp/ directory so it gets byte-compiled
Ben Wing <ben@xemacs.org>
parents:
5064
diff
changeset
|
499 `(quote ,(car body)) |
|
14f0dd1fabdb
move test-harness to lisp/ directory so it gets byte-compiled
Ben Wing <ben@xemacs.org>
parents:
5064
diff
changeset
|
500 `(quote (progn ,@body))))) |
|
14f0dd1fabdb
move test-harness to lisp/ directory so it gets byte-compiled
Ben Wing <ben@xemacs.org>
parents:
5064
diff
changeset
|
501 `(Skip-Test-Unless (fboundp 'defadvice) "can't defadvice" |
|
5274
ecdd1daab447
Add an omitted comma, Check-Message, test-harness.el.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5136
diff
changeset
|
502 ,expected-message-regexp |
|
5069
14f0dd1fabdb
move test-harness to lisp/ directory so it gets byte-compiled
Ben Wing <ben@xemacs.org>
parents:
5064
diff
changeset
|
503 (let ((messages "")) |
|
14f0dd1fabdb
move test-harness to lisp/ directory so it gets byte-compiled
Ben Wing <ben@xemacs.org>
parents:
5064
diff
changeset
|
504 (defadvice message (around collect activate) |
|
14f0dd1fabdb
move test-harness to lisp/ directory so it gets byte-compiled
Ben Wing <ben@xemacs.org>
parents:
5064
diff
changeset
|
505 (defvar messages) |
|
14f0dd1fabdb
move test-harness to lisp/ directory so it gets byte-compiled
Ben Wing <ben@xemacs.org>
parents:
5064
diff
changeset
|
506 (let ((msg-string (apply 'format (ad-get-args 0)))) |
|
14f0dd1fabdb
move test-harness to lisp/ directory so it gets byte-compiled
Ben Wing <ben@xemacs.org>
parents:
5064
diff
changeset
|
507 (setq messages (concat messages msg-string)) |
|
14f0dd1fabdb
move test-harness to lisp/ directory so it gets byte-compiled
Ben Wing <ben@xemacs.org>
parents:
5064
diff
changeset
|
508 msg-string)) |
|
14f0dd1fabdb
move test-harness to lisp/ directory so it gets byte-compiled
Ben Wing <ben@xemacs.org>
parents:
5064
diff
changeset
|
509 (ignore-errors |
|
14f0dd1fabdb
move test-harness to lisp/ directory so it gets byte-compiled
Ben Wing <ben@xemacs.org>
parents:
5064
diff
changeset
|
510 (call-with-condition-handler |
|
14f0dd1fabdb
move test-harness to lisp/ directory so it gets byte-compiled
Ben Wing <ben@xemacs.org>
parents:
5064
diff
changeset
|
511 #'(lambda (error-info) |
|
14f0dd1fabdb
move test-harness to lisp/ directory so it gets byte-compiled
Ben Wing <ben@xemacs.org>
parents:
5064
diff
changeset
|
512 (Print-Failure "%S ==> unexpected error %S" |
|
14f0dd1fabdb
move test-harness to lisp/ directory so it gets byte-compiled
Ben Wing <ben@xemacs.org>
parents:
5064
diff
changeset
|
513 ,quoted-body error-info) |
|
14f0dd1fabdb
move test-harness to lisp/ directory so it gets byte-compiled
Ben Wing <ben@xemacs.org>
parents:
5064
diff
changeset
|
514 (incf other-failures) |
|
14f0dd1fabdb
move test-harness to lisp/ directory so it gets byte-compiled
Ben Wing <ben@xemacs.org>
parents:
5064
diff
changeset
|
515 (test-harness-unexpected-error-do-debug error-info)) |
|
14f0dd1fabdb
move test-harness to lisp/ directory so it gets byte-compiled
Ben Wing <ben@xemacs.org>
parents:
5064
diff
changeset
|
516 #'(lambda () |
|
14f0dd1fabdb
move test-harness to lisp/ directory so it gets byte-compiled
Ben Wing <ben@xemacs.org>
parents:
5064
diff
changeset
|
517 (setq trick-optimizer (progn ,@body)) |
|
14f0dd1fabdb
move test-harness to lisp/ directory so it gets byte-compiled
Ben Wing <ben@xemacs.org>
parents:
5064
diff
changeset
|
518 (if (string-match ,expected-message-regexp messages) |
|
14f0dd1fabdb
move test-harness to lisp/ directory so it gets byte-compiled
Ben Wing <ben@xemacs.org>
parents:
5064
diff
changeset
|
519 (progn |
|
14f0dd1fabdb
move test-harness to lisp/ directory so it gets byte-compiled
Ben Wing <ben@xemacs.org>
parents:
5064
diff
changeset
|
520 (Print-Pass |
|
14f0dd1fabdb
move test-harness to lisp/ directory so it gets byte-compiled
Ben Wing <ben@xemacs.org>
parents:
5064
diff
changeset
|
521 "%S ==> value %S, message %S, matching %S, as expected" |
|
14f0dd1fabdb
move test-harness to lisp/ directory so it gets byte-compiled
Ben Wing <ben@xemacs.org>
parents:
5064
diff
changeset
|
522 ,quoted-body trick-optimizer messages |
|
14f0dd1fabdb
move test-harness to lisp/ directory so it gets byte-compiled
Ben Wing <ben@xemacs.org>
parents:
5064
diff
changeset
|
523 ',expected-message-regexp) |
|
14f0dd1fabdb
move test-harness to lisp/ directory so it gets byte-compiled
Ben Wing <ben@xemacs.org>
parents:
5064
diff
changeset
|
524 (incf passes)) |
|
14f0dd1fabdb
move test-harness to lisp/ directory so it gets byte-compiled
Ben Wing <ben@xemacs.org>
parents:
5064
diff
changeset
|
525 (Print-Failure |
|
14f0dd1fabdb
move test-harness to lisp/ directory so it gets byte-compiled
Ben Wing <ben@xemacs.org>
parents:
5064
diff
changeset
|
526 "%S ==> value %S, message %S, NOT matching expected %S" |
|
14f0dd1fabdb
move test-harness to lisp/ directory so it gets byte-compiled
Ben Wing <ben@xemacs.org>
parents:
5064
diff
changeset
|
527 ,quoted-body trick-optimizer messages |
|
14f0dd1fabdb
move test-harness to lisp/ directory so it gets byte-compiled
Ben Wing <ben@xemacs.org>
parents:
5064
diff
changeset
|
528 ',expected-message-regexp) |
|
14f0dd1fabdb
move test-harness to lisp/ directory so it gets byte-compiled
Ben Wing <ben@xemacs.org>
parents:
5064
diff
changeset
|
529 (incf missing-message-failures))))) |
|
14f0dd1fabdb
move test-harness to lisp/ directory so it gets byte-compiled
Ben Wing <ben@xemacs.org>
parents:
5064
diff
changeset
|
530 (ad-unadvise 'message))))) |
| 428 | 531 |
| 3472 | 532 ;; #### Perhaps this should override `message' itself, too? |
| 533 (defmacro Silence-Message (&rest body) | |
|
4323
94509abd0ef0
Commit a forgotten chunk of 4d0f773d5e21.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4199
diff
changeset
|
534 `(flet ((append-message (&rest args) ()) |
|
94509abd0ef0
Commit a forgotten chunk of 4d0f773d5e21.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4199
diff
changeset
|
535 (clear-message (&rest args) ())) |
|
94509abd0ef0
Commit a forgotten chunk of 4d0f773d5e21.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4199
diff
changeset
|
536 ,@body)) |
| 3472 | 537 |
| 428 | 538 (defmacro Ignore-Ebola (&rest body) |
| 539 `(let ((debug-issue-ebola-notices -42)) ,@body)) | |
| 540 | |
| 541 (defun Int-to-Marker (pos) | |
| 542 (save-excursion | |
| 543 (set-buffer standard-output) | |
| 544 (save-excursion | |
| 545 (goto-char pos) | |
| 546 (point-marker)))) | |
| 547 | |
| 548 (princ "Testing Interpreted Lisp\n\n") | |
|
5040
3daf9fc57cd4
fixes to test harness to allow backtracing/debugging of failures
Ben Wing <ben@xemacs.org>
parents:
4962
diff
changeset
|
549 |
|
3daf9fc57cd4
fixes to test harness to allow backtracing/debugging of failures
Ben Wing <ben@xemacs.org>
parents:
4962
diff
changeset
|
550 (test-harness-error-wrap |
|
3daf9fc57cd4
fixes to test harness to allow backtracing/debugging of failures
Ben Wing <ben@xemacs.org>
parents:
4962
diff
changeset
|
551 "executing interpreted code" |
|
3daf9fc57cd4
fixes to test harness to allow backtracing/debugging of failures
Ben Wing <ben@xemacs.org>
parents:
4962
diff
changeset
|
552 "Test suite execution aborted." |
|
3daf9fc57cd4
fixes to test harness to allow backtracing/debugging of failures
Ben Wing <ben@xemacs.org>
parents:
4962
diff
changeset
|
553 (funcall (test-harness-read-from-buffer inbuffer))) |
|
3daf9fc57cd4
fixes to test harness to allow backtracing/debugging of failures
Ben Wing <ben@xemacs.org>
parents:
4962
diff
changeset
|
554 |
| 428 | 555 (princ "\nTesting Compiled Lisp\n\n") |
|
5040
3daf9fc57cd4
fixes to test harness to allow backtracing/debugging of failures
Ben Wing <ben@xemacs.org>
parents:
4962
diff
changeset
|
556 |
| 1758 | 557 (let (code |
| 558 (test-harness-test-compiled t)) | |
|
5040
3daf9fc57cd4
fixes to test harness to allow backtracing/debugging of failures
Ben Wing <ben@xemacs.org>
parents:
4962
diff
changeset
|
559 (test-harness-error-wrap |
|
3daf9fc57cd4
fixes to test harness to allow backtracing/debugging of failures
Ben Wing <ben@xemacs.org>
parents:
4962
diff
changeset
|
560 "byte-compiling code" nil |
|
3daf9fc57cd4
fixes to test harness to allow backtracing/debugging of failures
Ben Wing <ben@xemacs.org>
parents:
4962
diff
changeset
|
561 (setq code |
|
3daf9fc57cd4
fixes to test harness to allow backtracing/debugging of failures
Ben Wing <ben@xemacs.org>
parents:
4962
diff
changeset
|
562 ;; our lisp code is often intentionally dubious, |
|
3daf9fc57cd4
fixes to test harness to allow backtracing/debugging of failures
Ben Wing <ben@xemacs.org>
parents:
4962
diff
changeset
|
563 ;; so throw away _all_ the byte compiler warnings. |
|
3daf9fc57cd4
fixes to test harness to allow backtracing/debugging of failures
Ben Wing <ben@xemacs.org>
parents:
4962
diff
changeset
|
564 (letf (((symbol-function 'byte-compile-warn) |
|
3daf9fc57cd4
fixes to test harness to allow backtracing/debugging of failures
Ben Wing <ben@xemacs.org>
parents:
4962
diff
changeset
|
565 'ignore)) |
|
3daf9fc57cd4
fixes to test harness to allow backtracing/debugging of failures
Ben Wing <ben@xemacs.org>
parents:
4962
diff
changeset
|
566 (byte-compile (test-harness-read-from-buffer |
|
3daf9fc57cd4
fixes to test harness to allow backtracing/debugging of failures
Ben Wing <ben@xemacs.org>
parents:
4962
diff
changeset
|
567 inbuffer)))) |
|
3daf9fc57cd4
fixes to test harness to allow backtracing/debugging of failures
Ben Wing <ben@xemacs.org>
parents:
4962
diff
changeset
|
568 ) |
|
3daf9fc57cd4
fixes to test harness to allow backtracing/debugging of failures
Ben Wing <ben@xemacs.org>
parents:
4962
diff
changeset
|
569 |
|
3daf9fc57cd4
fixes to test harness to allow backtracing/debugging of failures
Ben Wing <ben@xemacs.org>
parents:
4962
diff
changeset
|
570 (test-harness-error-wrap "executing byte-compiled code" |
|
3daf9fc57cd4
fixes to test harness to allow backtracing/debugging of failures
Ben Wing <ben@xemacs.org>
parents:
4962
diff
changeset
|
571 "Test suite execution aborted." |
|
3daf9fc57cd4
fixes to test harness to allow backtracing/debugging of failures
Ben Wing <ben@xemacs.org>
parents:
4962
diff
changeset
|
572 (if code (funcall code))) |
|
3daf9fc57cd4
fixes to test harness to allow backtracing/debugging of failures
Ben Wing <ben@xemacs.org>
parents:
4962
diff
changeset
|
573 ) |
| 826 | 574 (princ (format "\nSUMMARY for %s:\n" filename)) |
| 428 | 575 (princ (format "\t%5d passes\n" passes)) |
| 576 (princ (format "\t%5d assertion failures\n" assertion-failures)) | |
| 577 (princ (format "\t%5d errors that should have been generated, but weren't\n" no-error-failures)) | |
| 578 (princ (format "\t%5d wrong-error failures\n" wrong-error-failures)) | |
| 579 (princ (format "\t%5d missing-message failures\n" missing-message-failures)) | |
| 580 (princ (format "\t%5d other failures\n" other-failures)) | |
| 581 (let* ((total (+ passes | |
| 582 assertion-failures | |
| 583 no-error-failures | |
| 584 wrong-error-failures | |
| 585 missing-message-failures | |
| 586 other-failures)) | |
| 587 (basename (file-name-nondirectory filename)) | |
| 588 (summary-msg | |
|
4906
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4891
diff
changeset
|
589 (cond ((> unexpected-test-file-failures 0) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4891
diff
changeset
|
590 (format test-harness-aborted-summary-template |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4891
diff
changeset
|
591 (concat basename ":") total)) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4891
diff
changeset
|
592 ((> total 0) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4891
diff
changeset
|
593 (format test-harness-file-summary-template |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4891
diff
changeset
|
594 (concat basename ":") |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4891
diff
changeset
|
595 passes total (/ (* 100 passes) total))) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4891
diff
changeset
|
596 (t |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4891
diff
changeset
|
597 (format test-harness-null-summary-template |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4891
diff
changeset
|
598 (concat basename ":"))))) |
| 973 | 599 (reasons "")) |
| 600 (maphash (lambda (key value) | |
| 601 (setq reasons | |
| 602 (concat reasons | |
| 1095 | 603 (format "\n %d tests skipped because %s." |
| 973 | 604 value key)))) |
| 605 skipped-test-reasons) | |
| 606 (when (> (length reasons) 1) | |
| 607 (setq summary-msg (concat summary-msg reasons " | |
|
4415
bceb3e285ae7
case-tests.el: fix it on non-DEBUG_XEMACS; save standard-case-table, use it
Aidan Kehoe <kehoea@parhasard.net>
parents:
4366
diff
changeset
|
608 It may be that XEmacs cannot find your installed packages. Set |
|
bceb3e285ae7
case-tests.el: fix it on non-DEBUG_XEMACS; save standard-case-table, use it
Aidan Kehoe <kehoea@parhasard.net>
parents:
4366
diff
changeset
|
609 EMACSPACKAGEPATH to the package hierarchy root or configure with |
|
bceb3e285ae7
case-tests.el: fix it on non-DEBUG_XEMACS; save standard-case-table, use it
Aidan Kehoe <kehoea@parhasard.net>
parents:
4366
diff
changeset
|
610 --package-path to enable the skipped tests."))) |
| 1719 | 611 (setq test-harness-file-results-alist |
| 612 (cons (list filename passes total) | |
| 613 test-harness-file-results-alist)) | |
| 428 | 614 (message "%s" summary-msg)) |
| 3471 | 615 (when (> unexpected-test-file-failures 0) |
| 616 (setq unexpected-test-suite-failure-files | |
| 617 (cons filename unexpected-test-suite-failure-files)) | |
| 618 (setq unexpected-test-suite-failures | |
| 619 (+ unexpected-test-suite-failures unexpected-test-file-failures)) | |
| 428 | 620 (message "Test suite execution failed unexpectedly.")) |
| 621 (fmakunbound 'Assert) | |
| 622 (fmakunbound 'Check-Error) | |
| 863 | 623 (fmakunbound 'Check-Message) |
| 624 (fmakunbound 'Check-Error-Message) | |
| 428 | 625 (fmakunbound 'Ignore-Ebola) |
| 626 (fmakunbound 'Int-to-Marker) | |
| 1719 | 627 (and noninteractive |
| 628 (message "%s" (buffer-substring-no-properties | |
| 1751 | 629 nil nil "*Test-Log*"))) |
| 630 ))) | |
| 428 | 631 |
| 632 (defvar test-harness-results-point-max nil) | |
| 633 (defmacro displaying-emacs-test-results (&rest body) | |
| 634 `(let ((test-harness-results-point-max test-harness-results-point-max)) | |
| 635 ;; Log the file name. | |
| 636 (test-harness-log-file) | |
| 637 ;; Record how much is logged now. | |
| 638 ;; We will display the log buffer if anything more is logged | |
| 639 ;; before the end of BODY. | |
| 640 (or test-harness-results-point-max | |
| 641 (save-excursion | |
| 642 (set-buffer (get-buffer-create "*Test-Log*")) | |
| 643 (setq test-harness-results-point-max (point-max)))) | |
| 644 (unwind-protect | |
| 645 (condition-case error-info | |
| 646 (progn ,@body) | |
| 647 (error | |
| 648 (test-harness-report-error error-info))) | |
| 649 (save-excursion | |
| 650 ;; If there were compilation warnings, display them. | |
| 651 (set-buffer "*Test-Log*") | |
| 652 (if (= test-harness-results-point-max (point-max)) | |
| 653 nil | |
| 654 (if temp-buffer-show-function | |
| 655 (let ((show-buffer (get-buffer-create "*Test-Log-Show*"))) | |
| 656 (save-excursion | |
| 657 (set-buffer show-buffer) | |
| 658 (setq buffer-read-only nil) | |
| 659 (erase-buffer)) | |
| 660 (copy-to-buffer show-buffer | |
| 661 (save-excursion | |
| 662 (goto-char test-harness-results-point-max) | |
| 663 (forward-line -1) | |
| 664 (point)) | |
| 665 (point-max)) | |
| 666 (funcall temp-buffer-show-function show-buffer)) | |
| 667 (select-window | |
| 668 (prog1 (selected-window) | |
| 669 (select-window (display-buffer (current-buffer))) | |
| 670 (goto-char test-harness-results-point-max) | |
| 671 (recenter 1))))))))) | |
| 672 | |
| 673 (defun batch-test-emacs-1 (file) | |
| 674 (condition-case error-info | |
| 675 (progn (test-emacs-test-file file) t) | |
| 676 (error | |
| 677 (princ ">>Error occurred processing ") | |
| 678 (princ file) | |
| 679 (princ ": ") | |
| 680 (display-error error-info nil) | |
| 681 (terpri) | |
| 682 nil))) | |
| 683 | |
| 684 (defun batch-test-emacs () | |
| 685 "Run `test-harness' on the files remaining on the command line. | |
| 686 Use this from the command line, with `-batch'; | |
| 687 it won't work in an interactive Emacs. | |
| 688 Each file is processed even if an error occurred previously. | |
|
5069
14f0dd1fabdb
move test-harness to lisp/ directory so it gets byte-compiled
Ben Wing <ben@xemacs.org>
parents:
5064
diff
changeset
|
689 A directory can be given as well, and all files will be processed. |
|
4948
8b230c53075b
fix some tests in `make check', also add our own file-tests
Ben Wing <ben@xemacs.org>
parents:
4856
diff
changeset
|
690 For example, invoke \"xemacs -batch -f batch-test-emacs tests\"" |
| 428 | 691 ;; command-line-args-left is what is left of the command line (from |
| 692 ;; startup.el) | |
| 693 (defvar command-line-args-left) ;Avoid 'free variable' warning | |
| 694 (defvar debug-issue-ebola-notices) | |
| 695 (if (not noninteractive) | |
| 696 (error "`batch-test-emacs' is to be used only with -batch")) | |
| 697 (let ((error nil)) | |
| 698 (dolist (file command-line-args-left) | |
| 699 (if (file-directory-p file) | |
| 700 (dolist (file-in-dir (directory-files file t)) | |
| 701 (when (and (string-match emacs-lisp-file-regexp file-in-dir) | |
| 702 (not (or (auto-save-file-name-p file-in-dir) | |
|
5069
14f0dd1fabdb
move test-harness to lisp/ directory so it gets byte-compiled
Ben Wing <ben@xemacs.org>
parents:
5064
diff
changeset
|
703 (backup-file-name-p file-in-dir)))) |
| 428 | 704 (or (batch-test-emacs-1 file-in-dir) |
| 705 (setq error t)))) | |
| 706 (or (batch-test-emacs-1 file) | |
| 707 (setq error t)))) | |
| 1719 | 708 (let ((namelen 0) |
| 709 (succlen 0) | |
| 710 (testlen 0) | |
| 711 (results test-harness-file-results-alist)) | |
| 712 ;; compute maximum lengths of variable components of report | |
| 713 ;; probably should just use (length "byte-compiler-tests.el") | |
| 714 ;; and 5-place sizes -- this will also work for the file-by-file | |
| 715 ;; printing when Adrian's kludge gets reverted | |
| 716 (flet ((print-width (i) | |
| 717 (let ((x 10) (y 1)) | |
| 718 (while (>= i x) | |
| 719 (setq x (* 10 x) y (1+ y))) | |
| 720 y))) | |
| 721 (while results | |
| 722 (let* ((head (car results)) | |
| 723 (nn (length (file-name-nondirectory (first head)))) | |
| 724 (ss (print-width (second head))) | |
| 725 (tt (print-width (third head)))) | |
| 726 (when (> nn namelen) (setq namelen nn)) | |
| 727 (when (> ss succlen) (setq succlen ss)) | |
| 728 (when (> tt testlen) (setq testlen tt))) | |
| 729 (setq results (cdr results)))) | |
| 730 ;; create format and print | |
| 1751 | 731 (let ((results (reverse test-harness-file-results-alist))) |
| 1719 | 732 (while results |
| 733 (let* ((head (car results)) | |
| 1751 | 734 (basename (file-name-nondirectory (first head))) |
| 1719 | 735 (nsucc (second head)) |
| 736 (ntest (third head))) | |
|
4906
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4891
diff
changeset
|
737 (cond ((member (first head) unexpected-test-suite-failure-files) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4891
diff
changeset
|
738 (message test-harness-aborted-summary-template |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4891
diff
changeset
|
739 (concat basename ":") |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4891
diff
changeset
|
740 ntest)) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4891
diff
changeset
|
741 ((> ntest 0) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4891
diff
changeset
|
742 (message test-harness-file-summary-template |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4891
diff
changeset
|
743 (concat basename ":") |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4891
diff
changeset
|
744 nsucc |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4891
diff
changeset
|
745 ntest |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4891
diff
changeset
|
746 (/ (* 100 nsucc) ntest))) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4891
diff
changeset
|
747 (t |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4891
diff
changeset
|
748 (message test-harness-null-summary-template |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4891
diff
changeset
|
749 (concat basename ":")))) |
| 3471 | 750 (setq results (cdr results))))) |
| 751 (when (> unexpected-test-suite-failures 0) | |
| 752 (message "\n***** There %s %d unexpected test suite %s in %s:" | |
| 753 (if (= unexpected-test-suite-failures 1) "was" "were") | |
| 754 unexpected-test-suite-failures | |
| 755 (if (= unexpected-test-suite-failures 1) "failure" "failures") | |
|
5366
f00192e1cd49
Examining the result of #'length: `eql', not `=', it's better style & cheaper
Aidan Kehoe <kehoea@parhasard.net>
parents:
5274
diff
changeset
|
756 (if (eql (length unexpected-test-suite-failure-files) 1) |
| 3471 | 757 "file" |
| 758 "files")) | |
| 759 (while unexpected-test-suite-failure-files | |
| 760 (let ((line (pop unexpected-test-suite-failure-files))) | |
| 761 (while (and (< (length line) 61) | |
| 762 unexpected-test-suite-failure-files) | |
| 763 (setq line | |
| 764 (concat line " " | |
| 765 (pop unexpected-test-suite-failure-files)))) | |
| 766 (message line))))) | |
| 1719 | 767 (message "\nDone") |
| 428 | 768 (kill-emacs (if error 1 0)))) |
| 769 | |
| 770 (provide 'test-harness) | |
| 771 | |
| 772 ;;; test-harness.el ends here |