From 1b5561b766da1bb32eb4e82b76da951c98822db7 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Thu, 8 May 2008 17:21:31 +0000 Subject: [PATCH] * Marked interactive tests in README * Removed the environment-variable hack in debug.ss (Note: messages? is now #f) * Made main.ss not run interactive tests when no tests are specified. Either specify tests to run, or use --all to run them all. svn: r9746 original commit: 940cb2e6ebade1f7240d0b18ea5a9639c88e8a58 --- collects/tests/framework/README | 4 +- collects/tests/framework/debug.ss | 18 +++----- collects/tests/framework/main.ss | 77 ++++++++++++++++++------------- 3 files changed, 55 insertions(+), 44 deletions(-) diff --git a/collects/tests/framework/README b/collects/tests/framework/README index e957acee..42c8ba6f 100644 --- a/collects/tests/framework/README +++ b/collects/tests/framework/README @@ -67,7 +67,7 @@ signal failures when there aren't any. | These tests will make sure that the usual checks against a user | losing their work are in place. -- interactive tests +- |# (interactive #| tests | these tests require intervention by people. Clicking and whatnot @@ -78,4 +78,4 @@ signal failures when there aren't any. | These tests will create objects in various configurations and | make sure that they are garbage collected -|#) +|#)) diff --git a/collects/tests/framework/debug.ss b/collects/tests/framework/debug.ss index 14dbef2d..2432f9fd 100644 --- a/collects/tests/framework/debug.ss +++ b/collects/tests/framework/debug.ss @@ -1,5 +1,5 @@ #lang mzscheme -(provide debug-printf debug-when interactive?) +(provide debug-printf debug-when) ;; all of the steps in the tcp connection (define mz-tcp? #f) @@ -12,20 +12,16 @@ ;; tests that passed and those that failed (define schedule? #t) -;; are we running in interactive mode? -(define interactive? (if (getenv "PLT_BUILD") #f #t)) - ;; all of the sexpression transactions between mz and mred -(define messages? interactive?) +(define messages? #f) (define-syntax (debug-when stx) (syntax-case stx (mr-tcp mz-tcp admin schedule messages) - [(_ mr-tcp rest ...) #'(when mr-tcp? (let () rest ...))] - [(_ mz-tcp rest ...) #'(when mz-tcp? (let () rest ...))] - [(_ admin rest ...) #'(when admin? (let () rest ...))] - [(_ schedule rest ...) #'(when schedule? (let () rest ...))] - [(_ interactive rest ...) #'(when interactive? (let () rest ...))] - [(_ messages rest ...) #'(when messages? (let () rest ...))] + [(_ mr-tcp rest ...) #'(when mr-tcp? (let () rest ...))] + [(_ mz-tcp rest ...) #'(when mz-tcp? (let () rest ...))] + [(_ admin rest ...) #'(when admin? (let () rest ...))] + [(_ schedule rest ...) #'(when schedule? (let () rest ...))] + [(_ messages rest ...) #'(when messages? (let () rest ...))] [(_ unk rest ...) (raise-syntax-error #f "unknown flag" stx #'unk)])) (define-syntax (debug-printf stx) diff --git a/collects/tests/framework/main.ss b/collects/tests/framework/main.ss index ea29643f..0191b3f7 100644 --- a/collects/tests/framework/main.ss +++ b/collects/tests/framework/main.ss @@ -12,19 +12,30 @@ (let-values ([(base name _2) (split-path preferences-file)]) (build-path base (string-append (path-element->string name) ".save")))) -(define all-files - (map symbol->string - (call-with-input-file - (build-path (collection-path "tests" "framework") "README") - read))) +(define-values (all-files interactive-files) + (let* ([files (call-with-input-file + (build-path (collection-path "tests" "framework") "README") + read)] + [files (map (lambda (x) + (cond [(symbol? x) (symbol->string x)] + [(pair? x) (cons (car x) (map symbol->string + (cdr x)))] + [else (error "bad specs in README")])) + files)] + [all (map (lambda (x) (if (pair? x) (cdr x) (list x))) files)] + [interactive (map (lambda (x) + (if (and (pair? x) (eq? 'interactive (car x))) + (cdr x) '())) + files)]) + (values (apply append all) (apply append interactive)))) (define all? #f) +(define batch? #f) ; non-interactive (implied by no test-file args) (define files-to-process null) (define command-line-flags `((once-each [("-a" "--all") - ,(lambda (flag) - (set! all? #t)) + ,(lambda (flag) (set! all? #t)) ("Run all of the tests")]) (multi [("-o" "--only") @@ -36,7 +47,12 @@ (parse-command-line "framework-test" (current-command-line-arguments) command-line-flags (lambda (collected . files) - (set! files-to-process (if (or all? (null? files)) all-files files))) + (when (null? files) (set! batch? #t)) + (let ([files (filter (lambda (x) (member x all-files)) files)]) + (set! files-to-process + (cond [all? all-files] + [batch? (remove* interactive-files all-files)] + [else files])))) `("Names of the tests; defaults to all tests")) (when (file-exists? preferences-file) @@ -51,29 +67,28 @@ (for-each (lambda (x) - (when (member x all-files) - (shutdown-mred) - (load-framework-automatically #t) - (let/ec k - (dynamic-wind - (lambda () - (set! jumped-out-tests (cons x jumped-out-tests)) - (set-section-name! x) - (set-section-jump! k)) - (lambda () - (with-handlers ([(lambda (_) #t) - (lambda (exn) - (debug-printf schedule "~a\n" - (if (exn? exn) - (exn-message exn) - exn)))]) - (debug-printf schedule "beginning ~a test suite\n" x) - (dynamic-require `(lib ,x "tests" "framework") #f) - (set! jumped-out-tests (remq x jumped-out-tests)) - (debug-printf schedule "PASSED ~a test suite\n" x))) - (lambda () - (reset-section-name!) - (reset-section-jump!)))))) + (shutdown-mred) + (load-framework-automatically #t) + (let/ec k + (dynamic-wind + (lambda () + (set! jumped-out-tests (cons x jumped-out-tests)) + (set-section-name! x) + (set-section-jump! k)) + (lambda () + (with-handlers ([(lambda (_) #t) + (lambda (exn) + (debug-printf schedule "~a\n" + (if (exn? exn) + (exn-message exn) + exn)))]) + (debug-printf schedule "beginning ~a test suite\n" x) + (dynamic-require `(lib ,x "tests" "framework") #f) + (set! jumped-out-tests (remq x jumped-out-tests)) + (debug-printf schedule "PASSED ~a test suite\n" x))) + (lambda () + (reset-section-name!) + (reset-section-jump!))))) files-to-process) (debug-printf admin " restoring preferences file ~s to ~s\n"