103 lines
3.5 KiB
Scheme
103 lines
3.5 KiB
Scheme
(module main mzscheme
|
|
(require (lib "launcher.ss" "launcher")
|
|
(lib "cmdline.ss")
|
|
(lib "list.ss")
|
|
(lib "unitsig.ss")
|
|
"debug.ss"
|
|
"test-suite-utils.ss")
|
|
|
|
(define argv (current-command-line-arguments))
|
|
|
|
(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 all-files
|
|
(map symbol->string
|
|
(load
|
|
(build-path
|
|
(collection-path "tests" "framework")
|
|
"README"))))
|
|
|
|
(define all? #f)
|
|
(define 3m? #f)
|
|
(define files-to-process null)
|
|
(define command-line-flags
|
|
`((once-each
|
|
[("--3m")
|
|
,(lambda (flag) (use-3m #t))
|
|
("Run the tests using a 3m mred")]
|
|
[("-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)
|
|
(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)
|
|
|
|
(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)]))
|