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

...

Browse Source 
original commit: d42652cda502d7c2d92cbb92a1a6c98cebb92291
This commit is contained in:
Robby Findler 2001-03-12 03:14:05 +00:00
parent 702ea96f46
commit 160d7f0489
5 changed files with 128 additions and 73 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

43
collects/tests/framework/debug.ss Normal file
View File

@ -0,0 +1,43 @@
(module debug-printf mzscheme
(provide debug-printf debug-when)
;; all of the steps in the tcp connection
(define tcp? #f)
;; administrative messages about preferences files and
;; command line flags
(define admin? #f)
;; tests that passed and those that failed
(define schedule? #t)
;; of the sexpression transactions between mz and mred
(define messages? #f)
(define-syntax debug-printf
(lambda (stx)
(syntax-case stx ()
[(_ flag rest ...)
(syntax (debug-when flag (printf rest ...)))])))
(define-syntax debug-when
(lambda (stx)
(syntax-case stx (tcp admin schedule messages)
[(_ tcp rest ...)
(syntax
(when tcp?
rest ...))]
[(_ admin rest ...)
(syntax
(when admin?
rest ...))]
[(_ schedule rest ...)
(syntax
(when schedule?
rest ...))]
[(_ messages rest ...)
(syntax
(when messages?
rest ...))]
[(_ unk rest ...)
(raise-syntax-error 'debug-when "unknown flag" stx (syntax unk))]))))

79
collects/tests/framework/framework-test-engine.ss
View File

@ -1,6 +1,11 @@
(require (lib "errortrace.ss" "errortrace"))
(module framework-test-engine mzscheme
(require (lib "pconvert.ss")
(lib "mred.ss" "mred"))
(lib "mred.ss" "mred")
(lib "errortrace.ss" "errortrace")
"debug.ss"
)
(define errs null)
(define sema (make-semaphore 1))
@ -9,50 +14,44 @@
(begin0 (f)
(semaphore-post sema)))
#|
(define (exception->string x)
(if (exn? x)
(if (defined? 'print-error-trace)
(let ([p (open-output-string)])
(print-error-trace p x)
(string-append (exn-message x) (string #\newline) (get-output-string p)))
(exn-message x))
(format "~s" x)))
|#
(define (exception->string x)
(if (exn? x)
; (let ([p (open-output-string)])
; (print-error-trace p x)
; (string-append (exn-message x) (string #\newline) (get-output-string p)))
(exn-message x)
(format "~s" x)))
(thread
(lambda ()
(let*-values ([(in out) (tcp-connect "localhost"
(load
(build-path
(collection-path "tests" "framework")
"receive-sexps-port.ss")))]
[(continue) (make-semaphore 0)])
(let loop ()
(let ([sexp (read in)])
(if (eof-object? sexp)
(begin
(close-input-port in)
(close-output-port out)
(exit))
(begin
(write
(let ([these-errs (protect (lambda () (begin0 errs (set! errs null))))])
(if (null? these-errs)
(with-handlers ([(lambda (x) #t)
(lambda (x) (list 'error (exception->string x)))])
(list 'normal (print-convert (eval sexp))))
(list 'error
(apply string-append
(map (lambda (x) (string-append (exception->string x) (string #\newline)))
these-errs)))))
out)
(loop))))))))
(let ([port (load
(build-path
(collection-path "tests" "framework")
"receive-sexps-port.ss"))])
(debug-printf tcp "about to connect to ~a~n" port)
(let*-values ([(in out) (tcp-connect "localhost" port)])
(let loop ()
(debug-printf tcp "about to read~n")
(let ([sexp (read in)])
(debug-printf tcp "got something~n")
(if (eof-object? sexp)
(begin
(close-input-port in)
(close-output-port out)
(exit))
(begin
(write
(let ([these-errs (protect (lambda () (begin0 errs (set! errs null))))])
(if (null? these-errs)
(with-handlers ([(lambda (x) #t)
(lambda (x) (list 'error (exception->string x)))])
(list 'normal (print-convert (eval sexp))))
(list 'error
(apply string-append
(map (lambda (x) (string-append (exception->string x) (string #\newline)))
these-errs)))))
out)
(loop)))))))))
(let ([od (event-dispatch-handler)]
[port (current-output-port)])
@ -65,4 +64,6 @@
(lambda ()
(set! errs (cons exn errs))))
(oe exn)))])
(od evt))))))
(od evt)))))
(yield (make-semaphore 0)))

15
collects/tests/framework/load.ss
View File

@ -7,14 +7,19 @@
(test
(string->symbol file)
void?
`(parameterize ([current-namespace (make-namespace 'mred)])
(require (lib ,file "framework"))
,exp
(void))))
`(parameterize ([current-namespace (make-namespace)])
(eval '(require (lib ,file "framework")))
(with-handlers ([(lambda (x) #t)
(lambda (x)
(if (exn? x)
(exn-message x)
(format "~s" x)))])
(eval ',exp)
(void)))))
(load-framework-automatically #f)
(test/load "prefs-file-unit.ss" 'framework:preferences@)
(test/load "prefs-file-unit.ss" 'framework:prefs-file@)
(test/load "prefs-file.ss" 'get-preferences-filename)
(test/load "gui-utils-unit.ss" 'framework:gui-utils@)

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

@ -2,6 +2,7 @@
(require (lib "launcher.ss" "launcher")
(lib "cmdline.ss")
(lib "unitsig.ss")
"debug.ss"
"test-suite-utils.ss")
;; must be run in the right context...
@ -46,7 +47,7 @@
(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)
(debug-printf admin "reusing command-line arguments: ~s~n" result)
result))
(vector))
argv))
@ -62,11 +63,11 @@
'truncate)
(when (file-exists? preferences-file)
(printf " saving preferences file ~s to ~s~n" preferences-file old-preferences-file)
(debug-printf admin " 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")
(debug-printf admin " backup preferences file exists, using that one~n")
(begin (copy-file preferences-file old-preferences-file)
(printf " saved preferences file~n"))))
(debug-printf admin " saved preferences file~n"))))
(with-handlers ([(lambda (x) #f)
(lambda (x) (display (exn-message x)) (newline))])
@ -82,30 +83,29 @@
(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)
(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)
(printf "PASSED ~a test suite~n" x)))
(debug-printf schedule "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)
(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))
(printf " restored preferences file~n")
(debug-printf admin " restored preferences file~n")
(shutdown-listener)
(unless (null? failed-tests)
(printf "FAILED tests:~n")
(debug-printf schedule "FAILED tests:~n")
(for-each (lambda (failed-test)
(printf " ~a // ~a~n" (car failed-test) (cdr failed-test)))
(debug-printf schedule " ~a // ~a~n" (car failed-test) (cdr failed-test)))
failed-tests)))

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

@ -1,7 +1,8 @@
(module test-suite-utils mzscheme
(require (lib "launcher.ss" "launcher")
(lib "pretty.ss")
(lib "list.ss"))
(lib "list.ss")
"debug.ss")
(provide
test-name
@ -68,9 +69,11 @@
(lambda (p)
(write next p))
'truncate)
(printf " tcp-listen failed for port ~a, attempting ~a~n"
port next)
(debug-printf tcp " tcp-listen failed for port ~a, attempting ~a~n"
port
next)
(loop)))])
(debug-printf tcp "listening to ~a~n" port)
(tcp-listen port)))))
(define in-port #f)
@ -83,6 +86,7 @@
[(macos) system*]
[else (lambda (x) (thread (lambda () (system* x))))])
(mred-program-launcher-path "Framework Test Engine"))
(debug-printf tcp "accepting listener~n")
(let-values ([(in out) (tcp-accept listener)])
(set! in-port in)
(set! out-port out))
@ -104,6 +108,7 @@
(define shutdown-listener
(lambda ()
(shutdown-mred)
(debug-printf tcp "closing listener~n")
(tcp-close listener)))
(define shutdown-mred
@ -146,17 +151,18 @@
(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)))])
(debug-when messages
(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?
@ -164,7 +170,7 @@
(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)
(debug-printf messages " ~a // ~a: sending to mred:~n" section-name test-name)
(show-text sexp)
(with-handlers ([(lambda (x) #t)
(lambda (x)
@ -210,7 +216,7 @@
(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)
(debug-printf messages " ~a // ~a: received from mred:~n" section-name test-name)
(show-text (second answer))
(eval (second answer))]))))))))
@ -235,7 +241,7 @@
(send-sexp-to-mred ''check-for-errors)))])
(not (passed? result))))])
(when failed
(printf "FAILED ~a: ~a~n" failed test-name)
(debug-printf schedule "FAILED ~a: ~a~n" failed test-name)
(set! failed-tests (cons (cons section-name test-name) failed-tests))
(case jump
[(section) (section-jump)]