;;;; *************************************************************************
;;;; FILE IDENTIFICATION
;;;;
-;;;; ID: $Id: tcase.lisp,v 1.1 2003/08/04 17:04:49 kevin Exp $
+;;;; ID: $Id$
;;;; Purpose: Test fixtures for XLUnit
;;;;
;;;; *************************************************************************
:documentation
"A function designator which will be applied to this instance
to perform that test-case.")
- (name :initarg :name :reader name
+ (name :initarg :name :reader name :initform ""
:documentation "The name of this test-case, used in reports.")
(description :initarg :description :reader description
:documentation
(defmethod tear-down ((test test-case))
)
-(defmethod run ((ob test-case))
- (run-on-test-results ob (make-instance 'test-results)))
-
+(defmethod run ((ob test) &key (handle-errors t))
+ "Generalized to work on test-case and test-suites"
+ (let ((res (make-test-results)))
+ (run-on-test-results ob res :handle-errors handle-errors)
+ res))
(defmethod run-on-test-results ((test test-case) result
&key (handle-errors t))
(tear-down test)))
(defmethod run-test ((test test-case))
- (funcall (method-body test)))
+ (funcall (method-body test)))
(defmethod run-protected ((test test-case) res &key (handle-errors t))
- (handler-case
- (run-base test)
- (assertion-failed (condition)
- (add-failure res test condition))
- (serious-condition (condition)
- (add-error res test condition)))
+ (if handle-errors
+ (handler-case
+ (run-base test)
+ (assertion-failed (condition)
+ (add-failure res test condition))
+ (serious-condition (condition)
+ (add-error res test condition)))
+ (run-base test))
res)
-
-
-(defmacro handler-case-if (test form &body cases)
- `(if ,test
- (handler-case
- ,form
- ,@cases)
- ,form))
-
-(defmacro unwind-protect-if (test protected cleanup)
- `(if ,test
- (unwind-protect
- ,protected
- ,cleanup)
- (progn ,protected ,cleanup)))
-
-#|
-(defmethod run-test ((test test-case)
- &key (result (make-instance 'test-results))
- (handle-errors t))
- "Perform the test represented by the given test-case or test-suite.
-Returns a test-results object."
- (incf (run-count result))
- (with-slots (failures errors) result
- (unwind-protect-if handle-errors
- (handler-case-if handle-errors
- (let ((res (progn (setup test)
- (funcall (method-body 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 method-body test-suite description)
- "Create a test-case which is an instance of FIXTURE. METHOD-BODY 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-case
-instance. DESCRIPTION is obviously what it says it is."
- (let ((newtest (make-instance fixture
- :name (etypecase name
- (symbol
- (string-downcase (symbol-name name)))
- (string
- name))
- :method-body
- (if (and (symbolp name) (null method-body))
- name
- method-body)
- :description description)))
- (when test-suite (add-test newtest test-suite))
- newtest))