r5452: *** empty log message ***

[xlunit.git] / suite.lisp

diff --git a/suite.lisp b/suite.lisp
index e410b5daa958d8708d75e2ec9009f6280f2b17a0..4a64425c9c89a870e3f5dbb96da25195c5552c83 100644 (file)
--- a/suite.lisp
+++ b/suite.lisp
@@ -2,7 +2,7 @@
 ;;;; *************************************************************************
 ;;;; FILE IDENTIFICATION
 ;;;;
-;;;; ID:      $Id: suite.lisp,v 1.2 2003/08/04 12:16:13 kevin Exp $
+;;;; ID:      $Id: suite.lisp,v 1.3 2003/08/04 16:13:58 kevin Exp $
 ;;;; Purpose: Suite functions for XLUnit
 ;;;;
 ;;;; *************************************************************************
@@ -10,12 +10,14 @@
 (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))
+  ((name :initform "" :initarg :name :reader test-suite-name)
+   (tests :initarg :tests :accessor tests :initform nil)
    (description :initarg :description :reader description
                :initform "No description.")))
 
+(defmacro get-suite (class-name)
+  `(suite (make-instance ',class-name)))
+ 
 
 (defmethod setup-testsuite-named (name)
   (declare (ignore name))
@@ -25,53 +27,37 @@
   (declare (ignore name))
   t)
 
-(defmethod run-test ((suite test-suite)
+(defmethod run-on-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))
+    (run-on-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)))
 
+(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)))
+  (setf (tests ob) (append (tests ob) (list new-test))))
 
-(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-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 test-named ((name string) (suite test-suite))
+(defmethod named ((name string) (suite test-suite))
   (gethash name (tests-hash suite)))
-
+|#
 
 ;; Dynamic test suite
 
@@ -79,8 +65,8 @@ instance"
     (fixture &key
             (name 
              (format nil "Automatic for ~A"
-                     (if (slot-boundp fixture 'test-name) 
-                         (test-name fixture)
+                     (if (slot-boundp fixture 'name) 
+                         (name fixture)
                        (type-of fixture))))
             description)
   (let ((suite  (make-instance 'test-suite
@@ -103,19 +89,44 @@ 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)))
 
 
+;----------------------------------------------------------------------
+; macro def-test-method
+;
+; Creates the representation of a test method (included within a
+; test-case object) and add it to the corresponding suite class.
+; => clos version of the pluggable selector pattern
+;
+; use:  (def-test-method test-assert-false (clos-unit-test)
+;          (assert-true (eql (+ 1 2) 4) "comment"))
+;
+; new: it calls the textui-test-run function during eval, so to
+;      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)
+            :name ',method-name)))
+     (setf (method-body ,(caar class-name))
+           #'(lambda() ,@method-body))
+     (add-test (suite ,(caar class-name)) ,(caar class-name))
+     (textui-test-run ,(caar class-name))))
+                                                                                 
+
 ;;; Test Runners
 
-(defmethod text-testrunner ((suite test-suite) &key (stream t)
+(defmethod textui-test-run ((suite test-suite) &key (stream t)
                                                    (handle-errors t))
   (let* ((start-time (get-internal-real-time))
-        (result (run-test suite :handle-errors handle-errors))
+        (result (run-on-test suite :handle-errors handle-errors))
         (seconds (/ (- (get-internal-real-time) start-time)
                     internal-time-units-per-second)))
     (result-printer result seconds stream)))