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

..

Browse Source 
original commit: 0f8b33f8637bca5bd047a33a4364c3c9db46c9bf
This commit is contained in:
Robby Findler 2002-09-18 04:01:31 +00:00
parent c94d5267b2
commit 38c68a12be
5 changed files with 392 additions and 461 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

44
collects/tests/framework/README
View File

@ -5,7 +5,7 @@ Each tests will rely on the sucessfully completion of all of the ones
before it. In addition, all test suites rely on the sucessful before it. In addition, all test suites rely on the sucessful
completion of the engine test suites and the mzscheme test suites. completion of the engine test suites and the mzscheme test suites.
All of these tests reside in PLTHOME/tests/framework/ All of these tests reside in PLTHOME/collects/tests/framework/
There will be a main mzscheme process which will start up a new mred There will be a main mzscheme process which will start up a new mred
as necessary for the test suites. Since some tests actually require as necessary for the test suites. Since some tests actually require
@ -15,9 +15,19 @@ To run a test use:
framework-test <test.ss> ... framework-test <test.ss> ...
where or <test.ss> is the name of one of the tests where or <test.ss> is the name of one of the tests below.
below. Alternatively, pass no command-line arguments to run the same Alternatively, pass no command-line arguments to run all of
test as last time, or `all' to run all of the tests. the tests. (Under windows, the app will be named "Framework
Test"; see the mred-launcher-names documentation for how the
names change on the various platforms)
Some of the tests in this file are not yet present in the
testing directory. They are planned future expansions of
this test suite (and have been for some time....)
OS X: you will have to click on the newly started mred
processes in the doc while the test suite runs or it will
signal failures when there aren't any.
- load: |# load.ss #| - load: |# load.ss #|
@ -35,10 +45,6 @@ test as last time, or `all' to run all of the tests.
| immediately and across reboots of mred. | immediately and across reboots of mred.
- specs |# spec-test.ss #|
| this tests that the specs are compiled properly.
- individual object tests: - individual object tests:
| These tests are simple object creation and basic operations. | These tests are simple object creation and basic operations.
@ -50,19 +56,9 @@ test as last time, or `all' to run all of the tests.
- texts: |# text.ss #| - texts: |# text.ss #|
- pasteboards: |# pasteboard.ss #| - pasteboards: |# pasteboard.ss #|
- basic connections between classes
| These tests will create objects in various configurations and
| trigger situations to test their functionality.
- edits to canvases: |# edit-canvas.ss #|
- canvases to frames: |# canvas-frame.ss #|
- edits to frames: |# edit-frame.ss #|
- handler: handler-test.ss
- keybindings: |# keys.ss #| - keybindings: |# keys.ss #|
| This tests all of the misc (non-scheme) keybindings | This tests the misc (non-scheme) keybindings
- searching: |# search.ss #| - searching: |# search.ss #|
@ -96,16 +92,6 @@ test as last time, or `all' to run all of the tests.
- closing: |# close.ss #| - closing: |# close.ss #|
- quitting: |# quit.ss #| - quitting: |# quit.ss #|
- docs:
| these tests perform santiy checks to ensure that the docs are up to
| date with the code and the mred web browser isn't horribly broken
- inheritance: inheritance.ss
| make sure that the super-class relationships in the docs match
| the code.
- interactive tests - interactive tests
| these tests require intervention by people. Clicking and whatnot | these tests require intervention by people. Clicking and whatnot

55
collects/tests/framework/exit.ss
View File

