X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Frun.lisp;h=286a7c40619d85e22f72b6a74c92b2d92d61a48b;hb=2f4561b2f18b405c4dbb0d8326d5de60c4d54d73;hp=417acd8ce44ae93f155fb868d9f1b7e61e786a11;hpb=b76fc6a27dc451c7f2f88eb9a1f028228530af6c;p=fiveam.git

diff --git a/src/run.lisp b/src/run.lisp
index 417acd8..286a7c4 100644
--- a/src/run.lisp
+++ b/src/run.lisp
@@ -30,8 +30,8 @@
 ;;;;   on this one (even if the dependency is not circular) will be
 ;;;;   skipped.
 
-;;;; The functions RUN!, !, !! and !!! are convenient wrappers around
-;;;; RUN and EXPLAIN.
+;;;; The functions RUN! is a convenient wrapper around RUN and
+;;;; EXPLAIN.
 
 (defparameter *debug-on-error* nil
   "T if we should drop into a debugger on error, NIL otherwise.")
@@ -117,10 +117,12 @@ run."))
 (defun results-status (result-list)
   "Given a list of test results (generated while running a test)
   return true if all of the results are of type TEST-PASSED,
-  faile otherwise."
-  (every (lambda (res)
-           (typep res 'test-passed))
-         result-list))
+  fail otherwise.
+  Returns a second value, which is the set of failed tests."
+  (let ((failed-tests
+          (remove-if #'test-passed-p result-list)))
+    (values (null failed-tests)
+            failed-tests)))
 
 (defun return-result-list (test-lambda)
   "Run the test function TEST-LAMBDA and return a list of all
@@ -202,9 +204,7 @@ run."))
                       (run-tests)
                       (run-tests)))
              (setf suite-results result-list
-                   (status suite) (every (lambda (res)
-                                           (typep res 'test-passed))
-                                         suite-results)))
+                   (status suite) (every #'test-passed-p suite-results)))
         (with-run-state (result-list)
           (setf result-list (nconc result-list suite-results)))))))
 
@@ -226,7 +226,7 @@ run."))
 
 (defun explain! (result-list)
   "Explain the results of RESULT-LIST using a
-detailed-text-explainer with output going to *test-dribble*"
+detailed-text-explainer with output going to `*test-dribble*`"
   (explain (make-instance 'detailed-text-explainer) result-list *test-dribble*))
 
 (defun debug! (&optional (test-spec *suite*))
@@ -235,34 +235,64 @@ detailed-text-explainer with output going to *test-dribble*"
         (*debug-on-failure* t))
     (run! test-spec)))
 
+(defun reset-all-tests-status (&optional (tests *test*))
+  "Resets the status of all TESTS to :unknown."
+  (maphash-values
+   (lambda (test)
+     (setf (status test) :unknown))
+   tests))
+
+(defun run-and-set-recently (function)
+  "Shifts the recently executed tests and lastly executes FUNCTION."
+  (shiftf *!!!* *!!* *!* function)
+  (funcall function))
+
+(defun run-and-bind-result-list (function)
+  (run-and-set-recently
+   (lambda ()
+     (reset-all-tests-status)
+     (bind-run-state ((result-list '()))
+       (with-simple-restart
+           (explain "Ignore the rest of the tests and explain current results")
+         (funcall function))
+       result-list))))
+
 (defun run (test-spec)
   "Run the test specified by TEST-SPEC.
 
 TEST-SPEC can be either a symbol naming a test or test suite, or
 a testable-object object. This function changes the operations
 performed by the !, !! and !!! functions."
-  (psetf *!* (lambda ()
-               (loop :for test :being :the :hash-keys :of *test*
-                     :do (setf (status (get-test test)) :unknown))
-               (bind-run-state ((result-list '()))
-                 (with-simple-restart (explain "Ignore the rest of the tests and explain current results")
-                   (%run test-spec))
-                 result-list))
-         *!!* *!*
-         *!!!* *!!*)
-  (funcall *!*))
-
-(defun ! ()
-  "Rerun the most recently run test and explain the results."
-  (explain! (funcall *!*)))
-
-(defun !! ()
-  "Rerun the second most recently run test and explain the results."
-  (explain! (funcall *!!*)))
-
-(defun !!! ()
-  "Rerun the third most recently run test and explain the results."
-  (explain! (funcall *!!!*)))
+  (run-and-bind-result-list (lambda () (%run test-spec))))
+
+(defun run-all-tests ()
+  "Run all tests in arbitrary order."
+  (run-and-bind-result-list
+   (lambda ()
+     (maphash-values
+      (lambda (test)
+        (when (typep test 'test-case)
+          (%run test)))
+      *test*))))
+
+(defun run-all-tests! ()
+  "Equivalent to (explain! (run-all-tests))."
+  (explain! (run-all-tests)))
+
+(defun run-all-test-suites ()
+  "Run all test suites in arbitrary order."
+  (run-and-bind-result-list
+   (lambda ()
+     (maphash-values
+      (lambda (test)
+        (when (typep test 'test-suite)
+          (format *test-dribble* "~& ~A: " (name test))
+          (%run test)))
+      *test*))))
+
+(defun run-all-test-suites! ()
+  "Equivalent to (explain (run-all-test-suites))."
+  (explain! (run-all-test-suites)))
 
 ;; Copyright (c) 2002-2003, Edward Marco Baringer
 ;; All rights reserved.