From 996c08e41c6c34b1fcd62fe930a2b0f4570120d7 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Fri, 4 Dec 1998 15:59:47 +0000 Subject: [PATCH] ... original commit: a6f1127374e372b5695cfb7ac26090647877825e --- collects/framework/frame.ss | 23 ++++++++------ collects/framework/frameworks.ss | 4 +-- collects/framework/icon.ss | 13 +++----- collects/tests/framework/main.ss | 21 +++++++----- collects/tests/framework/pasteboard.ss | 44 ++++++++++++++++++++++++++ collects/tests/framework/text.ss | 3 ++ 6 files changed, 80 insertions(+), 28 deletions(-) create mode 100644 collects/tests/framework/pasteboard.ss diff --git a/collects/framework/frame.ss b/collects/framework/frame.ss index 36117c97..b5716824 100644 --- a/collects/framework/frame.ss +++ b/collects/framework/frame.ss @@ -787,8 +787,8 @@ (send offb ok?)) (register-collecting-blit gc-canvas 0 0 - (icon:get-gc-width) - (icon:get-gc-height) + (send onb get-width) + (send onb get-height) onb offb))))]) (sequence @@ -798,13 +798,18 @@ (list rest-panel)))) (register-gc-blit) - (let ([gc-width (icon:get-gc-width)] - [gc-height (icon:get-gc-height)]) - (send* gc-canvas - (min-client-width gc-width) - (min-client-height gc-height) - (stretchable-width #f) - (stretchable-height #f))) + (let* ([gcb (icon:get-gc-on-bitmap)] + [gc-width (if (send gcb ok?) + (send gcb get-width) + 10)] + [gc-height (if (send gcb ok?) + (send gcb get-height) + 10)]) + '(send* gc-canvas + (min-client-width gc-width) + (min-client-height gc-height) + (stretchable-width #f) + (stretchable-height #f))) (send* (get-info-panel) (set-alignment 'right 'center) (stretchable-height #f) diff --git a/collects/framework/frameworks.ss b/collects/framework/frameworks.ss index 92e8f1a2..280bf8a6 100644 --- a/collects/framework/frameworks.ss +++ b/collects/framework/frameworks.ss @@ -202,9 +202,7 @@ get-anchor-bdc get-gc-on-bitmap - get-gc-off-bitmap - get-gc-width - get-gc-height)) + get-gc-off-bitmap)) (define-signature framework:keymap^ (set-keymap-error-handler diff --git a/collects/framework/icon.ss b/collects/framework/icon.ss index 4385f066..e9b439cb 100644 --- a/collects/framework/icon.ss +++ b/collects/framework/icon.ss @@ -66,12 +66,6 @@ (set! gc-on-bitmap ((load-icon "recycle.gif" 'gif))))) (define (get-gc-on-bitmap) (fetch) gc-on-bitmap) - (define (get-gc-width) (fetch) (if (send gc-on-bitmap ok?) - (send gc-on-bitmap get-width) - 10)) - (define (get-gc-height) (fetch) (if (send gc-on-bitmap ok?) - (send gc-on-bitmap get-height) - 10)) (define get-gc-off-bitmap (let ([bitmap #f]) @@ -79,8 +73,11 @@ (if bitmap bitmap (begin - (let ([bdc (make-object bitmap-dc%)]) - (set! bitmap (make-object bitmap% (get-gc-width) (get-gc-height))) + (let ([bdc (make-object bitmap-dc%)] + [onb (get-gc-on-bitmap)]) + (set! bitmap (make-object bitmap% + (send onb get-width) + (send onb get-height))) (send bdc set-bitmap bitmap) (send bdc clear) (send bdc set-bitmap #f) diff --git a/collects/tests/framework/main.ss b/collects/tests/framework/main.ss index fe8b2bfe..f66c6404 100644 --- a/collects/tests/framework/main.ss +++ b/collects/tests/framework/main.ss @@ -12,7 +12,9 @@ ((struct eof-result ()) load-framework-automatically shutdown-listener shutdown-mred mred-running? send-sexp-to-mred - test wait-for-frame)) + test + wait-for-frame + wait-for)) (define-signature internal-TestSuite^ ((open TestSuite^) @@ -178,18 +180,21 @@ [(continue) (void)] [else (jump)])))))])) - (define (wait-for-frame name) + (define (wait-for sexp) (let ([timeout 10] [pause-time 1/2]) (send-sexp-to-mred `(let loop ([n ,(/ timeout pause-time)]) (if (zero? n) - (error 'wait-for-mred-frame - ,(format "after ~a seconds, frame labelled ~s didn't appear" timeout name)) - (let ([win (get-top-level-focus-window)]) - (unless (and win (string=? (send win get-label) ,name)) - (sleep ,pause-time) - (loop (- n 1))))))))))) + (error 'wait-for + ,(format "after ~a seconds, ~s didn't come true" timeout sexp)) + (unless ,sexp + (sleep ,pause-time) + (loop (- n 1)))))))) + + (define (wait-for-frame name) + (wait-for `(let ([win (get-top-level-focus-window)]) + (and win (string=? (send win get-label) ,name))))))) (define Engine (unit/sig Engine^ diff --git a/collects/tests/framework/pasteboard.ss b/collects/tests/framework/pasteboard.ss new file mode 100644 index 00000000..6ba05f03 --- /dev/null +++ b/collects/tests/framework/pasteboard.ss @@ -0,0 +1,44 @@ +(define (test-creation frame class name) + (test + name + (lambda (x) #t) + (lambda () + (send-sexp-to-mred + `(let* ([% (class-asi ,frame + (override + [get-editor% + (lambda () + ,class)]))] + [f (make-object % "test pasteboard")]) + (send f show #t))) + (wait-for-frame "test pasteboard") + (send-sexp-to-mred + `(send (get-top-level-focus-window) show #f))))) + +(test-creation 'frame:editor% + '(editor:basic-mixin pasteboard%) + 'editor:basic-mixin-creation) +(test-creation 'frame:editor% + 'pasteboard:basic% + 'pasteboard:basic-creation) + +(test-creation 'frame:editor% + '(editor:file-mixin pasteboard:basic%) + 'editor:file-mixin-creation) +(test-creation 'frame:editor% + 'pasteboard:file% + 'pasteboard:file-creation) + +(test-creation 'frame:editor% + '(editor:backup-autosave-mixin pasteboard:file%) + 'editor:backup-autosave-mixin-creation) +(test-creation 'frame:editor% + 'pasteboard:backup-autosave% + 'pasteboard:backup-autosave-creation) + +(test-creation 'frame:pasteboard-info% + '(editor:info-mixin pasteboard:backup-autosave%) + 'editor:info-mixin-creation) +(test-creation 'frame:pasteboard-info% + 'pasteboard:info% + 'pasteboard:info-creation) diff --git a/collects/tests/framework/text.ss b/collects/tests/framework/text.ss index 82b1a011..b4bd96d4 100644 --- a/collects/tests/framework/text.ss +++ b/collects/tests/framework/text.ss @@ -10,6 +10,9 @@ [f (make-object % "test text")]) (send f show #t))) (wait-for-frame "test text") + (send-sexp-to-mred + `(test:keypress #\a)) + (wait-for `(string=? "a" (send (send (get-top-level-focus-window) get-editor) get-text))) (send-sexp-to-mred `(send (get-top-level-focus-window) show #f)))))