1 ;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
2 ;;;; *************************************************************************
3 ;;;; FILE IDENTIFICATION
6 ;;;; Purpose: eXtreme Lisp Test Suite
7 ;;;; Authors: Kevin Rosenberg and Craig Brozefsky
9 ;;;; Put in public domain by Kevin Rosenberg and onShore, Inc
10 ;;;; $Id: src.lisp,v 1.2 2003/08/04 09:46:44 kevin Exp $
11 ;;;; *************************************************************************
16 (defclass test-fixture ()
18 :initarg :test-thunk :reader test-thunk
19 :initform 'perform-test
21 "A thunk or symbol which will be applied to this instance, a
22 test-case, to perform that test-case. Defaults to 'perform-test")
27 "The name of this test-case, used in reports.")
32 "Short description of this test-case, uses in reports"))
34 "Base class for test-fixtures. Test-cases are instances of test-fixtures."))
36 (defmethod setup ((test test-fixture))
37 "Method called before performing a test, should set up the
38 environment the test-case needs to operate in."
41 (defmethod teardown ((test test-fixture))
42 "Method called after performing a test. Should reverse everything that the
43 setup method did for this instance."
46 (define-condition test-failure-condition (simple-condition)
48 (:documentation "Base class for all test failures."))
50 (defclass test-failure ()
51 ((failed-test :initarg :failed-test :reader failed-test)
52 (thrown-condition :initarg :thrown-condition :reader thrown-condition)))
54 (defmethod print-object ((obj test-failure) stream)
55 (print-unreadable-object (obj stream :type t :identity nil)
56 (format stream "~A: " (failed-test obj))
57 (apply #'format stream
58 (simple-condition-format-control (thrown-condition obj))
59 (simple-condition-format-arguments (thrown-condition obj)))))
61 (defmethod is-failure ((failure test-failure))
62 (typep (thrown-condition failure) 'test-failure-condition))
64 (defun failure (format-str &rest args)
65 "Signal a test failure and exit the test."
66 (signal 'test-failure-condition
67 :format-control format-str
68 :format-arguments args))
70 (defmacro test-assert (test &optional msg)
72 (failure "Test assertion: ~s" ',test)))
74 (defun assert-equal (v1 v2 &optional msg)
76 (failure "Test equal: ~s ~s" v1 v2)))
78 (defun assert-true (v &optional msg)
80 (failure "Test true: ~s [~A]" v (if msg msg ""))))
82 (defun assert-false (v &optional msg)
84 (failure "Test false ~A" (if msg msg ""))))
87 (defmethod perform-test ((test test-fixture))
88 "Default method for performing tests upon a test-fixture."
91 (defmacro handler-case-if (test form &body cases)
98 (defmacro unwind-protect-if (test protected cleanup)
103 (progn ,protected ,cleanup)))
105 (defclass test-result ()
106 ((test :initarg :test :reader result-test)
107 (count :initform 0 :accessor test-count)
108 (failures :initarg :failures :reader test-failures :initform nil)
109 (errors :initarg :errors :reader test-errors :initform nil))
110 (:documentation "The result of applying a test"))
112 (defclass test-suite ()
113 ((name :initarg :name :reader test-suite-name)
114 (tests :initarg :tests :accessor tests-hash
115 :initform (make-hash-table :test 'equal))
116 (description :initarg :description :reader description
117 :initform "No description.")))
119 (defmethod setup-testsuite-named (name)
120 (declare (ignore name))
123 (defmethod teardown-testsuite-named (name)
124 (declare (ignore name))
127 (defmethod run-test ((suite test-suite) (result test-result)
128 &key (handle-errors t))
129 (setup-testsuite-named (slot-value suite 'name))
130 (dolist (test (tests suite))
131 (run-test test result :handle-errors handle-errors))
132 (teardown-testsuite-named (slot-value suite 'name))
135 (defmethod run-test ((test test-fixture) result &key (handle-errors t))
136 "Perform the test represented by the given test-case or test-suite.
137 Returns one or more test-result objects, one for each test-case
139 (incf (test-count result))
140 (with-slots (failures errors) result
141 (unwind-protect-if handle-errors
142 (handler-case-if handle-errors
143 (let ((res (progn (setup test)
144 (funcall (test-thunk test) test))))
145 (if (typep res 'test-failure-condition)
146 (push (make-instance 'test-failure
148 :thrown-condition res)
150 (test-failure-condition (failure)
151 (push (make-instance 'test-failure
153 :thrown-condition failure)
156 (push (make-instance 'test-failure
158 :thrown-condition err)
165 (make-instance 'test-failure
166 :failed-test test :thrown-condition err)
172 (defun make-test (fixture name &key test-thunk test-suite description)
173 "Create a test-case which is an instance of FIXTURE. TEST-THUNK is
174 the method that will be invoked when perfoming this test, and can be a
175 symbol or a lambda taking a single argument, the test-fixture
176 instance. DESCRIPTION is obviously what it says it is."
177 (let ((newtest (make-instance fixture
178 :test-name (string name)
180 (if(and (symbolp name) (null test-thunk))
183 :description description)))
184 (if test-suite (add-test newtest test-suite))
187 (defmethod tests ((suite test-suite))
189 (maphash #'(lambda (k v)
191 (setf tlist (cons v tlist)))
195 (defun make-test-suite (name-or-fixture &optional description testspecs)
196 "Returns a new test-suite based on a name and TESTSPECS or a fixture
198 (etypecase name-or-fixture
200 (make-test-suite-for-fixture (make-instance name-or-fixture)))
202 (let ((suite (make-instance 'test-suite :name name-or-fixture
203 :description description)))
204 (dolist (testspec testspecs)
205 (add-test (apply #'make-test testspec) suite))
208 (defmethod add-test ((test test-fixture) (suite test-suite))
209 (setf (gethash (test-name test) (tests-hash suite)) test))
211 (defmethod add-test ((test test-suite) (suite test-suite))
212 (setf (gethash (test-suite-name test) (tests-hash suite)) test))
214 (defmethod remove-test ((test test-fixture) (suite test-suite))
215 (remhash (test-name test) (tests-hash suite)))
217 (defmethod remove-test ((test test-suite) (suite test-suite))
218 (remhash (test-suite-name test) (tests-hash suite)))
220 (defmethod test-named ((name string) (suite test-suite))
221 (gethash name (tests-hash suite)))
223 (defmethod was-successful ((result test-result))
224 (and (null (test-failures result))
225 (null (test-errors result))))
227 (defmethod text-testrunner ((suite test-suite) &key (stream t)
229 (let ((result (make-instance 'test-result))
230 (start-time (get-internal-real-time)))
231 (run-test suite result :handle-errors handle-errors)
232 (let ((seconds (/ (- (get-internal-real-time) start-time)
233 internal-time-units-per-second)))
234 (result-printer result seconds stream))))
236 (defun result-printer (result seconds stream)
237 (format stream "~&Time: ~D~%~%" (coerce seconds 'float))
238 (print-defects (test-errors result) "error" stream)
239 (print-defects (test-failures result) "failure" stream)
240 (if (was-successful result)
241 (format stream "OK (~D tests)~%" (test-count result))
243 (format stream "~%FAILURES!!!~%")
244 (format stream "Tests run: ~D, Failures: ~D, Errors: ~D~%"
245 (test-count result) (length (test-failures result))
246 (length (test-errors result))))))
248 (defun print-defects (defects type stream)
250 (let ((count (length defects)))
252 (format stream "~&There was ~D ~A:~%" count type)
253 (format stream "~&There were ~D ~As:~%" count type))
255 (let ((defect (nth i defects)))
256 (format stream "~&~D) ~A " i (class-name
257 (class-of (failed-test defect))))
258 (apply #'format stream (simple-condition-format-control
259 (thrown-condition defect))
260 (simple-condition-format-arguments
261 (thrown-condition defect)))
262 (fresh-line stream))))))
264 (defmethod summary ((result test-result))
265 (format nil "~D run, ~D errored, ~D failed"
266 (test-count result) (length (test-errors result))
267 (length (test-failures result))))
269 ;;; Dynamic test suite addition by Kevin Rosenberg 8/2003
271 (defun make-test-suite-for-fixture
274 (format nil "Automatic for ~A"
275 (if (slot-boundp fixture 'test-name)
279 (let ((suite (make-instance 'test-suite
281 :description description))
282 (fns (find-test-generic-functions fixture)))
284 (make-test (class-name (class-of fixture)) fn
288 (defun find-test-generic-functions (instance)
289 "Return a list of symbols for generic functions specialized on the
290 class of an instance and whose name begins with the string 'test-'.
291 This is used to dynamically generate a list of tests for a fixture."
293 (package (symbol-package (class-name (class-of instance)))))
294 (do-symbols (s package)
295 (when (and (> (length (symbol-name s)) 5)
296 (string-equal "test-" (subseq (symbol-name s) 0 5))
298 (typep (symbol-function s) 'generic-function)
299 (plusp (length (compute-applicable-methods
300 (ensure-generic-function s)