X-Git-Url: http://git.kpe.io/?a=blobdiff_plain;f=fixture.lisp;fp=fixture.lisp;h=8408cc841c535cb5c9aa3a93f1f1719db522a145;hb=318cda1a328e9d99af2270c73cb13262e485a1ff;hp=0000000000000000000000000000000000000000;hpb=bee53ea40ad9caeeed1e7392d1f59127df7512ac;p=xlunit.git

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