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

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

@ -6,9 +6,14 @@
(for-syntax racket/base (for-syntax racket/base
syntax/parse)) syntax/parse))
;; {{ Shelly ;; {{ Shelly
;; This macro is intended to make Eli proud. ;; 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 ;; Wow, RackUnit really sucks that test-begin/case don't work inside
;; each other like this already. We Want's RackUnit's detailed printing ;; each other like this already. We Want's RackUnit's detailed printing
;; of test failure, but not it's throw-away-the-exception behavior: ;; of test failure, but not it's throw-away-the-exception behavior:
@ -57,7 +62,8 @@
cmd cmd
(define output-port (open-output-string)) (define output-port (open-output-string))
(define error-port (open-output-string)) (define error-port (open-output-string))
(printf "$ ~a\n" cmd) (when (verbose?)
(printf "$ ~a\n" cmd))
(match-define (match-define
(list stdout stdin pid stderr to-proc) (list stdout stdin pid stderr to-proc)
(process/ports #f (process/ports #f
@ -67,23 +73,26 @@
cmd)) cmd))
(define stdout-t (define stdout-t
(thread (thread
(λ () (λ ()
(with-handlers ([exn:input-port-closed? void]) (with-handlers ([exn:input-port-closed? void])
(copy-port stdout output-port (if (verbose?)
(current-output-port)))))) (copy-port stdout output-port
(current-output-port))
(copy-port stdout output-port))))))
(define stderr-t (define stderr-t
(thread (thread
(λ () (λ ()
(with-handlers ([exn:input-port-closed? void]) (with-handlers ([exn:input-port-closed? void])
(define cop (current-output-port)) (define cop (current-output-port))
(let loop () (let loop ()
(define l (read-bytes-line stderr)) (define l (read-bytes-line stderr))
(unless (eof-object? l) (unless (eof-object? l)
(displayln l error-port) (displayln l error-port)
(displayln (format "STDERR: ~a" l) cop) (when (verbose?)
(flush-output error-port) (displayln (format "STDERR: ~a" l) cop)
(flush-output cop) (flush-output cop))
(loop))))))) (flush-output error-port)
(loop)))))))
(to-proc 'wait) (to-proc 'wait)
(define cmd-status (to-proc 'exit-code)) (define cmd-status (to-proc 'exit-code))
(when stdin (close-output-port stdin)) (when stdin (close-output-port stdin))
@ -119,9 +128,9 @@
(let () (let ()
(define mv m) (define mv m)
(check-case mv (check-case mv
(printf "# Starting... ~a\n" mv) (when (verbose?) (printf "# Starting... ~a\n" mv))
case.code ... case.code ...
(printf "# Ending... ~a\n" mv))))])) (when (verbose?) (printf "# Ending... ~a\n" mv)))))]))
(define-syntax (shelly-wind stx) (define-syntax (shelly-wind stx)
(syntax-parse (syntax-parse
stx stx

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

@ -29,35 +29,46 @@
(shelly-case "All tests" (shelly-case "All tests"
(for-each (λ (x) (x)) l))))) (for-each (λ (x) (x)) l)))))
(run-tests (define (go)
"name" (run-tests
"basic" "create" "install" "permissions" "name"
"conflicts" "checksums" "basic" "create" "install" "permissions"
"deps" "update" "implies" "conflicts" "checksums"
"remove" "deps" "update" "implies"
"promote" "remove"
"locking" "promote"
"overwrite" "locking"
"config" "overwrite"
"clone" "config"
"catalog-links" "clone"
"catalog-links"
"network"
"planet"
"main-server"
"update-deps" "network"
"update-auto" "planet"
"scope" "main-server"
"trash"
"migrate" "update-deps"
"versions" "update-auto"
"platform" "scope"
"raco" "trash"
"binary" "migrate"
"catalogs" "versions"
"failure") "platform"
"raco"
"binary"
"catalogs"
"failure"))
(module+ test (module+ test
(module config info (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)] (for* ([m1 '(src both zo-stays zo-goes)]
[m2 '(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-nc1-dir m1)
(set-conflict-mode t1-nc2-dir m2) (set-conflict-mode t1-nc2-dir m2)
(if (and (eq? m1 'zo-goes) (eq? m2 'zo-goes)) (if (and (eq? m1 'zo-goes) (eq? m2 'zo-goes))

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

@ -9,6 +9,7 @@
racket/path racket/path
racket/list racket/list
racket/format racket/format
racket/port
setup/dirs setup/dirs
"shelly.rkt") "shelly.rkt")
@ -111,20 +112,26 @@
(require web-server/http (require web-server/http
web-server/servlet-env) web-server/servlet-env)
(define (start-file-server) (define (start-file-server)
(serve/servlet (λ (req) (response/xexpr "None")) (parameterize ([current-error-port (if (verbose?)
#:command-line? #t (current-output-port)
#:port 9997 (open-output-nowhere))])
#:extra-files-paths (list (build-path test-directory "test-pkgs")))) (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") (require "basic-index.rkt")
(define *index-ht-1* (make-hash)) (define *index-ht-1* (make-hash))
(define *index-ht-2* (make-hash)) (define *index-ht-2* (make-hash))
(define (start-pkg-server index-ht port) (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 (serve/servlet (pkg-index/basic
(λ (pkg-name) (λ (pkg-name)
(define r (hash-ref index-ht pkg-name #f)) (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) r)
(λ () index-ht)) (λ () index-ht))
#:command-line? #t #:command-line? #t