...
original commit: b3a602549d893612b6a2e6028f65e7d7148e8b4b
This commit is contained in:
Robby Findler
parent
3b9c4ebaa0
commit
1b917add1f
|
|
@ -1,3 +1,5 @@
|
|||
`(load.ss)
|
||||
|
||||
`(#|
|
||||
Framework Test Suite Overview
|
||||
|
||||
|
|
|
|||
|
|
@ -1,142 +1,31 @@
|
|||
(let ([pred (lambda (x) (void? x))]
|
||||
[old-load-framework-automatically? (load-framework-automatically)])
|
||||
(module load mzscheme
|
||||
(require "test-suite-utils.ss")
|
||||
|
||||
(define old-load-framework-automatically? (load-framework-automatically))
|
||||
|
||||
(define (test/load file exp)
|
||||
(test
|
||||
(string->symbol file)
|
||||
void?
|
||||
`(parameterize ([current-namespace (make-namespace 'mred)])
|
||||
(require (lib ,file "framework"))
|
||||
,exp
|
||||
(void))))
|
||||
|
||||
(load-framework-automatically #f)
|
||||
|
||||
(test
|
||||
'guiutilss.ss
|
||||
pred
|
||||
'(parameterize ([current-namespace (make-namespace 'mred)])
|
||||
(require-library "guiutilss.ss" "framework")
|
||||
(global-defined-value 'framework:gui-utils^)
|
||||
(void)))
|
||||
|
||||
(test
|
||||
'guiutils.ss
|
||||
pred
|
||||
'(parameterize ([current-namespace (make-namespace 'mred)])
|
||||
(require-library "guiutils.ss" "framework")
|
||||
(global-defined-value 'gui-utils:read-snips/chars-from-text)
|
||||
(void)))
|
||||
(test/load "prefs-file-unit.ss" 'framework:preferences@)
|
||||
(test/load "prefs-file.ss" 'get-preferences-filename)
|
||||
|
||||
(test
|
||||
'guiutilsr.ss
|
||||
pred
|
||||
'(parameterize ([current-namespace (make-namespace 'mred)])
|
||||
(require-library "guiutilss.ss" "framework")
|
||||
(eval
|
||||
'(invoke-unit/sig
|
||||
(compound-unit/sig
|
||||
(import)
|
||||
(link [m : mred^ (mred@)]
|
||||
[g : framework:gui-utils^ ((require-library "guiutilsr.ss" "framework") m)])
|
||||
(export))))
|
||||
(void)))
|
||||
(test/load "gui-utils-unit.ss" 'framework:gui-utils@)
|
||||
(test/load "gui-utils.ss" 'next-untitled-name)
|
||||
|
||||
|
||||
(test
|
||||
'macro.ss
|
||||
pred
|
||||
'(parameterize ([current-namespace (make-namespace 'mred)])
|
||||
(require-library "macro.ss" "framework")
|
||||
(global-defined-value 'mixin)
|
||||
(void)))
|
||||
(test
|
||||
'tests.ss
|
||||
(lambda (x) x)
|
||||
'(parameterize ([current-namespace (make-namespace 'mred)])
|
||||
(require-library "tests.ss" "framework")
|
||||
(unit/sig? (require-library "keys.ss" "framework"))))
|
||||
(test
|
||||
'testr.ss
|
||||
pred
|
||||
'(parameterize ([current-namespace (make-namespace 'mred)])
|
||||
(require-library "tests.ss" "framework")
|
||||
(eval
|
||||
'(define-values/invoke-unit/sig
|
||||
((unit test : framework:test^))
|
||||
(compound-unit/sig
|
||||
(import)
|
||||
(link [mred : mred^ (mred@)]
|
||||
[keys : framework:keys^ ((require-library "keys.ss" "framework"))]
|
||||
[test : framework:test^ ((require-library "testr.ss" "framework") mred keys)])
|
||||
(export (unit test)))))
|
||||
(global-defined-value 'test:run-one)
|
||||
(global-defined-value 'test:button-push)
|
||||
(void)))
|
||||
(test
|
||||
'test.ss
|
||||
pred
|
||||
'(parameterize ([current-namespace (make-namespace 'mred)])
|
||||
(require-library "test.ss" "framework")
|
||||
(global-defined-value 'test:run-one)
|
||||
(global-defined-value 'test:button-push)
|
||||
(void)))
|
||||
(test/load "test-unit.ss" 'framework:test@)
|
||||
(test/load "test.ss" 'test:run-interval)
|
||||
|
||||
(test
|
||||
'frameworkp.ss
|
||||
pred
|
||||
'(parameterize ([current-namespace (make-namespace 'mred)])
|
||||
(require-library "frameworks.ss" "framework")
|
||||
(require-library "file.ss")
|
||||
(eval
|
||||
'(define-values/invoke-unit/sig
|
||||
framework^
|
||||
(compound-unit/sig
|
||||
(import)
|
||||
(link [mred : mred^ (mred@)]
|
||||
[core : mzlib:core^ ((require-library "corer.ss"))]
|
||||
[pf : framework:prefs-file^
|
||||
((let ([tf (make-temporary-file)])
|
||||
(unit/sig framework:prefs-file^ (import)
|
||||
(define (get-preferences-filename) tf))))]
|
||||
[framework : framework^ ((require-library "frameworkp.ss" "framework")
|
||||
core mred pf)])
|
||||
(export (open framework)))))
|
||||
(global-defined-value 'preferences:get)
|
||||
(void)))
|
||||
(test/load "macro.ss" '(mixin () () ()))
|
||||
|
||||
(test
|
||||
'frameworkr.ss
|
||||
pred
|
||||
'(parameterize ([current-namespace (make-namespace 'mred)])
|
||||
(require-library "frameworks.ss" "framework")
|
||||
(eval
|
||||
'(define-values/invoke-unit/sig
|
||||
framework^
|
||||
(compound-unit/sig
|
||||
(import)
|
||||
(link [mred : mred^ (mred@)]
|
||||
[core : mzlib:core^ ((require-library "corer.ss"))]
|
||||
[framework : framework^ ((require-library "frameworkr.ss" "framework") core mred)])
|
||||
(export (open framework)))))
|
||||
(global-defined-value 'test:run-one)
|
||||
(global-defined-value 'test:button-push)
|
||||
(global-defined-value 'frame:basic-mixin)
|
||||
(global-defined-value 'editor:basic-mixin)
|
||||
(global-defined-value 'exit:exit)
|
||||
(void)))
|
||||
(test
|
||||
'framework.ss
|
||||
pred
|
||||
'(parameterize ([current-namespace (make-namespace 'mred)])
|
||||
(require-library "framework.ss" "framework")
|
||||
(global-defined-value 'test:run-one)
|
||||
(global-defined-value 'test:button-push)
|
||||
(global-defined-value 'frame:basic-mixin)
|
||||
(global-defined-value 'editor:basic-mixin)
|
||||
(global-defined-value 'exit:exit)
|
||||
(void)))
|
||||
(test
|
||||
'framework.ss/gen
|
||||
(lambda (x) x)
|
||||
'(parameterize ([current-namespace (make-namespace 'mred)])
|
||||
(require-library "pretty.ss")
|
||||
(let* ([op ((global-defined-value 'pretty-print-print-line))]
|
||||
[np (lambda x (apply op x))])
|
||||
((global-defined-value 'pretty-print-print-line) np)
|
||||
(require-library "framework.ss" "framework")
|
||||
(eq? np ((global-defined-value 'pretty-print-print-line))))))
|
||||
(test/load "framework-unit.ss" 'framework@)
|
||||
(test/load "framework.ss" 'frame:basic-mixin)
|
||||
|
||||
(load-framework-automatically old-load-framework-automatically?))
|
||||
|
||||
|
|
|
|||
|
|
@ -1,395 +1,108 @@
|
|||
(module main mzscheme
|
||||
(require (lib "launcher.ss" "launcher")
|
||||
(lib "cmdline.ss")
|
||||
(lib "etc.ss")
|
||||
(lib "list.ss")
|
||||
(lib "string.ss")
|
||||
(lib "file.ss")
|
||||
(lib "unitsig.ss")
|
||||
(lib "class.ss")
|
||||
"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)
|
||||
(write 6012 port))))
|
||||
(write initial-port port))))
|
||||
|
||||
(define-signature TestSuite^
|
||||
((struct eof-result ())
|
||||
load-framework-automatically
|
||||
shutdown-listener shutdown-mred mred-running?
|
||||
send-sexp-to-mred queue-sexp-to-mred
|
||||
test
|
||||
wait-for-frame
|
||||
(define preferences-file (build-path (find-system-path 'pref-dir)
|
||||
(case (system-type)
|
||||
[(macos) "MrEd Preferences"]
|
||||
[(windows) "mred.pre"]
|
||||
[(unix) ".mred.prefs"])))
|
||||
(define old-preferences-file (let-values ([(base name _2) (split-path preferences-file)])
|
||||
(build-path base (string-append name ".save"))))
|
||||
|
||||
|
||||
;; sexp -> void
|
||||
;; grabs the frontmost window, executes the sexp and waits for a new frontmost window
|
||||
wait-for-new-frame
|
||||
|
||||
wait-for))
|
||||
|
||||
(define-signature internal-TestSuite^
|
||||
((open TestSuite^)
|
||||
test-name
|
||||
failed-tests))
|
||||
|
||||
(define-signature Engine^
|
||||
(only-these-tests
|
||||
section-name
|
||||
section-jump))
|
||||
|
||||
(define TestSuite
|
||||
(unit/sig internal-TestSuite^
|
||||
(import (program)
|
||||
Engine^
|
||||
launcher-maker^
|
||||
mzlib:pretty-print^
|
||||
mzlib:function^)
|
||||
|
||||
(define test-name "<<setup>>")
|
||||
(define failed-tests null)
|
||||
|
||||
(define-struct eof-result ())
|
||||
|
||||
(define load-framework-automatically? #t)
|
||||
|
||||
(define listener
|
||||
(let loop ()
|
||||
(let ([port (load-relative "receive-sexps-port.ss")])
|
||||
(with-handlers ([(lambda (x) #t)
|
||||
(lambda (x)
|
||||
(let ([next (+ port 1)])
|
||||
(call-with-output-file (build-path (current-load-relative-directory)
|
||||
"receive-sexps-port.ss")
|
||||
(lambda (p)
|
||||
(write next p))
|
||||
'truncate)
|
||||
(printf " tcp-listen failed for port ~a, attempting ~a~n"
|
||||
port next)
|
||||
(loop)))])
|
||||
(tcp-listen port)))))
|
||||
|
||||
(define in-port #f)
|
||||
(define out-port #f)
|
||||
|
||||
(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")))
|
||||
(let-values ([(in out) (tcp-accept listener)])
|
||||
(set! in-port in)
|
||||
(set! out-port out))
|
||||
(when load-framework-automatically?
|
||||
(queue-sexp-to-mred
|
||||
`(begin
|
||||
(require (lib "framework.ss" "framework")
|
||||
(lib "gui.ss" "tests" "utils")))))))
|
||||
|
||||
(define load-framework-automatically
|
||||
(case-lambda
|
||||
[(new-load-framework-automatically?)
|
||||
(unless (eq? (not (not new-load-framework-automatically?))
|
||||
load-framework-automatically?)
|
||||
(set! load-framework-automatically? (not (not new-load-framework-automatically?)))
|
||||
(shutdown-mred))]
|
||||
[() load-framework-automatically?]))
|
||||
|
||||
(define shutdown-listener
|
||||
(lambda ()
|
||||
(shutdown-mred)
|
||||
(tcp-close listener)))
|
||||
|
||||
(define shutdown-mred
|
||||
(lambda ()
|
||||
(when (and in-port
|
||||
out-port)
|
||||
(with-handlers ([(lambda (x) #t) (lambda (x) (void))])
|
||||
(close-output-port out-port))
|
||||
(with-handlers ([(lambda (x) #t) (lambda (x) (void))])
|
||||
(close-input-port in-port))
|
||||
(set! in-port #f)
|
||||
(set! in-port #f))))
|
||||
|
||||
(define mred-running?
|
||||
(lambda ()
|
||||
(if (char-ready? in-port)
|
||||
(not (eof-object? (peek-char in-port)))
|
||||
#t)))
|
||||
|
||||
(define queue-sexp-to-mred
|
||||
(lambda (sexp)
|
||||
(send-sexp-to-mred
|
||||
`(let ([thunk (lambda () ,sexp)]
|
||||
[sema (make-semaphore 0)])
|
||||
(queue-callback (lambda ()
|
||||
(thunk)
|
||||
(semaphore-post sema)))
|
||||
(semaphore-wait sema)))))
|
||||
|
||||
(define re:tcp-read-error (regexp "tcp-read:"))
|
||||
(define re:tcp-write-error (regexp "tcp-write:"))
|
||||
(define (tcp-error? exn)
|
||||
(or (regexp-match re:tcp-read-error (exn-message exn))
|
||||
(regexp-match re:tcp-write-error (exn-message exn))))
|
||||
|
||||
(define send-sexp-to-mred
|
||||
(let ([failed-last-time? #f])
|
||||
(lambda (sexp)
|
||||
(let/ec k
|
||||
(let ([show-text
|
||||
(lambda (sexp)
|
||||
|
||||
(parameterize ([pretty-print-print-line
|
||||
(let ([prompt " "]
|
||||
[old-liner (pretty-print-print-line)])
|
||||
(lambda (ln port ol cols)
|
||||
(let ([ov (old-liner ln port ol cols)])
|
||||
(if ln
|
||||
(begin (display prompt port)
|
||||
(+ (string-length prompt) ov))
|
||||
ov))))])
|
||||
(pretty-print sexp)
|
||||
(newline)))])
|
||||
(unless (and in-port
|
||||
out-port
|
||||
(with-handlers ([tcp-error?
|
||||
(lambda (x) #f)])
|
||||
(or (not (char-ready? in-port))
|
||||
(not (eof-object? (peek-char in-port))))))
|
||||
(restart-mred))
|
||||
(printf " ~a // ~a: sending to mred:~n" section-name test-name)
|
||||
(show-text sexp)
|
||||
(with-handlers ([(lambda (x) #t)
|
||||
(lambda (x)
|
||||
(cond
|
||||
;; this means that mred was closed
|
||||
;; so we can restart it and try again.
|
||||
[(tcp-error? x)
|
||||
(restart-mred)
|
||||
(write sexp out-port)
|
||||
(newline out-port)]
|
||||
[else (raise x)]))])
|
||||
(write sexp out-port)
|
||||
(newline out-port))
|
||||
(let ([answer
|
||||
(with-handlers ([(lambda (x) #t)
|
||||
(lambda (x)
|
||||
(if (tcp-error? x);; assume tcp-error means app closed
|
||||
eof
|
||||
(list 'cant-read
|
||||
(string-append
|
||||
(exn-message x)
|
||||
"; rest of string: "
|
||||
(format
|
||||
"~s"
|
||||
(apply
|
||||
string
|
||||
(let loop ()
|
||||
(if (char-ready? in-port)
|
||||
(let ([char (read-char in-port)])
|
||||
(if (eof-object? char)
|
||||
null
|
||||
(cons char (loop))))
|
||||
null))))))))])
|
||||
(read in-port))])
|
||||
(unless (or (eof-object? answer)
|
||||
(and (list? answer)
|
||||
(= 2 (length answer))))
|
||||
(error 'send-sexp-to-mred "unpected result from mred: ~s~n" answer))
|
||||
(if (eof-object? answer)
|
||||
(raise (make-eof-result))
|
||||
(case (car answer)
|
||||
[(error)
|
||||
(error 'send-sexp-to-mred "mred raised \"~a\"" (second answer))]
|
||||
[(cant-read) (error 'mred/cant-parse (second answer))]
|
||||
[(normal)
|
||||
(printf " ~a // ~a: received from mred:~n" section-name test-name)
|
||||
(show-text (second answer))
|
||||
(eval (second answer))]))))))))
|
||||
|
||||
|
||||
(define test
|
||||
(case-lambda
|
||||
[(in-test-name passed? sexp/proc) (test in-test-name passed? sexp/proc 'section)]
|
||||
[(in-test-name passed? sexp/proc jump)
|
||||
(fluid-let ([test-name in-test-name])
|
||||
(when (or (not only-these-tests)
|
||||
(memq test-name only-these-tests))
|
||||
(let ([failed
|
||||
(with-handlers ([(lambda (x) #t)
|
||||
(lambda (x)
|
||||
(if (exn? x)
|
||||
(exn-message x)
|
||||
x))])
|
||||
(let ([result
|
||||
(if (procedure? sexp/proc)
|
||||
(sexp/proc)
|
||||
(begin0 (send-sexp-to-mred sexp/proc)
|
||||
(send-sexp-to-mred ''check-for-errors)))])
|
||||
(not (passed? result))))])
|
||||
(when failed
|
||||
(printf "FAILED ~a: ~a~n" failed test-name)
|
||||
(set! failed-tests (cons (cons section-name test-name) failed-tests))
|
||||
(case jump
|
||||
[(section) (section-jump)]
|
||||
[(continue) (void)]
|
||||
[else (jump)])))))]))
|
||||
|
||||
(define (wait-for/wrapper wrapper sexp)
|
||||
(let ([timeout 10]
|
||||
[pause-time 1/2])
|
||||
(send-sexp-to-mred
|
||||
(wrapper
|
||||
`(let ([test (lambda () ,sexp)])
|
||||
(let loop ([n ,(/ timeout pause-time)])
|
||||
(if (zero? n)
|
||||
(error 'wait-for
|
||||
,(format "after ~a seconds, ~s didn't come true" timeout sexp))
|
||||
(unless (test)
|
||||
(sleep ,pause-time)
|
||||
(loop (- n 1))))))))))
|
||||
|
||||
(define (wait-for sexp) (wait-for/wrapper (lambda (x) x) sexp))
|
||||
|
||||
(define (wait-for-new-frame sexp)
|
||||
(wait-for/wrapper
|
||||
(lambda (w)
|
||||
`(let ([frame (get-top-level-focus-window)])
|
||||
,sexp
|
||||
,w))
|
||||
`(not (eq? frame (get-top-level-focus-window)))))
|
||||
|
||||
(define (wait-for-frame name)
|
||||
(wait-for `(let ([win (get-top-level-focus-window)])
|
||||
(and win
|
||||
(string=? (send win get-label) ,name)))))))
|
||||
|
||||
(define Engine
|
||||
(unit/sig Engine^
|
||||
(import (argv)
|
||||
internal-TestSuite^
|
||||
mzlib:command-line^
|
||||
mzlib:function^
|
||||
mzlib:file^
|
||||
mzlib:string^
|
||||
mzlib:pretty-print^)
|
||||
|
||||
(define section-jump void)
|
||||
(define section-name "<<setup>>")
|
||||
(define only-these-tests #f)
|
||||
|
||||
(define preferences-file (build-path (find-system-path 'pref-dir)
|
||||
(case (system-type)
|
||||
[(macos) "MrEd Preferences"]
|
||||
[(windows) "mred.pre"]
|
||||
[(unix) ".mred.prefs"])))
|
||||
(define old-preferences-file (let-values ([(base name _2) (split-path preferences-file)])
|
||||
(build-path base (string-append name ".save"))))
|
||||
(with-handlers ([(lambda (x) #f)
|
||||
(lambda (x) (display (exn-message x)) (newline))])
|
||||
(let* ([all-files (map symbol->string (load-relative "README"))]
|
||||
[all? #f]
|
||||
[files-to-process null]
|
||||
[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 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")]
|
||||
[parsed-argv (if (equal? argv (vector))
|
||||
(if (file-exists? saved-command-line-file)
|
||||
(begin
|
||||
(let ([result (call-with-input-file saved-command-line-file read)])
|
||||
(printf "reusing command-line arguments: ~s~n" result)
|
||||
result))
|
||||
(vector))
|
||||
argv)])
|
||||
(parse-command-line "framework-test" parsed-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"))
|
||||
(call-with-output-file saved-command-line-file
|
||||
(lambda (port)
|
||||
(write parsed-argv port))
|
||||
'truncate))
|
||||
|
||||
(with-handlers ([(lambda (x) #f)
|
||||
(lambda (x) (display (exn-message x)) (newline))])
|
||||
(let* ([all-files (map symbol->string (load-relative "README"))]
|
||||
[all? #f]
|
||||
[files-to-process null]
|
||||
[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 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")]
|
||||
[parsed-argv (if (equal? argv (vector))
|
||||
(if (file-exists? saved-command-line-file)
|
||||
(begin
|
||||
(let ([result (call-with-input-file saved-command-line-file read)])
|
||||
(printf "reusing command-line arguments: ~s~n" result)
|
||||
result))
|
||||
(vector))
|
||||
argv)])
|
||||
(parse-command-line "framework-test" parsed-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"))
|
||||
(call-with-output-file saved-command-line-file
|
||||
(lambda (port)
|
||||
(write parsed-argv port))
|
||||
'truncate))
|
||||
|
||||
|
||||
(when (file-exists? preferences-file)
|
||||
(printf " saving preferences file ~s to ~s~n" preferences-file old-preferences-file)
|
||||
(if (file-exists? old-preferences-file)
|
||||
(printf " backup preferences file exists, using that one~n")
|
||||
(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)
|
||||
|
||||
(invoke-unit/sig
|
||||
(eval
|
||||
`(unit/sig ()
|
||||
(import TestSuite^
|
||||
mzlib:function^
|
||||
mzlib:file^
|
||||
mzlib:string^
|
||||
mzlib:pretty-print^)
|
||||
(include ,x)))
|
||||
TestSuite^
|
||||
mzlib:function^
|
||||
mzlib:file^
|
||||
mzlib:string^
|
||||
mzlib:pretty-print^)
|
||||
(printf "PASSED ~a test suite~n" x))))))
|
||||
files-to-process)))
|
||||
|
||||
(printf " 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))
|
||||
(printf " restored preferences file~n")
|
||||
(printf " saving preferences file ~s to ~s~n" preferences-file old-preferences-file)
|
||||
(if (file-exists? old-preferences-file)
|
||||
(printf " backup preferences file exists, using that one~n")
|
||||
(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)
|
||||
|
||||
(shutdown-listener)
|
||||
(eval `(require ,x))
|
||||
|
||||
(printf "PASSED ~a test suite~n" x))))))
|
||||
files-to-process)))
|
||||
|
||||
(unless (null? failed-tests)
|
||||
(printf "FAILED tests:~n")
|
||||
(for-each (lambda (failed-test)
|
||||
(printf " ~a // ~a~n" (car failed-test) (cdr failed-test)))
|
||||
failed-tests))))
|
||||
(printf " 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))
|
||||
(printf " restored preferences file~n")
|
||||
|
||||
(shutdown-listener)
|
||||
|
||||
(invoke-unit/sig
|
||||
(compound-unit/sig
|
||||
(import (P : (program))
|
||||
(A : (argv))
|
||||
[launcher : launcher-maker^])
|
||||
(link
|
||||
[T : internal-TestSuite^ (TestSuite P E launcher)]
|
||||
[E : Engine^ (Engine A T M)])
|
||||
(export))
|
||||
(program)
|
||||
(argv)
|
||||
launcher-maker^))
|
||||
(unless (null? failed-tests)
|
||||
(printf "FAILED tests:~n")
|
||||
(for-each (lambda (failed-test)
|
||||
(printf " ~a // ~a~n" (car failed-test) (cdr failed-test)))
|
||||
failed-tests)))
|
||||
242
collects/tests/framework/test-suite-utils.ss
Normal file
242
collects/tests/framework/test-suite-utils.ss
Normal file
|
|
@ -0,0 +1,242 @@
|
|||
(module test-suite-utils mzscheme
|
||||
(require (lib "launcher.ss" "launcher")
|
||||
(lib "pretty.ss")
|
||||
(lib "list.ss"))
|
||||
|
||||
(provide
|
||||
test-name
|
||||
failed-tests
|
||||
(struct eof-result ())
|
||||
load-framework-automatically
|
||||
shutdown-listener shutdown-mred mred-running?
|
||||
send-sexp-to-mred queue-sexp-to-mred
|
||||
test
|
||||
wait-for-frame
|
||||
|
||||
;; sexp -> void
|
||||
;; grabs the frontmost window, executes the sexp and waits for a new frontmost window
|
||||
wait-for-new-frame
|
||||
|
||||
wait-for)
|
||||
|
||||
(define test-name "<<setup>>")
|
||||
(define failed-tests null)
|
||||
|
||||
(define-struct eof-result ())
|
||||
|
||||
(define load-framework-automatically? #t)
|
||||
|
||||
(define listener
|
||||
(let loop ()
|
||||
(let ([port (load-relative "receive-sexps-port.ss")])
|
||||
(with-handlers ([(lambda (x) #t)
|
||||
(lambda (x)
|
||||
(let ([next (+ port 1)])
|
||||
(call-with-output-file (build-path (current-load-relative-directory)
|
||||
"receive-sexps-port.ss")
|
||||
(lambda (p)
|
||||
(write next p))
|
||||
'truncate)
|
||||
(printf " tcp-listen failed for port ~a, attempting ~a~n"
|
||||
port next)
|
||||
(loop)))])
|
||||
(tcp-listen port)))))
|
||||
|
||||
(define in-port #f)
|
||||
(define out-port #f)
|
||||
|
||||
(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")))
|
||||
(let-values ([(in out) (tcp-accept listener)])
|
||||
(set! in-port in)
|
||||
(set! out-port out))
|
||||
(when load-framework-automatically?
|
||||
(queue-sexp-to-mred
|
||||
`(begin
|
||||
(require (lib "framework.ss" "framework")
|
||||
(lib "gui.ss" "tests" "utils")))))))
|
||||
|
||||
(define load-framework-automatically
|
||||
(case-lambda
|
||||
[(new-load-framework-automatically?)
|
||||
(unless (eq? (not (not new-load-framework-automatically?))
|
||||
load-framework-automatically?)
|
||||
(set! load-framework-automatically? (not (not new-load-framework-automatically?)))
|
||||
(shutdown-mred))]
|
||||
[() load-framework-automatically?]))
|
||||
|
||||
(define shutdown-listener
|
||||
(lambda ()
|
||||
(shutdown-mred)
|
||||
(tcp-close listener)))
|
||||
|
||||
(define shutdown-mred
|
||||
(lambda ()
|
||||
(when (and in-port
|
||||
out-port)
|
||||
(with-handlers ([(lambda (x) #t) (lambda (x) (void))])
|
||||
(close-output-port out-port))
|
||||
(with-handlers ([(lambda (x) #t) (lambda (x) (void))])
|
||||
(close-input-port in-port))
|
||||
(set! in-port #f)
|
||||
(set! in-port #f))))
|
||||
|
||||
(define mred-running?
|
||||
(lambda ()
|
||||
(if (char-ready? in-port)
|
||||
(not (eof-object? (peek-char in-port)))
|
||||
#t)))
|
||||
|
||||
(define queue-sexp-to-mred
|
||||
(lambda (sexp)
|
||||
(send-sexp-to-mred
|
||||
`(let ([thunk (lambda () ,sexp)]
|
||||
[sema (make-semaphore 0)])
|
||||
(queue-callback (lambda ()
|
||||
(thunk)
|
||||
(semaphore-post sema)))
|
||||
(semaphore-wait sema)))))
|
||||
|
||||
(define re:tcp-read-error (regexp "tcp-read:"))
|
||||
(define re:tcp-write-error (regexp "tcp-write:"))
|
||||
(define (tcp-error? exn)
|
||||
(or (regexp-match re:tcp-read-error (exn-message exn))
|
||||
(regexp-match re:tcp-write-error (exn-message exn))))
|
||||
|
||||
(define send-sexp-to-mred
|
||||
(let ([failed-last-time? #f])
|
||||
(lambda (sexp)
|
||||
(let/ec k
|
||||
(let ([show-text
|
||||
(lambda (sexp)
|
||||
|
||||
(parameterize ([pretty-print-print-line
|
||||
(let ([prompt " "]
|
||||
[old-liner (pretty-print-print-line)])
|
||||
(lambda (ln port ol cols)
|
||||
(let ([ov (old-liner ln port ol cols)])
|
||||
(if ln
|
||||
(begin (display prompt port)
|
||||
(+ (string-length prompt) ov))
|
||||
ov))))])
|
||||
(pretty-print sexp)
|
||||
(newline)))])
|
||||
(unless (and in-port
|
||||
out-port
|
||||
(with-handlers ([tcp-error?
|
||||
(lambda (x) #f)])
|
||||
(or (not (char-ready? in-port))
|
||||
(not (eof-object? (peek-char in-port))))))
|
||||
(restart-mred))
|
||||
(printf " ~a // ~a: sending to mred:~n" section-name test-name)
|
||||
(show-text sexp)
|
||||
(with-handlers ([(lambda (x) #t)
|
||||
(lambda (x)
|
||||
(cond
|
||||
;; this means that mred was closed
|
||||
;; so we can restart it and try again.
|
||||
[(tcp-error? x)
|
||||
(restart-mred)
|
||||
(write sexp out-port)
|
||||
(newline out-port)]
|
||||
[else (raise x)]))])
|
||||
(write sexp out-port)
|
||||
(newline out-port))
|
||||
(let ([answer
|
||||
(with-handlers ([(lambda (x) #t)
|
||||
(lambda (x)
|
||||
(if (tcp-error? x);; assume tcp-error means app closed
|
||||
eof
|
||||
(list 'cant-read
|
||||
(string-append
|
||||
(exn-message x)
|
||||
"; rest of string: "
|
||||
(format
|
||||
"~s"
|
||||
(apply
|
||||
string
|
||||
(let loop ()
|
||||
(if (char-ready? in-port)
|
||||
(let ([char (read-char in-port)])
|
||||
(if (eof-object? char)
|
||||
null
|
||||
(cons char (loop))))
|
||||
null))))))))])
|
||||
(read in-port))])
|
||||
(unless (or (eof-object? answer)
|
||||
(and (list? answer)
|
||||
(= 2 (length answer))))
|
||||
(error 'send-sexp-to-mred "unpected result from mred: ~s~n" answer))
|
||||
(if (eof-object? answer)
|
||||
(raise (make-eof-result))
|
||||
(case (car answer)
|
||||
[(error)
|
||||
(error 'send-sexp-to-mred "mred raised \"~a\"" (second answer))]
|
||||
[(cant-read) (error 'mred/cant-parse (second answer))]
|
||||
[(normal)
|
||||
(printf " ~a // ~a: received from mred:~n" section-name test-name)
|
||||
(show-text (second answer))
|
||||
(eval (second answer))]))))))))
|
||||
|
||||
|
||||
(define test
|
||||
(case-lambda
|
||||
[(in-test-name passed? sexp/proc) (test in-test-name passed? sexp/proc 'section)]
|
||||
[(in-test-name passed? sexp/proc jump)
|
||||
(fluid-let ([test-name in-test-name])
|
||||
(when (or (not only-these-tests)
|
||||
(memq test-name only-these-tests))
|
||||
(let ([failed
|
||||
(with-handlers ([(lambda (x) #t)
|
||||
(lambda (x)
|
||||
(if (exn? x)
|
||||
(exn-message x)
|
||||
x))])
|
||||
(let ([result
|
||||
(if (procedure? sexp/proc)
|
||||
(sexp/proc)
|
||||
(begin0 (send-sexp-to-mred sexp/proc)
|
||||
(send-sexp-to-mred ''check-for-errors)))])
|
||||
(not (passed? result))))])
|
||||
(when failed
|
||||
(printf "FAILED ~a: ~a~n" failed test-name)
|
||||
(set! failed-tests (cons (cons section-name test-name) failed-tests))
|
||||
(case jump
|
||||
[(section) (section-jump)]
|
||||
[(continue) (void)]
|
||||
[else (jump)])))))]))
|
||||
|
||||
(define (wait-for/wrapper wrapper sexp)
|
||||
(let ([timeout 10]
|
||||
[pause-time 1/2])
|
||||
(send-sexp-to-mred
|
||||
(wrapper
|
||||
`(let ([test (lambda () ,sexp)])
|
||||
(let loop ([n ,(/ timeout pause-time)])
|
||||
(if (zero? n)
|
||||
(error 'wait-for
|
||||
,(format "after ~a seconds, ~s didn't come true" timeout sexp))
|
||||
(unless (test)
|
||||
(sleep ,pause-time)
|
||||
(loop (- n 1))))))))))
|
||||
|
||||
(define (wait-for sexp) (wait-for/wrapper (lambda (x) x) sexp))
|
||||
|
||||
(define (wait-for-new-frame sexp)
|
||||
(wait-for/wrapper
|
||||
(lambda (w)
|
||||
`(let ([frame (get-top-level-focus-window)])
|
||||
,sexp
|
||||
,w))
|
||||
`(not (eq? frame (get-top-level-focus-window)))))
|
||||
|
||||
(define (wait-for-frame name)
|
||||
(wait-for `(let ([win (get-top-level-focus-window)])
|
||||
(and win
|
||||
(string=? (send win get-label) ,name))))))
|
||||
Loading…
Reference in New Issue
Block a user