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

* Marked interactive tests in README

Browse Source 
* 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
This commit is contained in:
Eli Barzilay 2008-05-08 17:21:31 +00:00
parent d01f7b678d
commit 1b5561b766
3 changed files with 55 additions and 44 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
collects/tests/framework/README
View File

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

18
collects/tests/framework/debug.ss
View File

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

77
collects/tests/framework/main.ss
View File

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