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
12 (in-package #:cl-user)
14 (defpackage #:xp-test-framework
16 (:nicknames #:xp-test #:xptest)
28 #:setup-testsuite-named
29 #:teardown-testsuite-named
37 (:documentation "This is the XP TestSuite Framework."))
41 (defclass test-fixture ()
45 :initform 'perform-test
47 "A thunk or symbol which will be applied to this instance, a
48 test-case, to perform that test-case. Defaults to 'perform-test")
53 "The name of this test-case, used in reports.")
58 "Short description of this test-case, uses in reports"))
60 "Base class for test-fixtures. Test-cases are instances of test-fixtures."))
62 (defmethod setup ((test test-fixture))
63 "Method called before performing a test, should set up the
64 environment the test-case needs to operate in."
67 (defmethod teardown ((test test-fixture))
68 "Method called after performing a test. Should reverse everything that the
69 setup method did for this instance."
72 (define-condition test-failure (simple-condition) ()
73 (:documentation "Base class for all test failures."))
75 (defun failure (format-str &rest args)
76 "Signal a test failure and exit the test."
78 #+(or cmu allegro openmcl) :format-control
79 #-(or cmu allegro openmcl) :format-string
81 :format-arguments args))
83 (defmacro test-assert (test)
85 (failure "Test assertion failed: ~s" ',test)))
88 (defmethod perform-test ((test test-fixture))
89 "Default method for performing tests upon a test-fixture."
92 (defmacro handler-case-if (test form &body cases)
99 (defmacro unwind-protect-if (test protected cleanup)
104 (progn ,protected ,cleanup)))
106 (defmethod run-test ((test test-fixture) &key (handle-errors t))
107 "Perform the test represented by the given test-case or test-suite.
108 Returns one or more test-result objects, one for each test-case
110 (let ((start-time (get-universal-time))
113 (unwind-protect-if handle-errors
114 (handler-case-if handle-errors
115 (let ((res (progn (setup test)
116 (apply (test-thunk test) (list test)))))
117 (if (typep res 'test-failure)
118 (setf failures (cons res failures))))
119 (test-failure (failure)
120 (setf failures (cons failure failures)))
122 (setf errs (cons err errs))))
123 (handler-case-if handle-errors
126 (setf errs (cons err errs)))))
127 (make-instance 'test-result
129 :start-time start-time
130 :stop-time (get-universal-time)
134 (defmacro def-test-fixture (name supers slotdefs &rest class-options)
135 "Define a new test-fixture class. Works just like defclass, but
136 ensure that test-fixture is a super."
137 `(defclass ,name ,(append supers (list 'test-fixture))
138 ,slotdefs ,@class-options))
140 (defmacro make-test-case (name fixture &key
141 (test-thunk 'perform-test)
143 (description "No description."))
144 "Create a test-case which is an instance of FIXTURE. TEST-THUNK is
145 the method that will be invoked when perfoming this test, and can be a
146 symbol or a lambda taking a single argument, the test-fixture
147 instance. DESCRIPTION is obviously what it says it is."
148 (let ((newtest (gensym "new-test")))
149 `(let ((,newtest (make-instance ,fixture
151 :test-thunk ,(if (eq test-thunk 'perform-test)
154 :description ,description)))
155 (if ,test-suite (add-test ,newtest ,test-suite))
158 (defclass test-suite ()
161 :reader test-suite-name)
165 :initform (make-hash-table :test 'equal))
167 :initarg :description
169 :initform "No description.")))
171 (defmethod tests ((suite test-suite))
173 (maphash #'(lambda (k v)
175 (setf tlist (cons v tlist)))
179 (defmacro make-test-suite (name description &rest testspecs)
180 "Returns a new test-suite. TESTSPECS are just like lists of
181 arguments to MAKE-TEST-CASE."
182 (let* ((newsuite (gensym "test-suite"))
183 (testforms (mapcar #'(lambda (spec)
186 (cons 'make-test-case spec)
189 `(let ((,newsuite (make-instance 'test-suite :name ,name
190 :description ,description)))
194 (defmethod add-test ((test test-fixture) (suite test-suite))
195 (setf (gethash (test-name test) (tests-hash suite)) test))
197 (defmethod add-test ((test test-suite) (suite test-suite))
198 (setf (gethash (test-suite-name test) (tests-hash suite)) test))
200 (defmethod remove-test ((test test-fixture) (suite test-suite))
201 (remhash (test-name test) (tests-hash suite)))
203 (defmethod remove-test ((test test-suite) (suite test-suite))
204 (remhash (test-suite-name test) (tests-hash suite)))
206 (defmethod test-named ((name string) (suite test-suite))
207 (gethash name (tests-hash suite)))
209 (defmethod setup-testsuite-named (name)
210 (declare (ignore name))
213 (defmethod teardown-testsuite-named (name)
214 (declare (ignore name))
217 (defmethod run-test ((suite test-suite) &key (handle-errors t))
218 (setup-testsuite-named (slot-value suite 'name))
219 (let ((res (mapcar (lambda (test) (run-test test
220 :handle-errors handle-errors))
222 (teardown-testsuite-named (slot-value suite 'name))
226 (defclass test-result ()
238 :reader test-failures
245 "The result of applying a test"))
247 (defmethod report-result ((result test-result) &key (stream t) (verbose nil))
248 "Print out a test-result object for a report to STREAM, default to
249 standard-output. If VERBOSE is non-nil then will produce a lengthy
250 and informative report, otherwise just prints wether the test passed
251 or failed or errored out."
252 (if verbose (format stream
253 "------------------------------------------------------~%"))
254 (format stream "Test ~A ~A ~%"
255 (test-name (result-test result))
257 ((test-failures result) "Failed")
258 ((test-errors result) "Errored")
262 (format stream "Description: ~A~%" (description (result-test result)))
263 (if (test-failures result)
265 (format stream "Failures:~%")
266 (mapcar #'(lambda (fail) (format stream " ~A" fail))
267 (test-failures result))))
268 (if (test-errors result)
270 (format stream "Errors:~%")
271 (mapcar #'(lambda (fail) (format stream " ~A" fail))
272 (test-errors result))))))
273 ;(format stream "~%~%") ; debian bug #190398
276 (defmethod report-result ((results list) &key (stream t) (verbose nil))
277 (dolist (foo results)
278 (report-result foo :stream stream :verbose verbose)))