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