2 ;; A test harness based on Franz's tester module
4 ;; copyright (c) 1985-1986 Franz Inc, Alameda, CA
5 ;; copyright (c) 1986-2002 Franz Inc, Berkeley, CA - All rights reserved.
6 ;; copyright (c) 2001-2003 Kevin Rosenberg (portability changes)
8 ;; This code is free software; you can redistribute it and/or
9 ;; modify it under the terms of the version 2.1 of
10 ;; the GNU Lesser General Public License as published by
11 ;; the Free Software Foundation, as clarified by the Franz
12 ;; preamble to the LGPL found in
13 ;; http://opensource.franz.com/preamble.html.
15 ;; This code is distributed in the hope that it will be useful,
16 ;; but without any warranty; without even the implied warranty of
17 ;; merchantability or fitness for a particular purpose. See the GNU
18 ;; Lesser General Public License for more details.
20 ;; Version 2.1 of the GNU Lesser General Public License can be
21 ;; found at http://opensource.franz.com/license.html.
22 ;; If it is not present, you can access it from
23 ;; http://www.gnu.org/copyleft/lesser.txt (until superseded by a newer
24 ;; version) or write to the Free Software Foundation, Inc., 59 Temple
25 ;; Place, Suite 330, Boston, MA 02111-1307 USA
27 ;;;; from the original ACL 6.1 sources:
28 ;; Id: tester.cl,v 2.2.12.1 2001/06/05 18:45:10 layer Exp
30 ;; $Id: src.lisp,v 1.3 2003/07/20 19:00:44 kevin Exp $
36 ;;;; Control variables:
37 #:*break-on-test-failures*
38 #:*error-protect-tests*
41 #:*test-unexpected-failures*
53 (in-package #:ptester)
55 ;; Added by Kevin Rosenberg
57 (define-condition simple-break (error simple-condition) ())
60 (unless (find-class 'break nil)
61 (define-condition break (simple-condition) ()))
63 ;; the if* macro used in Allegro:
65 ;; This is in the public domain... please feel free to put this definition
66 ;; in your code or distribute it with your version of lisp.
68 (eval-when (:compile-toplevel :load-toplevel :execute)
69 (defvar if*-keyword-list '("then" "thenret" "else" "elseif")))
71 (defmacro if* (&rest args)
72 (do ((xx (reverse args) (cdr xx))
79 (cond ((eq state :compl)
81 (t (error "if*: illegal form ~s" args))))
82 (cond ((and (symbolp (car xx))
83 (member (symbol-name (car xx))
85 :test #'string-equal))
86 (setq lookat (symbol-name (car xx)))))
88 (cond ((eq state :init)
89 (cond (lookat (cond ((string-equal lookat "thenret")
93 "if*: bad keyword ~a" lookat))))
96 (push (car xx) col))))
99 (cond ((string-equal lookat "else")
102 "if*: multiples elses")))
105 (push `(t ,@col) totalcol))
106 ((string-equal lookat "then")
108 (t (error "if*: bad keyword ~s"
110 (t (push (car xx) col))))
114 "if*: keyword ~s at the wrong place " (car xx)))
115 (t (setq state :compl)
116 (push `(,(car xx) ,@col) totalcol))))
118 (cond ((not (string-equal lookat "elseif"))
119 (error "if*: missing elseif clause ")))
120 (setq state :init)))))
123 (defvar *break-on-test-failures* nil
124 "When a test failure occurs, common-lisp:break is called, allowing
125 interactive debugging of the failure.")
127 (defvar *test-errors* 0
128 "The value is the number of test errors which have occurred.")
129 (defvar *test-successes* 0
130 "The value is the number of test successes which have occurred.")
131 (defvar *test-unexpected-failures* 0
132 "The value is the number of unexpected test failures which have occurred.")
134 (defvar *error-protect-tests* nil
135 "Protect each test from errors. If an error occurs, then that will be
136 taken as a test failure unless test-error is being used.")
138 (defmacro test-values-errorset (form &optional announce catch-breaks)
140 (let ((g-announce (gensym))
141 (g-catch-breaks (gensym)))
142 `(let* ((,g-announce ,announce)
143 (,g-catch-breaks ,catch-breaks))
144 (handler-case (cons t (multiple-value-list ,form))
145 (condition (condition)
146 (if* (and (null ,g-catch-breaks)
147 (typep condition 'simple-break))
148 then (break condition)
150 then (format *error-output* "~&Condition type: ~a~%"
151 (class-of condition))
152 (format *error-output* "~&Message: ~a~%" condition))
155 (defmacro test-values (form &optional announce catch-breaks)
157 (if* *error-protect-tests*
158 then `(test-values-errorset ,form ,announce ,catch-breaks)
159 else `(cons t (multiple-value-list ,form))))
161 (defmacro test (expected-value test-form
162 &key (test #'eql test-given)
163 (multiple-values nil multiple-values-given)
164 (fail-info nil fail-info-given)
165 (known-failure nil known-failure-given)
167 ;;;;;;;;;; internal, undocumented keywords:
168 ;;;; Note about these keywords: if they were documented, we'd have a
169 ;;;; problem, since they break the left-to-right order of evaluation.
170 ;;;; Specifically, errorset breaks it, and I don't see any way around
171 ;;;; that. `errorset' is used by the old test.cl module (eg,
172 ;;;; test-equal-errorset).
175 (wanted-message nil wanted-message-given)
176 (got-message nil got-message-given))
177 "Perform a single test. `expected-value' is the reference value for the
178 test. `test-form' is a form that will produce the value to be compared to
179 the expected-value. If the values are not the same, then an error is
180 logged, otherwise a success is logged.
182 Normally the comparison of values is done with `eql'. The `test' keyword
183 argument can be used to specify other comparison functions, such as eq,
184 equal,equalp, string=, string-equal, etc.
186 Normally, only the first return value from the test-form is considered,
187 however if `multiple-values' is t, then all values returned from test-form
190 `fail-info' allows more information to be printed with a test failure.
192 `known-failure' marks the test as a known failure. This allows for
193 programs that do regression analysis on the output from a test run to
194 discriminate on new versus known failures."
196 :expected-result ,expected-value
198 (,(if errorset 'test-values-errorset 'test-values) ,test-form t)
199 ,@(when test-given `(:predicate ,test))
200 ,@(when multiple-values-given `(:multiple-values ,multiple-values))
201 ,@(when fail-info-given `(:fail-info ,fail-info))
202 ,@(when known-failure-given `(:known-failure ,known-failure))
203 :test-form ',(if reported-form reported-form test-form)
204 ,@(when wanted-message-given `(:wanted-message ,wanted-message))
205 ,@(when got-message-given `(:got-message ,got-message))))
207 (defgeneric conditionp (thing) )
208 (defmethod conditionp ((thing condition)) t)
209 (defmethod conditionp ((thing t)) nil)
211 (defmacro test-error (form &key announce
213 (fail-info nil fail-info-given)
214 (known-failure nil known-failure-given)
215 (condition-type ''simple-error)
216 (include-subtypes nil include-subtypes-given)
217 (format-control nil format-control-given)
218 (format-arguments nil format-arguments-given))
219 "Test that `form' signals an error. The order of evaluation of the
220 arguments is keywords first, then test form.
222 If `announce' is non-nil, then cause the error message to be printed.
224 The `catch-breaks' is non-nil then consider a call to common-lisp:break an
227 `fail-info' allows more information to be printed with a test failure.
229 `known-failure' marks the test as a known failure. This allows for
230 programs that do regression analysis on the output from a test run to
231 discriminate on new versus known failures.
233 If `condition-type' is non-nil, it should be a symbol naming a condition
234 type, which is used to check against the signalled condition type. The
235 test will fail if they do not match.
237 `include-subtypes', used with `condition-type', can be used to match a
238 condition to an entire subclass of the condition type hierarchy.
240 `format-control' and `format-arguments' can be used to check the error
242 (let ((g-announce (gensym))
243 (g-catch-breaks (gensym))
244 (g-fail-info (gensym))
245 (g-known-failure (gensym))
246 (g-condition-type (gensym))
247 (g-include-subtypes (gensym))
248 (g-format-control (gensym))
249 (g-format-arguments (gensym))
251 `(let* ((,g-announce ,announce)
252 (,g-catch-breaks ,catch-breaks)
253 ,@(when fail-info-given `((,g-fail-info ,fail-info)))
254 ,@(when known-failure-given `((,g-known-failure ,known-failure)))
255 (,g-condition-type ,condition-type)
256 ,@(when include-subtypes-given
257 `((,g-include-subtypes ,include-subtypes)))
258 ,@(when format-control-given
259 `((,g-format-control ,format-control)))
260 ,@(when format-arguments-given
261 `((,g-format-arguments ,format-arguments)))
262 (,g-c (test-values-errorset ,form ,g-announce ,g-catch-breaks)))
267 (test-values (and (conditionp ,g-c)
268 ,@(if* include-subtypes-given
269 then `((if* ,g-include-subtypes
270 then (typep ,g-c ,g-condition-type)
271 else (eq (class-of ,g-c)
273 ,g-condition-type))))
274 else `((eq (class-of ,g-c)
275 (find-class ,g-condition-type))))
276 ,@(when format-control-given
278 (null ,g-format-control)
280 (concatenate 'simple-string
281 "~1@<" ,g-format-control "~:@>")
282 (simple-condition-format-control ,g-c)))))
283 ,@(when format-arguments-given
285 (null ,g-format-arguments)
288 (simple-condition-format-arguments ,g-c))))))
291 ,@(when fail-info-given `(:fail-info ,g-fail-info))
292 ,@(when known-failure-given `(:known-failure ,g-known-failure))
293 :condition-type ,g-condition-type
295 ,@(when include-subtypes-given
296 `(:include-subtypes ,g-include-subtypes))
297 ,@(when format-control-given
298 `(:format-control ,g-format-control))
299 ,@(when format-arguments-given
300 `(:format-arguments ,g-format-arguments))))))
302 (defmacro test-no-error (form &key announce
304 (fail-info nil fail-info-given)
305 (known-failure nil known-failure-given))
306 "Test that `form' does not signal an error. The order of evaluation of
307 the arguments is keywords first, then test form.
309 If `announce' is non-nil, then cause the error message to be printed.
311 The `catch-breaks' is non-nil then consider a call to common-lisp:break an
314 `fail-info' allows more information to be printed with a test failure.
316 `known-failure' marks the test as a known failure. This allows for
317 programs that do regression analysis on the output from a test run to
318 discriminate on new versus known failures."
319 (let ((g-announce (gensym))
320 (g-catch-breaks (gensym))
321 (g-fail-info (gensym))
322 (g-known-failure (gensym))
324 `(let* ((,g-announce ,announce)
325 (,g-catch-breaks ,catch-breaks)
326 ,@(when fail-info-given `((,g-fail-info ,fail-info)))
327 ,@(when known-failure-given `((,g-known-failure ,known-failure)))
328 (,g-c (test-values-errorset ,form ,g-announce ,g-catch-breaks)))
332 :test-results (test-values (not (conditionp ,g-c)))
335 ,@(when fail-info-given `(:fail-info ,g-fail-info))
336 ,@(when known-failure-given `(:known-failure ,g-known-failure))))))
338 (defvar *warn-cookie* (cons nil nil))
340 (defmacro test-warning (form &key fail-info known-failure)
341 "Test that `form' signals a warning. The order of evaluation of
342 the arguments is keywords first, then test form.
344 `fail-info' allows more information to be printed with a test failure.
346 `known-failure' marks the test as a known failure. This allows for
347 programs that do regression analysis on the output from a test run to
348 discriminate on new versus known failures."
349 (let ((g-fail-info (gensym))
350 (g-known-failure (gensym))
352 `(let* ((,g-fail-info ,fail-info)
353 (,g-known-failure ,known-failure)
354 (,g-value (test-values-errorset ,form nil t)))
357 (if* (or (typep ,g-value 'simple-warning) (typep ,g-value 'warning))
359 else ;; test produced no warning
362 :reported-form ,form ;; quoted by test macro
363 :wanted-message "a warning"
364 :got-message "no warning"
365 :fail-info ,g-fail-info
366 :known-failure ,g-known-failure))))
368 (defmacro test-no-warning (form &key fail-info known-failure)
369 "Test that `form' does not signal a warning. The order of evaluation of
370 the arguments is keywords first, then test form.
372 `fail-info' allows more information to be printed with a test failure.
374 `known-failure' marks the test as a known failure. This allows for
375 programs that do regression analysis on the output from a test run to
376 discriminate on new versus known failures."
377 (let ((g-fail-info (gensym))
378 (g-known-failure (gensym))
380 `(let* ((,g-fail-info ,fail-info)
381 (,g-known-failure ,known-failure)
382 (,g-value (test-values-errorset ,form nil t)))
385 (if* (or (typep ,g-value 'simple-warning) (typep ,g-value 'warning))
386 then nil ;; test produced warning
389 :reported-form ',form
390 :wanted-message "no warning"
391 :got-message "a warning"
392 :fail-info ,g-fail-info
393 :known-failure ,g-known-failure))))
395 (defvar *announce-test* nil) ;; if true announce each test that was done
397 (defmacro errorset (form) ;subset of test-values-errorset
399 (values-list (cons t (multiple-value-list ,form)))
401 (format *error-output* "~&An error occurred: ~a~%" cond)
405 (defun test-check (&key (predicate #'eql)
406 expected-result test-results test-form
407 multiple-values fail-info known-failure
408 wanted-message got-message condition-type condition
409 include-subtypes format-control format-arguments
410 &aux fail predicate-failed got wanted)
411 ;; for debugging large/complex test sets:
412 (when *announce-test*
413 (format t "Just did test ~s~%" test-form)
416 ;; this is an internal function
417 (flet ((check (expected-result result)
420 (errorset (funcall predicate expected-result result))))
421 (failed (null (car results))))
424 (setq predicate-failed t)
427 (when (conditionp test-results)
428 (setq condition test-results)
429 (setq test-results nil))
430 (when (null (car test-results))
432 (if* (and (not fail) (not multiple-values))
433 then ;; should be a single result
434 ;; expected-result is the single result wanted
435 (when (not (and (cdr test-results)
436 (check expected-result (cadr test-results))))
438 (when (and (not fail) (cddr test-results))
439 (setq fail 'single-got-multiple))
440 else ;; multiple results wanted
441 ;; expected-result is a list of results, each of which
442 ;; should be checked against the corresponding test-results
443 ;; using the predicate
444 (do ((got (cdr test-results) (cdr got))
445 (want expected-result (cdr want)))
446 ((or (null got) (null want))
447 (when (not (and (null want) (null got)))
449 (when (not (check (car got) (car want)))
450 (return (setq fail t)))))
452 then (when (not known-failure)
453 (format *error-output*
454 "~& * * * UNEXPECTED TEST FAILURE * * *~%")
455 (incf *test-unexpected-failures*))
456 (format *error-output* "~&Test failed: ~@[known failure: ~*~]~s~%"
457 known-failure test-form)
458 (if* (eq 'single-got-multiple fail)
462 Reason: additional value were returned from test form.~%")
463 elseif predicate-failed
464 then (format *error-output* "Reason: predicate error.~%")
465 elseif (null (car test-results))
466 then (format *error-output* "~
467 Reason: an error~@[ (of type `~s')~] was detected.~%"
468 (when condition (class-of condition)))
470 then (if* (not (conditionp condition))
471 then (format *error-output* "~
472 Reason: expected but did not detect an error of type `~s'.~%"
474 elseif (null condition-type)
475 then (format *error-output* "~
476 Reason: detected an unexpected error of type `~s':
480 elseif (not (if* include-subtypes
481 then (typep condition condition-type)
482 else (eq (class-of condition)
483 (find-class condition-type))))
484 then (format *error-output* "~
485 Reason: detected an incorrect condition type.~%")
486 (format *error-output*
487 " wanted: ~s~%" condition-type)
488 (format *error-output*
489 " got: ~s~%" (class-of condition))
490 elseif (and format-control
493 (concatenate 'simple-string
494 "~1@<" format-control "~:@>"))
496 (simple-condition-format-control
498 then ;; format control doesn't match
499 (format *error-output* "~
500 Reason: the format-control was incorrect.~%")
501 (format *error-output* " wanted: ~s~%" wanted)
502 (format *error-output* " got: ~s~%" got)
503 elseif (and format-arguments
505 (setq got format-arguments)
507 (simple-condition-format-arguments
509 then (format *error-output* "~
510 Reason: the format-arguments were incorrect.~%")
511 (format *error-output* " wanted: ~s~%" wanted)
512 (format *error-output* " got: ~s~%" got)
513 else ;; what else????
514 (error "internal-error"))
515 else (let ((*print-length* 50)
518 then (format *error-output*
519 " wanted: ~a~%" wanted-message)
520 else (if* (not multiple-values)
521 then (format *error-output*
526 " wanted values: ~{~s~^, ~}~%"
529 then (format *error-output*
530 " got: ~a~%" got-message)
531 else (if* (not multiple-values)
532 then (format *error-output* " got: ~s~%"
533 (second test-results))
536 " got values: ~{~s~^, ~}~%"
537 (cdr test-results))))))
539 (format *error-output* "Additional info: ~a~%" fail-info))
541 (when *break-on-test-failures*
542 (break "~a is non-nil." '*break-on-test-failures*))
543 else (when known-failure
544 (format *error-output*
545 "~&Expected test failure for ~s did not occur.~%"
548 (format *error-output* "Additional info: ~a~%" fail-info))
550 (incf *test-successes*))
553 (defmacro with-tests ((&key (name "unnamed")) &body body)
554 (let ((g-name (gensym)))
555 `(flet ((doit () ,@body))
556 (let ((,g-name ,name)
559 (*test-unexpected-failures* 0))
560 (format *error-output* "Begin ~a test~%" ,g-name)
561 (if* *break-on-test-failures*
563 else (handler-case (doit)
568 ~&Test ~a aborted by signalling an uncaught error:~%~a~%"
571 (let ((state (sys:gsgc-switch :print)))
572 (setf (sys:gsgc-switch :print) nil)
573 (format t "~&**********************************~%")
574 (format t "End ~a test~%" ,g-name)
575 (format t "Errors detected in this test: ~s " *test-errors*)
576 (unless (zerop *test-unexpected-failures*)
577 (format t "UNEXPECTED: ~s" *test-unexpected-failures*))
578 (format t "~%Successes this test:~s~%" *test-successes*)
579 (setf (sys:gsgc-switch :print) state))
582 (format t "~&**********************************~%")
583 (format t "End ~a test~%" ,g-name)
584 (format t "Errors detected in this test: ~D " *test-errors*)
585 (unless (zerop *test-unexpected-failures*)
586 (format t "UNEXPECTED: ~D" *test-unexpected-failures*))
587 (format t "~%Successes this test:~D~%" *test-successes*))))))
589 (provide :tester #+module-versions 1.1)