(defparameter *debug-on-error* nil
"T if we should drop into a debugger on error, NIL otherwise.")
+(defparameter *debug-on-failure* nil
+ "T if we should drop into a debugger on a failing check, NIL otherwise.")
+
(defun import-testing-symbols (package-designator)
(import '(5am::is 5am::is-true 5am::is-false 5am::signals 5am::finishes)
package-designator))
(with-run-state (result-list)
(bind-run-state ((current-test test))
(labels ((abort-test (e)
- (add-result 'unexpected-test-failure
- :test-expr nil
- :test-case test
- :reason (format nil "Unexpected Error: ~S." e)
- :condition e))
+ (add-result 'unexpected-test-failure
+ :test-expr nil
+ :test-case test
+ :reason (format nil "Unexpected Error: ~S~%~A." e e)
+ :condition e))
(run-it ()
(let ((result-list '()))
(declare (special result-list))
- (handler-bind ((error (lambda (e)
- (unless *debug-on-error*
+ (handler-bind ((check-failure (lambda (e)
+ (declare (ignore e))
+ (unless *debug-on-failure*
+ (invoke-restart
+ (find-restart 'ignore-failure)))))
+ (error (lambda (e)
+ (unless (or *debug-on-error*
+ (typep e 'check-failure))
(abort-test e)
(return-from run-it result-list)))))
(restart-case
- (funcall (test-lambda test))
+ (let ((*readtable* (copy-readtable))
+ (*package* (runtime-package test)))
+ (funcall (test-lambda test)))
(retest ()
:report (lambda (stream)
(format stream "~@<Rerun the test ~S~@:>" test))
(return-from run-it (run-it)))
(ignore ()
:report (lambda (stream)
- (format stream "~@<Signal a test failure and abort the test ~S.~@:>" test))
+ (format stream "~@<Signal an exceptional test failure and abort the test ~S.~@:>" test))
(abort-test (make-instance 'test-failure :test-case test
:reason "Failure restart."))))
result-list))))
(defmethod %run ((test test-case))
(run-resolving-dependencies test))
+(defmethod %run ((tests list))
+ (mapc #'%run tests))
+
(defmethod %run ((suite test-suite))
(let ((suite-results '()))
- (bind-run-state ((result-list '()))
- (loop for test being the hash-values of (tests suite)
- do (%run test)
- finally (setf suite-results result-list)))
- (setf (status suite) (every (lambda (res)
- (typep res 'test-passed))
- suite-results))
- (with-run-state (result-list)
- (setf result-list (nconc result-list suite-results)))))
+ (unwind-protect
+ (bind-run-state ((result-list '()))
+ (unwind-protect
+ (loop for test being the hash-values of (tests suite)
+ do (%run test))
+ (setf suite-results result-list))
+ (setf (status suite)
+ (every (lambda (res)
+ (typep res 'test-passed))
+ suite-results)))
+ (with-run-state (result-list)
+ (setf result-list (nconc result-list suite-results))))))
(defmethod %run ((test-name symbol))
(when-bind test (get-test test-name)
;;;; ** Public entry points
-(defun run! (test-spec)
+(defun run! (&optional (test-spec *suite*))
"Equivalent to (explain (run TEST-SPEC))."
(explain! (run test-spec)))
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*))
+ "Calls (run! test-spec) but enters the debugger if any kind of error happens."
+ (let ((*debug-on-error* t)
+ (*debug-on-failure* t))
+ (run! test-spec)))
+
(defun run (test-spec)
- "Run the test specified by 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 '()))
- (%run test-spec)
- result-list))
- *!!* *!*
- *!!!* *!!*)
- (funcall *!*))
+ (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."