suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

raco test: add -m/--modules flag, exit code 2 for timeout

Browse Source 
Treats file arguments the same as a file in a directory, package,
or collection.

If any test fails due to a timeout, the exit code is 2 (instead
of 1 for only non-timeout failures or 0 for only success).

original commit: bce27aa387
This commit is contained in:
Matthew Flatt 2013-12-30 17:03:11 -07:00
parent b29b18178b
commit 8453e44798
1 changed files with 38 additions and 15 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

53
pkgs/compiler-pkgs/compiler-lib/compiler/commands/test.rkt
View File

@ -94,13 +94,14 @@
'process))] 'process))]
#:timeout [timeout default-timeout]) #:timeout [timeout default-timeout])
(define c (make-custodian)) (define c (make-custodian))
(define timeout? #f)
(with-handlers ([exn:fail? (lambda (exn) (with-handlers ([exn:fail? (lambda (exn)
(custodian-shutdown-all c) (custodian-shutdown-all c)
(unless quiet? (unless quiet?
(eprintf "~a: ~a\n" (eprintf "~a: ~a\n"
(extract-file-name p) (extract-file-name p)
(exn-message exn))) (exn-message exn)))
(summary 1 1 (current-label) #f))]) (summary 1 1 (current-label) #f (if timeout? 1 0)))])
(define e (open-output-bytes)) (define e (open-output-bytes))
(define stdout (if quiet-program? (define stdout (if quiet-program?
@ -127,6 +128,7 @@
((executable-yield-handler) 0) ((executable-yield-handler) 0)
(set! done? #t))))) (set! done? #t)))))
(unless (thread? (sync/timeout timeout t)) (unless (thread? (sync/timeout timeout t))
(set! timeout? #t)
(error 'test "timeout after ~a seconds" timeout)) (error 'test "timeout after ~a seconds" timeout))
(unless done? (unless done?
(error 'test "test raised an exception")) (error 'test "test raised an exception"))
@ -149,6 +151,7 @@
;; Wait for the place to finish: ;; Wait for the place to finish:
(unless (sync/timeout timeout (place-dead-evt pl)) (unless (sync/timeout timeout (place-dead-evt pl))
(set! timeout? #t)
(error 'test "timeout after ~a seconds" timeout)) (error 'test "timeout after ~a seconds" timeout))
;; Get result code and test results: ;; Get result code and test results:
@ -177,6 +180,7 @@
(define proc (list-ref ps 4)) (define proc (list-ref ps 4))
(unless (sync/timeout timeout (thread (lambda () (proc 'wait)))) (unless (sync/timeout timeout (thread (lambda () (proc 'wait))))
(set! timeout? #t)
(error 'test "timeout after ~a seconds" timeout)) (error 'test "timeout after ~a seconds" timeout))
(define results (define results
@ -200,9 +204,9 @@
(error 'test "non-zero exit: ~e" result-code)) (error 'test "non-zero exit: ~e" result-code))
(cond (cond
[test-results [test-results
(summary (car test-results) (cdr test-results) (current-label) #f)] (summary (car test-results) (cdr test-results) (current-label) #f 0)]
[else [else
(summary 0 1 (current-label) #f)]))) (summary 0 1 (current-label) #f 0)])))
;; For recording stderr while also propagating to the original stderr: ;; For recording stderr while also propagating to the original stderr:
(define (tee-output-port p1 p2) (define (tee-output-port p1 p2)
@ -254,7 +258,7 @@
+inf.0))) +inf.0)))
(define current-label (make-parameter "???")) (define current-label (make-parameter "???"))
(struct summary (failed total label body-res)) (struct summary (failed total label body-res timeout))
(define-syntax-rule (with-summary label . body) (define-syntax-rule (with-summary label . body)
(call-with-summary label (lambda () . body))) (call-with-summary label (lambda () . body)))
@ -270,7 +274,8 @@
(apply + (map summary-failed res)) (apply + (map summary-failed res))
(apply + (map summary-total res)) (apply + (map summary-total res))
(current-label) (current-label)
res))) res
(apply + (map summary-timeout res)))))
(define (iprintf i fmt . more) (define (iprintf i fmt . more)
@ -283,9 +288,9 @@
(match sum (match sum
[(list sum ...) [(list sum ...)
(append-map flatten sum)] (append-map flatten sum)]
[(summary failed total `(file ,p) body) [(summary failed total `(file ,p) body timeout)
(list sum)] (list sum)]
[(summary failed total label body) [(summary failed total label body timeout)
(flatten body)] (flatten body)]
[(? void?) [(? void?)
empty]))) empty])))
@ -304,7 +309,7 @@
(define failed-wid (max-width summary-failed)) (define failed-wid (max-width summary-failed))
(define total-wid (max-width summary-total)) (define total-wid (max-width summary-total))
(for ([f (in-list sfiles)]) (for ([f (in-list sfiles)])
(match-define (summary failed total `(file ,p) _) f) (match-define (summary failed total `(file ,p) _ _) f)
(displayln (~a (~a #:min-width failed-wid (displayln (~a (~a #:min-width failed-wid
#:align 'right #:align 'right
(if (zero? failed) (if (zero? failed)
@ -412,7 +417,7 @@
[(directory-exists? p) [(directory-exists? p)
(set! single-file? #f) (set! single-file? #f)
(if (omit-path? (path->directory-path p)) (if (omit-path? (path->directory-path p))
(summary 0 0 #f 0) (summary 0 0 #f null 0)
(with-summary (with-summary
`(directory ,p) `(directory ,p)
(map/parallel (map/parallel
@ -458,7 +463,7 @@
(test-module p file-name args #f #:sema continue-sema))))))))] (test-module p file-name args #f #:sema continue-sema))))))))]
[(not (file-exists? p)) [(not (file-exists? p))
(error 'test "given path ~e does not exist" p)] (error 'test "given path ~e does not exist" p)]
[else (summary 0 0 #f null)])])) [else (summary 0 0 #f null 0)])]))
(module paths racket/base (module paths racket/base
(require setup/link (require setup/link
@ -523,8 +528,11 @@
(define collections? #f) (define collections? #f)
(define packages? #f) (define packages? #f)
(define check-top-suffix? #f)
(define (test-top e #:sema continue-sema) (define (test-top e
#:check-suffix? check-suffix?
#:sema continue-sema)
(cond (cond
[collections? [collections?
(match (collection-paths e) (match (collection-paths e)
@ -542,7 +550,9 @@
(test-files pd #:sema continue-sema)) (test-files pd #:sema continue-sema))
(error 'test "Package ~e is not installed" e))] (error 'test "Package ~e is not installed" e))]
[else [else
(test-files e #:sema continue-sema)])) (test-files e
#:check-suffix? check-suffix?
#:sema continue-sema)]))
;; -------------------------------------------------- ;; --------------------------------------------------
;; Reading "info.rkt" files ;; Reading "info.rkt" files
@ -646,9 +656,14 @@
[("--package" "-p") [("--package" "-p")
"Interpret arguments as packages" "Interpret arguments as packages"
(set! packages? #t)] (set! packages? #t)]
[("--modules" "-m")
("Interpret arguments as modules"
" (ignore argument unless \".rkt\", \".scrbl\", or enabled by \"info.rkt\")")
(set! check-top-suffix? #t)]
#:once-each #:once-each
[("--drdr") [("--drdr")
"Configure defaults to imitate DrDr" "Configure defaults to imitate DrDr"
(set! check-top-suffix? #t)
(set! first-avail? #t) (set! first-avail? #t)
(when (zero? jobs) (when (zero? jobs)
(set-jobs! (processor-count))) (set-jobs! (processor-count)))
@ -710,7 +725,11 @@
(define sum (define sum
;; The #:sema argument everywhre makes tests start ;; The #:sema argument everywhre makes tests start
;; in a deterministic order: ;; in a deterministic order:
(map/parallel test-top file-or-directory (map/parallel (lambda (f #:sema s)
(test-top f
#:check-suffix? check-top-suffix?
#:sema s))
file-or-directory
#:sema (make-semaphore))) #:sema (make-semaphore)))
(when table? (when table?
(display-summary sum)) (display-summary sum))
@ -724,5 +743,9 @@
(for ([i (in-range (- (summary-total s) (for ([i (in-range (- (summary-total s)
(summary-failed s)))]) (summary-failed s)))])
(test-log! #t)))) (test-log! #t))))
(define r (test-log #:display? #t #:exit? #t)) (test-log #:display? #t #:exit? #f)
(exit (if (zero? (car r)) 0 1)))) (define sum1 (call-with-summary #f (lambda () sum)))
(exit (cond
[(positive? (summary-timeout sum1)) 2]
[(positive? (summary-failed sum1)) 1]
[else 0]))))