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 ;;;; $Id: src.lisp,v 1.3 2003/08/04 09:50:33 kevin Exp $
10 ;;;; *************************************************************************
15 (defclass test-fixture ()
17 :initarg :test-thunk :reader test-thunk
18 :initform 'perform-test
20 "A thunk or symbol which will be applied to this instance, a
21 test-case, to perform that test-case. Defaults to 'perform-test")
26 "The name of this test-case, used in reports.")
31 "Short description of this test-case, uses in reports"))
33 "Base class for test-fixtures. Test-cases are instances of test-fixtures."))
35 (defmethod setup ((test test-fixture))
36 "Method called before performing a test, should set up the
37 environment the test-case needs to operate in."
40 (defmethod teardown ((test test-fixture))
41 "Method called after performing a test. Should reverse everything that the
42 setup method did for this instance."
45 (define-condition test-failure-condition (simple-condition)
47 (:documentation "Base class for all test failures."))
49 (defclass test-failure ()
50 ((failed-test :initarg :failed-test :reader failed-test)
51 (thrown-condition :initarg :thrown-condition :reader thrown-condition)))
53 (defmethod print-object ((obj test-failure) stream)
54 (print-unreadable-object (obj stream :type t :identity nil)
55 (format stream "~A: " (failed-test obj))
56 (apply #'format stream
57 (simple-condition-format-control (thrown-condition obj))
58 (simple-condition-format-arguments (thrown-condition obj)))))
60 (defmethod is-failure ((failure test-failure))
61 (typep (thrown-condition failure) 'test-failure-condition))
63 (defun failure (format-str &rest args)
64 "Signal a test failure and exit the test."
65 (signal 'test-failure-condition
66 :format-control format-str
67 :format-arguments args))
69 (defmacro test-assert (test &optional msg)
71 (failure "Test assertion: ~s" ',test)))
73 (defun assert-equal (v1 v2 &optional msg)
75 (failure "Test equal: ~s ~s" v1 v2)))
77 (defun assert-true (v &optional msg)
79 (failure "Test true: ~s [~A]" v (if msg msg ""))))
81 (defun assert-false (v &optional msg)
83 (failure "Test false ~A" (if msg msg ""))))
86 (defmethod perform-test ((test test-fixture))
87 "Default method for performing tests upon a test-fixture."
90 (defmacro handler-case-if (test form &body cases)
97 (defmacro unwind-protect-if (test protected cleanup)
102 (progn ,protected ,cleanup)))
104 (defclass test-result ()
105 ((test :initarg :test :reader result-test)
106 (count :initform 0 :accessor test-count)
107 (failures :initarg :failures :reader test-failures :initform nil)
108 (errors :initarg :errors :reader test-errors :initform nil))
109 (:documentation "The result of applying a test"))
111 (defclass test-suite ()
112 ((name :initarg :name :reader test-suite-name)
113 (tests :initarg :tests :accessor tests-hash
114 :initform (make-hash-table :test 'equal))
115 (description :initarg :description :reader description
116 :initform "No description.")))
118 (defmethod setup-testsuite-named (name)
119 (declare (ignore name))
122 (defmethod teardown-testsuite-named (name)
123 (declare (ignore name))
126 (defmethod run-test ((suite test-suite) (result test-result)
127 &key (handle-errors t))
128 (setup-testsuite-named (slot-value suite 'name))
129 (dolist (test (tests suite))
130 (run-test test result :handle-errors handle-errors))
131 (teardown-testsuite-named (slot-value suite 'name))
134 (defmethod run-test ((test test-fixture) result &key (handle-errors t))
135 "Perform the test represented by the given test-case or test-suite.
136 Returns one or more test-result objects, one for each test-case
138 (incf (test-count result))
139 (with-slots (failures errors) result
140 (unwind-protect-if handle-errors
141 (handler-case-if handle-errors
142 (let ((res (progn (setup test)
143 (funcall (test-thunk test) test))))
144 (if (typep res 'test-failure-condition)
145 (push (make-instance 'test-failure
147 :thrown-condition res)
149 (test-failure-condition (failure)
150 (push (make-instance 'test-failure
152 :thrown-condition failure)
155 (push (make-instance 'test-failure
157 :thrown-condition err)
164 (make-instance 'test-failure
165 :failed-test test :thrown-condition err)
171 (defun make-test (fixture name &key test-thunk test-suite description)
172 "Create a test-case which is an instance of FIXTURE. TEST-THUNK is
173 the method that will be invoked when perfoming this test, and can be a
174 symbol or a lambda taking a single argument, the test-fixture
175 instance. DESCRIPTION is obviously what it says it is."
176 (let ((newtest (make-instance fixture
177 :test-name (string name)
179 (if(and (symbolp name) (null test-thunk))
182 :description description)))
183 (if test-suite (add-test newtest test-suite))
186 (defmethod tests ((suite test-suite))
188 (maphash #'(lambda (k v)
190 (setf tlist (cons v tlist)))
194 (defun make-test-suite (name-or-fixture &optional description testspecs)
195 "Returns a new test-suite based on a name and TESTSPECS or a fixture
197 (etypecase name-or-fixture
199 (make-test-suite-for-fixture (make-instance name-or-fixture)))
201 (let ((suite (make-instance 'test-suite :name name-or-fixture
202 :description description)))
203 (dolist (testspec testspecs)
204 (add-test (apply #'make-test testspec) suite))
207 (defmethod add-test ((test test-fixture) (suite test-suite))
208 (setf (gethash (test-name test) (tests-hash suite)) test))
210 (defmethod add-test ((test test-suite) (suite test-suite))
211 (setf (gethash (test-suite-name test) (tests-hash suite)) test))
213 (defmethod remove-test ((test test-fixture) (suite test-suite))
214 (remhash (test-name test) (tests-hash suite)))
216 (defmethod remove-test ((test test-suite) (suite test-suite))
217 (remhash (test-suite-name test) (tests-hash suite)))
219 (defmethod test-named ((name string) (suite test-suite))
220 (gethash name (tests-hash suite)))
222 (defmethod was-successful ((result test-result))
223 (and (null (test-failures result))
224 (null (test-errors result))))
226 (defmethod text-testrunner ((suite test-suite) &key (stream t)
228 (let ((result (make-instance 'test-result))
229 (start-time (get-internal-real-time)))
230 (run-test suite result :handle-errors handle-errors)
231 (let ((seconds (/ (- (get-internal-real-time) start-time)
232 internal-time-units-per-second)))
233 (result-printer result seconds stream))))
235 (defun result-printer (result seconds stream)
236 (format stream "~&Time: ~D~%~%" (coerce seconds 'float))
237 (print-defects (test-errors result) "error" stream)
238 (print-defects (test-failures result) "failure" stream)
239 (if (was-successful result)
240 (format stream "OK (~D tests)~%" (test-count result))
242 (format stream "~%FAILURES!!!~%")
243 (format stream "Tests run: ~D, Failures: ~D, Errors: ~D~%"
244 (test-count result) (length (test-failures result))
245 (length (test-errors result))))))
247 (defun print-defects (defects type stream)
249 (let ((count (length defects)))
251 (format stream "~&There was ~D ~A:~%" count type)
252 (format stream "~&There were ~D ~As:~%" count type))
254 (let ((defect (nth i defects)))
255 (format stream "~&~D) ~A " i (class-name
256 (class-of (failed-test defect))))
257 (apply #'format stream (simple-condition-format-control
258 (thrown-condition defect))
259 (simple-condition-format-arguments
260 (thrown-condition defect)))
261 (fresh-line stream))))))
263 (defmethod summary ((result test-result))
264 (format nil "~D run, ~D errored, ~D failed"
265 (test-count result) (length (test-errors result))
266 (length (test-failures result))))
268 ;;; Dynamic test suite addition by Kevin Rosenberg 8/2003
270 (defun make-test-suite-for-fixture
273 (format nil "Automatic for ~A"
274 (if (slot-boundp fixture 'test-name)
278 (let ((suite (make-instance 'test-suite
280 :description description))
281 (fns (find-test-generic-functions fixture)))
283 (make-test (class-name (class-of fixture)) fn
287 (defun find-test-generic-functions (instance)
288 "Return a list of symbols for generic functions specialized on the
289 class of an instance and whose name begins with the string 'test-'.
290 This is used to dynamically generate a list of tests for a fixture."
292 (package (symbol-package (class-name (class-of instance)))))
293 (do-symbols (s package)
294 (when (and (> (length (symbol-name s)) 5)
295 (string-equal "test-" (subseq (symbol-name s) 0 5))
297 (typep (symbol-function s) 'generic-function)
298 (plusp (length (compute-applicable-methods
299 (ensure-generic-function s)