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

Add a quiet mode to the pkg tests.

Browse Source
This commit is contained in:
Sam Tobin-Hochstadt 2015-10-08 17:35:07 -04:00
parent 7555d022db
commit de27223635
4 changed files with 80 additions and 52 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

19
pkgs/racket-test/tests/pkg/shelly.rkt
View File

@ -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
@ -69,8 +75,10 @@
(thread
(λ ()
(with-handlers ([exn:input-port-closed? void])
(if (verbose?)
(copy-port stdout output-port
(current-output-port))))))
(current-output-port))
(copy-port stdout output-port))))))
(define stderr-t
(thread
(λ ()
@ -80,9 +88,10 @@
(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)
(flush-output cop)
(loop)))))))
(to-proc 'wait)
(define cmd-status (to-proc 'exit-code))
@ -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

17
pkgs/racket-test/tests/pkg/test.rkt
View File

@ -29,7 +29,8 @@
(shelly-case "All tests"
(for-each (λ (x) (x)) l)))))
(run-tests
(define (go)
(run-tests
"name"
"basic" "create" "install" "permissions"
"conflicts" "checksums"
@ -56,8 +57,18 @@
"raco"
"binary"
"catalogs"
"failure")
"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))))

3
pkgs/racket-test/tests/pkg/tests-conflicts.rkt
View File

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

13
pkgs/racket-test/tests/pkg/util.rkt
View File

@ -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)
(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"))))
#: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