X-Git-Url: http://git.kpe.io/?a=blobdiff_plain;f=tcase.lisp;fp=tcase.lisp;h=da0d8ded73b5868c510094dac93ab7dee05e7a38;hb=381a23bb7ab8dd206bcd430ce9c7ee9c53e52f13;hp=0000000000000000000000000000000000000000;hpb=e6a0ad7329d3ce497ce8c9f3d0d37811b2da4811;p=xlunit.git

diff --git a/tcase.lisp b/tcase.lisp
new file mode 100644
index 0000000..da0d8de
--- /dev/null
+++ b/tcase.lisp
@@ -0,0 +1,147 @@
+;;;; -*- 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))