--- /dev/null
+;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name: fixture.lisp
+;;;; Purpose: eXtreme Lisp Test Suite
+;;;; Authors: Kevin Rosenberg and Craig Brozefsky
+;;;;
+;;;; $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
+ :documentation
+ "A thunk or symbol which will be applied to this instance, a
+test-case, to perform that test-case. Defaults to 'perform-test")
+ (test-name
+ :initarg :test-name
+ :reader test-name
+ :documentation
+ "The name of this test-case, used in reports.")
+ (test-description
+ :initarg :description
+ :reader description
+ :documentation
+ "Short description of this test-case, uses in reports"))
+ (:documentation
+ "Base class for test-fixtures. Test-cases are instances of test-fixtures."))
+
+(defgeneric setup (test)
+ (:documentation
+ "Method called before performing a test, should set up the
+environment the test-case needs to operate in."))
+
+(defmethod setup ((test test-fixture))
+ t)
+
+(defgeneric teardown (test)
+ (:documentation
+ "Method called after performing a test. Should reverse everything
+that the setup method did for this instance."))
+
+(defmethod teardown ((test test-fixture))
+ t)
+
+
+(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-fixture)
+ &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."
+ (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))))
+ 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
+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))
+