2 ;;;; xptestsuite.lisp --- Test suite based on Extreme Programming
3 ;;;; Framework by Kent Beck
5 ;;;; Inspired by http://www.xprogramming.com/testfram.htm
7 ;;;; Author: Craig Brozefsky <craig@onshore.com>
8 ;;;; Put in public domain by onShore, Inc
10 ;;;; $Id: xptestsuite.lisp,v 1.2 2003/02/23 05:51:55 kevin Exp $
14 (defclass test-fixture ()
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 (simple-condition) ()
46 (:documentation "Base class for all test failures."))
48 (defun failure (format-str &rest args)
49 "Signal a test failure and exit the test."
51 #+(or cmu allegro openmcl) :format-control
52 #-(or cmu allegro openmcl) :format-string
54 :format-arguments args))
56 (defmacro test-assert (test)
58 (failure "Test assertion failed: ~s" ',test)))
61 (defmethod perform-test ((test test-fixture))
62 "Default method for performing tests upon a test-fixture."
65 (defmacro handler-case-if (test form &body cases)
72 (defmacro unwind-protect-if (test protected cleanup)
77 (progn ,protected ,cleanup)))
79 (defmethod run-test ((test test-fixture) &key (handle-errors t))
80 "Perform the test represented by the given test-case or test-suite.
81 Returns one or more test-result objects, one for each test-case
83 (let ((start-time (get-universal-time))
86 (unwind-protect-if handle-errors
87 (handler-case-if handle-errors
88 (let ((res (progn (setup test)
89 (apply (test-thunk test) (list test)))))
90 (if (typep res 'test-failure)
91 (setf failures (cons res failures))))
92 (test-failure (failure)
93 (setf failures (cons failure failures)))
95 (setf errs (cons err errs))))
96 (handler-case-if handle-errors
99 (setf errs (cons err errs)))))
100 (make-instance 'test-result
102 :start-time start-time
103 :stop-time (get-universal-time)
107 (defmacro def-test-fixture (name supers slotdefs &rest class-options)
108 "Define a new test-fixture class. Works just like defclass, but
109 ensure that test-fixture is a super."
110 `(defclass ,name ,(append supers (list 'test-fixture))
111 ,slotdefs ,@class-options))
113 (defmacro make-test-case (name fixture &key
114 (test-thunk 'perform-test)
116 (description "No description."))
117 "Create a test-case which is an instance of FIXTURE. TEST-THUNK is
118 the method that will be invoked when perfoming this test, and can be a
119 symbol or a lambda taking a single argument, the test-fixture
120 instance. DESCRIPTION is obviously what it says it is."
121 (let ((newtest (gensym "new-test")))
122 `(let ((,newtest (make-instance ,fixture
124 :test-thunk ,(if (eq test-thunk 'perform-test)
127 :description ,description)))
128 (if ,test-suite (add-test ,newtest ,test-suite))
131 (defclass test-suite ()
134 :reader test-suite-name)
138 :initform (make-hash-table :test 'equal))
140 :initarg :description
142 :initform "No description.")))
144 (defmethod tests ((suite test-suite))
146 (maphash #'(lambda (k v)
148 (setf tlist (cons v tlist)))
152 (defmacro make-test-suite (name description &rest testspecs)
153 "Returns a new test-suite. TESTSPECS are just like lists of
154 arguments to MAKE-TEST-CASE."
155 (let* ((newsuite (gensym "test-suite"))
156 (testforms (mapcar #'(lambda (spec)
159 (cons 'make-test-case spec)
162 `(let ((,newsuite (make-instance 'test-suite :name ,name
163 :description ,description)))
167 (defmethod add-test ((test test-fixture) (suite test-suite))
168 (setf (gethash (test-name test) (tests-hash suite)) test))
170 (defmethod add-test ((test test-suite) (suite test-suite))
171 (setf (gethash (test-suite-name test) (tests-hash suite)) test))
173 (defmethod remove-test ((test test-fixture) (suite test-suite))
174 (remhash (test-name test) (tests-hash suite)))
176 (defmethod remove-test ((test test-suite) (suite test-suite))
177 (remhash (test-suite-name test) (tests-hash suite)))
179 (defmethod test-named ((name string) (suite test-suite))
180 (gethash name (tests-hash suite)))
182 (defmethod setup-testsuite-named (name)
183 (declare (ignore name))
186 (defmethod teardown-testsuite-named (name)
187 (declare (ignore name))
190 (defmethod run-test ((suite test-suite) &key (handle-errors t))
191 (setup-testsuite-named (slot-value suite 'name))
192 (let ((res (mapcar (lambda (test) (run-test test
193 :handle-errors handle-errors))
195 (teardown-testsuite-named (slot-value suite 'name))
199 (defclass test-result ()
211 :reader test-failures
218 "The result of applying a test"))
220 (defmethod report-result ((result test-result) &key (stream t) (verbose nil))
221 "Print out a test-result object for a report to STREAM, default to
222 standard-output. If VERBOSE is non-nil then will produce a lengthy
223 and informative report, otherwise just prints wether the test passed
224 or failed or errored out."
225 (if verbose (format stream
226 "------------------------------------------------------~%"))
227 (format stream "Test ~A ~A ~%"
228 (test-name (result-test result))
230 ((test-failures result) "Failed")
231 ((test-errors result) "Errored")
235 (format stream "Description: ~A~%" (description (result-test result)))
236 (if (test-failures result)
238 (format stream "Failures:~%")
239 (mapcar #'(lambda (fail) (format stream " ~A" fail))
240 (test-failures result))))
241 (if (test-errors result)
243 (format stream "Errors:~%")
244 (mapcar #'(lambda (fail) (format stream " ~A" fail))
245 (test-errors result))))))
246 (format stream "~%~%"))
248 (defmethod report-result ((results list) &key (stream t) (verbose nil))
249 (dolist (foo results)
250 (report-result foo :stream stream :verbose verbose)))