PR 9873 (hopefully)
svn: r12193 original commit: bd375ef6050111faa3bc8855679d06f537966df9
This commit is contained in:
parent
03ebe888e7
commit
b3229d808d
|
@ -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)
|
||||
|
|
|
@ -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.
|
||||
|
|
|
@ -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))))
|
||||
|
|
Loading…
Reference in New Issue
Block a user