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

misc reformatting

Browse Source 
svn: r9733
This commit is contained in:
Eli Barzilay 2008-05-08 10:39:58 +00:00
parent 807dd0436f
commit f818c88a33
1 changed files with 93 additions and 90 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -1,100 +1,103 @@
#lang mzscheme
(require launcher
mzlib/cmdline
mzlib/list
mzlib/unitsig
"debug.ss"
"test-suite-utils.ss")
(module main mzscheme (define argv (current-command-line-arguments))
(require launcher
mzlib/cmdline
mzlib/list
mzlib/unitsig
"debug.ss"
"test-suite-utils.ss")
(define argv (current-command-line-arguments)) (define preferences-file (find-system-path 'pref-file))
(define preferences-file (find-system-path 'pref-file)) (define old-preferences-file
(let-values ([(base name _2) (split-path preferences-file)])
(build-path base (string-append (path->string name) ".save"))))
(define old-preferences-file (let-values ([(base name _2) (split-path preferences-file)]) (define all-files
(build-path base (string-append (path->string name) ".save")))) (map symbol->string
(call-with-input-file
(build-path (collection-path "tests" "framework") "README")
read)))
(define all-files (define all? #f)
(map symbol->string (define 3m? #f)
(call-with-input-file (build-path (define files-to-process null)
(collection-path "tests" "framework") (define command-line-flags
"README") `((once-each
read))) [("-a" "--all")
,(lambda (flag)
(set! all? #t))
("Run all of the tests")])
(multi
[("-o" "--only")
,(lambda (flag _only-these-tests)
(set-only-these-tests! (cons (string->symbol _only-these-tests)
(or (get-only-these-tests) null))))
("Only run test named <test-name>" "test-name")])))
(define all? #f) (parse-command-line "framework-test" argv command-line-flags
(define 3m? #f) (lambda (collected . files)
(define files-to-process null) (set! files-to-process (if (or all? (null? files)) all-files files)))
(define command-line-flags `("Names of the tests; defaults to all tests"))
`((once-each
[("-a" "--all")
,(lambda (flag)
(set! all? #t))
("Run all of the tests")])
(multi
[("-o" "--only")
,(lambda (flag _only-these-tests)
(set-only-these-tests! (cons (string->symbol _only-these-tests)
(or (get-only-these-tests) null))))
("Only run test named <test-name>" "test-name")])))
(parse-command-line "framework-test" argv command-line-flags
(lambda (collected . files)
(set! files-to-process (if (or all? (null? files)) all-files files)))
`("Names of the tests; defaults to all tests"))
(when (file-exists? preferences-file) (when (file-exists? preferences-file)
(debug-printf admin " saving preferences file ~s to ~s~n" preferences-file old-preferences-file) (debug-printf admin " saving preferences file ~s to ~s\n"
(if (file-exists? old-preferences-file) preferences-file old-preferences-file)
(debug-printf admin " backup preferences file exists, using that one~n") (if (file-exists? old-preferences-file)
(begin (copy-file preferences-file old-preferences-file) (debug-printf admin " backup preferences file exists, using that one\n")
(debug-printf admin " saved preferences file~n")))) (begin (copy-file preferences-file old-preferences-file)
(debug-printf admin " saved preferences file\n"))))
(define jumped-out-tests '())
(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 (x) #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" old-preferences-file preferences-file) (define jumped-out-tests '())
(when (file-exists? preferences-file)
(unless (file-exists? old-preferences-file)
(error 'framework-test "lost preferences file backup!"))
(delete-file preferences-file)
(copy-file old-preferences-file preferences-file)
(delete-file old-preferences-file))
(debug-printf admin " restored preferences file~n")
(shutdown-listener) (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 (x) #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)
(cond (debug-printf admin " restoring preferences file ~s to ~s\n"
[(not (null? jumped-out-tests)) old-preferences-file preferences-file)
(printf "Test suites ended with exns ~s\n" jumped-out-tests)] (when (file-exists? preferences-file)
[(null? failed-tests) (unless (file-exists? old-preferences-file)
(printf "All tests passed.~n")] (error 'framework-test "lost preferences file backup!"))
[else (delete-file preferences-file)
(debug-printf schedule "FAILED tests:~n") (copy-file old-preferences-file preferences-file)
(for-each (lambda (failed-test) (delete-file old-preferences-file))
(debug-printf schedule " ~a // ~a~n" (car failed-test) (cdr failed-test))) (debug-printf admin " restored preferences file\n")
failed-tests)]))
(shutdown-listener)
(cond
[(not (null? jumped-out-tests))
(printf "Test suites ended with exns ~s\n" jumped-out-tests)]
[(null? failed-tests)
(printf "All tests passed.\n")]
[else
(debug-printf schedule "FAILED tests:\n")
(for-each (lambda (failed-test)
(debug-printf schedule " ~a // ~a\n"
(car failed-test) (cdr failed-test)))
failed-tests)])