Browse files

Improved LIFT's handling and reporting of timeout failures.

They now act like regular failures and respond to break-on-failures-p
and are reported properly in the HTML report.
  • Loading branch information...
1 parent 452d63b commit f398dcbd5cb01ba11b693b06a7f28dc02515406f Gary King committed Oct 20, 2010
Showing with 31 additions and 28 deletions.
  1. +15 −21 dev/lift.lisp
  2. +16 −7 dev/test-runner.lisp
View
36 dev/lift.lisp
@@ -1473,27 +1473,21 @@ Test options are one of :setup, :teardown, :test, :tests, :documentation, :expor
(call-next-method))
(call-next-method)))
-(defmethod lift-test :around ((suite test-mixin) name)
- (if (profile suite)
- (with-profile-report ((format nil "~a-~a"
- (testsuite-name suite) name)
- (profile suite))
- (call-next-method))
- (call-next-method)))
-
-(defmethod do-testing :around ((testsuite process-test-mixin) result fn)
- (declare (ignore fn))
- (handler-case
- (with-timeout ((maximum-time testsuite))
- (call-next-method))
- (timeout-error
- (c)
- (declare (ignore c))
- (let ((suite-name (class-name (class-of testsuite))))
- (report-test-problem
- 'test-timeout-failure result suite-name (current-method testsuite)
- (make-instance 'test-timeout-condition
- :maximum-time (maximum-time testsuite)))))))
+(defmethod do-test :around ((suite process-test-mixin) name result)
+ (declare (ignore name))
+ (handler-bind ((timeout-error
+ (lambda (c)
+ (let ((suite-name (class-name (class-of suite))))
+ (report-test-problem
+ 'test-timeout-failure result suite-name (current-method suite)
+ (make-instance 'test-timeout-condition
+ :maximum-time (maximum-time suite))))
+ (if (find-restart 'test-failed)
+ (invoke-restart 'test-failed c)
+ (error c)))))
+ (with-timeout ((maximum-time suite))
+ (call-next-method))
+ ))
(defmethod testsuite-log-data ((suite t))
nil)
View
23 dev/test-runner.lisp
@@ -246,7 +246,8 @@ nor configuration file options were specified.")))))
(suite-name (class-name (class-of suite)))
(*current-test-case-name* test-case-name)
(*current-testsuite-name* suite-name)
- (error nil))
+ (error nil)
+ (current-condition nil))
(loop for case in (ensure-list
(test-case-option suite-name test-case-name :depends-on))
unless (test-case-tested-p suite-name case) do
@@ -310,16 +311,24 @@ nor configuration file options were specified.")))))
(report-test-problem
'test-failure result suite-name
*current-test-case-name* condition)
- (if (and *test-break-on-failures?*
- (not (test-case-expects-failure-p
- suite-name test-case-name)))
- (let ((*in-middle-of-failure?* nil))
- (invoke-debugger condition))
- (go :test-end)))
+ (setf current-condition condition)
+ (go :test-failed))
+ (test-failed (condition)
+ :test (lambda (c) (declare (ignore c))
+ *in-middle-of-failure?*)
+ (setf current-condition condition)
+ (go :test-failed))
(retry-test ()
:report (lambda (s) (format s "Re-run test-case ~a"
*current-test-case-name*))
(go :test-start)))
+ :test-failed
+ (if (and *test-break-on-failures?*
+ (not (test-case-expects-failure-p
+ suite-name test-case-name)))
+ (let ((*in-middle-of-failure?* nil))
+ (invoke-debugger current-condition))
+ (go :test-end))
:test-end)
(maybe-push-result)))
(setf *current-test-case-name* test-case-name *test-result* result)

0 comments on commit f398dcb

Please sign in to comment.