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) (define schedule? #t)
;; all of the sexpression transactions between mz and mred ;; all of the sexpression transactions between mz and mred
(define messages? #f) (define messages? #t)
(define-syntax (debug-when stx) (define-syntax (debug-when stx)
(syntax-case stx (mr-tcp mz-tcp admin schedule messages) (syntax-case stx (mr-tcp mz-tcp admin schedule messages)

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

@ -12,9 +12,11 @@
(lambda () (lambda ()
(let ([frame-label (let ([frame-label
(send-sexp-to-mred (send-sexp-to-mred
`(let ([f (instantiate ,class-expression () ,@args)]) `(queue-callback/res
(send f show #t) (λ ()
(send f get-label)))]) (let ([f (instantiate ,class-expression () ,@args)])
(send f show #t)
(send f get-label)))))])
(wait-for-frame frame-label) (wait-for-frame frame-label)
(queue-sexp-to-mred (queue-sexp-to-mred
'(send (get-top-level-focus-window) close)) '(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) (namespace-require 'racket/gui)
(eval '(define (queue-callback/res thunk)
(define c (make-channel))
(queue-callback (λ () (channel-put c (thunk))))
(channel-get c)))
(void (void
(thread (thread
(lambda () (lambda ()

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

@ -21,8 +21,8 @@
(when (file-exists? prefs-file) (when (file-exists? prefs-file)
(copy-file prefs-file saved-prefs-file) (copy-file prefs-file saved-prefs-file)
(delete-file prefs-file) (delete-file prefs-file)
(debug-printf admin "saved preferences file from ~s to ~s\n" (debug-printf admin "saved preferences file from ~s\n" prefs-file)
prefs-file saved-prefs-file)) (debug-printf admin " to ~s\n" saved-prefs-file))
(shutdown-mred) (shutdown-mred)
@ -92,20 +92,20 @@
(test 'dialog-appears (test 'dialog-appears
(lambda (x) (eq? 'passed x)) (lambda (x) (eq? 'passed x))
(lambda () (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))) (preferences:show-dialog)))
(wait-for-frame "Preferences") (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)]) (let ([f (get-top-level-focus-window)])
(if f (if f
(if (string=? "Preferences" (send f get-label)) (if (string=? "Preferences" (send f get-label))
'failed 'failed
'passed) 'passed)
'passed)))))) 'passed))))))
(when (file-exists? saved-prefs-file) (when (file-exists? saved-prefs-file)
(debug-printf admin "restoring preferences file from ~s to ~s\n" (debug-printf admin "restoring preferences file from ~s\n" saved-prefs-file)
saved-prefs-file prefs-file) (debug-printf admin " to ~s\n" prefs-file)
(when (file-exists? prefs-file) (when (file-exists? prefs-file)
(delete-file prefs-file)) (delete-file prefs-file))
(copy-file saved-prefs-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 (define queue-sexp-to-mred
(lambda (sexp) (lambda (sexp)
(send-sexp-to-mred (send-sexp-to-mred
`(let ([thunk (lambda () ,sexp)] `(let ([thunk (lambda () ,sexp)] ;; lotech hygiene
[sema (make-semaphore 0)]) [c (make-channel)])
(queue-callback (lambda () (queue-callback (lambda () (channel-put c (thunk))))
(thunk) (channel-wait c)))))
(semaphore-post sema)))
(semaphore-wait sema)))))
(define re:tcp-read-error (regexp "tcp-read:")) (define re:tcp-read-error (regexp "tcp-read:"))
(define re:tcp-write-error (regexp "tcp-write:")) (define re:tcp-write-error (regexp "tcp-write:"))