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) (send-sexp-to-mred '(begin (preferences:set 'framework:verify-exit #t)
(test:run-one (lambda () (exit:exit))))) (test:run-one (lambda () (exit:exit)))))
(wait-for-frame "Warning") (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))) 'failed)))
(test 'exit/prompt/no-twice (test 'exit/prompt/no-twice
@ -32,7 +35,9 @@
(exit/push-button "Cancel") (exit/push-button "Cancel")
(exit/push-button "Cancel") (exit/push-button "Cancel")
(with-handlers ([eof-result? (lambda (x) 'passed)]) (with-handlers ([eof-result? (lambda (x) 'passed)])
(exit/push-button "Quit") (exit/push-button (case (system-type)
[(windows) "Exit"]
[else "Quit"]))
'failed)))) 'failed))))
(test 'exit/esc-cancel (test 'exit/esc-cancel
@ -48,7 +53,10 @@
(wait-for-new-frame `(test:close-top-level-window (get-top-level-focus-window))) (wait-for-new-frame `(test:close-top-level-window (get-top-level-focus-window)))
(exit/wait-for-warning) (exit/wait-for-warning)
(with-handlers ([eof-result? (lambda (x) 'passed)]) (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)))) '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"))

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

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

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

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

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

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