..
original commit: 0f8b33f8637bca5bd047a33a4364c3c9db46c9bf
This commit is contained in:
Robby Findler
parent
c94d5267b2
commit
38c68a12be
|
|
@ -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 <test.ss> ...
|
||||
|
||||
where or <test.ss> 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 <test.ss> 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
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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%))
|
||||
|
|
|
|||
|
|
@ -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)))))))
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user