X-Git-Url: http://git.kpe.io/?p=xlunit.git;a=blobdiff_plain;f=suite.lisp;h=f2394abecf65b106b677ce896e2776d0ba480dee;hp=85cfcc6e2d40986119cca7c9d27012e940d8e356;hb=6e195606e06173086a91616042adef3072633d92;hpb=381a23bb7ab8dd206bcd430ce9c7ee9c53e52f13

diff --git a/suite.lisp b/suite.lisp
index 85cfcc6..f2394ab 100644
--- a/suite.lisp
+++ b/suite.lisp
@@ -2,14 +2,14 @@
 ;;;; *************************************************************************
 ;;;; FILE IDENTIFICATION
 ;;;;
-;;;; ID:      $Id: suite.lisp,v 1.5 2003/08/04 17:04:49 kevin Exp $
+;;;; ID:      $Id: suite.lisp,v 1.6 2003/08/04 19:31:34 kevin Exp $
 ;;;; Purpose: Suite functions for XLUnit
 ;;;;
 ;;;; *************************************************************************
 
 (in-package #:xlunit)
 
-(defclass test-suite ()
+(defclass test-suite (test)
   ((name :initform "" :initarg :name :reader test-suite-name)
    (tests :initarg :tests :accessor tests :initform nil)
    (description :initarg :description :reader description
@@ -19,65 +19,37 @@
   `(suite (make-instance ',class-name)))
  
 
-(defmethod setup-testsuite-named (name)
-  (declare (ignore name))
-  t)
-
-(defmethod teardown-testsuite-named (name)
-  (declare (ignore name))
-  t)
-
-(defmethod run-on-test ((suite test-suite)
-		     &key (result (make-instance 'test-results))
-		     (handle-errors t))
-  (setup-testsuite-named (slot-value suite 'name))
-  (dolist (test (tests suite))
-    (run-on-test test :result result :handle-errors handle-errors))
-  (teardown-testsuite-named (slot-value suite 'name))
-  result)
-
-
 (defmethod add-test ((ob test-suite) (new-test test))
-  (setf (tests ob)
-        (delete-if #'(lambda (existing-tests-or-suite)
-                       (cond ((typep existing-tests-or-suite 'test-suite)
-                              (eq existing-tests-or-suite new-test))
-                             ((typep existing-tests-or-suite 'test-case)
-                              (eql (name existing-tests-or-suite)
-                                   (name new-test)))))
-                   (tests ob)))
+  (remove-test new-test ob)
   (setf (tests ob) (append (tests ob) (list new-test))))
 
-#|
-(defmethod remove-test ((test test-case) (suite test-suite))
-  (remhash (name test) (tests-hash suite)))
-
-(defmethod remove-test ((test test-suite) (suite test-suite))
-  (remhash (test-suite-name test) (tests-hash suite)))
 
-(defmethod named ((name string) (suite test-suite))
-  (gethash name (tests-hash suite)))
-|#
+(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 new-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 'name) 
-			  (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-'.
@@ -111,12 +83,15 @@ This is used to dynamically generate a list of tests for a fixture."
 ;      allow the usual lisp-like incremental developing and test.
 ;----------------------------------------------------------------------
                                                                                  
-(defmacro def-test-method (method-name class-name &body method-body)
-  `(let ((,(caar class-name)
-          (make-instance ',(cadar class-name)
+(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 ,(caar class-name))
+     (setf (method-body ,instance-name)
            #'(lambda() ,@method-body))
-     (add-test (suite ,(caar class-name)) ,(caar class-name))
-     (textui-test-run ,(caar class-name))))
+     (add-test (suite ,instance-name) ,instance-name)
+     (when ,run 
+       (textui-test-run ,instance-name))))