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

raco test: responsible-party and varying-party logging, lock names

Browse Source 
The responsible party for a test defaults to the enclosing package's
author.

Also, add support for a `test-timeouts` fallback in "info.rkt".
This commit is contained in:
Matthew Flatt 2013-12-31 14:52:07 -07:00
parent 796f82e4ad
commit 59cbefe47a
2 changed files with 403 additions and 179 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -14,6 +14,7 @@
racket/system
rackunit/log
pkg/lib
pkg/path
setup/collects
setup/getinfo)
@ -37,6 +38,13 @@
(define single-file? #t)
(define lock-file-dir (or (getenv "PLTLOCKDIR")
(find-system-path 'temp-dir)))
(define max-lock-delay (or (let ([n (string->number (or (getenv "PLTLOCKTIME") ""))])
(and (real? n)
n))
(* 4 60 60))) ; default: wait at most 4 hours
;; Stub for running a test in a process:
(module process racket/base
(require rackunit/log)
@ -88,11 +96,15 @@
;; 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 args
#:id id
#:mode [mode (or default-mode
(if single-file?
'direct
'process))]
#:timeout [timeout default-timeout])
#:timeout timeout
#:responsible responsible
#:lock-name lock-name
#:random? random?)
(define c (make-custodian))
(define timeout? #f)
(with-handlers ([exn:fail? (lambda (exn)
@ -102,6 +114,7 @@
(extract-file-name p)
(exn-message exn)))
(summary 1 1 (current-label) #f (if timeout? 1 0)))])
(define (go)
(define e (open-output-bytes))
(define stdout (if quiet-program?
@ -113,6 +126,15 @@
(tee-output-port (current-error-port) e)
(current-error-port))))
(unless quiet?
(when responsible
(fprintf stdout "raco test:~a @(test-responsible '~s)\n"
id
responsible))
(when random?
(fprintf stdout "raco test:~a @(test-random #t)\n"
id)))
(define-values (result-code test-results)
(case mode
[(direct)
@ -206,7 +228,17 @@
[test-results
(summary (car test-results) (cdr test-results) (current-label) #f 0)]
[else
(summary 0 1 (current-label) #f 0)])))
(summary 0 1 (current-label) #f 0)]))
;; Serialize the above with a lock, if any:
(if lock-name
(call-with-file-lock/timeout
#:max-delay max-lock-delay
(build-path lock-file-dir lock-name)
'exclusive
go
(lambda () (error 'test "could not obtain lock: ~s" lock-name)))
(go))))
;; For recording stderr while also propagating to the original stderr:
(define (tee-output-port p1 p2)
@ -242,7 +274,14 @@
(append mod '(config))
(error 'test "cannot add test-config submodule to path: ~s" mod)))
(define (dynamic-require* p d args try-config?)
(define (dynamic-require* p d
#:id id
#:try-config? try-config?
#:args args
#:timeout timeout
#:responsible responsible
#:lock-name lock-name
#:random? random?)
(define lookup
(or (cond
[(not try-config?) #f]
@ -252,10 +291,17 @@
(lambda (what get-default) (get-default))))
(dynamic-require-elsewhere
p d args
#:id id
#:responsible (lookup 'responsible
(lambda () responsible))
#:timeout (if default-timeout
(lookup 'timeout
(lambda () default-timeout))
+inf.0)))
(lambda () timeout))
+inf.0)
#:lock-name (lookup 'lock-name
(lambda () lock-name))
#:random? (lookup 'random?
(lambda () random?))))
(define current-label (make-parameter "???"))
(struct summary (failed total label body-res timeout))
@ -370,7 +416,14 @@
;; Perform test of one module (in parallel, as allowed by
;; `task-sema`):
(define (test-module p mod args try-config? #:sema continue-sema)
(define (test-module p mod
#:sema continue-sema
#:try-config? try-config?
#:args [args '()]
#:timeout [timeout +inf.0]
#:responsible [responsible #f]
#:lock-name [lock-name #f]
#:random? [random? #f])
(call-with-semaphore
task-sema ; limits parallelism
(lambda ()
@ -397,7 +450,16 @@
(flush-output))
id)))
(begin0
(dynamic-require* mod 0 args try-config?)
(dynamic-require* mod 0
#:id (if (jobs . <= . 1)
""
(format " ~a" id))
#:try-config? try-config?
#:args args
#:timeout timeout
#:responsible responsible
#:lock-name lock-name
#:random? random?)
(call-with-semaphore
ids-lock
(lambda ()
@ -416,7 +478,9 @@
(cond
[(directory-exists? p)
(set! single-file? #f)
(if (omit-path? (path->directory-path p))
(define dir-p (path->directory-path p))
(check-info dir-p)
(if (omit-path? dir-p)
(summary 0 0 #f null 0)
(with-summary
`(directory ,p)
@ -431,13 +495,29 @@
(or (not check-suffix?)
(regexp-match rx:default-suffixes p)
(get-cmdline p #f))
(not (omit-path? p)))
(define args (get-cmdline p))
(begin (check-info p)
(not (omit-path? p))))
;; The above `omit-path?` loads "info.rkt" files
(define norm-p (normalize-info-path p))
(define args (get-cmdline norm-p))
(define timeout (get-timeout norm-p))
(define lock-name (get-lock-name norm-p))
(define responsible (get-responsible norm-p))
(define random? (get-random norm-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))
(define (test-this-module mod try-config?)
(test-module p mod
#:try-config? try-config?
#:sema continue-sema
#:args args
#:timeout timeout
#:responsible responsible
#:lock-name lock-name
#:random? random?))
(with-summary
`(file ,p)
(let ([something-wasnt-declared? #f]
@ -454,13 +534,13 @@
#f]
[(module-declared? mod #t)
(set! did-one? #t)
(test-module p mod args #t #:sema continue-sema)]
(test-this-module mod #t)]
[else
(set! something-wasnt-declared? #t)
#f]))
(list
(and (and run-anyways? something-wasnt-declared?)
(test-module p file-name args #f #:sema continue-sema))))))))]
(test-this-module file-name #f))))))))]
[(not (file-exists? p))
(error 'test "given path ~e does not exist" p)]
[else (summary 0 0 #f null 0)])]))
@ -559,11 +639,16 @@
(define omit-paths (make-hash))
(define command-line-arguments (make-hash))
(define timeouts (make-hash))
(define lock-names (make-hash))
(define responsibles (make-hash))
(define randoms (make-hash))
(define pkg-cache (make-hash))
(define collects-cache (make-hash))
(define info-done (make-hash))
(define (check-info p check-up?)
(define (check-dir-info p)
(define-values (base name dir?) (split-path p))
(define dir (normalize-info-path
(if dir?
@ -572,60 +657,91 @@
(path->complete-path base)
(current-directory)))))
(when (and check-up? (not dir?))
;; Check enclosing collection
(define c (path->collects-relative p #:cache collects-cache))
(when (list? c)
(check-info/parents dir
(apply build-path (map bytes->path (reverse (cdr (reverse (cdr c)))))))))
(unless (hash-ref info-done dir #f)
(hash-set! info-done dir #t)
(define info (get-info/full dir))
(when info
(define v (info 'test-omit-paths (lambda () '())))
(define (bad what v)
(log-error "bad `~a' in \"info.rkt\": ~e" what v))
(define (get-members table what all-ok?)
(define v (info what (lambda () '())))
(cond
[(eq? v 'all)
(hash-set! omit-paths dir #t)]
[(and all-ok? (eq? v 'all))
(hash-set! table dir #t)]
[(list? v)
(for ([i (in-list v)])
(unless (path-string? i) (bad 'test-omit-paths v))
(unless (path-string? i) (bad what v))
(define p (normalize-info-path (path->complete-path i dir)))
(define dp (if (directory-exists? p)
(path->directory-path p)
p))
(hash-set! omit-paths dp #t))]
[else (bad 'test-omit-paths v)])
(hash-set! table dp #t))]
[else (bad what v)]))
(get-members omit-paths 'test-omit-paths #t)
(get-members randoms 'test-randoms #t)
(define a (info 'test-command-line-arguments (lambda () '())))
(unless (list? a) (bad 'test-command-line-arguments a))
(define (get-keyed table what check? #:ok-all? [ok-all? #f])
(define a (info what (lambda () '())))
(if (list? a)
(for ([arg (in-list a)])
(unless (and (list? arg)
(= 2 (length arg))
(path-string? (car arg))
(list? (cadr arg))
(andmap path-string? (cadr arg)))
(bad 'test-command-line-arguments a))
(hash-set! command-line-arguments
(normalize-info-path (path->complete-path (car arg) dir))
(cadr arg))))))
(or (path-string? (car arg))
(and ok-all?
(eq? (car arg) 'all)))
(check? (cadr arg)))
(bad what a))
(hash-set! table
(normalize-info-path (if (eq? (car arg) 'all)
dir
(path->complete-path (car arg) dir)))
(cadr arg)))
(bad what a)))
(get-keyed command-line-arguments
'test-command-line-arguments
(lambda (v) (and (list? v)
(andmap path-string? v))))
(get-keyed timeouts
'test-timeouts
(lambda (v) (real? v)))
(get-keyed lock-names
'test-lock-names
(lambda (v) (or (not v)
(and (string? v)
(path-string? v)))))
(get-keyed responsibles
'test-responsibles
ok-responsible?
#:ok-all? #t)
(get-keyed randoms
'test-random
(lambda (v) (string? v))))))
(define (check-info/parents dir subpath)
(let loop ([dir dir] [subpath subpath])
(unless (hash-ref info-done dir #f)
(check-info dir #f)
(check-dir-info dir)
(define-values (next-subpath subpath-name subpath-dir?) (split-path subpath))
(define-values (next-dir dir-name dir-dir?) (split-path dir))
(when (path? next-subpath)
(loop next-dir next-subpath)))))
(loop next-dir next-subpath))))
(define (check-info p)
(check-dir-info p)
;; Check enclosing collection
(define-values (base name dir?) (split-path p))
(define c (if dir?
#f
(path->collects-relative p #:cache collects-cache)))
(when (list? c)
(check-info/parents base
(apply build-path (map bytes->path (reverse (cdr (reverse (cdr c)))))))))
(define (normalize-info-path p)
(simplify-path (path->complete-path p) #f))
(define (omit-path? p)
(check-info p #t)
(let ([p (normalize-info-path p)])
(or (hash-ref omit-paths p #f)
(let-values ([(base name dir?) (split-path p)])
@ -633,8 +749,40 @@
(omit-path? base))))))
(define (get-cmdline p [default null])
(let ([p (normalize-info-path p)])
(hash-ref command-line-arguments p default)))
(hash-ref command-line-arguments p default))
(define (get-timeout p) (hash-ref timeouts p +inf.0))
(define (get-lock-name p) (hash-ref lock-names p #f))
(define (get-responsible p)
(or (let loop ([p p])
(or (hash-ref responsibles p #f)
(let-values ([(base name dir?) (split-path p)])
(and (path? base)
(loop base)))))
;; Check package authors:
(let-values ([(pkg subpath) (path->pkg+subpath p #:cache pkg-cache)])
(and pkg
(let ([pkg-dir (if (path? subpath)
(apply build-path
(drop-right (explode-path p)
(length (explode-path subpath))))
pkg)])
(define info (get-info/full pkg-dir))
(and info
(let ([v (info 'pkg-authors (lambda () #f))])
(and (ok-responsible? v)
v))))))))
(define (get-random p) (hash-ref randoms p #f))
(define (ok-responsible? v)
(or (string? v)
(symbol? v)
(and (list? v)
(andmap (lambda (v) (or (symbol? v) (string? v)))
v))))
;; --------------------------------------------------

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

@ -3,17 +3,19 @@
scribble/bnf
"common.rkt"
(for-label racket/runtime-path
racket/base
launcher/launcher
rackunit/log))
@title[#:tag "test"]{@exec{raco test}: Run tests}
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 requires and runs the (by default)
@racket[test] submodule associated with each path given on the command
line. 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
directly, in separate processes (the default), or in separate places.
The current directory is set to a test file's directory before running
the file.
When an argument path refers to a directory, the tool recursively
discovers and runs all files within the directory that end in
@ -24,8 +26,7 @@ discovers and runs all files within the directory that end in
A test is counted as failing if it logs a failing test code via
@racket[test-log!], causes Racket to exit with a non-zero exit code, or
(when @Flag{e} or @DFlag{check-stderr} is specified) if it produces
output on the error port. The current directory is set to a test
file's directory before running the file.
output on the error port.
The @exec{raco test} command accepts several flags:
@ -104,7 +105,8 @@ The @exec{raco test} command accepts several flags:
--- count any stderr output as a test failure.}
@item{@Flag{q} or @DFlag{quiet}
--- suppresses output of progress information.}
--- suppresses output of progress information, responsible
parties, and varying output (see @secref["test-responsible"]).}
@item{@DFlag{table} or @Flag{t}
--- Print a summary table after all tests. If a test uses
@ -115,6 +117,8 @@ The @exec{raco test} command accepts several flags:
]
@section[#:tag "test-config"]{Test Configuration by Submodule}
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
@ -123,32 +127,104 @@ identifiers:
@itemlist[
@item{@racket[timeout] --- override the default timeout for the test,
when timeouts are enabled.}
@item{@racket[timeout] --- a real number to override the default
timeout for the test, which applies only when timeouts are
enabled.}
@item{@racket[responsible] --- a string, symbol, or list of symbols
and strings identifying a responsible party that should be
notified when the test fails. See @secref["test-responsible"].}
@item{@racket[lock-name] --- a string that names a lock file that is
used to serialize tests (i.e., tests that have the same lock
name do not run concurrently). The lock file's location is
determined by the @envvar{PLTLOCKDIR} enviornment varible or
defaults to @racket[(find-system-path 'temp-dir)]. The maximum
time to wait on the lock file is determined by the
@envvar{PLTLOCKTIME} environment variable or defaults to 4
hours.}
@item{@racket[random?] --- if true, indicates that the test's output
is expected to vary. See @secref["test-responsible"].}
]
To prevent @exec{raco test} from running a particular file, normally
the file should contain a submodule that takes no action. In some
cases, however, adding a submodule is inconvenient or impossible
(e.g., because the file will not always compile). Thus, @exec{raco
test} also consults any @filepath{info.rkt} file in the candidate test
file's directory; in the case of a file within a collection,
@filepath{info.rkt} files from any enclosing collection directories
are also consulted. The following @filepath{info.rkt} fields are
recognized:
@section[#:tag "test-config-info"]{Test Configuration by @filepath{info.rkt}}
Submodule-based test configuration is preferred (see
@secref["test-config"]). In particular, to prevent @exec{raco test}
from running a particular file, normally the file should contain a
submodule that takes no action.
In some cases, however, adding a submodule is inconvenient or
impossible (e.g., because the file will not always compile). Thus,
@exec{raco test} also consults any @filepath{info.rkt} file in the
candidate test file's directory. In the case of a file within a
collection, @filepath{info.rkt} files from any enclosing collection
directories are also consulted for @racket[test-omit-paths]. Finally,
for a file within a package, the package's @filepath{info.rkt} is
consulted for @racket[pkg-authors] to set the default responsible
parties (see @secref["test-responsible"]) for all files in the
package.
The following @filepath{info.rkt} fields are recognized:
@itemlist[
@item{@racket[test-omit-paths] --- a list of path strings (relative
to the enclosing directory) or @racket['all] to omit all files within
the enclosing directory. When a path string refers to a directory,
all files within the directory are omitted.}
to the enclosing directory) or @racket['all] to omit all files
within the enclosing directory. When a path string refers to a
directory, all files within the directory are omitted.}
@item{@racket[test-command-line-arguments] --- a list of
@racket[(list _module-path-string (list _argument-path-string ...))],
where @racket[current-command-line-arguments] is set to a vector that
contains the @racket[_argument-path-string] when running
@racket[_module-path-string].}
@racket[(list _module-path-string (list _argument-path-string
...))], where @racket[current-command-line-arguments] is set to
a vector that contains the @racket[_argument-path-string] when
running @racket[_module-path-string].}
@item{@racket[test-timeouts] --- a list of @racket[(list
_module-path-string _real-number)] to override the default
timeout for @racket[_module-path-string].}
@item{@racket[test-responsibles] --- a list of @racket[(list
_module-path-string _party)] or @racket[(list 'all _party)] to
override the default responsible party for
@racket[_module-path-string] or all files within the directory
(except as overridden), respectively. Each @racket[_party] is a
string, symbol, or list of symbols and strings. See
@secref["test-responsible"].}
@item{@racket[test-lock-names] --- a list of @racket[(list
_module-path-string _lock-string)] to declare a lock file name
for @racket[_module-path-string]. See @racket[lock-name] in
@secref["test-config"].}
@item{@racket[test-randoms] --- a list of path strings (relative to
the enclosing directory) for modules whose output varies.
See @secref["test-responsible"].}
]
@section[#:tag "test-responsible"]{Responsible-Party and Varying-Output Logging}
When a test has a declared responsible party, then the test's output
is prefixed with a
@verbatim[#:indent 2]{raco test:@nonterm{which} @"@"(test-responsible '@nonterm{responsible})}
line, where @nonterm{which} is a space followed by an exact
non-negative number indicating a parallel task when parallelism is
enabled (or empty otherwise), and @nonterm{responsible} is a string,
symbol, or list datum.
When a test's output (as written to stdout) is expected to vary across
runs---aside from varying output that has the same form as produced by
@racket[time]---then it should be declared as varying. In that case,
the test's output is prefixed with a
@verbatim[#:indent 2]{raco test:@nonterm{which} @"@"(test-random #t)}
line.