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

...

Browse Source 
original commit: 4f8c6a5fa391304e17cc5d2ebbfaad806e97d512
This commit is contained in:
Robby Findler 2001-03-11 01:10:36 +00:00
parent 1b917add1f
commit 8564dd2ecb
2 changed files with 49 additions and 32 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -5,17 +5,8 @@
"test-suite-utils.ss"
(lib "guis.ss" "tests" "utils"))
(provide
only-these-tests
section-name
section-jump)
(define initial-port 6012)
(define section-jump void)
(define section-name "<<setup>>")
(define only-these-tests #f)
(unless (file-exists? (build-path (current-load-relative-directory) "receive-sexps-port.ss"))
(call-with-output-file (build-path (current-load-relative-directory) "receive-sexps-port.ss")
(lambda (port)
@ -44,8 +35,8 @@
(multi
[("-o" "--only")
,(lambda (flag _only-these-tests)
(set! only-these-tests (cons (string->symbol _only-these-tests)
(or only-these-tests null))))
(set-only-these-tests (cons (string->symbol _only-these-tests)
(or only-these-tests null))))
("Only run test named <test-name>" "test-name")]))])
(let* ([saved-command-line-file (build-path (collection-path "tests" "framework") "saved-command-line.ss")]
@ -74,21 +65,28 @@
(begin (copy-file preferences-file old-preferences-file)
(printf " saved preferences file~n"))))
(for-each (lambda (x)
(when (member x all-files)
(shutdown-mred)
(let/ec k
(fluid-let ([section-name x]
[section-jump k])
(with-handlers ([(lambda (x) #t)
(lambda (exn)
(printf "~a~n" (if (exn? exn) (exn-message exn) exn)))])
(printf "beginning ~a test suite~n" x)
(for-each
(lambda (x)
(when (member x all-files)
(shutdown-mred)
(let/ec k
(dynamic-wind
(lambda ()
(set-section-name! x)
(set-section-jump k))
(lambda ()
(with-handlers ([(lambda (x) #t)
(lambda (exn)
(printf "~a~n" (if (exn? exn) (exn-message exn) exn)))])
(printf "beginning ~a test suite~n" x)
(eval `(require ,x))
(printf "PASSED ~a test suite~n" x))))))
files-to-process)))
(eval `(require ,x))
(printf "PASSED ~a test suite~n" x)))
(lambda ()
(reset-section-name!)
(reset-section-jump!))))))
files-to-process)))
(printf " restoring preferences file ~s to ~s~n" old-preferences-file preferences-file)
(when (file-exists? preferences-file)

33
collects/tests/framework/test-suite-utils.ss
View File

@ -6,7 +6,10 @@
(provide
test-name
failed-tests
(struct eof-result ())
;(struct eof-result ())
eof-result?
load-framework-automatically
shutdown-listener shutdown-mred mred-running?
send-sexp-to-mred queue-sexp-to-mred
@ -17,7 +20,24 @@
;; grabs the frontmost window, executes the sexp and waits for a new frontmost window
wait-for-new-frame
wait-for)
wait-for
reset-section-jump!
set-section-jump!
reset-section-name!
set-section-name!
set-only-these-tests!)
(define section-jump void)
(define (set-section-jump! _s) (set! section-jump _s))
(define (reset-section-jump!) (set! section-jump #f))
(define section-name "<<setup>>")
(define (set-section-name! _s) (set! section-name _s))
(define (reset-section-name!) (set! section-name "<<setup>>"))
(define only-these-tests #f)
(define (set-only-these-tests! _t) (set! only-these-tests _t))
(define test-name "<<setup>>")
(define failed-tests null)
@ -48,11 +68,10 @@
(define restart-mred
(lambda ()
(shutdown-mred)
(let-values ([(base _1 _2) (split-path program)])
((case (system-type)
[(macos) system*]
[else (lambda (x) (thread (lambda () (system* x))))])
(mred-program-launcher-path "Framework Test Engine")))
((case (system-type)
[(macos) system*]
[else (lambda (x) (thread (lambda () (system* x))))])
(mred-program-launcher-path "Framework Test Engine"))
(let-values ([(in out) (tcp-accept listener)])
(set! in-port in)
(set! out-port out))