;;;; *************************************************************************
;;;; FILE IDENTIFICATION
;;;;
-;;;; Name: fixture.lisp
-;;;; Purpose: eXtreme Lisp Test Suite
-;;;; Authors: Kevin Rosenberg and Craig Brozefsky
+;;;; ID: $Id$
+;;;; Purpose: Test fixtures for XLUnit
;;;;
-;;;; $Id: fixture.lisp,v 1.1 2003/08/04 12:01:54 kevin Exp $
;;;; *************************************************************************
(in-package #:xlunit)
(defclass test-fixture ()
- ((test-thunk
- :initarg :test-thunk :reader test-thunk
- :initform 'perform-test
+ ((test-fn
+ :initarg :test-fn :reader test-fn :initform nil
:documentation
- "A thunk or symbol which will be applied to this instance, a
-test-case, to perform that test-case. Defaults to 'perform-test")
+ "A function designator which will be applied to this instance
+to perform that test-case.")
(test-name
- :initarg :test-name
- :reader test-name
+ :initarg :test-name :reader test-name
:documentation
"The name of this test-case, used in reports.")
(test-description
- :initarg :description
- :reader description
+ :initarg :description :reader description
:documentation
"Short description of this test-case, uses in reports"))
(:documentation
`(if ,test
(handler-case
,form
- ,@cases)
+ ,@cases)
,form))
(defmacro unwind-protect-if (test protected cleanup)
`(if ,test
(unwind-protect
- ,protected
- ,cleanup)
+ ,protected
+ ,cleanup)
(progn ,protected ,cleanup)))
(defmethod run-test ((test test-fixture)
- &key (result (make-instance 'test-result))
- (handle-errors t))
+ &key (result (make-instance 'test-result))
+ (handle-errors t))
"Perform the test represented by the given test-case or test-suite.
-Returns one or more test-result objects, one for each test-case
-performed."
+Returns a test-result object."
(incf (test-count result))
(with-slots (failures errors) result
(unwind-protect-if handle-errors
- (handler-case-if handle-errors
- (let ((res (progn (setup test)
- (funcall (test-thunk test) test))))
- (if (typep res 'test-failure-condition)
- (push (make-instance 'test-failure
- :failed-test test
- :thrown-condition res)
- failures)))
- (test-failure-condition (failure)
- (push (make-instance 'test-failure
- :failed-test test
- :thrown-condition failure)
- failures))
- (error (err)
- (push (make-instance 'test-failure
- :failed-test test
- :thrown-condition err)
- errors)))
- (if handle-errors
- (handler-case
- (teardown test)
- (error (err)
- (push
- (make-instance 'test-failure
- :failed-test test :thrown-condition err)
- errors)))
- (teardown test))))
+ (handler-case-if handle-errors
+ (let ((res (progn (setup test)
+ (funcall (test-fn test) test))))
+ (when (typep res 'test-failure-condition)
+ (push (make-test-failure test res) failures)))
+ (test-failure-condition (failure)
+ (push (make-test-failure test failure) failures))
+ (error (err)
+ (push (make-test-failure test err) errors)))
+
+ (if handle-errors
+ (handler-case
+ (teardown test)
+ (error (err)
+ (push (make-test-failure test err) errors)))
+ (teardown test))))
result)
-(defun make-test (fixture name &key test-thunk test-suite description)
- "Create a test-case which is an instance of FIXTURE. TEST-THUNK is
+(defun make-test (fixture name &key test-fn test-suite description)
+ "Create a test-case which is an instance of FIXTURE. TEST-FN is
the method that will be invoked when perfoming this test, and can be a
symbol or a lambda taking a single argument, the test-fixture
instance. DESCRIPTION is obviously what it says it is."
(let ((newtest (make-instance fixture
- :test-name (etypecase name
- (symbol
- (string-downcase (symbol-name name)))
- (string
- name))
- :test-thunk
- (if(and (symbolp name) (null test-thunk))
- name
- test-thunk)
- :description description)))
- (if test-suite (add-test newtest test-suite))
- newtest))
-
+ :test-name (etypecase name
+ (symbol
+ (string-downcase (symbol-name name)))
+ (string
+ name))
+ :test-fn
+ (if(and (symbolp name) (null test-fn))
+ name
+ test-fn)
+ :description description)))
+ (when test-suite (add-test newtest test-suite))
+ newtest))