;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
;;;; *************************************************************************
;;;; FILE IDENTIFICATION
;;;;
;;;; ID:      $Id: tcase.lisp,v 1.1 2003/08/04 17:04:49 kevin Exp $
;;;; Purpose: Test fixtures for XLUnit
;;;;
;;;; *************************************************************************

(in-package #:xlunit)


(defclass test ()
  ())

(defclass test-case (test)
  ((existing-suites :initform nil :accessor existing-suites
		    :allocation :class)
   (method-body
    :initarg :method-body :accessor method-body :initform nil
    :documentation
    "A function designator which will be applied to this instance
to perform that test-case.")
   (name :initarg :name :reader name
	 :documentation "The name of this test-case, used in reports.")
   (description :initarg :description :reader description
		:documentation
		"Short description of this test-case, uses in reports")
   (suite :initform nil :accessor suite :initarg :suite))
  (:documentation
   "Base class for test-cases."))

(defmethod initialize-instance :after ((ob test-case) &rest initargs)
  (declare (ignore initargs))
  (if (null (existing-suites ob))
    (setf (existing-suites ob) (make-hash-table)))  ;;hash singleton
  (unless (gethash (type-of ob) (existing-suites ob))
    (setf (gethash (type-of ob) (existing-suites ob))
          (make-instance 'test-suite)))             ;;specifi suite singleton
  (setf (suite ob) (gethash (type-of ob) (existing-suites ob))))
 

(defgeneric set-up (test)
  (:documentation
   "Method called before performing a test, should set up the
environment the test-case needs to operate in."))

(defmethod set-up ((test test-case))
  )

(defgeneric tear-down (test)
  (:documentation
   "Method called after performing a test.  Should reverse everything
that the setup method did for this instance."))

(defmethod tear-down ((test test-case))
  )

(defmethod run ((ob test-case))
  (run-on-test-results ob (make-instance 'test-results)))
   

(defmethod run-on-test-results ((test test-case) result
				&key (handle-errors t))
  (start-test test result)
  (run-protected test result :handle-errors handle-errors)
  (end-test test result))

(defmethod run-base ((test test-case))
  (set-up test)
  (unwind-protect
      (run-test test)
    (tear-down test)))

(defmethod run-test ((test test-case))
  (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)))
  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))