186 lines
6.7 KiB
Racket
186 lines
6.7 KiB
Racket
#lang mzscheme
|
|
(require "test-suite-utils.ss")
|
|
|
|
(define windows-menu-prefix
|
|
(let ([basics (list "Bring Frame to Front..." "Most Recent Window"
|
|
#f)])
|
|
(if (eq? (system-type) 'macosx)
|
|
(list* "Minimize" "Zoom" basics)
|
|
basics)))
|
|
(send-sexp-to-mred
|
|
'(define-syntax car*
|
|
(syntax-rules ()
|
|
[(car* x) (if (pair? x)
|
|
(car x)
|
|
(error 'car* "got a non-pair for ~s" 'x))])))
|
|
|
|
;; this test uses a new eventspace so that the gracket 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 (parameterize ([current-eventspace new-eventspace])
|
|
(send (make-object frame:basic% "first") show #t))
|
|
(preferences:set 'framework:verify-exit #t)))
|
|
(wait-for-frame "first" 'new-eventspace)
|
|
(send-sexp-to-mred
|
|
`(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
|
|
`(parameterize ([current-eventspace new-eventspace])
|
|
(test:button-push "Cancel")))
|
|
(wait-for-frame "first" 'new-eventspace)
|
|
(send-sexp-to-mred
|
|
`(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.
|
|
|
|
(test
|
|
'one-frame-registered
|
|
(lambda (x) (equal? x (list "test" "first")))
|
|
(lambda ()
|
|
(send-sexp-to-mred
|
|
`(send (make-object frame:basic% "test") show #t))
|
|
(wait-for-frame "test")
|
|
(send-sexp-to-mred
|
|
`(begin0 (map (lambda (x) (send x get-label))
|
|
(send (group:get-the-frame-group) get-frames))
|
|
(send (get-top-level-focus-window) close)))))
|
|
|
|
(test
|
|
'two-frames-registered
|
|
(lambda (x) (equal? x (list "test2" "test1" "first")))
|
|
(lambda ()
|
|
(send-sexp-to-mred
|
|
'(send (make-object frame:basic% "test1") show #t))
|
|
(wait-for-frame "test1")
|
|
(send-sexp-to-mred
|
|
'(send (make-object frame:basic% "test2") show #t))
|
|
(wait-for-frame "test2")
|
|
(send-sexp-to-mred
|
|
`(begin0 (let ([frames (send (group:get-the-frame-group) get-frames)])
|
|
(for-each (lambda (x)
|
|
(unless (equal? (send x get-label) "first")
|
|
(send x close)))
|
|
frames)
|
|
(map (lambda (x) (send x get-label)) frames))))))
|
|
|
|
(test
|
|
'one-frame-unregistered
|
|
(lambda (x) (equal? x (list "test1" "first")))
|
|
(lambda ()
|
|
(send-sexp-to-mred
|
|
'(send (make-object frame:basic% "test1") show #t))
|
|
(wait-for-frame "test1")
|
|
(send-sexp-to-mred
|
|
'(send (make-object frame:basic% "test2") show #t))
|
|
(wait-for-frame "test2")
|
|
(queue-sexp-to-mred
|
|
`(send (get-top-level-focus-window) close))
|
|
(send-sexp-to-mred
|
|
`(let ([frames (send (group:get-the-frame-group) get-frames)])
|
|
(for-each (lambda (x)
|
|
(unless (equal? (send x get-label) "first")
|
|
(send x close)))
|
|
frames)
|
|
(map (lambda (x) (send x get-label)) frames)))))
|
|
|
|
(when (eq? (system-type) 'macosx)
|
|
|
|
(test
|
|
'windows-menu
|
|
(lambda (x)
|
|
(equal? x (append windows-menu-prefix (list "first" "test"))))
|
|
(lambda ()
|
|
(send-sexp-to-mred
|
|
'(let ([frame (make-object frame:basic% "test")])
|
|
(send frame show #t)))
|
|
(wait-for-frame "test")
|
|
(send-sexp-to-mred
|
|
'(begin0 (map (lambda (x)
|
|
(and (is-a? x labelled-menu-item<%>) (send x get-label)))
|
|
(send (car* (send (send (get-top-level-focus-window)
|
|
get-menu-bar)
|
|
get-items))
|
|
get-items))
|
|
(send (get-top-level-focus-window) close)))))
|
|
|
|
(test
|
|
'windows-menu-unshown
|
|
(lambda (x)
|
|
(equal? x (append windows-menu-prefix (list "first" "test"))))
|
|
(lambda ()
|
|
(send-sexp-to-mred
|
|
'(let ([frame1 (make-object frame:basic% "test")]
|
|
[frame2 (make-object frame:basic% "test-not-shown")])
|
|
(send frame1 show #t)))
|
|
(wait-for-frame "test")
|
|
(send-sexp-to-mred
|
|
'(begin0 (map (lambda (x)
|
|
(and (is-a? x labelled-menu-item<%>) (send x get-label)))
|
|
(send (car* (send (send (get-top-level-focus-window)
|
|
get-menu-bar)
|
|
get-items))
|
|
get-items))
|
|
(send (get-top-level-focus-window) close)))))
|
|
|
|
(test
|
|
'windows-menu-sorted1
|
|
(lambda (x)
|
|
(equal? x (append windows-menu-prefix (list "aaa" "bbb" "first"))))
|
|
(lambda ()
|
|
(send-sexp-to-mred
|
|
'(let ([frame (make-object frame:basic% "aaa")])
|
|
(send frame show #t)))
|
|
(wait-for-frame "aaa")
|
|
(send-sexp-to-mred
|
|
'(let ([frame (make-object frame:basic% "bbb")])
|
|
(send frame show #t)))
|
|
(wait-for-frame "bbb")
|
|
(send-sexp-to-mred
|
|
`(let ([frames (send (group:get-the-frame-group) get-frames)])
|
|
(begin0 (map (lambda (x)
|
|
(and (is-a? x labelled-menu-item<%>) (send x get-label)))
|
|
(send (car* (send (send (car* frames) get-menu-bar)
|
|
get-items))
|
|
get-items))
|
|
(for-each (lambda (x)
|
|
(unless (equal? (send x get-label) "first")
|
|
(send x close)))
|
|
frames))))))
|
|
|
|
(test
|
|
'windows-menu-sorted2
|
|
(lambda (x)
|
|
(equal? x (append windows-menu-prefix (list "aaa" "bbb" "first"))))
|
|
(lambda ()
|
|
(send-sexp-to-mred
|
|
'(let ([frame (make-object frame:basic% "bbb")])
|
|
(send frame show #t)))
|
|
(wait-for-frame "bbb")
|
|
(send-sexp-to-mred
|
|
'(let ([frame (make-object frame:basic% "aaa")])
|
|
(send frame show #t)))
|
|
(wait-for-frame "aaa")
|
|
(send-sexp-to-mred
|
|
`(let ([frames (send (group:get-the-frame-group) get-frames)])
|
|
(begin0 (map (lambda (x)
|
|
(and (is-a? x labelled-menu-item<%>) (send x get-label)))
|
|
(send (car* (send (send (car* frames) get-menu-bar)
|
|
get-items))
|
|
get-items))
|
|
(for-each (lambda (x)
|
|
(unless (equal? (send x get-label) "first")
|
|
(send x close)))
|
|
frames))))))
|
|
)
|