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

...

Browse Source 
original commit: ef63af74dbac8a38dc51d9518b5b2b5536a29735
This commit is contained in:
Robby Findler 2000-06-26 02:33:21 +00:00
parent 01b7aaac01
commit f055d3d3ad
4 changed files with 45 additions and 31 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -16,7 +16,10 @@
(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 "Quit"))
(wait-for-new-frame `(test:button-push
,(case (system-type)
[(windows) "Exit"]
[else "Quit"])))
'failed)))
(test 'exit/prompt/no-twice
@ -32,7 +35,9 @@
(exit/push-button "Cancel")
(exit/push-button "Cancel")
(with-handlers ([eof-result? (lambda (x) 'passed)])
(exit/push-button "Quit")
(exit/push-button (case (system-type)
[(windows) "Exit"]
[else "Quit"]))
'failed))))
(test 'exit/esc-cancel
@ -48,7 +53,10 @@
(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 "Quit"))
(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"))

8
collects/tests/framework/main.ss
View File

@ -126,7 +126,11 @@
(semaphore-post sema)))
(semaphore-wait sema)))))
(define re:tcp-error (regexp "tcp-read:"))
(define re:tcp-read-error (regexp "tcp-read:"))
(define re:tcp-write-error (regexp "tcp-write:"))
(define (tcp-error? exn)
(or (regexp-match re:tcp-read-error (exn-message exn))
(regexp-match re:tcp-write-error (exn-message exn))))
(define send-sexp-to-mred
(lambda (sexp)
@ -156,7 +160,7 @@
(let ([answer
(with-handlers ([(lambda (x) #t)
(lambda (x)
(if (regexp-match re:tcp-error (exn-message x))
(if (tcp-error? x);; assume tcp-error means app closed
eof
(list 'cant-read
(string-append

50
collects/tests/framework/mem.ss
View File

@ -35,13 +35,11 @@
(foldl (lambda (b n) (if (weak-box-value b) (+ n 1) n))
0
boxes))])
(when (> (calc-results) 0)
(collect-garbage)
(collect-garbage)
(collect-garbage)
(collect-garbage)
(collect-garbage)
(collect-garbage))
(let loop ([tries 4])
(unless (zero? tries)
(when (> (calc-results) 0)
(collect-garbage)
(loop (- tries 1)))))
(let ([res (calc-results)])
(when (> res 0)
(set! anything? #t)
@ -52,14 +50,15 @@
[else (make-object button% "NOTHING!" f (lambda x (send f show #f)))])
(send f show #t)))))
(define (test-frame-allocate name %)
(send-sexp-to-mred '(preferences:set 'framework:exit-when-no-frames #f))
(test-allocate name
`(lambda () (let ([f (make-object ,% ,name)])
(send f show #t)
f))
`(lambda (f) (send f close)))
(send-sexp-to-mred '(preferences:set 'framework:exit-when-no-frames #t)))
(define (test-frame-allocate %)
(let ([name (symbol->string %)])
(send-sexp-to-mred '(preferences:set 'framework:exit-when-no-frames #f))
(test-allocate name
`(lambda () (let ([f (make-object ,% ,name)])
(send f show #t)
f))
`(lambda (f) (send f close)))
(send-sexp-to-mred '(preferences:set 'framework:exit-when-no-frames #t))))
(test-allocate "frame%"
'(lambda () (let ([f (make-object frame% "test frame")])
@ -95,14 +94,17 @@
'(lambda (t) (void)))
(test-frame-allocate "frame:basic%" 'frame:basic%)
(test-frame-allocate "frame:standard-menus%" 'frame:standard-menus%)
(test-frame-allocate "frame:text%" 'frame:text%)
(test-frame-allocate "frame:searchable%" 'frame:searchable%)
(test-frame-allocate "frame:text-info%" 'frame:text-info%)
(test-frame-allocate "frame:text-info-file%" 'frame:text-info-file%)
(test-frame-allocate "frame:pasteboard%" 'frame:pasteboard%)
(test-frame-allocate "frame:pasteboard-info%" 'frame:pasteboard-info%)
(test-frame-allocate "frame:pasteboard-info-file%" 'frame:pasteboard-info-file%)
(test-frame-allocate 'frame:basic%)
(test-frame-allocate 'frame:info%)
(test-frame-allocate 'frame:text-info%)
(test-frame-allocate 'frame:pasteboard-info%)
(test-frame-allocate 'frame:standard-menus%)
(test-frame-allocate 'frame:text%)
(test-frame-allocate 'frame:text-info-file%)
(test-frame-allocate 'frame:searchable%)
(test-frame-allocate 'frame:pasteboard%)
(test-frame-allocate 'frame:pasteboard-info-file%)
(done)

4
collects/tests/framework/pasteboard.ss
View File

@ -37,9 +37,9 @@
'pasteboard:backup-autosave%
'pasteboard:backup-autosave-creation)
(test-creation 'frame:pasteboard-info%
(test-creation 'frame:pasteboard%
'(editor:info-mixin pasteboard:backup-autosave%)
'editor:info-mixin-creation)
(test-creation 'frame:pasteboard-info%
(test-creation 'frame:pasteboard%
'pasteboard:info%
'pasteboard:info-creation)