diff --git a/collects/rackunit/private/test-case.rkt b/collects/rackunit/private/test-case.rkt index 6bbee11d60..136740efe9 100644 --- a/collects/rackunit/private/test-case.rkt +++ b/collects/rackunit/private/test-case.rkt @@ -26,7 +26,8 @@ ;; Run a test-case immediately, printing information on failure (define (default-test-case-around thunk) (with-handlers ([(lambda (e) #t) default-test-case-handler]) - (thunk))) + (parameterize ((current-custodian (make-custodian))) + (thunk)))) ;; default-test-case-handler : any -> any (define (default-test-case-handler e) diff --git a/collects/rackunit/text-ui.rkt b/collects/rackunit/text-ui.rkt index 240632eefd..eae23b6536 100644 --- a/collects/rackunit/text-ui.rkt +++ b/collects/rackunit/text-ui.rkt @@ -216,27 +216,28 @@ ;; run-tests : test [(U 'quiet 'normal 'verbose)] -> integer (define (run-tests test [mode 'normal]) - (monad-value - ((compose - (sequence* + (parameterize ((current-custodian (make-custodian))) + (monad-value + ((compose + (sequence* + (case mode + [(normal verbose) + (display-counter*)] + [(quiet) + (lambda (a) a)]) + (counter->vector)) + (match-lambda + ((vector s f e) + (return-hash (+ f e))))) (case mode - [(normal verbose) - (display-counter*)] - [(quiet) - (lambda (a) a)]) - (counter->vector)) - (match-lambda - ((vector s f e) - (return-hash (+ f e))))) - (case mode - ((quiet) - (fold-test-results - (lambda (result seed) - ((update-counter! result) seed)) - ((put-initial-counter) - (make-empty-hash)) - test)) - ((normal) (std-test/text-ui display-context test)) - ((verbose) (std-test/text-ui - (lambda (x) (display-context x #t)) - test)))))) + ((quiet) + (fold-test-results + (lambda (result seed) + ((update-counter! result) seed)) + ((put-initial-counter) + (make-empty-hash)) + test)) + ((normal) (std-test/text-ui display-context test)) + ((verbose) (std-test/text-ui + (lambda (x) (display-context x #t)) + test))))))) diff --git a/collects/tests/rackunit/text-ui-test.rkt b/collects/tests/rackunit/text-ui-test.rkt index 8716bc2ec6..751deb1a90 100644 --- a/collects/tests/rackunit/text-ui-test.rkt +++ b/collects/tests/rackunit/text-ui-test.rkt @@ -220,5 +220,19 @@ (check = foo 2))) 'verbose) (check = foo 3))))) - )) + (test-case + "cannot kill current thread in test case" + (check-equal? (call-in-nested-thread + (lambda () + (with-silent-output + (lambda () + (run-tests + (test-suite "tests" + (test-case "kill-thread" + (kill-thread (current-thread))))))))) + ;; If the kill-thread were successful, call-in-nested-thread + ;; would raise error. We expect kill-thread to raise error, + ;; caught by run-tests. + 1)) + ))