Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
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...
commit f398dcbd5cb01ba11b693b06a7f28dc02515406f 1 parent 452d63b
Gary King authored
Showing with 31 additions and 28 deletions.
  1. +15 −21 dev/lift.lisp
  2. +16 −7 dev/test-runner.lisp
36 dev/lift.lisp
View
@@ -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)
23 dev/test-runner.lisp
View
@@ -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)
Please sign in to comment.
Something went wrong with that request. Please try again.