;;;; -*- 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))