diff --git a/collects/tests/framework/main.ss b/collects/tests/framework/main.ss index 13f5502e50..ac7bea7b81 100644 --- a/collects/tests/framework/main.ss +++ b/collects/tests/framework/main.ss @@ -1,100 +1,103 @@ +#lang mzscheme +(require launcher + mzlib/cmdline + mzlib/list + mzlib/unitsig + "debug.ss" + "test-suite-utils.ss") -(module main mzscheme - (require launcher - mzlib/cmdline - mzlib/list - mzlib/unitsig - "debug.ss" - "test-suite-utils.ss") +(define argv (current-command-line-arguments)) - (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)]) - (build-path base (string-append (path->string name) ".save")))) - +(define all-files + (map symbol->string + (call-with-input-file + (build-path (collection-path "tests" "framework") "README") + read))) - (define all-files - (map symbol->string - (call-with-input-file (build-path - (collection-path "tests" "framework") - "README") - read))) +(define all? #f) +(define 3m? #f) +(define files-to-process null) +(define command-line-flags + `((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")]))) - (define all? #f) - (define 3m? #f) - (define files-to-process null) - (define command-line-flags - `((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")]))) - - (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")) +(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) - (debug-printf admin " saving preferences file ~s to ~s~n" preferences-file old-preferences-file) - (if (file-exists? old-preferences-file) - (debug-printf admin " backup preferences file exists, using that one~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) +(when (file-exists? preferences-file) + (debug-printf admin " saving preferences file ~s to ~s\n" + preferences-file old-preferences-file) + (if (file-exists? old-preferences-file) + (debug-printf admin " backup preferences file exists, using that one\n") + (begin (copy-file preferences-file old-preferences-file) + (debug-printf admin " saved preferences file\n")))) - (debug-printf admin " restoring preferences file ~s to ~s~n" old-preferences-file preferences-file) - (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") +(define jumped-out-tests '()) - (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 - [(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)])) +(debug-printf admin " restoring preferences file ~s to ~s\n" + old-preferences-file preferences-file) +(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) + +(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)])