@ -7,61 +7,9 @@
(not (mred-running?)))) (not (mred-running?))))
(lambda () (lambda ()
(with-handlers ([eof-result? (lambda (x) 'passed)]) (with-handlers ([eof-result? (lambda (x) 'passed)])
(send-sexp-to-mred '(preferences:set 'framework:verify-exit #f))
(send-sexp-to-mred '(begin (exit:exit) (sleep/yield 1))) (send-sexp-to-mred '(begin (exit:exit) (sleep/yield 1)))
'failed))) 'failed)))
(test 'exit/prompt
(lambda (x) (and (eq? x 'passed)
(not (mred-running?))))
(lambda ()
(with-handlers ([eof-result? (lambda (x) 'passed)])
(send-sexp-to-mred '(begin (preferences:set 'framework:verify-exit #t)
(test:run-one (lambda () (exit:exit)))))
(wait-for-frame "Warning")
(wait-for-new-frame `(test:button-push
,(case (system-type)
[(windows) "Exit"]
[else "Quit"])))
'failed)))
(test 'exit/prompt/no-twice
(lambda (x) (and (eq? x 'passed)
(not (mred-running?))))
(let ([exit/push-button
(lambda (button)
(send-sexp-to-mred '(begin (preferences:set 'framework:verify-exit #t)
(test:run-one (lambda () (exit:exit)))))
(wait-for-frame "Warning")
(wait-for-new-frame `(test:button-push ,button)))])
(lambda ()
(exit/push-button "Cancel")
(exit/push-button "Cancel")
(with-handlers ([eof-result? (lambda (x) 'passed)])
(exit/push-button (case (system-type)
[(windows) "Exit"]
[else "Quit"]))
'failed))))
(test 'exit/esc-cancel
(lambda (x) (and (eq? x 'passed)
(not (mred-running?))))
(let ([exit/wait-for-warning
(lambda ()
(send-sexp-to-mred '(begin (preferences:set 'framework:verify-exit #t)
(test:run-one (lambda () (exit:exit)))))
(wait-for-frame "Warning"))])
(lambda ()
(exit/wait-for-warning)
(wait-for-new-frame `(test:close-top-level-window (get-top-level-focus-window)))
(exit/wait-for-warning)
(with-handlers ([eof-result? (lambda (x) 'passed)])
(wait-for-new-frame `(test:button-push
,(case (system-type)
[(windows) "Exit"]
[else "Quit"])))
'failed))))
(define tmp-file (build-path (find-system-path 'temp-dir) "framework-exit-test-suite")) (define tmp-file (build-path (find-system-path 'temp-dir) "framework-exit-test-suite"))
;; need to test "on" callbacks ;; need to test "on" callbacks
(test 'exit-callback-called (test 'exit-callback-called
@ -74,7 +22,6 @@
(with-handlers ([eof-result? (lambda (x) 'passed)]) (with-handlers ([eof-result? (lambda (x) 'passed)])
(send-sexp-to-mred (send-sexp-to-mred
`(begin `(begin
(preferences:set 'framework:verify-exit #f)
(exit:insert-can?-callback (lambda () (call-with-output-file ,tmp-file void) #t)) (exit:insert-can?-callback (lambda () (call-with-output-file ,tmp-file void) #t))
(begin (exit:exit) (sleep/yield 1))))))) (begin (exit:exit) (sleep/yield 1)))))))
@ -84,7 +31,6 @@
(with-handlers ([eof-result? (lambda (x) 'passed)]) (with-handlers ([eof-result? (lambda (x) 'passed)])
(send-sexp-to-mred (send-sexp-to-mred
`(begin `(begin
(preferences:set 'framework:verify-exit #f)
((exit:insert-can?-callback (lambda () (error 'called-exit-callback)))) ((exit:insert-can?-callback (lambda () (error 'called-exit-callback))))
(begin (exit:exit) (sleep/yield 1))))))) (begin (exit:exit) (sleep/yield 1)))))))
@ -94,7 +40,6 @@
(begin0 (begin0
(send-sexp-to-mred (send-sexp-to-mred
`(begin `(begin
(preferences:set 'framework:verify-exit #f)
(let ([rm-callback (exit:insert-can?-callback (lambda () #f))]) (let ([rm-callback (exit:insert-can?-callback (lambda () #f))])
(exit:exit) (exit:exit)
(rm-callback) (rm-callback)

304
collects/tests/framework/frame.ss
View File

@ -1,159 +1,161 @@
(module frame mzscheme (module frame mzscheme
(require "test-suite-utils.ss") (require "test-suite-utils.ss")
(define (test-creation name class-expression . args) (send-sexp-to-mred '(send (make-object frame:basic%
(test "dummy to keep from quitting")
name show #t))
(lambda (x) (eq? 'passed x))
(lambda ()
(let ([frame-label
(send-sexp-to-mred
`(let ([f (instantiate ,class-expression () ,@args)])
(preferences:set 'framework:exit-when-no-frames #f)
(send f show #t)
(send f get-label)))])
(wait-for-frame frame-label)
(queue-sexp-to-mred
'(send (get-top-level-focus-window) close))
'passed))))
(test-creation (define (test-creation name class-expression . args)
'basic%-creation
'frame:basic%
'(label "test"))
(test-creation
'basic-mixin-creation
'(frame:basic-mixin frame%)
'(label "test"))
(test-creation
'info-mixin-creation
'(frame:info-mixin frame:basic%)
'(label "test"))
(test-creation
'info%-creation
'frame:info%
'(label "test"))
(test-creation
'text-info-mixin-creation
'(frame:text-info-mixin frame:info%)
'(label "test"))
(test-creation
'text-info%-creation
'frame:text-info%
'(label "test"))
(test-creation
'pasteboard-info-mixin-creation
'(frame:pasteboard-info-mixin frame:info%)
'(label "test"))
(test-creation
'pasteboard-info%-creation
'frame:pasteboard-info%
'(label "test"))
(test-creation
'standard-menus%-creation
'frame:standard-menus%
'(label "test"))
(test-creation
'standard-menus-mixin
'(frame:standard-menus-mixin frame:basic%)
'(label "test"))
(test-creation
'text%-creation
'frame:text%)
(test-creation
'text-mixin-creation
'(frame:text-mixin frame:editor%))
(test-creation
'text-mixin-creation
'(frame:text-mixin frame:editor%))
(test-creation
'searchable%-creation
'frame:searchable%)
(test-creation
'searchable-mixin
'(frame:searchable-mixin frame:text%))
(test-creation
'text-info-file%-creation
'frame:text-info-file%)
(test-creation
'text-info-file-mixin-creation
'(frame:file-mixin frame:text%))
(test-creation
'pasteboard-mixin-creation
'(frame:pasteboard-mixin frame:editor%))
(test-creation
'pasteboard-mixin-creation
'(frame:pasteboard-mixin (frame:editor-mixin frame:standard-menus%)))
(test-creation
'pasteboard%-creation
'frame:pasteboard%)
(test-creation
'pasteboard-info-file-mixin-creation
'(frame:file-mixin frame:pasteboard%))
(test-creation
'pasteboard-info-file%-creation
'frame:pasteboard-info-file%)
(define (test-open name class-expression)
(let* ([test-file-contents "test"]
[tmp-file-name "framework-tmp"]
[tmp-file (build-path (collection-path "tests" "framework")
tmp-file-name)])
(test (test
name name
(lambda (x) (lambda (x) (eq? 'passed x))
(when (file-exists? tmp-file)
(delete-file tmp-file))
(equal? x test-file-contents))
(lambda () (lambda ()
(let ([frame-name (let ([frame-label
(send-sexp-to-mred (send-sexp-to-mred
`(let ([frame (instantiate ,class-expression ())]) `(let ([f (instantiate ,class-expression () ,@args)])
(preferences:set 'framework:exit-when-no-frames #f) (send f show #t)
(preferences:set 'framework:file-dialogs 'common) (send f get-label)))])
(send frame show #t) (wait-for-frame frame-label)
(send frame get-label)))]) (queue-sexp-to-mred
(wait-for-frame frame-name) '(send (get-top-level-focus-window) close))
(send-sexp-to-mred 'passed))))
`(test:menu-select "File" "Open..."))
(wait-for-frame "Get file")
(call-with-output-file tmp-file
(lambda (port)
(display test-file-contents port))
'truncate)
(send-sexp-to-mred
`(begin (send (find-labelled-window "Full pathname") focus)
,(case (system-type)
[(macos macosx) `(test:keystroke #\a '(meta))]
[(unix) `(test:keystroke #\a '(meta))]
[(windows) `(test:keystroke #\a '(control))]
[else (error 'file-open-dialog "unknown system type: ~a" (system-type))])
(for-each test:keystroke
(string->list ,tmp-file))
(test:keystroke #\return)))
(wait-for-frame tmp-file-name)
(begin0
(send-sexp-to-mred
`(let* ([w (get-top-level-focus-window)]
[t (send (send w get-editor) get-text)])
(test:close-top-level-window w)
t))
(wait-for-frame frame-name)
(queue-sexp-to-mred
`(send (get-top-level-focus-window) close))))))))
(test-open "frame:editor open" 'frame:text%) (test-creation
(test-open "frame:searchable open" 'frame:searchable%) 'basic%-creation
(test-open "frame:text-info open" 'frame:text-info-file%)) 'frame:basic%
'(label "test"))
(test-creation
'basic-mixin-creation
'(frame:basic-mixin frame%)
'(label "test"))
(test-creation
'info-mixin-creation
'(frame:info-mixin frame:basic%)
'(label "test"))
(test-creation
'info%-creation
'frame:info%
'(label "test"))
(test-creation
'text-info-mixin-creation
'(frame:text-info-mixin frame:info%)
'(label "test"))
(test-creation
'text-info%-creation
'frame:text-info%
'(label "test"))
(test-creation
'pasteboard-info-mixin-creation
'(frame:pasteboard-info-mixin frame:info%)
'(label "test"))
(test-creation
'pasteboard-info%-creation
'frame:pasteboard-info%
'(label "test"))
(test-creation
'standard-menus%-creation
'frame:standard-menus%
'(label "test"))
(test-creation
'standard-menus-mixin
'(frame:standard-menus-mixin frame:basic%)
'(label "test"))
(test-creation
'text%-creation
'frame:text%)
(test-creation
'text-mixin-creation
'(frame:text-mixin frame:editor%))
(test-creation
'text-mixin-creation
'(frame:text-mixin frame:editor%))
(test-creation
'searchable%-creation
'frame:searchable%)
(test-creation
'searchable-mixin
'(frame:searchable-mixin frame:text%))
(test-creation
'text-info-file%-creation
'frame:text-info-file%)
(test-creation
'text-info-file-mixin-creation
'(frame:file-mixin frame:text%))
(test-creation
'pasteboard-mixin-creation
'(frame:pasteboard-mixin frame:editor%))
(test-creation
'pasteboard-mixin-creation
'(frame:pasteboard-mixin (frame:editor-mixin frame:standard-menus%)))
(test-creation
'pasteboard%-creation
'frame:pasteboard%)
(test-creation
'pasteboard-info-file-mixin-creation
'(frame:file-mixin frame:pasteboard%))
(test-creation
'pasteboard-info-file%-creation
'frame:pasteboard-info-file%)
(define (test-open name class-expression)
(let* ([test-file-contents "test"]
[tmp-file-name "framework-tmp"]
[tmp-file (build-path (collection-path "tests" "framework")
tmp-file-name)])
(test
name
(lambda (x)
(when (file-exists? tmp-file)
(delete-file tmp-file))
(equal? x test-file-contents))
(lambda ()
(let ([frame-name
(send-sexp-to-mred
`(let ([frame (instantiate ,class-expression ())])
(preferences:set 'framework:file-dialogs 'common)
(send frame show #t)
(send frame get-label)))])
(wait-for-frame frame-name)
(send-sexp-to-mred
`(test:menu-select "File" "Open..."))
(wait-for-frame "Get file")
(call-with-output-file tmp-file
(lambda (port)
(display test-file-contents port))
'truncate)
(send-sexp-to-mred
`(begin (send (find-labelled-window "Full pathname") focus)
,(case (system-type)
[(macos macosx) `(test:keystroke #\a '(meta))]
[(unix) `(test:keystroke #\a '(meta))]
[(windows) `(test:keystroke #\a '(control))]
[else (error 'file-open-dialog "unknown system type: ~a" (system-type))])
(for-each test:keystroke
(string->list ,tmp-file))
(test:keystroke #\return)))
(wait-for-frame tmp-file-name)
(begin0
(send-sexp-to-mred
`(let* ([w (get-top-level-focus-window)]
[t (send (send w get-editor) get-text)])
(test:close-top-level-window w)
t))
(wait-for-frame frame-name)
(queue-sexp-to-mred
`(send (get-top-level-focus-window) close))))))))
(test-open "frame:editor open" 'frame:text%)
(test-open "frame:searchable open" 'frame:searchable%)
(test-open "frame:text-info open" 'frame:text-info-file%))

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

@ -1,160 +1,157 @@
(module group-test mzscheme (module group-test mzscheme
(require "test-suite-utils.ss") (require "test-suite-utils.ss")
(test (test
'exit-off 'exit-on
(lambda (x) (not (equal? x "test"))) (lambda (x) #t)
(lambda () (lambda ()
(send-sexp-to-mred (send-sexp-to-mred
'(begin (send (make-object frame:basic% "test") show #t) '(begin (send (make-object frame:basic% "first") show #t)
(preferences:set 'framework:verify-exit #f) (preferences:set 'framework:verify-exit #t)))
(preferences:set 'framework:exit-when-no-frames #f))) (wait-for-frame "first")
(wait-for-frame "test") (send-sexp-to-mred
(send-sexp-to-mred `(queue-callback (lambda () (send (get-top-level-focus-window) close))))
`(begin (send (get-top-level-focus-window) close) (wait-for-frame "Warning")
(let ([f (get-top-level-focus-window)]) (send-sexp-to-mred
(if f `(test:button-push "Cancel"))
(send f get-label) (wait-for-frame "first")
#f)))))) 'passed))
(test
'exit-on
(lambda (x) (not (equal? x "test")))
(lambda ()
(send-sexp-to-mred
'(begin (send (make-object frame:basic% "test") show #t)
(preferences:set 'framework:verify-exit #t)
(preferences:set 'framework:exit-when-no-frames #t)))
(wait-for-frame "test")
(send-sexp-to-mred
`(queue-callback (lambda () (send (get-top-level-focus-window) close))))
(wait-for-frame "Warning")
(send-sexp-to-mred
`(test:button-push "Cancel"))
(wait-for-frame "test")
(queue-sexp-to-mred
`(begin (preferences:set 'framework:exit-when-no-frames #f)
(send (get-top-level-focus-window) close)
(let ([f (get-top-level-focus-window)])
(if f
(send f get-label)
#f))))))
(test ;; after the first test, we should have one frame that will always
'one-frame-registered ;; be in the group.
(lambda (x) (equal? x (list "test")))
(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 (test
'two-frames-registered 'one-frame-registered
(lambda (x) (equal? x (list "test2" "test1"))) (lambda (x) (equal? x (list "test" "first")))
(lambda () (lambda ()
(send-sexp-to-mred (send-sexp-to-mred
'(send (make-object frame:basic% "test1") show #t)) `(send (make-object frame:basic% "test") show #t))
(wait-for-frame "test1") (wait-for-frame "test")
(send-sexp-to-mred (send-sexp-to-mred
'(send (make-object frame:basic% "test2") show #t)) `(begin0
(wait-for-frame "test2") (map (lambda (x) (send x get-label)) (send (group:get-the-frame-group) get-frames))
(send-sexp-to-mred (send (get-top-level-focus-window) close)))))
`(begin0
(let ([frames (send (group:get-the-frame-group) get-frames)])
(for-each (lambda (x) (send x close)) frames)
(map (lambda (x) (send x get-label)) frames))))))
(test (test
'one-frame-unregistered 'two-frames-registered
(lambda (x) (equal? x (list "test1"))) (lambda (x) (equal? x (list "test2" "test1" "first")))
(lambda () (lambda ()
(send-sexp-to-mred (send-sexp-to-mred
'(send (make-object frame:basic% "test1") show #t)) '(send (make-object frame:basic% "test1") show #t))
(wait-for-frame "test1") (wait-for-frame "test1")
(send-sexp-to-mred (send-sexp-to-mred
'(send (make-object frame:basic% "test2") show #t)) '(send (make-object frame:basic% "test2") show #t))
(wait-for-frame "test2") (wait-for-frame "test2")
(queue-sexp-to-mred (send-sexp-to-mred
`(send (get-top-level-focus-window) close)) `(begin0
(send-sexp-to-mred (let ([frames (send (group:get-the-frame-group) get-frames)])
`(let ([frames (send (group:get-the-frame-group) get-frames)]) (for-each (lambda (x)
(for-each (lambda (x) (send x close)) frames) (unless (equal? (send x get-label) "first")
(map (lambda (x) (send x get-label)) frames))))) (send x close)))
frames)
(map (lambda (x) (send x get-label)) frames))))))
(test (test
'windows-menu 'one-frame-unregistered
(lambda (x) (lambda (x) (equal? x (list "test1" "first")))
(equal? x (list "Bring Frame to Front..." "Next Window" "Previous Window" #f "test"))) (lambda ()
(lambda () (send-sexp-to-mred
(send-sexp-to-mred '(send (make-object frame:basic% "test1") show #t))
'(let ([frame (make-object frame:basic% "test")]) (wait-for-frame "test1")
(send frame show #t))) (send-sexp-to-mred
(wait-for-frame "test") '(send (make-object frame:basic% "test2") show #t))
(send-sexp-to-mred (wait-for-frame "test2")
'(begin0 (queue-sexp-to-mred
(map `(send (get-top-level-focus-window) close))
(lambda (x) (and (is-a? x labelled-menu-item<%>) (send x get-label))) (send-sexp-to-mred
(send (car (send (send (get-top-level-focus-window) get-menu-bar) get-items)) get-items)) `(let ([frames (send (group:get-the-frame-group) get-frames)])
(send (get-top-level-focus-window) close))))) (for-each (lambda (x)
(unless (equal? (send x get-label) "first")
(send x close)))
frames)
(map (lambda (x) (send x get-label)) frames)))))
(test (test
'windows-menu-unshown 'windows-menu
(lambda (x) (lambda (x)
(equal? x (list "Bring Frame to Front..." "Next Window" "Previous Window" #f "test"))) (equal? x (list "Bring Frame to Front..." "Most Recent Window" "Next Window" "Previous Window"
(lambda () #f "first" "test")))
(send-sexp-to-mred (lambda ()
'(let ([frame1 (make-object frame:basic% "test")] (send-sexp-to-mred
[frame2 (make-object frame:basic% "test-not-shown")]) '(let ([frame (make-object frame:basic% "test")])
(send frame1 show #t))) (send frame show #t)))
(wait-for-frame "test") (wait-for-frame "test")
(send-sexp-to-mred (send-sexp-to-mred
'(begin0 '(begin0
(map (map
(lambda (x) (and (is-a? x labelled-menu-item<%>) (send x get-label))) (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 (car (send (send (get-top-level-focus-window) get-menu-bar) get-items)) get-items))
(send (get-top-level-focus-window) close))))) (send (get-top-level-focus-window) close)))))
(test (test
'windows-menu-sorted1 'windows-menu-unshown
(lambda (x) (lambda (x)
(equal? x (list "Bring Frame to Front..." "Next Window" "Previous Window" #f "aaa" "bbb"))) (equal? x (list "Bring Frame to Front..." "Most Recent Window" "Next Window" "Previous Window"
(lambda () #f "first" "test")))
(send-sexp-to-mred (lambda ()
'(let ([frame (make-object frame:basic% "aaa")]) (send-sexp-to-mred
(send frame show #t))) '(let ([frame1 (make-object frame:basic% "test")]
(wait-for-frame "aaa") [frame2 (make-object frame:basic% "test-not-shown")])
(send-sexp-to-mred (send frame1 show #t)))
'(let ([frame (make-object frame:basic% "bbb")]) (wait-for-frame "test")
(send frame show #t))) (send-sexp-to-mred
(wait-for-frame "bbb") '(begin0
(send-sexp-to-mred (map
`(let ([frames (send (group:get-the-frame-group) get-frames)]) (lambda (x) (and (is-a? x labelled-menu-item<%>) (send x get-label)))
(begin0 (send (car (send (send (get-top-level-focus-window) get-menu-bar) get-items)) get-items))
(map (send (get-top-level-focus-window) close)))))
(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) (send x close)) frames))))))
(test (test
'windows-menu-sorted2 'windows-menu-sorted1
(lambda (x) (lambda (x)
(equal? x (list "Bring Frame to Front..." "Next Window" "Previous Window" #f "aaa" "bbb"))) (equal? x (list "Bring Frame to Front..." "Most Recent Window" "Next Window" "Previous Window"
(lambda () #f "aaa" "bbb" "first")))
(send-sexp-to-mred (lambda ()
'(let ([frame (make-object frame:basic% "bbb")]) (send-sexp-to-mred
(send frame show #t))) '(let ([frame (make-object frame:basic% "aaa")])
(wait-for-frame "bbb") (send frame show #t)))
(send-sexp-to-mred (wait-for-frame "aaa")
'(let ([frame (make-object frame:basic% "aaa")]) (send-sexp-to-mred
(send frame show #t))) '(let ([frame (make-object frame:basic% "bbb")])
(wait-for-frame "aaa") (send frame show #t)))
(send-sexp-to-mred (wait-for-frame "bbb")
`(let ([frames (send (group:get-the-frame-group) get-frames)]) (send-sexp-to-mred
(begin0 `(let ([frames (send (group:get-the-frame-group) get-frames)])
(map (begin0
(lambda (x) (and (is-a? x labelled-menu-item<%>) (send x get-label))) (map
(send (car (send (send (car frames) get-menu-bar) get-items)) get-items)) (lambda (x) (and (is-a? x labelled-menu-item<%>) (send x get-label)))
(for-each (lambda (x) (send x close)) frames))))))) (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 (list "Bring Frame to Front..." "Most Recent Window" "Next Window" "Previous Window"
#f "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)))))))

125
collects/tests/framework/text.ss
View File

@ -1,68 +1,69 @@
(module text mzscheme (module text mzscheme
(require "test-suite-utils.ss") (require "test-suite-utils.ss")
(define (test-creation frame% class name) (define dummy-frame-title "dummy to avoid quitting")
(test (send-sexp-to-mred `(send (make-object frame:basic% ,dummy-frame-title) show #t))
name
(lambda (x) (eq? x 'passed)) (define (test-creation frame% class name)
(lambda () (test
(let ([label name
(send-sexp-to-mred (lambda (x)
`(let ([f (instantiate (class ,frame% (equal? x (list dummy-frame-title))) ;; ensure no frames left
(override get-editor%) (lambda ()
[define (get-editor%) ,class] (let ([label
(super-instantiate ())) (send-sexp-to-mred
())]) `(let ([f (instantiate (class ,frame%
(preferences:set 'framework:exit-when-no-frames #f) (override get-editor%)
(send f show #t) [define (get-editor%) ,class]
(send f get-label)))]) (super-instantiate ()))
(wait-for-frame label) ())])
(send-sexp-to-mred `(test:keystroke #\a)) (send f show #t)
(wait-for `(string=? "a" (send (send (get-top-level-focus-window) get-editor) get-text))) (send f get-label)))])
(send-sexp-to-mred (wait-for-frame label)
`(begin (send (send (get-top-level-focus-window) get-editor) lock #t) (send-sexp-to-mred `(test:keystroke #\a))
(send (send (get-top-level-focus-window) get-editor) lock #f))) (wait-for `(string=? "a" (send (send (get-top-level-focus-window) get-editor) get-text)))
(queue-sexp-to-mred (send-sexp-to-mred
`(send (get-top-level-focus-window) close)) `(begin (send (send (get-top-level-focus-window) get-editor) lock #t)
'passed)))) (send (send (get-top-level-focus-window) get-editor) lock #f)))
(queue-sexp-to-mred
`(send (get-top-level-focus-window) close))
(send-sexp-to-mred `(map (lambda (x) (send x get-label)) (get-top-level-windows)))))))
(test-creation 'frame:text% (test-creation 'frame:text%
'(text:basic-mixin (editor:basic-mixin text%)) '(text:basic-mixin (editor:basic-mixin text%))
'text:basic-mixin-creation) 'text:basic-mixin-creation)
(test-creation 'frame:text% (test-creation 'frame:text%
'text:basic% 'text:basic%
'text:basic-creation) 'text:basic-creation)
(test-creation 'frame:text% (test-creation 'frame:text%
'(editor:file-mixin text:keymap%) '(editor:file-mixin text:keymap%)
'editor:file-mixin-creation) 'editor:file-mixin-creation)
(test-creation 'frame:text% (test-creation 'frame:text%
'text:file% 'text:file%
'text:file-creation) 'text:file-creation)
(test-creation 'frame:text% (test-creation 'frame:text%
'(text:clever-file-format-mixin text:file%) '(text:clever-file-format-mixin text:file%)
'text:clever-file-format-mixin-creation) 'text:clever-file-format-mixin-creation)
(test-creation 'frame:text% (test-creation 'frame:text%
'text:clever-file-format% 'text:clever-file-format%
'text:clever-file-format-creation) 'text:clever-file-format-creation)
(test-creation 'frame:text% (test-creation 'frame:text%
'(editor:backup-autosave-mixin text:clever-file-format%) '(editor:backup-autosave-mixin text:clever-file-format%)
'editor:backup-autosave-mixin-creation) 'editor:backup-autosave-mixin-creation)
(test-creation 'frame:text% (test-creation 'frame:text%
'text:backup-autosave% 'text:backup-autosave%
'text:backup-autosave-creation) 'text:backup-autosave-creation)
(test-creation 'frame:text% (test-creation 'frame:text%
'(text:searching-mixin text:backup-autosave%) '(text:searching-mixin text:backup-autosave%)
'text:searching-mixin-creation) 'text:searching-mixin-creation)
(test-creation 'frame:text% (test-creation 'frame:text%
'text:searching% 'text:searching%
'text:searching-creation) 'text:searching-creation)
(test-creation '(frame:searchable-mixin frame:text%) (test-creation '(frame:searchable-mixin frame:text%)
'(text:info-mixin (editor:info-mixin text:searching%)) '(text:info-mixin (editor:info-mixin text:searching%))
'text:info-mixin-creation) 'text:info-mixin-creation)
(test-creation '(frame:searchable-mixin frame:text%) (test-creation '(frame:searchable-mixin frame:text%)
'text:info% 'text:info%
'text:info-creation) 'text:info-creation))
)