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

raco test: add DrDr-like modes

Browse Source 
Run tests in separate processes, support tests in
parallel, flag tests with non-zero exit codes or
stderr output as failing, add timeout support, etc.

Use the `--drdr` flag as a shorthand for DrDr-like flags.
The `--drdr` flag causes `raco test` to check for a `drdr`
submodule, then a `test` submodule, then run the module
directly. (The idea is that DrDr will eventualy try the
same sequence.) A test can declare an alternate timeout
through a `config` sub-submodule (and the idea is that
"props" will go away).
This commit is contained in:
Matthew Flatt 2013-12-28 19:48:10 -06:00
parent 5ea4c2ab68
commit 0db19423b4
2 changed files with 415 additions and 68 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -6,41 +6,200 @@
racket/function
racket/port
racket/path
racket/place
racket/future
compiler/find-exe
raco/command-name
racket/system
rackunit/log
pkg/lib)
(define submodules '())
(define first-avail? #f)
(define run-anyways? #t)
(define quiet? #f)
(define quiet-program? #f)
(define table? #f)
(define (dynamic-require* p d)
(parameterize
([current-output-port
(if quiet-program?
(open-output-nowhere)
(current-output-port))]
[current-error-port
(if quiet-program?
(open-output-nowhere)
(current-error-port))])
(dynamic-require p d)))
(define jobs 0)
(define task-sema (make-semaphore 1))
(define default-timeout +inf.0)
(define default-mode 'process)
;; Stub for running a test in a place:
(module start racket/base
(require racket/place
rackunit/log)
(provide go)
(define (go pch)
(define l (place-channel-get pch))
;; Run the test:
(parameterize ([current-command-line-arguments '#()]
[current-directory (caddr l)])
(dynamic-require (car l) (cadr l)))
;; If the tests use `rackunit`, collect result stats:
(define test-results
(test-log #:display? #f #:exit? #f))
;; Return test results. If we don't get this far, the result
;; code of the place determines whether it the test counts as
;; successful.
(place-channel-put pch
;; If the test did not use `rackunit`, claim
;; success:
(if (zero? (car test-results))
(cons 0 1)
test-results))))
;; Run each test in its own place or process, and collect both test
;; results and whether any output went to stderr.
(define (dynamic-require-elsewhere p d
#:mode [mode default-mode]
#:timeout [timeout default-timeout])
(define c (make-custodian))
(with-handlers ([exn:fail? (lambda (exn)
(custodian-shutdown-all c)
(unless quiet?
(eprintf "~a: ~a\n"
(extract-file-name p)
(exn-message exn)))
(summary 1 1 (current-label) #f))])
(define e (open-output-bytes))
(define stdout (if quiet-program?
(open-output-nowhere)
(current-output-port)))
(define stderr (if quiet-program?
e
(tee-output-port (current-error-port) e)))
(define-values (result-code test-results)
(case mode
[(place)
;; Start the test place:
(define-values (pl in out/f err/f)
(parameterize ([current-custodian c])
(dynamic-place* '(submod compiler/commands/test start)
'go
#:in (current-input-port)
#:out stdout
#:err stderr)))
;; Send the module path to test:
(place-channel-put pl (list p d (current-directory)))
;; Wait for the place to finish:
(unless (sync/timeout timeout (place-dead-evt pl))
(error 'test "timeout after ~a seconds" timeout))
;; Get result code and test results:
(values (place-wait pl)
(sync/timeout 0 pl))]
[(process)
(define ps
(parameterize ([current-output-port stdout]
[current-error-port stderr]
[current-subprocess-custodian-mode 'kill]
[current-custodian c])
(process*/ports stdout
(current-input-port)
stderr
(find-exe)
"-l"
"racket/base"
"-e"
(format "(dynamic-require '~s ~s)"
(normalize-module-path p)
d))))
(define proc (list-ref ps 4))
(unless (sync/timeout timeout (thread (lambda () (proc 'wait))))
(error 'test "timeout after ~a seconds" timeout))
(values (proc 'exit-code)
#f)]))
;; Shut down the place/process (usually a no-op unless it timed out):
(custodian-shutdown-all c)
;; Check results:
(unless (equal? #"" (get-output-bytes e))
(error 'test "non-empty stderr: ~e" (get-output-bytes e)))
(unless (zero? result-code)
(error 'test "non-zero exit: ~e" result-code))
(cond
[test-results
(summary (car test-results) (cdr test-results) (current-label) #f)]
[else
(summary 0 1 (current-label) #f)])))
;; For recording stderr while also propagating to the original stderr:
(define (tee-output-port p1 p2)
(make-output-port
(object-name p1)
p1
(lambda (bstr start end non-block? enable-break?)
(cond
[(= start end)
(flush-output p1)
0]
[else
(define n (write-bytes-avail* bstr p1 start end))
(cond
[(or (not n)
(zero? n))
(wrap-evt p1 (lambda (v) 0))]
[else
(write-bytes bstr p2 start (+ start n))
n])]))
(lambda ()
(close-output-port p1)
(close-output-port p2))))
(define (extract-file-name p)
(cond
[(and (pair? p) (eq? 'submod (car p)))
(cadr p)]
[else p]))
(define (add-submod mod sm)
(if (and (pair? mod) (eq? 'submod (car mod)))
(append mod '(config))
(error 'test "cannot add test-config submodule to path: ~s" mod)))
(define (dynamic-require* p d try-config?)
(define lookup
(or (cond
[(not try-config?) #f]
[(module-declared? (add-submod p 'config) #t)
(dynamic-require (add-submod p 'config) '#%info-lookup)]
[else #f])
(lambda (what get-default) (get-default))))
(dynamic-require-elsewhere
p d
#:timeout (lookup 'timeout
(lambda () default-timeout))))
(define current-label (make-parameter "???"))
(struct summary (failed total label body-res))
(define-syntax-rule (with-summary label . body)
(let ()
(match-define (cons before-failed before-total)
(test-log #:display? #f #:exit? #f))
(define res (begin . body))
(match-define (cons after-failed after-total)
(test-log #:display? #f #:exit? #f))
(summary (- after-failed before-failed)
(- after-total before-total)
label
(call-with-summary label (lambda () . body)))
(define (call-with-summary label thunk)
(define res
;; Produces either a summary or a list of summary:
(parameterize ([current-label label])
(thunk)))
(if (summary? res)
res
(summary
(apply + (map summary-failed res))
(apply + (map summary-total res))
(current-label)
res)))
(define (iprintf i fmt . more)
(for ([j (in-range i)])
(display #\space))
@ -68,7 +227,7 @@
(define (max-width f)
(string-length
(number->string
(apply max (map f sfiles)))))
(apply max 0 (map f sfiles)))))
(define failed-wid (max-width summary-failed))
(define total-wid (max-width summary-total))
(for ([f (in-list sfiles)])
@ -84,48 +243,133 @@
total)
" " p))))
(define (do-test e [check-suffix? #f])
;; Like `map`, but allows `run-one-test`s in parallel while starting
;; tasks in the order that a plain `map` would run them. The #:sema
;; argument everywhere makes tests start in a deterministic order
;; and keeps a filesystem traversal from getting far ahead of the
;; test runs.
(define (map/parallel f l #:sema continue-sema)
(cond
[(jobs . <= . 1) (map (lambda (v) (f v #:sema continue-sema)) l)]
[else
(struct task (th result-box))
(define ts
(for/list ([i (in-list l)])
(define b (box #f))
(define c-sema (make-semaphore))
(define t (thread
(lambda ()
(set-box! b (with-handlers ([exn? values])
(f i #:sema c-sema)))
;; If no parallel task was ever created,
;; count that as progress to the parent
;; thread:
(semaphore-post c-sema))))
(sync c-sema)
(task t b)))
(semaphore-post continue-sema)
(map sync (map task-th ts))
(for/list ([t (in-list ts)])
(define v (unbox (task-result-box t)))
(if (exn? v)
(raise v)
v))]))
(define (normalize-module-path p)
(cond
[(path? p) (path->string p)]
[(and (pair? p) (eq? 'submod (car p)))
(list* 'submod (normalize-module-path (cadr p)) (cddr p))]
[else p]))
(define ids '(1))
(define ids-lock (make-semaphore 1))
(define (set-jobs! n)
(set! jobs n)
(set! task-sema (make-semaphore jobs))
(set! ids (for/list ([i (in-range jobs)]) i)))
;; Perform test of one module (in parallel, as allowed by
;; `task-sema`):
(define (test-module p mod try-config? #:sema continue-sema)
(call-with-semaphore
task-sema ; limits parallelism
(lambda ()
(semaphore-post continue-sema) ; allow next to try to start
(define id
(call-with-semaphore
ids-lock
(lambda ()
(define id (car ids))
(set! ids (cdr ids))
(unless quiet?
;; in lock, so printouts are not interleaved
(printf "raco test: ~a~s\n"
(if (jobs . <= . 1)
""
(format "~a " id))
(let ([m (normalize-module-path p)])
(if (and (pair? mod) (eq? 'submod (car mod)))
(list* 'submod m (cddr mod))
m))))
id)))
(begin0
(dynamic-require* mod 0 try-config?)
(call-with-semaphore
ids-lock
(lambda ()
(set! ids (cons id ids))))))))
;; Perform all tests in path `e`:
(define (test-files e [check-suffix? #f] #:sema continue-sema)
(match e
[(? string? s)
(do-test (string->path s))]
(test-files (string->path s) check-suffix? #:sema continue-sema)]
[(? path? p)
(cond
[(directory-exists? p)
(with-summary
`(directory ,p)
(map
(λ (dp)
(do-test (build-path p dp) #t))
(directory-list p)))]
(map/parallel
(λ (dp #:sema s)
(test-files (build-path p dp) #t #:sema s))
(directory-list p)
#:sema continue-sema))]
[(and (file-exists? p)
(or (not check-suffix?)
(regexp-match #rx#"\\.rkt$" (path->bytes p))))
(parameterize ([current-directory (let-values ([(base name dir?) (split-path p)])
(if (path? base)
base
(current-directory)))])
(define file-name (file-name-from-path p))
(with-summary
`(file ,p)
(parameterize ([current-command-line-arguments '#()])
(define something-wasnt-declared? #f)
(for ([submodule (in-list (if (null? submodules)
(let ([something-wasnt-declared? #f]
[did-one? #f])
(filter
values
(append
(for/list ([submodule (in-list (if (null? submodules)
'(test)
(reverse submodules)))])
(define mod `(submod ,p ,submodule))
(define mod `(submod ,file-name ,submodule))
(cond
[(and did-one? first-avail?)
#f]
[(module-declared? mod #t)
(unless quiet?
(printf "raco test: ~s\n" `(submod ,(if (absolute-path? p)
`(file ,(path->string p))
(path->string p))
,submodule)))
(dynamic-require* mod 0)]
(set! did-one? #t)
(test-module p mod #t #:sema continue-sema)]
[else
(set! something-wasnt-declared? #t)]))
(when (and run-anyways? something-wasnt-declared?)
(unless quiet?
(printf "raco test: ~s\n" (if (absolute-path? p)
`(file ,(path->string p))
(path->string p))))
(dynamic-require* p 0))))]
(set! something-wasnt-declared? #t)
#f]))
(list
(and (and run-anyways? something-wasnt-declared?)
(test-module p file-name #f #:sema continue-sema))))))))]
[(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)])]))
(module paths racket/base
(require setup/link
@ -191,7 +435,7 @@
(define collections? #f)
(define packages? #f)
(define (do-test-wrap e)
(define (test-top e #:sema continue-sema)
(cond
[collections?
(match (collection-paths e)
@ -200,19 +444,40 @@
[l
(with-summary
`(collection ,e)
(map do-test l))])]
(map/parallel test-files l #:sema continue-sema))])]
[packages?
(define pd (pkg-directory e))
(if pd
(with-summary
`(package ,e)
(do-test pd))
(test-files pd #:sema continue-sema))
(error 'test "Package ~e is not installed" e))]
[else
(do-test e)]))
(test-files e #:sema continue-sema)]))
(define (string->number* what s check)
(define n (string->number s))
(unless (check n)
(raise-user-error (string->symbol (short-program+command-name))
"invalid ~a: ~s"
what
s))
n)
(command-line
#:program (short-program+command-name)
#:once-each
[("--drdr")
"Configure defaults to imitate DrDr"
(when (null? submodules)
(set! submodules '(drdr test)))
(set! first-avail? #t)
(when (zero? jobs)
(set-jobs! (processor-count)))
(when (equal? default-timeout +inf.0)
(set! default-timeout 600))
(set! quiet-program? #t)
(set! table? #t)]
#:multi
[("--submodule" "-s") name
"Runs submodule <name>\n (defaults to running just the `test' submodule)"
@ -226,6 +491,9 @@
"Require nothing if submodule is absent"
(set! run-anyways? #f)]
#:once-each
[("--first-avail")
"Run only the first available submodule"
(set! first-avail? #f)]
[("--quiet" "-q")
"Suppress `raco test: ...' message"
(set! quiet? #t)]
@ -235,6 +503,15 @@
[("--quiet-program" "-Q")
"Quiet the program"
(set! quiet-program? #t)]
[("--place")
"Run tests in places instead of processes"
(set! default-mode 'place)]
[("--jobs" "-j") n
"Run up to <n> tests in parallel"
(set-jobs! (string->number* "jobs" n exact-positive-integer?))]
[("--timeout") seconds
"Set default timeout to <seconds>"
(set-jobs! (string->number* "timeout" seconds real?))]
#:once-any
[("--collection" "-c")
"Interpret arguments as collections"
@ -243,7 +520,19 @@
"Interpret arguments as packages"
(set! packages? #t)]
#:args file-or-directory
(begin (define sum (map do-test-wrap file-or-directory))
(begin (define sum
;; The #:sema argument everywhre makes tests start
;; in a deterministic order:
(map/parallel test-top file-or-directory
#:sema (make-semaphore)))
(when table?
(display-summary sum))
;; Re-log failures and successes, and then report using `test-log`.
;; (This is awkward; is it better to not try to use `test-log`?)
(for ([s (in-list sum)])
(for ([i (in-range (summary-failed s))])
(test-log! #f))
(for ([i (in-range (- (summary-total s)
(summary-failed s)))])
(test-log! #t)))
(void (test-log #:display? #t #:exit? #t))))

78
pkgs/racket-pkgs/racket-doc/scribblings/raco/test.scrbl
View File

@ -7,28 +7,86 @@
@title[#:tag "test"]{@exec{raco test}: Run tests}
The @exec{raco test} command requires and runs the @racket[test]
submodule (if any) associated with each path given on the command line. When a
path refers to a directory, the tool recursively discovers all
files that end in @filepath{.rkt} within the directory and runs their
@racket[test] submodules.
The @exec{raco test} command requires and (by default) runs the
@racket[test] submodule (if any) associated with each path given on
the command line. By default, each test is run in a separate Racket
process. Command-line flag can control which submodule is run, whether
to run the main module if no submodule is found, and whether to run
tests as processes or places.
The @exec{raco test} command accepts a few flags:
When an argument path refers to a directory, the tool recursively
discovers all files that end in @filepath{.rkt} within the directory
and runs them.
A test is counted as failing if it causes Racket to exit with a
non-zero exit code or if it produces output on the error port. The
current directory is set to a file's directory before running the
file.
The @exec{raco test} command accepts several flags:
@itemize[
@item{@DFlag{drdr}
--- Configures defaults to imitate the DrDr continuous testing
system: using as many jobs as available processors, setting the
default timeout to 600 seconds, trying the @racket[drdr] and
the @racket[test] submodules in that order, running a module
directly if neither submodule is available, quieting program
output, and printing a table of results.}
@item{@Flag{s} @nonterm{name} or @DFlag{submodule} @nonterm{name}
--- Requires the submodule @nonterm{name} rather than @racket[test].}
--- Requires the submodule @nonterm{name} rather than @racket[test].
Supply @Flag{s} or @DFlag{submodule} to run multiple submodules,
or combine multiple submodules with @DFlag{first-avail} to
run the first available of the listed modules.}
@item{@Flag{r} or @DFlag{run-if-absent}
--- Requires the top-level module of a file if the relevant submodule is not
--- Requires the top-level module of a file if a relevant submodule is not
present. This is the default mode.}
@item{@Flag{x} or @DFlag{no-run-if-absent}
--- Ignores a file if the relevant submodule is not present.}
@item{@DFlag{first-avail}
--- When multiple submodule names are provided with @Flag{s} or
@DFlag{submodule}, runs only the first available submodule.}
@item{@Flag{q} or @DFlag{quiet}
--- suppresses output of progress information.}
@item{@Flag{Q} or @DFlag{quiet-program}
--- suppresses output from each test program.}
@item{@DFlag{place}
--- Runs each test in a @tech[#:doc '(lib
"scribblings/reference/reference.scrbl")]{place}, instead of in an
operating-system process.}
@item{@Flag{j} @nonterm{n} or @DFlag{jobs} @nonterm{n}
--- Runs up to @nonterm{n} tests in parallel.}
@item{@DFlag{timeout} @nonterm{seconds}
--- Sets the default timeout (after which a test counts as failed)
to @nonterm{seconds}.}
@item{@Flag{c} or @DFlag{collection}
--- Intreprets the arguments as collections where all files should be tested.}
--- Intreprets the arguments as collections where whose files should be tested.}
@item{@Flag{p} or @DFlag{package}
--- Intreprets the arguments as packages where all files should be tested. (All package scopes are searched for the first, most specific package.)}
--- Intreprets the arguments as packages whose files should
be tested. (All package scopes are searched for the first, most
specific package.)}
]
When @exec{raco test} runs a test in a submodule, a @racket[config]
sub-submodule can provide additional configuration for running the
test. The @racket[config] sub-submodule should use the
@racketmodname[info] module language to define the following
identifiers:
@itemlist[
@item{@racket[timeout] --- override the default timeout for the test}
]