From de2722363565b984611d9812d0942e74fb41d3fd Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Thu, 8 Oct 2015 17:35:07 -0400 Subject: [PATCH] Add a quiet mode to the pkg tests. --- pkgs/racket-test/tests/pkg/shelly.rkt | 43 +++++++----- pkgs/racket-test/tests/pkg/test.rkt | 67 +++++++++++-------- .../racket-test/tests/pkg/tests-conflicts.rkt | 3 +- pkgs/racket-test/tests/pkg/util.rkt | 19 ++++-- 4 files changed, 80 insertions(+), 52 deletions(-) diff --git a/pkgs/racket-test/tests/pkg/shelly.rkt b/pkgs/racket-test/tests/pkg/shelly.rkt index ba1c56f5de..0b2f93bd6e 100644 --- a/pkgs/racket-test/tests/pkg/shelly.rkt +++ b/pkgs/racket-test/tests/pkg/shelly.rkt @@ -6,9 +6,14 @@ (for-syntax racket/base syntax/parse)) + ;; {{ Shelly ;; This macro is intended to make Eli proud. +;; Do we print a lot of output? +(define verbose? (make-parameter #t)) +(provide verbose?) + ;; Wow, RackUnit really sucks that test-begin/case don't work inside ;; each other like this already. We Want's RackUnit's detailed printing ;; of test failure, but not it's throw-away-the-exception behavior: @@ -57,7 +62,8 @@ cmd (define output-port (open-output-string)) (define error-port (open-output-string)) - (printf "$ ~a\n" cmd) + (when (verbose?) + (printf "$ ~a\n" cmd)) (match-define (list stdout stdin pid stderr to-proc) (process/ports #f @@ -67,23 +73,26 @@ cmd)) (define stdout-t (thread - (λ () - (with-handlers ([exn:input-port-closed? void]) - (copy-port stdout output-port - (current-output-port)))))) + (λ () + (with-handlers ([exn:input-port-closed? void]) + (if (verbose?) + (copy-port stdout output-port + (current-output-port)) + (copy-port stdout output-port)))))) (define stderr-t (thread (λ () - (with-handlers ([exn:input-port-closed? void]) - (define cop (current-output-port)) - (let loop () - (define l (read-bytes-line stderr)) - (unless (eof-object? l) - (displayln l error-port) - (displayln (format "STDERR: ~a" l) cop) - (flush-output error-port) - (flush-output cop) - (loop))))))) + (with-handlers ([exn:input-port-closed? void]) + (define cop (current-output-port)) + (let loop () + (define l (read-bytes-line stderr)) + (unless (eof-object? l) + (displayln l error-port) + (when (verbose?) + (displayln (format "STDERR: ~a" l) cop) + (flush-output cop)) + (flush-output error-port) + (loop))))))) (to-proc 'wait) (define cmd-status (to-proc 'exit-code)) (when stdin (close-output-port stdin)) @@ -119,9 +128,9 @@ (let () (define mv m) (check-case mv - (printf "# Starting... ~a\n" mv) + (when (verbose?) (printf "# Starting... ~a\n" mv)) case.code ... - (printf "# Ending... ~a\n" mv))))])) + (when (verbose?) (printf "# Ending... ~a\n" mv)))))])) (define-syntax (shelly-wind stx) (syntax-parse stx diff --git a/pkgs/racket-test/tests/pkg/test.rkt b/pkgs/racket-test/tests/pkg/test.rkt index d4e222c558..42b0801335 100644 --- a/pkgs/racket-test/tests/pkg/test.rkt +++ b/pkgs/racket-test/tests/pkg/test.rkt @@ -29,35 +29,46 @@ (shelly-case "All tests" (for-each (λ (x) (x)) l))))) -(run-tests - "name" - "basic" "create" "install" "permissions" - "conflicts" "checksums" - "deps" "update" "implies" - "remove" - "promote" - "locking" - "overwrite" - "config" - "clone" - "catalog-links" - - "network" - "planet" - "main-server" +(define (go) + (run-tests + "name" + "basic" "create" "install" "permissions" + "conflicts" "checksums" + "deps" "update" "implies" + "remove" + "promote" + "locking" + "overwrite" + "config" + "clone" + "catalog-links" - "update-deps" - "update-auto" - "scope" - "trash" - "migrate" - "versions" - "platform" - "raco" - "binary" - "catalogs" - "failure") + "network" + "planet" + "main-server" + + "update-deps" + "update-auto" + "scope" + "trash" + "migrate" + "versions" + "platform" + "raco" + "binary" + "catalogs" + "failure")) (module+ test (module config info - (define timeout 2400))) + (define timeout 2400)) + (go)) + +(module+ main + (require racket/cmdline) + (define quiet? #f) + (command-line + #:once-each + ["-q" "run quietly" (set! quiet? #t)] + #:args () + (parameterize ([verbose? (not quiet?)]) (go)))) diff --git a/pkgs/racket-test/tests/pkg/tests-conflicts.rkt b/pkgs/racket-test/tests/pkg/tests-conflicts.rkt index f5993d1228..94e7b6d9e9 100644 --- a/pkgs/racket-test/tests/pkg/tests-conflicts.rkt +++ b/pkgs/racket-test/tests/pkg/tests-conflicts.rkt @@ -226,7 +226,8 @@ (for* ([m1 '(src both zo-stays zo-goes)] [m2 '(src both zo-stays zo-goes)]) - (printf "trying ~s ~s\n" m1 m2) + (when (verbose?) + (printf "trying ~s ~s\n" m1 m2)) (set-conflict-mode t1-nc1-dir m1) (set-conflict-mode t1-nc2-dir m2) (if (and (eq? m1 'zo-goes) (eq? m2 'zo-goes)) diff --git a/pkgs/racket-test/tests/pkg/util.rkt b/pkgs/racket-test/tests/pkg/util.rkt index 83af634585..944b274b32 100644 --- a/pkgs/racket-test/tests/pkg/util.rkt +++ b/pkgs/racket-test/tests/pkg/util.rkt @@ -9,6 +9,7 @@ racket/path racket/list racket/format + racket/port setup/dirs "shelly.rkt") @@ -111,20 +112,26 @@ (require web-server/http web-server/servlet-env) (define (start-file-server) - (serve/servlet (λ (req) (response/xexpr "None")) - #:command-line? #t - #:port 9997 - #:extra-files-paths (list (build-path test-directory "test-pkgs")))) + (parameterize ([current-error-port (if (verbose?) + (current-output-port) + (open-output-nowhere))]) + (serve/servlet (λ (req) (response/xexpr "None")) + #:command-line? #t + #:port 9997 + #:extra-files-paths (list (build-path test-directory "test-pkgs"))))) (require "basic-index.rkt") (define *index-ht-1* (make-hash)) (define *index-ht-2* (make-hash)) (define (start-pkg-server index-ht port) - (parameterize ([current-error-port (current-output-port)]) + (parameterize ([current-error-port (if (verbose?) + (current-output-port) + (open-output-nowhere))]) (serve/servlet (pkg-index/basic (λ (pkg-name) (define r (hash-ref index-ht pkg-name #f)) - (printf "[>server ~a] ~a = ~a\n" port pkg-name r) + (when (verbose?) + (printf "[>server ~a] ~a = ~a\n" port pkg-name r)) r) (λ () index-ht)) #:command-line? #t