r5465: *** empty log message ***

[xlunit.git] / tcase.lisp

diff --git a/tcase.lisp b/tcase.lisp
index 3d68142afba33e56f6b0f2cee2fc6040f6dbc77d..4c13e1eefc05871c2516ffb87701b39094ec9780 100644 (file)
--- a/tcase.lisp
+++ b/tcase.lisp
@@ -2,7 +2,7 @@
 ;;;; *************************************************************************
 ;;;; FILE IDENTIFICATION
 ;;;;
-;;;; ID:      $Id: tcase.lisp,v 1.2 2003/08/04 19:31:34 kevin Exp $
+;;;; ID:      $Id: tcase.lisp,v 1.5 2003/08/06 14:51:01 kevin Exp $
 ;;;; Purpose: Test fixtures for XLUnit
 ;;;;
 ;;;; *************************************************************************
@@ -59,7 +59,7 @@ that the setup method did for this instance."))
 (defmethod run ((ob test) &key (handle-errors t))
   "Generalized to work on test-case and test-suites"
   (let ((res (make-test-results)))
-    (run-on-test-results ob res :handle-errors t)
+    (run-on-test-results ob res :handle-errors handle-errors)
     res))
 
 (defmethod run-on-test-results ((test test-case) result
@@ -72,20 +72,35 @@ that the setup method did for this instance."))
   (set-up test)
   (unwind-protect
       (run-test test)
-    (tear-down test)))
+    (tear-down test))
+  (values))
 
 (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)))
+(defmethod run-protected ((test test-case) res 
+                         &key (handle-errors t) test-condition)
+  (if handle-errors
+      (handler-case
+         (run-base test)
+       (assertion-failed (condition)
+         (add-failure res test condition))
+       (t (condition)
+         (when (and test-condition
+                    (not (typep condition test-condition)))
+           (add-failure res test
+                        (make-instance 'assertion-failed
+                          :format-control
+                          "Assert condition ~A, but condition ~A signaled"
+                          :format-arguments
+                          (list test-condition condition)))))
+       (serious-condition (condition)
+         (add-error res test condition))
+       (:no-error ()
+         (when test-condition
+           (add-failure res test
+                        (make-instance 'assertion-failed
+                          :format-control "Assert condition ~A, but no condition signaled"
+                          :format-arguments (list test-condition))))))
+    (run-base test))
   res)
-
-
-
-