diff --git a/pkgs/compiler-pkgs/compiler-lib/compiler/commands/test.rkt b/pkgs/compiler-pkgs/compiler-lib/compiler/commands/test.rkt index 1a70821686..e3d583b1dc 100644 --- a/pkgs/compiler-pkgs/compiler-lib/compiler/commands/test.rkt +++ b/pkgs/compiler-pkgs/compiler-lib/compiler/commands/test.rkt @@ -29,6 +29,8 @@ (define quiet-program? #f) (define check-stderr? #f) (define table? #f) +(define fresh-user? #f) +(define empty-input? #f) (define jobs 0) ; 0 mean "default" (define task-sema (make-semaphore 1)) @@ -47,7 +49,8 @@ ;; Stub for running a test in a process: (module process racket/base - (require rackunit/log) + (require rackunit/log + racket/file) ;; Arguments are a temp file to hold test results, the module ;; path to run, and the `dynamic-require` second argument: (define argv (current-command-line-arguments)) @@ -56,6 +59,12 @@ (define d (read (open-input-string (vector-ref argv 2)))) (define args (list-tail (vector->list argv) 3)) + ;; In case PLTUSERHOME is set, make sure relevant + ;; directories exist: + (define (ready-dir d) + (make-directory* d)) + (ready-dir (find-system-path 'doc-dir)) + (parameterize ([current-command-line-arguments (list->vector args)]) (dynamic-require test-module d) ((executable-yield-handler) 0)) @@ -125,6 +134,9 @@ (if check-stderr? (tee-output-port (current-error-port) e) (current-error-port)))) + (define stdin (if empty-input? + (open-input-bytes #"") + (current-input-port))) (unless quiet? (when responsible @@ -133,7 +145,11 @@ responsible)) (when random? (fprintf stdout "raco test:~a @(test-random #t)\n" - id))) + id)) + (when lock-name + (fprintf stdout "raco test:~a @(lock-name ~s)\n" + id + lock-name))) (define-values (result-code test-results) (case mode @@ -143,6 +159,7 @@ (define t (parameterize ([current-output-port stdout] [current-error-port stderr] + [current-input-port stdin] [current-command-line-arguments (list->vector args)]) (thread (lambda () @@ -164,7 +181,7 @@ (parameterize ([current-custodian c]) (dynamic-place* '(submod compiler/commands/test place) 'go - #:in (current-input-port) + #:in stdin #:out stdout #:err stderr))) @@ -181,14 +198,27 @@ (sync/timeout 0 pl))] [(process) (define tmp-file (make-temporary-file)) + (define tmp-dir (and fresh-user? + (make-temporary-file "home~a" 'directory))) (define ps (parameterize ([current-output-port stdout] [current-error-port stderr] [current-subprocess-custodian-mode 'kill] - [current-custodian c]) + [current-custodian c] + [current-environment-variables (environment-variables-copy + (current-environment-variables))]) + (environment-variables-set! (current-environment-variables) + #"PLTUSERHOME" + (path->bytes tmp-dir)) + (environment-variables-set! (current-environment-variables) + #"TMPDIR" + (path->bytes tmp-dir)) + (environment-variables-set! (current-environment-variables) + #"PLTADDONDIR" + (path->bytes (find-system-path 'addon-dir))) (apply process*/ports stdout - (current-input-port) + stdin stderr (find-exe) "-l" @@ -208,6 +238,10 @@ (define results (with-handlers ([exn:fail:read? (lambda () #f)]) (call-with-input-file* tmp-file read))) + + (delete-file tmp-file) + (when tmp-dir + (delete-directory/files tmp-dir)) (values (proc 'exit-code) (and (pair? results) @@ -832,12 +866,14 @@ "Configure defaults to imitate DrDr" (set! check-top-suffix? #t) (set! first-avail? #t) + (set! empty-input? #t) (when (zero? jobs) (set-jobs! (processor-count))) (unless default-timeout (set! default-timeout 90)) (set! check-stderr? #t) (set! quiet-program? #t) + (set! fresh-user? #t) (set! table? #t) (unless default-mode (set! default-mode 'process))] @@ -874,12 +910,18 @@ [("--timeout") seconds "Set default timeout to " (set! default-timeout (string->number* "timeout" seconds real?))] + [("--fresh-user") + "Fresh PLTUSERHOME, etc., for each test" + (set! fresh-user? #t)] [("--quiet-program" "-Q") "Quiet the program" (set! quiet-program? #t)] [("--check-stderr" "-e") "Treat stderr output as a test failure" (set! check-stderr? #t)] + [("--empty-stdin") + "Call program with an empty stdin" + (set! empty-input? #t)] [("--quiet" "-q") "Suppress `raco test: ...' message" (set! quiet? #t)] diff --git a/pkgs/racket-pkgs/racket-doc/scribblings/raco/test.scrbl b/pkgs/racket-pkgs/racket-doc/scribblings/raco/test.scrbl index 96d73d3056..3ff92ff36c 100644 --- a/pkgs/racket-pkgs/racket-doc/scribblings/raco/test.scrbl +++ b/pkgs/racket-pkgs/racket-doc/scribblings/raco/test.scrbl @@ -54,9 +54,14 @@ The @exec{raco test} command accepts several flags: @item{@DFlag{drdr} --- Configures defaults to imitate the DrDr continuous testing - system: ignore non-modules, use as many jobs as available processors, set the - default timeout to 90 seconds, count stderr output as a test failure, - quiet program output, and print a table of results.} + system: ignore non-modules, run tests in separate processes, + use as many jobs as available processors, + set the default timeout to 90 seconds, + create a fresh @envvar{PLTUSERHOME} and @envvar{TMPDIR} for each test, + count stderr output as a test failure, + quiet program output, + provide program empty input, + and print a table of results.} @item{@Flag{s} @nonterm{name} or @DFlag{submodule} @nonterm{name} --- Requires the submodule @nonterm{name} rather than @racket[test]. @@ -101,12 +106,22 @@ The @exec{raco test} command accepts several flags: If any test fails due to a timeout, the exit status of @exec{raco test} is 2 (as opposed to 1 for only non-timeout failures or 0 for success).} + @item{@DFlag{fresh-user} + --- When running tests in a separate process, creates a fresh + directory and sets @envvar{PLTUSERHOME} and @envvar{TMPDIR}. The + @envvar{PLTADDONDIR} environment variable is also set so that + the add-on directory (which is where packages are installed, for + example), does @emph{not} change for each test process.} + @item{@Flag{Q} or @DFlag{quiet-program} --- suppresses output from each test program.} @item{@Flag{e} or @DFlag{check-stderr} --- count any stderr output as a test failure.} + @item{@DFlag{empty-stdin} + --- provide an empty stdin to each test program.} + @item{@Flag{q} or @DFlag{quiet} --- suppresses output of progress information, responsible parties, and varying output (see @secref["test-responsible"]).}