* 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

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

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 ...))]
+    [(_ mr-tcp rest ...)   #'(when mr-tcp?      (let () rest ...))]
-    [(_ mz-tcp rest ...)      #'(when mz-tcp?      (let () rest ...))]
+    [(_ mz-tcp rest ...)   #'(when mz-tcp?      (let () rest ...))]
-    [(_ admin rest ...)       #'(when admin?       (let () rest ...))]
+    [(_ admin rest ...)    #'(when admin?       (let () rest ...))]
-    [(_ schedule rest ...)    #'(when schedule?    (let () rest ...))]
+    [(_ schedule rest ...) #'(when schedule?    (let () rest ...))]
-    [(_ interactive rest ...) #'(when interactive? (let () rest ...))]
+    [(_ messages rest ...) #'(when messages?    (let () rest ...))]
-    [(_ messages rest ...)    #'(when messages?    (let () rest ...))]
     [(_ unk rest ...) (raise-syntax-error #f "unknown flag" stx #'unk)]))
 
 (define-syntax (debug-printf stx)

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
+(define-values (all-files interactive-files)
-  (map symbol->string
+  (let* ([files (call-with-input-file
-       (call-with-input-file
+                    (build-path (collection-path "tests" "framework") "README")
-           (build-path (collection-path "tests" "framework") "README")
+                  read)]
-         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)
+      ,(lambda (flag) (set! all? #t))
-         (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)
-     (shutdown-mred)
+   (load-framework-automatically #t)
-     (load-framework-automatically #t)
+   (let/ec k
-     (let/ec k
+     (dynamic-wind
-       (dynamic-wind
+       (lambda ()
-         (lambda ()
+         (set! jumped-out-tests (cons x jumped-out-tests))
-           (set! jumped-out-tests (cons x jumped-out-tests))
+         (set-section-name! x)
-           (set-section-name! x)
+         (set-section-jump! k))
-           (set-section-jump! k))
+       (lambda ()
-         (lambda ()
+         (with-handlers ([(lambda (_) #t)
-           (with-handlers ([(lambda (_) #t)
+                          (lambda (exn)
-                            (lambda (exn)
+                            (debug-printf schedule "~a\n"
-                              (debug-printf schedule "~a\n"
+                                          (if (exn? exn)
-                                            (if (exn? exn)
+                                            (exn-message exn)
-                                              (exn-message exn)
+                                            exn)))])
-                                              exn)))])
+           (debug-printf schedule "beginning ~a test suite\n" x)
-             (debug-printf schedule "beginning ~a test suite\n" x)
+           (dynamic-require `(lib ,x "tests" "framework") #f)
-             (dynamic-require `(lib ,x "tests" "framework") #f)
+           (set! jumped-out-tests (remq x jumped-out-tests))
-             (set! jumped-out-tests (remq x jumped-out-tests))
+           (debug-printf schedule "PASSED ~a test suite\n" x)))
-             (debug-printf schedule "PASSED ~a test suite\n" x)))
+       (lambda ()
-         (lambda ()
+         (reset-section-name!)
-           (reset-section-name!)
+         (reset-section-jump!)))))
-           (reset-section-jump!))))))
  files-to-process)
 
 (debug-printf admin "  restoring preferences file ~s to ~s\n"