From 38c68a12be81d9636ba4e67b95967411026c1aa3 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Wed, 18 Sep 2002 04:01:31 +0000 Subject: [PATCH] .. original commit: 0f8b33f8637bca5bd047a33a4364c3c9db46c9bf --- collects/tests/framework/README | 44 ++-- collects/tests/framework/exit.ss | 55 ----- collects/tests/framework/frame.ss | 310 ++++++++++++------------ collects/tests/framework/group-test.ss | 311 ++++++++++++------------- collects/tests/framework/text.ss | 133 +++++------ 5 files changed, 392 insertions(+), 461 deletions(-) diff --git a/collects/tests/framework/README b/collects/tests/framework/README index ba3713b9..fb69543f 100644 --- a/collects/tests/framework/README +++ b/collects/tests/framework/README @@ -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 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 as necessary for the test suites. Since some tests actually require @@ -15,9 +15,19 @@ To run a test use: framework-test ... -where or is the name of one of the tests -below. Alternatively, pass no command-line arguments to run the same -test as last time, or `all' to run all of the tests. +where or is the name of one of the tests below. +Alternatively, pass no command-line arguments to run all of +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 #| @@ -35,10 +45,6 @@ test as last time, or `all' to run all of the tests. | immediately and across reboots of mred. -- specs |# spec-test.ss #| - - | this tests that the specs are compiled properly. - - individual object tests: | 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 #| - 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 #| - | This tests all of the misc (non-scheme) keybindings + | This tests the misc (non-scheme) keybindings - searching: |# search.ss #| @@ -96,16 +92,6 @@ test as last time, or `all' to run all of the tests. - closing: |# close.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 | these tests require intervention by people. Clicking and whatnot diff --git a/collects/tests/framework/exit.ss b/collects/tests/framework/exit.ss index 3a77229f..4154fdf8 100644 --- a/collects/tests/framework/exit.ss +++ b/collects/tests/framework/exit.ss @@ -7,61 +7,9 @@ (not (mred-running?)))) (lambda () (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))) '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")) ;; need to test "on" callbacks (test 'exit-callback-called @@ -74,7 +22,6 @@ (with-handlers ([eof-result? (lambda (x) 'passed)]) (send-sexp-to-mred `(begin - (preferences:set 'framework:verify-exit #f) (exit:insert-can?-callback (lambda () (call-with-output-file ,tmp-file void) #t)) (begin (exit:exit) (sleep/yield 1))))))) @@ -84,7 +31,6 @@ (with-handlers ([eof-result? (lambda (x) 'passed)]) (send-sexp-to-mred `(begin - (preferences:set 'framework:verify-exit #f) ((exit:insert-can?-callback (lambda () (error 'called-exit-callback)))) (begin (exit:exit) (sleep/yield 1))))))) @@ -94,7 +40,6 @@ (begin0 (send-sexp-to-mred `(begin - (preferences:set 'framework:verify-exit #f) (let ([rm-callback (exit:insert-can?-callback (lambda () #f))]) (exit:exit) (rm-callback) diff --git a/collects/tests/framework/frame.ss b/collects/tests/framework/frame.ss index 11c17ac1..eff7a67a 100644 --- a/collects/tests/framework/frame.ss +++ b/collects/tests/framework/frame.ss @@ -1,159 +1,161 @@ (module frame mzscheme (require "test-suite-utils.ss") - -(define (test-creation name class-expression . args) - (test - name - (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 - '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)]) + + (send-sexp-to-mred '(send (make-object frame:basic% + "dummy to keep from quitting") + show #t)) + + (define (test-creation name class-expression . args) (test name - (lambda (x) - (when (file-exists? tmp-file) - (delete-file tmp-file)) - (equal? x test-file-contents)) + (lambda (x) (eq? 'passed x)) (lambda () - (let ([frame-name - (send-sexp-to-mred - `(let ([frame (instantiate ,class-expression ())]) - (preferences:set 'framework:exit-when-no-frames #f) - (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%)) + (let ([frame-label + (send-sexp-to-mred + `(let ([f (instantiate ,class-expression () ,@args)]) + (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 + '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 + 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%)) diff --git a/collects/tests/framework/group-test.ss b/collects/tests/framework/group-test.ss index 50d7527e..4a6ffda1 100644 --- a/collects/tests/framework/group-test.ss +++ b/collects/tests/framework/group-test.ss @@ -1,160 +1,157 @@ (module group-test mzscheme (require "test-suite-utils.ss") - -(test - 'exit-off - (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 #f) - (preferences:set 'framework:exit-when-no-frames #f))) - (wait-for-frame "test") - (send-sexp-to-mred - `(begin (send (get-top-level-focus-window) close) - (let ([f (get-top-level-focus-window)]) - (if f - (send f get-label) - #f)))))) -(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 - 'one-frame-registered - (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 - 'two-frames-registered - (lambda (x) (equal? x (list "test2" "test1"))) - (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) (send x close)) frames) - (map (lambda (x) (send x get-label)) frames)))))) - -(test - 'one-frame-unregistered - (lambda (x) (equal? x (list "test1"))) - (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) (send x close)) frames) - (map (lambda (x) (send x get-label)) frames))))) - -(test - 'windows-menu - (lambda (x) - (equal? x (list "Bring Frame to Front..." "Next Window" "Previous Window" #f "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 (list "Bring Frame to Front..." "Next Window" "Previous Window" #f "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 (list "Bring Frame to Front..." "Next Window" "Previous Window" #f "aaa" "bbb"))) - (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) (send x close)) frames)))))) - -(test - 'windows-menu-sorted2 - (lambda (x) - (equal? x (list "Bring Frame to Front..." "Next Window" "Previous Window" #f "aaa" "bbb"))) - (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) (send x close)) frames))))))) + (test + 'exit-on + (lambda (x) #t) + (lambda () + (send-sexp-to-mred + '(begin (send (make-object frame:basic% "first") show #t) + (preferences:set 'framework:verify-exit #t))) + (wait-for-frame "first") + (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 "first") + 'passed)) + + ;; 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))))) + + (test + 'windows-menu + (lambda (x) + (equal? x (list "Bring Frame to Front..." "Most Recent Window" "Next Window" "Previous Window" + #f "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 (list "Bring Frame to Front..." "Most Recent Window" "Next Window" "Previous Window" + #f "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 (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% "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 (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))))))) diff --git a/collects/tests/framework/text.ss b/collects/tests/framework/text.ss index 68f8582b..f656c4d1 100644 --- a/collects/tests/framework/text.ss +++ b/collects/tests/framework/text.ss @@ -1,68 +1,69 @@ (module text mzscheme (require "test-suite-utils.ss") - -(define (test-creation frame% class name) - (test - name - (lambda (x) (eq? x 'passed)) - (lambda () - (let ([label - (send-sexp-to-mred - `(let ([f (instantiate (class ,frame% - (override get-editor%) - [define (get-editor%) ,class] - (super-instantiate ())) - ())]) - (preferences:set 'framework:exit-when-no-frames #f) - (send f show #t) - (send f get-label)))]) - (wait-for-frame label) - (send-sexp-to-mred `(test:keystroke #\a)) - (wait-for `(string=? "a" (send (send (get-top-level-focus-window) get-editor) get-text))) - (send-sexp-to-mred - `(begin (send (send (get-top-level-focus-window) get-editor) lock #t) - (send (send (get-top-level-focus-window) get-editor) lock #f))) - (queue-sexp-to-mred - `(send (get-top-level-focus-window) close)) - 'passed)))) - - -(test-creation 'frame:text% - '(text:basic-mixin (editor:basic-mixin text%)) - 'text:basic-mixin-creation) -(test-creation 'frame:text% - 'text:basic% - 'text:basic-creation) - -(test-creation 'frame:text% - '(editor:file-mixin text:keymap%) - 'editor:file-mixin-creation) -(test-creation 'frame:text% - 'text:file% - 'text:file-creation) -(test-creation 'frame:text% - '(text:clever-file-format-mixin text:file%) - 'text:clever-file-format-mixin-creation) -(test-creation 'frame:text% - 'text:clever-file-format% - 'text:clever-file-format-creation) -(test-creation 'frame:text% - '(editor:backup-autosave-mixin text:clever-file-format%) - 'editor:backup-autosave-mixin-creation) -(test-creation 'frame:text% - 'text:backup-autosave% - 'text:backup-autosave-creation) -(test-creation 'frame:text% - '(text:searching-mixin text:backup-autosave%) - 'text:searching-mixin-creation) -(test-creation 'frame:text% - 'text:searching% - 'text:searching-creation) -(test-creation '(frame:searchable-mixin frame:text%) - '(text:info-mixin (editor:info-mixin text:searching%)) - 'text:info-mixin-creation) -(test-creation '(frame:searchable-mixin frame:text%) - 'text:info% - 'text:info-creation) - -) + + (define dummy-frame-title "dummy to avoid quitting") + (send-sexp-to-mred `(send (make-object frame:basic% ,dummy-frame-title) show #t)) + + (define (test-creation frame% class name) + (test + name + (lambda (x) + (equal? x (list dummy-frame-title))) ;; ensure no frames left + (lambda () + (let ([label + (send-sexp-to-mred + `(let ([f (instantiate (class ,frame% + (override get-editor%) + [define (get-editor%) ,class] + (super-instantiate ())) + ())]) + (send f show #t) + (send f get-label)))]) + (wait-for-frame label) + (send-sexp-to-mred `(test:keystroke #\a)) + (wait-for `(string=? "a" (send (send (get-top-level-focus-window) get-editor) get-text))) + (send-sexp-to-mred + `(begin (send (send (get-top-level-focus-window) get-editor) lock #t) + (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% + '(text:basic-mixin (editor:basic-mixin text%)) + 'text:basic-mixin-creation) + (test-creation 'frame:text% + 'text:basic% + 'text:basic-creation) + + (test-creation 'frame:text% + '(editor:file-mixin text:keymap%) + 'editor:file-mixin-creation) + (test-creation 'frame:text% + 'text:file% + 'text:file-creation) + (test-creation 'frame:text% + '(text:clever-file-format-mixin text:file%) + 'text:clever-file-format-mixin-creation) + (test-creation 'frame:text% + 'text:clever-file-format% + 'text:clever-file-format-creation) + (test-creation 'frame:text% + '(editor:backup-autosave-mixin text:clever-file-format%) + 'editor:backup-autosave-mixin-creation) + (test-creation 'frame:text% + 'text:backup-autosave% + 'text:backup-autosave-creation) + (test-creation 'frame:text% + '(text:searching-mixin text:backup-autosave%) + 'text:searching-mixin-creation) + (test-creation 'frame:text% + 'text:searching% + 'text:searching-creation) + (test-creation '(frame:searchable-mixin frame:text%) + '(text:info-mixin (editor:info-mixin text:searching%)) + 'text:info-mixin-creation) + (test-creation '(frame:searchable-mixin frame:text%) + 'text:info% + 'text:info-creation))