X-Git-Url: http://git.kpe.io/?a=blobdiff_plain;f=suite.lisp;h=4592100637ad30c018cce32e270f7b4449ddcc7f;hb=0114e93940d17c3dd840f37a81d6fb0da66e7a25;hp=046b61ad67543f68a00d6422c9ad8cb343c5d431;hpb=318cda1a328e9d99af2270c73cb13262e485a1ff;p=xlunit.git

diff --git a/suite.lisp b/suite.lisp
index 046b61a..4592100 100644
--- a/suite.lisp
+++ b/suite.lisp
@@ -2,98 +2,54 @@
 ;;;; *************************************************************************
 ;;;; FILE IDENTIFICATION
 ;;;;
-;;;; Name:        suite.lisp
-;;;; Purpose:     Suite functions for XLUnit
-;;;; Authors:     Kevin Rosenberg and Craig Brozefsky
+;;;; ID:      $Id: suite.lisp,v 1.8 2003/08/06 11:37:23 kevin Exp $
+;;;; Purpose: Suite functions for XLUnit
 ;;;;
-;;;; $Id: suite.lisp,v 1.1 2003/08/04 12:01:54 kevin Exp $
 ;;;; *************************************************************************
 
 (in-package #:xlunit)
 
-(defclass test-suite ()
-  ((name :initarg :name :reader test-suite-name)
-   (tests :initarg :tests :accessor tests-hash
-	  :initform (make-hash-table :test 'equal))
+(defclass test-suite (test)
+  ((name :initform "" :initarg :name :reader test-suite-name)
+   (tests :initarg :tests :accessor tests :initform nil)
    (description :initarg :description :reader description
 		:initform "No description.")))
 
-
-(defmethod setup-testsuite-named (name)
-  (declare (ignore name))
-  t)
-
-(defmethod teardown-testsuite-named (name)
-  (declare (ignore name))
-  t)
-
-(defmethod run-test ((suite test-suite)
-		     &key (result (make-instance 'test-result))
-		     (handle-errors t))
-  (setup-testsuite-named (slot-value suite 'name))
-  (dolist (test (tests suite))
-    (run-test test :result result :handle-errors handle-errors))
-  (teardown-testsuite-named (slot-value suite 'name))
-  result)
-
-(defmethod tests ((suite test-suite))
-  (let ((tlist nil))
-    (maphash #'(lambda (k v)
-		 (declare (ignore k))
-		 (setf tlist (cons v tlist)))
-	     (tests-hash suite))
-    (reverse tlist)))
-
-
-(defun make-test-suite (name-or-fixture &optional description testspecs)
-  "Returns a new test-suite based on a name and TESTSPECS or a fixture
-instance"
-  (etypecase name-or-fixture
-    (symbol
-     (make-test-suite-for-fixture (make-instance name-or-fixture)))
-    (string
-     (let ((suite (make-instance 'test-suite :name name-or-fixture
-				 :description description)))
-       (dolist (testspec testspecs)
-	 (add-test (apply #'make-test testspec) suite))
-       suite))))
-
-
-(defmethod add-test ((test test-fixture) (suite test-suite))
-  (setf (gethash (test-name test) (tests-hash suite)) test))
-
-(defmethod add-test ((test test-suite) (suite test-suite))
-  (setf (gethash (test-suite-name test) (tests-hash suite)) test))
-
-(defmethod remove-test ((test test-fixture) (suite test-suite))
-  (remhash (test-name test) (tests-hash suite)))
-
-(defmethod remove-test ((test test-suite) (suite test-suite))
-  (remhash (test-suite-name test) (tests-hash suite)))
-
-(defmethod test-named ((name string) (suite test-suite))
-  (gethash name (tests-hash suite)))
-
+(defmacro get-suite (class-name)
+  `(suite (make-instance ',class-name)))
+ 
+
+(defmethod add-test ((ob test-suite) (new-test test))
+  (remove-test new-test ob)
+  (setf (tests ob) (append (tests ob) (list new-test))))
+
+
+(defmethod run-on-test-results ((ob test-suite) (result test-results)
+				&key (handle-errors t))
+  (mapc #'(lambda (composite)  ;;test-case or suite
+            (run-on-test-results composite result
+				:handle-errors handle-errors))
+        (tests ob)))
+
+(defmethod named-test (name (suite test-suite))
+  (some (lambda (test-or-suite)
+	  (when (and (typep test-or-suite 'test-case)
+		     (equal name (name test-or-suite)))
+	    test-or-suite))
+	(tests suite)))
+
+(defmethod remove-test ((test test) (suite test-suite))
+  (setf (tests suite)
+    (delete-if #'(lambda (existing-tests-or-suite)
+		   (cond ((typep existing-tests-or-suite 'test-suite)
+			  (eq existing-tests-or-suite test))
+			 ((typep existing-tests-or-suite 'test-case)
+			  (eql (name existing-tests-or-suite)
+			       (name test)))))
+	       (tests suite))))
 
 ;; Dynamic test suite
 
-(defun make-test-suite-for-fixture 
-    (fixture &key
-	     (name 
-	      (format nil "Automatic for ~A"
-		      (if (slot-boundp fixture 'test-name) 
-			  (test-name fixture)
-			(type-of fixture))))
-	     description)
-  (let ((suite  (make-instance 'test-suite
-		  :name name
-		  :description description))
-	(fns (find-test-generic-functions fixture)))
-    (dolist (fn fns)
-      (make-test (class-name (class-of fixture)) fn
-		 :test-suite suite))
-    suite))
-
 (defun find-test-generic-functions (instance)
   "Return a list of symbols for generic functions specialized on the
 class of an instance and whose name begins with the string 'test-'.
@@ -105,20 +61,22 @@ This is used to dynamically generate a list of tests for a fixture."
 		 (string-equal "test-" (subseq (symbol-name s) 0 5))
 		 (fboundp s)
 		 (typep (symbol-function s) 'generic-function)
-		 (plusp (length (compute-applicable-methods 
-				 (ensure-generic-function s)
-				 (list instance)))))
+		 (ignore-errors
+		   (plusp (length (compute-applicable-methods 
+				   (ensure-generic-function s)
+				   (list instance))))))
 	(push s res)))
     (nreverse res)))
 
 
-;;; Test Runners
-
-(defmethod text-testrunner ((suite test-suite) &key (stream t)
-						    (handle-errors t))
-  (let* ((start-time (get-internal-real-time))
-	 (result (run-test suite :handle-errors handle-errors))
-	 (seconds (/ (- (get-internal-real-time) start-time)
-		     internal-time-units-per-second)))
-    (result-printer result seconds stream)))
-
+(defmacro def-test-method (method-name ((instance-name class-name)
+					&key (run t))
+			   &body method-body)
+  `(let ((,instance-name
+          (make-instance ',class-name
+            :name ',method-name)))
+     (setf (method-body ,instance-name)
+           #'(lambda() ,@method-body))
+     (add-test (suite ,instance-name) ,instance-name)
+     (when ,run 
+       (textui-test-run ,instance-name))))