Add a quiet mode to the pkg tests.

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

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))))

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))

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