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

make the framework test suite only modify gui objects on the eventspace handler thread

Browse Source 
original commit: a32adbe7db6e8302bbd2bf0d21b6ad9cb04ad0d1
This commit is contained in:
Robby Findler 2011-01-07 06:39:27 -06:00
parent 0c9aceeb9e
commit 24a195eee2
5 changed files with 29 additions and 23 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
collects/tests/framework/debug.rkt
View File

@ -13,7 +13,7 @@
(define schedule? #t)
;; all of the sexpression transactions between mz and mred
(define messages? #f)
(define messages? #t)
(define-syntax (debug-when stx)
(syntax-case stx (mr-tcp mz-tcp admin schedule messages)

6
collects/tests/framework/frame.rkt
View File

@ -12,9 +12,11 @@
(lambda ()
(let ([frame-label
(send-sexp-to-mred
`(let ([f (instantiate ,class-expression () ,@args)])
`(queue-callback/res
(λ ()
(let ([f (instantiate ,class-expression () ,@args)])
(send f show #t)
(send f get-label)))])
(send f get-label)))))])
(wait-for-frame frame-label)
(queue-sexp-to-mred
'(send (get-top-level-focus-window) close))

5
collects/tests/framework/framework-test-engine.rkt
View File

@ -22,6 +22,11 @@
(namespace-require 'racket/gui)
(eval '(define (queue-callback/res thunk)
(define c (make-channel))
(queue-callback (λ () (channel-put c (thunk))))
(channel-get c)))
(void
(thread
(lambda ()

12
collects/tests/framework/prefs.rkt
View File

@ -21,8 +21,8 @@
(when (file-exists? prefs-file)
(copy-file prefs-file saved-prefs-file)
(delete-file prefs-file)
(debug-printf admin "saved preferences file from ~s to ~s\n"
prefs-file saved-prefs-file))
(debug-printf admin "saved preferences file from ~s\n" prefs-file)
(debug-printf admin " to ~s\n" saved-prefs-file))
(shutdown-mred)
@ -92,10 +92,10 @@
(test 'dialog-appears
(lambda (x) (eq? 'passed x))
(lambda ()
(send-sexp-to-mred '(begin (send (make-object frame:basic% "frame") show #t)
(queue-sexp-to-mred '(begin (send (make-object frame:basic% "frame") show #t)
(preferences:show-dialog)))
(wait-for-frame "Preferences")
(send-sexp-to-mred '(begin (preferences:hide-dialog)
(queue-sexp-to-mred '(begin (preferences:hide-dialog)
(let ([f (get-top-level-focus-window)])
(if f
(if (string=? "Preferences" (send f get-label))
@ -104,8 +104,8 @@
'passed))))))
(when (file-exists? saved-prefs-file)
(debug-printf admin "restoring preferences file from ~s to ~s\n"
saved-prefs-file prefs-file)
(debug-printf admin "restoring preferences file from ~s\n" saved-prefs-file)
(debug-printf admin " to ~s\n" prefs-file)
(when (file-exists? prefs-file)
(delete-file prefs-file))
(copy-file saved-prefs-file prefs-file)

11
collects/tests/framework/test-suite-utils.rkt
View File

@ -140,12 +140,11 @@
(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)))))
`(let ([thunk (lambda () ,sexp)] ;; lotech hygiene
[c (make-channel)])
(queue-callback (lambda () (channel-put c (thunk))))
(channel-wait c)))))
(define re:tcp-read-error (regexp "tcp-read:"))
(define re:tcp-write-error (regexp "tcp-write:"))