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

PR 9873 (hopefully)

Browse Source 
svn: r12193

original commit: bd375ef6050111faa3bc8855679d06f537966df9
This commit is contained in:
Robby Findler 2008-10-31 12:40:05 +00:00
parent 03ebe888e7
commit b3229d808d
3 changed files with 293 additions and 278 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
collects/framework/private/group.ss
View File

@ -273,12 +273,14 @@
(or (not (preferences:get 'framework:exit-when-no-frames))
(exit:exiting?)
(not (= 1 number-of-frames))
(current-eventspace-has-standard-menus?)
(exit:user-oks-exit))))
(define (on-close-action)
(when (preferences:get 'framework:exit-when-no-frames)
(unless (exit:exiting?)
(when (null? (send (get-the-frame-group) get-frames))
(when (and (null? (send (get-the-frame-group) get-frames))
(not (current-eventspace-has-standard-menus?)))
(exit:exit)))))
(define (choose-a-frame parent)

27
collects/tests/framework/group-test.ss
View File

@ -5,7 +5,7 @@
(let ([basics (list "Bring Frame to Front..." "Most Recent Window"
#f)])
(if (eq? (system-type) 'macosx)
(list* "Minimize" "Zoom" #f basics)
(list* "Minimize" "Zoom" basics)
basics)))
(send-sexp-to-mred
'(define-syntax car*
@ -14,23 +14,32 @@
(car x)
(error 'car* "got a non-pair for ~s" 'x))])))
;; this test uses a new eventspace so that the mred function
;; current-eventspace-has-standard-menus? returns #f and thus
;; all of the platforms behave the same way.
(test
'exit-on
(lambda (x) (equal? x '("first")))
(lambda ()
(send-sexp-to-mred `(define new-eventspace (make-eventspace)))
(send-sexp-to-mred
'(begin (send (make-object frame:basic% "first") show #t)
'(begin (parameterize ([current-eventspace new-eventspace])
(send (make-object frame:basic% "first") show #t))
(preferences:set 'framework:verify-exit #t)))
(wait-for-frame "first")
(wait-for-frame "first" 'new-eventspace)
(send-sexp-to-mred
`(queue-callback (lambda () (send (get-top-level-focus-window) close))))
(wait-for-frame "Warning")
`(queue-callback (lambda ()
(parameterize ([current-eventspace new-eventspace])
(send (get-top-level-focus-window) close)))))
(wait-for-frame "Warning" 'new-eventspace)
(send-sexp-to-mred
`(test:button-push "Cancel"))
(wait-for-frame "first")
`(parameterize ([current-eventspace new-eventspace])
(test:button-push "Cancel")))
(wait-for-frame "first" 'new-eventspace)
(send-sexp-to-mred
`(map (lambda (x) (send x get-label))
(send (group:get-the-frame-group) get-frames)))))
`(parameterize ([current-eventspace new-eventspace])
(map (lambda (x) (send x get-label))
(send (group:get-the-frame-group) get-frames))))))
;; after the first test, we should have one frame that will always
;; be in the group.

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

@ -1,9 +1,8 @@
#lang scheme
(module test-suite-utils mzscheme
(require launcher
mzlib/pretty
mzlib/list
mzlib/process
(require (only-in mzscheme fluid-let)
launcher
scheme/system
"debug.ss")
(provide
@ -70,7 +69,8 @@
(if l
(begin (debug-printf mz-tcp "listening to ~a\n" port)
(call-with-output-file port-filename
(lambda (p) (write port p)) 'truncate)
(lambda (p) (write port p))
#:exists 'truncate)
l)
(begin (debug-printf mz-tcp " tcp-listen failed for port ~a\n" port)
(loop (add1 port)))))))
@ -292,7 +292,11 @@
,w))
`(not (eq? frame (get-top-level-focus-window)))))
(define (wait-for-frame name)
(wait-for `(let ([win (get-top-level-focus-window)])
(define (wait-for-frame name [eventspace #f])
(let ([exp `(let ([win (get-top-level-focus-window)])
(and win
(string=? (send win get-label) ,name))))))
(string=? (send win get-label) ,name)))])
(if eventspace
`(parameterize ([current-eventspace ,eventspace])
,exp)
(wait-for exp))))