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.1 2003/08/04 06:00:01 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 (simple-condition) ()
47 (:documentation "Base class for all test failures."))
49 (defun failure (format-str &rest args)
50 "Signal a test failure and exit the test."
52 :format-control format-str
53 :format-arguments args))
55 (defmacro test-assert (test)
57 (failure "Test assertion failed: ~s" ',test)))
59 (defun assert-equal (v1 v2)
61 (failure "Test equals failed: ~s ~s" v1 v2)))
63 (defun assert-true (v)
65 (failure "Test true failed: ~s" v)))
67 (defun assert-false (v)
69 (failure "Test false failed")))
72 (defmethod perform-test ((test test-fixture))
73 "Default method for performing tests upon a test-fixture."
76 (defmacro handler-case-if (test form &body cases)
83 (defmacro unwind-protect-if (test protected cleanup)
88 (progn ,protected ,cleanup)))
90 (defmethod run-test ((test test-fixture) &key (handle-errors t))
91 "Perform the test represented by the given test-case or test-suite.
92 Returns one or more test-result objects, one for each test-case
96 (unwind-protect-if handle-errors
97 (handler-case-if handle-errors
98 (let ((res (progn (setup test)
99 (funcall (test-thunk test) test))))
100 (if (typep res 'test-failure)
101 (setf failures (cons res failures))))
102 (test-failure (failure)
103 (setf failures (cons failure failures)))
105 (setf errs (cons err errs))))
106 (handler-case-if handle-errors
109 (setf errs (cons err errs)))))
110 (make-instance 'test-result
115 (defmacro def-test-fixture (name supers slotdefs &rest class-options)
116 "Define a new test-fixture class. Works just like defclass, but
117 ensure that test-fixture is a super."
118 `(defclass ,name ,(append supers (list 'test-fixture))
119 ,slotdefs ,@class-options))
121 (defun make-test-case (name fixture &key
122 (test-thunk 'perform-test)
125 "Create a test-case which is an instance of FIXTURE. TEST-THUNK is
126 the method that will be invoked when perfoming this test, and can be a
127 symbol or a lambda taking a single argument, the test-fixture
128 instance. DESCRIPTION is obviously what it says it is."
129 (let ((newtest (make-instance fixture
131 :test-thunk test-thunk
132 :description description)))
133 (if test-suite (add-test newtest test-suite))
136 (defclass test-suite ()
137 ((name :initarg :name :reader test-suite-name)
138 (tests :initarg :tests :accessor tests-hash
139 :initform (make-hash-table :test 'equal))
140 (description :initarg :description :reader description
141 :initform "No description.")))
143 (defmethod tests ((suite test-suite))
145 (maphash #'(lambda (k v)
147 (setf tlist (cons v tlist)))
151 (defun make-test-suite (name-or-fixture &optional description testspecs)
152 "Returns a new test-suite based on a name and TESTSPECS or a fixture
154 (etypecase name-or-fixture
156 (make-test-suite-for-fixture (make-instance name-or-fixture)))
158 (let ((suite (make-instance 'test-suite :name name-or-fixture
159 :description description)))
160 (dolist (testspec testspecs)
161 (add-test (apply #'make-test-case testspec) suite))
164 (defmethod add-test ((test test-fixture) (suite test-suite))
165 (setf (gethash (test-name test) (tests-hash suite)) test))
167 (defmethod add-test ((test test-suite) (suite test-suite))
168 (setf (gethash (test-suite-name test) (tests-hash suite)) test))
170 (defmethod remove-test ((test test-fixture) (suite test-suite))
171 (remhash (test-name test) (tests-hash suite)))
173 (defmethod remove-test ((test test-suite) (suite test-suite))
174 (remhash (test-suite-name test) (tests-hash suite)))
176 (defmethod test-named ((name string) (suite test-suite))
177 (gethash name (tests-hash suite)))
179 (defmethod setup-testsuite-named (name)
180 (declare (ignore name))
183 (defmethod teardown-testsuite-named (name)
184 (declare (ignore name))
187 (defmethod run-test ((suite test-suite) &key (handle-errors t))
188 (let ((start-time (get-internal-real-time)))
189 (setup-testsuite-named (slot-value suite 'name))
190 (let ((res (mapcar (lambda (test) (run-test test
191 :handle-errors handle-errors))
193 (teardown-testsuite-named (slot-value suite 'name))
194 (make-instance 'suite-results
197 :start-time start-time
198 :stop-time (get-internal-real-time)))))
201 (defclass test-result ()
202 ((test :initarg :test :reader result-test)
203 (failures :initarg :failures :reader test-failures :initform nil)
204 (errors :initarg :errors :reader test-errors :initform nil))
205 (:documentation "The result of applying a test"))
207 (defclass suite-results ()
208 ((suite :initarg :suite :reader suite)
209 (start-time :initarg :start-time :reader start-time)
210 (stop-time :initarg :stop-time :reader stop-time)
211 (test-results :initarg :test-results :reader test-results))
212 (:documentation "Results of running a suite"))
215 (defmethod report-result ((result test-result) &key (stream t)
217 "Print out a test-result object for a report to STREAM, default to
218 standard-output. If VERBOSE is non-nil then will produce a lengthy
219 and informative report, otherwise just prints wether the test passed
220 or failed or errored out."
221 (when (or verbose (test-failures result) (test-errors result))
224 "------------------------------------------------------~%"))
225 (format stream "~A~A"
226 (test-name (result-test result))
228 ((test-failures result) ":")
229 ((test-errors result) ":")
231 (when (test-failures result)
232 (format stream " Failures: ~{~A~^; ~}" (test-failures result)))
233 (when (test-errors result)
234 (format stream " Errors: ~{~A~^; ~}" (test-errors result)))
237 (when (description (result-test result))
238 (format stream "Description: ~A~%"
239 (description (result-test result)))))))
241 (defmethod report-result ((results suite-results) &key (stream t)
243 (format stream "~&.............~%")
244 (format stream "~&Time: ~D~%"
246 (/ (- (stop-time results) (start-time results))
247 internal-time-units-per-second)))
248 (if (some (lambda (res) (or (test-failures res) (test-errors res)))
249 (test-results results))
250 (dolist (foo (test-results results))
251 (report-result foo :stream stream :verbose verbose))
252 (format stream "~&OK (~D tests)~%" (length (test-results results)))))
255 ;;; Dynamic test suite addition by Kevin Rosenberg 8/2003
257 (defun make-test-suite-for-fixture
260 (format nil "Automatic for ~A"
261 (if (slot-boundp fixture 'test-name)
265 (let ((suite (make-instance 'test-suite
267 :description description))
268 (fns (find-test-generic-functions fixture)))
270 (make-test-case fn (class-name (class-of fixture))
275 (defun find-test-generic-functions (instance)
276 "Return a list of symbols for generic functions specialized on the
277 class of an instance and whose name begins with the string 'test-'.
278 This is used to dynamically generate a list of tests for a fixture."
280 (package (symbol-package (class-name (class-of instance)))))
281 (do-symbols (s package)
282 (multiple-value-bind (sym status)
283 (find-symbol (symbol-name s) package)
284 (when (and (or (eq status :external)
285 (eq status :internal))
287 (eq (symbol-package sym) package)
288 (> (length (symbol-name sym)) 5)
289 (string-equal "test-" (subseq (symbol-name sym) 0 5))
290 (typep (symbol-function sym) 'generic-function)
293 (compute-applicable-methods
294 (ensure-generic-function sym)