+;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; ID: $Id: test-case.lisp,v 1.1 2003/08/04 16:13:58 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-on-test ((test test-case)
+ &key (result (make-instance 'test-result))
+ (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-result))
+ (handle-errors t))
+ "Perform the test represented by the given test-case or test-suite.
+Returns a test-result 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))