From a67f509f90359203463c943e4de90eb5e8a91656 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Sun, 4 Sep 2011 23:59:42 -0500 Subject: [PATCH] add frame:focus-table-mixin & related things to be able to make drracket test suites that don't depend on the OS giving any focus messages --- collects/drracket/private/debug.rkt | 12 ++- collects/drracket/private/frame.rkt | 9 +- collects/drracket/private/init.rkt | 5 +- .../private/language-configuration.rkt | 13 ++- collects/drracket/private/language.rkt | 15 ++- collects/drracket/private/rep.rkt | 8 +- collects/drracket/private/syncheck/gui.rkt | 3 +- collects/drracket/private/unit.rkt | 29 ++++-- collects/framework/main.rkt | 26 ++++- collects/framework/private/finder.rkt | 12 ++- collects/framework/private/frame.rkt | 34 +++++-- collects/framework/private/sig.rkt | 2 + collects/framework/test.rkt | 98 ++++++++++++------- collects/scribblings/framework/frame.scrbl | 29 ++++++ .../scribblings/framework/main-extracts.rkt | 2 +- .../drracket/no-write-and-frame-leak.rkt | 10 +- .../drracket/private/drracket-test-util.rkt | 31 +++--- collects/tests/drracket/repl-test.rkt | 9 +- collects/tests/drracket/stepper-test.rkt | 2 +- .../drracket/teaching-lang-save-file.rkt | 4 +- 20 files changed, 243 insertions(+), 110 deletions(-) diff --git a/collects/drracket/private/debug.rkt b/collects/drracket/private/debug.rkt index 40cc97f4a9..4e8728c243 100644 --- a/collects/drracket/private/debug.rkt +++ b/collects/drracket/private/debug.rkt @@ -900,7 +900,8 @@ profile todo: (message-box (string-constant drscheme) (string-constant editor-changed-since-srcloc-recorded) frame - '(ok caution)))) + '(ok caution) + #:dialog-mixin frame:focus-table-mixin))) (when (and rep editor) (when (is-a? editor text:basic<%>) (send rep highlight-errors same-src-srclocs '()) @@ -1007,7 +1008,8 @@ profile todo: (string-constant test-coverage-clear-and-do-not-ask-again) (send (get-canvas) get-top-level-window) '(default=1) - 2)]) + 2 + #:dialog-mixin frame:focus-table-mixin)]) (case msg-box-result [(1) #t] [(2) #f] @@ -1419,7 +1421,8 @@ profile todo: (eq? (message-box (string-constant drscheme) (string-constant profiling-clear?) frame - '(yes-no)) + '(yes-no) + #:dialog-mixin frame:focus-table-mixin) 'yes)))))) (define/private (do-reset-profile) @@ -1561,7 +1564,8 @@ profile todo: (send (get-current-tab) refresh-profile)] [else (message-box (string-constant drscheme) - (string-constant profiling-no-information-available))])) + (string-constant profiling-no-information-available) + #:dialog-mixin frame:focus-table-mixin)])) (define/public (hide-profile-gui) (when profile-gui-constructed? diff --git a/collects/drracket/private/frame.rkt b/collects/drracket/private/frame.rkt index a13e60daa7..590e225b4d 100644 --- a/collects/drracket/private/frame.rkt +++ b/collects/drracket/private/frame.rkt @@ -295,7 +295,8 @@ [else (message-box (string-constant drscheme) (format (string-constant keybindings-planet-malformed-spec) - planet-spec))])))))) + planet-spec) + #:dialog-mixin frame:focus-table-mixin)])))))) (let ([ud (preferences:get 'drracket:user-defined-keybindings)]) (unless (null? ud) (new separator-menu-item% (parent keybindings-menu)) @@ -343,7 +344,8 @@ (if (path? item) (path->string item) (format "~s" item)) - (exn-message x))) + (exn-message x)) + #:dialog-mixin frame:focus-table-mixin) #f)]) (keymap:add-user-keybindings-file item) #t)) @@ -459,7 +461,8 @@ (message-box (string-constant drscheme) (if (exn? exn) (format "~a" (exn-message exn)) - (format "~s" exn))))]) + (format "~s" exn)) + #:dialog-mixin frame:focus-table-mixin))]) (let* ([url (string->url s-url)] [tmp-filename (make-temporary-file "tmp~a.plt")] [port (get-impure-port url)] diff --git a/collects/drracket/private/init.rkt b/collects/drracket/private/init.rkt index eb331b133f..8bee64b9ab 100644 --- a/collects/drracket/private/init.rkt +++ b/collects/drracket/private/init.rkt @@ -1,7 +1,8 @@ #lang racket/unit (require string-constants "drsig.rkt" - racket/gui/base) + racket/gui/base + framework) (import) @@ -50,4 +51,4 @@ (parameterize ([current-custodian system-custodian]) (parameterize ([current-eventspace error-display-eventspace]) - (message-box title text #f '(stop ok)))))))) + (message-box title text #f '(stop ok) #:dialog-mixin frame:focus-table-mixin))))))) diff --git a/collects/drracket/private/language-configuration.rkt b/collects/drracket/private/language-configuration.rkt index 1370d7259f..67a6a00177 100644 --- a/collects/drracket/private/language-configuration.rkt +++ b/collects/drracket/private/language-configuration.rkt @@ -162,7 +162,7 @@ (define language-dialog (λ (show-welcome? language-settings-to-show [parent #f]) (define ret-dialog% - (class dialog% + (class (frame:focus-table-mixin dialog%) (define/override (on-subwindow-char receiver evt) (case (send evt get-key-code) [(escape) (cancel-callback)] @@ -170,7 +170,7 @@ [else (or (key-pressed receiver evt) (super on-subwindow-char receiver evt))])) - (super-instantiate ()))) + (super-new))) (define dialog (instantiate ret-dialog% () (label (if show-welcome? @@ -214,7 +214,8 @@ (define (ok-callback) (unless (enter-callback) (message-box (string-constant drscheme) - (string-constant please-select-a-language)))) + (string-constant please-select-a-language) + #:dialog-mixin frame:focus-table-mixin))) ;; cancel-callback : -> void (define (cancel-callback) @@ -1285,7 +1286,8 @@ (message-box (string-constant drscheme) (if (exn? x) (exn-message x) - (format "uncaught exception: ~s" x))) + (format "uncaught exception: ~s" x)) + #:dialog-mixin frame:focus-table-mixin) read-syntax/namespace-introduce)]) (contract (->* () @@ -1335,7 +1337,8 @@ numberss summaries urls - reader-specs))]))))) + reader-specs) + #:dialog-mixin frame:focus-table-mixin)]))))) (define (platform-independent-string->path str) (apply diff --git a/collects/drracket/private/language.rkt b/collects/drracket/private/language.rkt index ccf7aedb4b..b662354dcd 100644 --- a/collects/drracket/private/language.rkt +++ b/collects/drracket/private/language.rkt @@ -783,7 +783,8 @@ [(string=? "" filename-str) (message-box (string-constant drscheme) (string-constant please-specify-a-filename) - dlg) + dlg + #:dialog-mixin frame:focus-table-mixin) #f] [(not (users-name-ok? mode extension dlg (string->path filename-str))) #f] @@ -797,7 +798,8 @@ (eq? (message-box (string-constant drscheme) (format (string-constant are-you-sure-delete?) filename) dlg - '(yes-no)) + '(yes-no) + #:dialog-mixin frame:focus-table-mixin) 'yes)) (define cancelled? #t) @@ -904,7 +906,8 @@ [(distribution) (string-constant distribution)]) name extension) - parent) + parent + #:dialog-mixin frame:focus-table-mixin) #f))))) ;; default-executable-filename : path symbol boolean -> path @@ -940,7 +943,8 @@ (λ (x) (message-box (string-constant drscheme) - (format "~a" (exn-message x))) + (format "~a" (exn-message x)) + #:dialog-mixin frame:focus-table-mixin) (void))]) (define init-code-tmp-filename (make-temporary-file "drs-standalone-exectable-init~a")) (define bootstrap-tmp-filename (make-temporary-file "drs-standalone-exectable-bootstrap~a")) @@ -1163,7 +1167,8 @@ (λ (x) (message-box (string-constant drscheme) - (format "~a" (exn-message x))) + (format "~a" (exn-message x)) + #:dialog-mixin frame:focus-table-mixin) (void))]) ((if gui? make-mred-launcher make-mzscheme-launcher) diff --git a/collects/drracket/private/rep.rkt b/collects/drracket/private/rep.rkt index bd41e6afd1..975a0e6b2c 100644 --- a/collects/drracket/private/rep.rkt +++ b/collects/drracket/private/rep.rkt @@ -903,7 +903,7 @@ TODO (floor (/ new-limit 1024 1024)))) frame '(default=1 stop) - )]) + #:dialog-mixin frame:focus-table-mixin)]) (when (equal? ans 3) (set-custodian-limit new-limit) (preferences:set 'drracket:child-only-memory-limit new-limit)) @@ -1369,7 +1369,8 @@ TODO #f (or (get-top-level-window) (get-can-close-parent)) '(default=1 caution) - 2) + 2 + #:dialog-mixin frame:focus-table-mixin) 1)] [(let ([user-eventspace (get-user-eventspace)]) (and user-eventspace @@ -1383,7 +1384,8 @@ TODO #f (or (get-top-level-window) (get-can-close-parent)) '(default=1 caution) - 2) + 2 + #:dialog-mixin frame:focus-table-mixin) 1)] [else #t]) (inner #t can-close?))) diff --git a/collects/drracket/private/syncheck/gui.rkt b/collects/drracket/private/syncheck/gui.rkt index e617784dc5..94fcacf337 100644 --- a/collects/drracket/private/syncheck/gui.rkt +++ b/collects/drracket/private/syncheck/gui.rkt @@ -612,7 +612,8 @@ If the namespace does not, they are colored the unbound color. (string-constant cancel) #f parent - '(stop default=2)) + '(stop default=2) + #:dialog-mixin frame:focus-table-mixin) 1))) (when do-renaming? diff --git a/collects/drracket/private/unit.rkt b/collects/drracket/private/unit.rkt index 4e0c5e5fa0..8c83dbc0f5 100644 --- a/collects/drracket/private/unit.rkt +++ b/collects/drracket/private/unit.rkt @@ -150,7 +150,8 @@ module browser threading seems wrong. [else (message-box (string-constant drscheme) - "Must choose a filename that ends with either .png, .jpg, .xbm, or .xpm")])))))])))))) + "Must choose a filename that ends with either .png, .jpg, .xbm, or .xpm" + #:dialog-mixin frame:focus-table-mixin)])))))])))))) (void)))))) @@ -338,7 +339,8 @@ module browser threading seems wrong. (message-box (string-constant drscheme) v - dlg)])))] + dlg + #:dialog-mixin frame:focus-table-mixin)])))] [cancel-callback (λ () (send dlg show #f))]) (let-values ([(ok cancel) @@ -364,7 +366,8 @@ module browser threading seems wrong. [(not program-filename) (message-box (string-constant create-executable-title) (string-constant must-save-before-executable) - frame)] + frame + #:dialog-mixin frame:focus-table-mixin)] [else (when (or (not (send definitions-text is-modified?)) (gui-utils:get-choice @@ -1667,7 +1670,8 @@ module browser threading seems wrong. (gui-utils:format-literal-label (string-constant erase-log-directory-contents) transcript-directory) this - '(yes-no))]) + '(yes-no) + #:dialog-mixin frame:focus-table-mixin)]) (cond [(eq? query 'no) #f] @@ -1680,7 +1684,8 @@ module browser threading seems wrong. (if (exn? exn) (format "~a" (exn-message exn)) (format "~s" exn))) - this) + this + #:dialog-mixin frame:focus-table-mixin) #f)]) (for-each (λ (file) (delete-file (build-path transcript-directory file))) dir-list) @@ -2669,7 +2674,8 @@ module browser threading seems wrong. #f this '(caution default=2 number-order) - 1)]) + 1 + #:dialog-mixin frame:focus-table-mixin)]) (case user-choice [(1) (void)] [(2) (revert)])))) @@ -3177,7 +3183,8 @@ module browser threading seems wrong. strs))]) (unless can-browse? (message-box (string-constant drscheme) - (string-constant module-browser-only-in-plt-and-module-langs))) + (string-constant module-browser-only-in-plt-and-module-langs) + #:dialog-mixin frame:focus-table-mixin)) can-browse?)) (define/private (update-module-browser-pane) @@ -3577,7 +3584,8 @@ module browser threading seems wrong. (send l capability-value 'drscheme:teachpack-menu-items) (format "\n ~a" (send l get-language-name)))) (drracket:language-configuration:get-languages)))))) - this))])))]))) + this + #:dialog-mixin frame:focus-table-mixin))])))]))) (define/private (initialize-menus) (let* ([mb (get-menu-bar)] @@ -4650,8 +4658,9 @@ module browser threading seems wrong. (frame:editor-mixin (frame:standard-menus-mixin (frame:register-group-mixin - (frame:basic-mixin - frame%)))))))))))))))))) + (frame:focus-table-mixin + (frame:basic-mixin + frame%))))))))))))))))))) (define-local-member-name enable-two-way-prefs) (define (make-two-way-prefs-dragable-panel% % pref-key) diff --git a/collects/framework/main.rkt b/collects/framework/main.rkt index 88de9a1db1..4352051fad 100644 --- a/collects/framework/main.rkt +++ b/collects/framework/main.rkt @@ -9,7 +9,12 @@ framework/framework-unit framework/private/sig (for-syntax scheme/base) - scribble/srcdoc) + scribble/srcdoc) + +;; these next two lines do a little dance to make the +;; require/doc setup work out properly +(require (prefix-in :: framework/private/focus-table)) +(define frame:lookup-focus-table ::frame:lookup-focus-table) (require framework/preferences framework/test @@ -709,7 +714,24 @@ @racket[bitmap% get-loaded-mask]) and @racket['large].}] Defaults to @racket[#f].}) - + + (proc-doc/names + frame:lookup-focus-table + (->* () (eventspace?) (listof (is-a?/c frame:focus-table<%>))) + (() + ((eventspace (current-eventspace)))) + @{Returns a list of the frames in @racket[eventspace], where the first element of the list + is the frame with the focus. + + The order and contents of the list are maintained by + the methods in @racket[frame:focus-table-mixin], meaning that the + OS-level callbacks that track the focus of individual frames is + ignored. + + See also @racket[test:use-focus-table] and @racket[test:get-active-top-level-window]. + + }) + (proc-doc/names group:get-the-frame-group (-> (is-a?/c group:%)) diff --git a/collects/framework/private/finder.rkt b/collects/framework/private/finder.rkt index 8b5675e986..ac020ee37f 100644 --- a/collects/framework/private/finder.rkt +++ b/collects/framework/private/finder.rkt @@ -1,14 +1,15 @@ #lang scheme/unit (require string-constants + (prefix-in r: racket/gui/base) "sig.rkt" "../preferences.rkt" mred/mred-sig scheme/path) - (import mred^ - [prefix keymap: framework:keymap^]) + [prefix keymap: framework:keymap^] + [prefix frame: framework:frame^]) (export (rename framework:finder^ [-put-file put-file] @@ -44,7 +45,8 @@ [name (or (and (string? name) (file-name-from-path name)) name)] [f (put-file prompt parent-win directory name - (default-extension) style (default-filters))]) + (default-extension) style (default-filters) + #:dialog-mixin frame:focus-table-mixin)]) (and f (or (not filter) (filter-match? filter f filter-msg)) (let* ([f (normal-case-path (simple-form-path f))] [dir (path-only f)] @@ -60,6 +62,7 @@ #f] [else f])))))) + (define op (current-output-port)) (define (*get-file style) (lambda ([directory #f] [prompt (string-constant select-file)] @@ -67,7 +70,8 @@ [filter-msg (string-constant file-wrong-form)] [parent-win (dialog-parent-parameter)]) (let ([f (get-file prompt parent-win directory #f - (default-extension) style (default-filters))]) + (default-extension) style (default-filters) + #:dialog-mixin frame:focus-table-mixin)]) (and f (or (not filter) (filter-match? filter f filter-msg)) (cond [(directory-exists? f) (message-box (string-constant error) diff --git a/collects/framework/private/frame.rkt b/collects/framework/private/frame.rkt index b051dea8a8..856b7fde77 100644 --- a/collects/framework/private/frame.rkt +++ b/collects/framework/private/frame.rkt @@ -9,6 +9,7 @@ "../preferences.rkt" "../gui-utils.rkt" "bday.rkt" + framework/private/focus-table mrlib/close-icon mred/mred-sig scheme/path) @@ -131,6 +132,26 @@ editing-this-file? get-filename make-visible)) + +(define focus-table<%> (interface ((class->interface frame%)))) +(define focus-table-mixin + (mixin (top-level-window<%>) (focus-table<%>) + (inherit get-eventspace) + + (define/override (show on?) + (define old (remove this (frame:lookup-focus-table (get-eventspace)))) + (define new (if on? (cons this old) old)) + (frame:set-focus-table (get-eventspace) new) + (super show on?)) + + (define/augment (on-close) + (frame:set-focus-table (get-eventspace) (remove this (frame:lookup-focus-table (get-eventspace)))) + (inner (void) on-close)) + + (super-new) + + (frame:set-focus-table (get-eventspace) (frame:lookup-focus-table (get-eventspace))))) + (define basic-mixin (mixin ((class->interface frame%)) (basic<%>) @@ -190,12 +211,11 @@ (λ (% parent) (make-object % parent))) - (inherit can-close? on-close) - (define/public close - (λ () - (when (can-close?) - (on-close) - (show #f)))) + (inherit on-close can-close?) + (define/public (close) + (when (can-close?) + (on-close) + (show #f))) (inherit accept-drop-files) @@ -2710,7 +2730,7 @@ (min-width (+ (inexact->exact (ceiling indicator-width)) 4)) (min-height (+ (inexact->exact (ceiling indicator-height)) 4)))) -(define basic% (register-group-mixin (basic-mixin frame%))) +(define basic% (focus-table-mixin (register-group-mixin (basic-mixin frame%)))) (define size-pref% (size-pref-mixin basic%)) (define info% (info-mixin basic%)) (define text-info% (text-info-mixin info%)) diff --git a/collects/framework/private/sig.rkt b/collects/framework/private/sig.rkt index 60520eeb3f..aa76198d74 100644 --- a/collects/framework/private/sig.rkt +++ b/collects/framework/private/sig.rkt @@ -256,6 +256,7 @@ (define-signature frame-class^ (basic<%> + focus-table<%> size-pref<%> register-group<%> status-line<%> @@ -285,6 +286,7 @@ delegate% pasteboard% + focus-table-mixin basic-mixin size-pref-mixin register-group-mixin diff --git a/collects/framework/test.rkt b/collects/framework/test.rkt index fe4bf793ca..df53fc681a 100644 --- a/collects/framework/test.rkt +++ b/collects/framework/test.rkt @@ -1,10 +1,12 @@ #lang at-exp scheme/gui -(require scribble/srcdoc) -(require/doc scheme/base scribble/manual) +(require scribble/srcdoc + (prefix-in :: framework/private/focus-table)) +(require/doc scheme/base scribble/manual + (for-label framework)) (define (test:top-level-focus-window-has? pred) - (let ([tlw (get-top-level-focus-window)]) + (let ([tlw (test:get-active-top-level-window)]) (and tlw (let loop ([tlw tlw]) (or (pred tlw) @@ -165,16 +167,30 @@ (define current-get-eventspaces (make-parameter (λ () (list (current-eventspace))))) -(define (get-active-frame) +(define test:use-focus-table (make-parameter #f)) + +(define (test:get-active-top-level-window) (ormap (λ (eventspace) (parameterize ([current-eventspace eventspace]) - (get-top-level-focus-window))) + (cond + [(test:use-focus-table) + (define lst (::frame:lookup-focus-table)) + (define focusd (and (not (null? lst)) (car lst))) + (when (eq? (test:use-focus-table) 'debug) + (define f2 (get-top-level-focus-window)) + (unless (eq? focusd f2) + (eprintf "found mismatch focus-table: ~s vs get-top-level-focus-window: ~s\n" + (map (λ (x) (send x get-label)) lst) + (and f2 (list (send f2 get-label)))))) + focusd] + [else + (get-top-level-focus-window)]))) ((current-get-eventspaces)))) (define (get-focused-window) - (let ([f (get-active-frame)]) + (let ([f (test:get-active-top-level-window)]) (and f - (send f get-focus-window)))) + (send f get-edit-target-window)))) (define time-stamp current-milliseconds) @@ -200,14 +216,13 @@ ;; get-parent returns () for no parent. ;; -(define in-active-frame? - (λ (window) - (let ([frame (get-active-frame)]) - (let loop ([window window]) - (cond [(not window) #f] - [(null? window) #f] ;; is this test needed? - [(eq? window frame) #t] - [else (loop (send window get-parent))]))))) +(define (in-active-frame? window) + (let ([frame (test:get-active-top-level-window)]) + (let loop ([window window]) + (cond [(not window) #f] + [(null? window) #f] ;; is this test needed? + [(eq? window frame) #t] + [else (loop (send window get-parent))])))) ;; ;; Verify modifier list. @@ -239,7 +254,7 @@ (cond [(or (string? b-desc) (procedure? b-desc)) - (let* ([active-frame (get-active-frame)] + (let* ([active-frame (test:get-active-top-level-window)] [_ (unless active-frame (error object-tag "could not find object: ~a, no active frame" @@ -516,7 +531,7 @@ [else (error key-tag - "focused window is not a text-field% and does not have on-char")])] + "focused window is not a text-field% and does not have on-char, ~e" window)])] [(send (car l) on-subwindow-char window event) #f] [else (loop (cdr l))]))) @@ -573,21 +588,20 @@ (define menu-tag 'test:menu-select) -(define menu-select - (λ (menu-name . item-names) - (cond - [(not (string? menu-name)) - (error menu-tag "expects string, given: ~e" menu-name)] - [(not (andmap string? item-names)) - (error menu-tag "expects strings, given: ~e" item-names)] - [else - (run-one - (λ () - (let* ([frame (get-active-frame)] - [item (get-menu-item frame (cons menu-name item-names))] - [evt (make-object control-event% 'menu)]) - (send evt set-time-stamp (current-milliseconds)) - (send item command evt))))]))) +(define (menu-select menu-name . item-names) + (cond + [(not (string? menu-name)) + (error menu-tag "expects string, given: ~e" menu-name)] + [(not (andmap string? item-names)) + (error menu-tag "expects strings, given: ~e" item-names)] + [else + (run-one + (λ () + (let* ([frame (test:get-active-top-level-window)] + [item (get-menu-item frame (cons menu-name item-names))] + [evt (make-object control-event% 'menu)]) + (send evt set-time-stamp (current-milliseconds)) + (send item command evt))))])) (define get-menu-item (λ (frame item-names) @@ -1021,7 +1035,7 @@ test:top-level-focus-window-has? (-> (-> (is-a?/c area<%>) boolean?) boolean?) (test) - @{Calls @racket[test] for each child of the top-level-focus-frame + @{Calls @racket[test] for each child of the @racket[test:get-active-top-level-window] and returns @racket[#t] if @racket[test] ever does, otherwise returns @racket[#f]. If there is no top-level-focus-window, returns @racket[#f].}) @@ -1041,4 +1055,20 @@ test:run-one (-> (-> void?) void?) (f) - @{Runs the function @racket[f] as if it was a simulated event.})) + @{Runs the function @racket[f] as if it was a simulated event.}) + + (parameter-doc + test:use-focus-table + (parameter/c (or/c boolean? 'debug)) + use-focus-table? + @{If @racket[#t], then the test framework uses @racket[frame:lookup-focus-table] to determine + which is the focused frame. If @racket[#f], then it uses @racket[get-top-level-focus-window]. + If @racket[test:use-focus-table]'s value is @racket['debug], then it still uses + @racket[frame:lookup-focus-table] but it also prints a message to the @racket[current-error-port] + when the two methods would give different results.}) + + (proc-doc/names + test:get-active-top-level-window + (-> (or/c (is-a?/c frame%) (is-a?/c dialog%) #f)) + () + @{Returns the frontmost frame, based on @racket[test:use-focus-table].})) diff --git a/collects/scribblings/framework/frame.scrbl b/collects/scribblings/framework/frame.scrbl index 571909cbbf..7e5a16ccc1 100644 --- a/collects/scribblings/framework/frame.scrbl +++ b/collects/scribblings/framework/frame.scrbl @@ -162,6 +162,35 @@ using the @method[frame:basic<%> make-root-area-container] method). } } + +@definterface[frame:focus-table<%> (frame%)]{} + +@defmixin[frame:focus-table-mixin (frame%) (frame:focus-table<%>)]{ + + Instances of classes returned from this mixin track how frontmost they are + based on calls made to methods at the Racket level, instead of using + the calls made by the operating system as it tracks the focus. + + See also @racket[frame:lookup-focus-table], @racket[test:use-focus-table] + and @racket[test:get-active-top-level-window]. + + @defmethod[#:mode override (show [on? boolean?]) void?]{ + When @racket[on?] is @racket[#t], adds this frame to the + front of the list of frames stored with the frame's eventspace. When + @racket[on?] is @racket[#f], this method removes this frame + from the list. + + See also @racket[frame:lookup-focus-table], @racket[test:use-focus-table] + and @racket[test:get-active-top-level-window]. + } + @defmethod[#:mode augment (on-close) void?]{ + Removes this frame from the list of frames stored with the frame's eventspace. + + See also @racket[frame:lookup-focus-table], @racket[test:use-focus-table] + and @racket[test:get-active-top-level-window]. + } +} + @definterface[frame:size-pref<%> (frame:basic<%>)]{ } diff --git a/collects/scribblings/framework/main-extracts.rkt b/collects/scribblings/framework/main-extracts.rkt index 443097475f..6d7e7c29f2 100644 --- a/collects/scribblings/framework/main-extracts.rkt +++ b/collects/scribblings/framework/main-extracts.rkt @@ -1,4 +1,4 @@ -#lang scheme/base +#lang racket/base (require scribble/extract) (provide-extracted (lib "framework/main.rkt")) diff --git a/collects/tests/drracket/no-write-and-frame-leak.rkt b/collects/tests/drracket/no-write-and-frame-leak.rkt index 1adbd72ef2..0a3b4f03b0 100644 --- a/collects/tests/drracket/no-write-and-frame-leak.rkt +++ b/collects/tests/drracket/no-write-and-frame-leak.rkt @@ -12,12 +12,6 @@ (error who "Deleting files is not allowed"))) void void)]) - (fire-up-drscheme-and-run-tests - (λ () - (define drs-frame (wait-for-drscheme-frame)) - (test:menu-select "File" "Close")))) - -(parameterize ([current-command-line-arguments '#()]) (fire-up-drscheme-and-run-tests (λ () (define drs-frame1 (wait-for-drscheme-frame)) @@ -29,7 +23,7 @@ (define drs-tabb (make-weak-box (send drs-frame1 get-current-tab))) (define tab-nsb (make-weak-box (send (send (send drs-frame1 get-current-tab) get-ints) get-user-namespace))) - (test:menu-select "File" "Close Tab") + (test:menu-select "File" (if (eq? (system-type) 'unix) "Close" "Close Tab")) (sync (system-idle-evt)) (test:menu-select "File" "New") @@ -38,7 +32,7 @@ (define drs-frame2b (make-weak-box (wait-for-new-frame drs-frame1))) (define frame2-nsb (make-weak-box (send (send (send (weak-box-value drs-frame2b) get-current-tab) get-ints) get-user-namespace))) - (test:menu-select "File" "Close") + (test:menu-select "File" (if (eq? (system-type) 'unix) "Close" "Close Window")) (sync (system-idle-evt)) (let loop ([n 30]) diff --git a/collects/tests/drracket/private/drracket-test-util.rkt b/collects/tests/drracket/private/drracket-test-util.rkt index 5d22431ccf..d0314f1ae9 100644 --- a/collects/tests/drracket/private/drracket-test-util.rkt +++ b/collects/tests/drracket/private/drracket-test-util.rkt @@ -61,7 +61,7 @@ (fw:preferences:set 'framework:file-dialogs 'common) (open-dialog) (let ([dlg (wait-for-new-frame drs)]) - (send (find-labelled-window "Filename:") focus) + (send (find-labelled-window "Filename:" #f (fw:test:get-active-top-level-window)) focus) (fw:test:keystroke #\a (list (case (system-type) [(windows) 'control] [(macosx macos) 'meta] @@ -100,7 +100,7 @@ (define (wait-for-drscheme-frame [print-message? #f]) (let ([wait-for-drscheme-frame-pred (lambda () - (let ([active (get-top-level-focus-window)]) + (let ([active (fw:test:get-active-top-level-window)]) (if (and active (drscheme-frame? active)) active @@ -123,15 +123,14 @@ [(old-frame extra-eventspaces timeout) (let ([wait-for-new-frame-pred (lambda () - (let ([active (or (get-top-level-focus-window) - (ormap + (let ([active (or (fw:test:get-active-top-level-window) + (ormap (lambda (eventspace) - (parameterize ([current-eventspace eventspace]) - (get-top-level-focus-window))) + (parameterize ([current-eventspace eventspace]) + (fw:test:get-active-top-level-window))) extra-eventspaces))]) (if (and active - (send active get-focus-window) - (not (eq? active old-frame))) + (not (eq? active old-frame))) active #f)))]) (poll-until wait-for-new-frame-pred timeout))])) @@ -172,7 +171,7 @@ (define (verify-drscheme-frame-frontmost function-name frame) (on-eventspace-handler-thread 'verify-drscheme-frame-frontmost) - (let ([tl (get-top-level-focus-window)]) + (let ([tl (fw:test:get-active-top-level-window)]) (unless (and (eq? frame tl) (drscheme-frame? tl)) (error function-name "drscheme frame not frontmost: ~e (found ~e)" frame tl)))) @@ -180,9 +179,9 @@ (define (clear-definitions frame) (queue-callback/res (λ () (verify-drscheme-frame-frontmost 'clear-definitions frame))) (fw:test:new-window (queue-callback/res (λ () (send frame get-definitions-canvas)))) - (let ([window (queue-callback/res (λ () (send frame get-focus-window)))]) + (let ([window (queue-callback/res (λ () (send frame get-edit-target-window)))]) (let-values ([(cw ch) (queue-callback/res (λ () (send window get-client-size)))] - [(w h) (queue-callback/res (λ () (send window get-size)))]) + [(w h) (queue-callback/res (λ () (send window get-size)))]) (fw:test:mouse-click 'left (inexact->exact (floor (+ cw (/ (- w cw) 2)))) (inexact->exact (floor (+ ch (/ (- h ch) 2))))))) @@ -344,10 +343,10 @@ (andmap (lambda (x) (or string? regexp?)) in-language-spec)) (error 'set-language-level! "expected a non-empty list of regexps and strings for language, got: ~e" in-language-spec)) (not-on-eventspace-handler-thread 'set-language-level!) - (let ([drs-frame (get-top-level-focus-window)]) + (let ([drs-frame (fw:test:get-active-top-level-window)]) (fw:test:menu-select "Language" "Choose Language...") (let* ([language-dialog (wait-for-new-frame drs-frame)] - [language-choice (find-labelled-window #f hierarchical-list%)] + [language-choice (find-labelled-window #f hierarchical-list% (fw:test:get-active-top-level-window))] [b1 (box 0)] [b2 (box 0)] [click-on-snip @@ -411,7 +410,7 @@ drs-frame)))))))) (define (set-module-language! [close-dialog? #t]) (not-on-eventspace-handler-thread 'set-module-language!) - (let ([drs-frame (get-top-level-focus-window)]) + (let ([drs-frame (fw:test:get-active-top-level-window)]) (fw:test:menu-select "Language" "Choose Language...") (let* ([language-dialog (wait-for-new-frame drs-frame)]) (fw:test:set-radio-box-item! #rx"Use the language declared in the source") @@ -616,7 +615,9 @@ ;; been read by this point, but hopefully that won't affect much ;; of the startup of drscheme) (fw:preferences:restore-defaults) - + + (fw:test:use-focus-table #t) + (thread (λ () (let ([orig-display-handler (error-display-handler)]) (uncaught-exception-handler diff --git a/collects/tests/drracket/repl-test.rkt b/collects/tests/drracket/repl-test.rkt index 051168a4e1..7d2ff09807 100644 --- a/collects/tests/drracket/repl-test.rkt +++ b/collects/tests/drracket/repl-test.rkt @@ -1201,18 +1201,21 @@ This produces an ACK message (case language-cust [(raw) (void)] [else + (define edit-target (queue-callback/res (λ () (send drscheme-frame get-edit-target-window)))) + (define defs-focus? (eq? edit-target definitions-canvas)) + (define ints-focus? (eq? edit-target interactions-canvas)) (cond [(eq? source-location 'definitions) - (unless (send definitions-canvas has-focus?) + (unless defs-focus? (fprintf (current-error-port) "FAILED execute test for ~s\n expected definitions to have the focus\n" program))] [(eq? source-location 'interactions) - (unless (send interactions-canvas has-focus?) + (unless ints-focus? (fprintf (current-error-port) "FAILED execute test for ~s\n expected interactions to have the focus\n" program))] - [(queue-callback/res (λ () (send definitions-canvas has-focus?))) + [defs-focus? (let ([start (car source-location)] [finish (cdr source-location)]) (let* ([error-ranges (queue-callback/res (λ () (send interactions-text get-error-ranges)))] diff --git a/collects/tests/drracket/stepper-test.rkt b/collects/tests/drracket/stepper-test.rkt index c9d660ec5a..7742c09805 100644 --- a/collects/tests/drracket/stepper-test.rkt +++ b/collects/tests/drracket/stepper-test.rkt @@ -488,7 +488,7 @@ (set-definitions-to-program drs-frame program) (let* ([stepper-frame (start-stepper drs-frame)] [steps (get-all-steps stepper-frame)]) - (test:menu-select "File" "Close") + (test:menu-select "File" (if (eq? (system-type) 'unix) "Close" "Close Window")) (let ([drs-frame1 (wait-for-new-frame stepper-frame)]) (unless (eq? drs-frame1 drs-frame) (error 'step-and-extract "didn't get back to drscheme frame, got: ~e" drs-frame))) diff --git a/collects/tests/drracket/teaching-lang-save-file.rkt b/collects/tests/drracket/teaching-lang-save-file.rkt index 297b7b42b7..4856656572 100644 --- a/collects/tests/drracket/teaching-lang-save-file.rkt +++ b/collects/tests/drracket/teaching-lang-save-file.rkt @@ -30,7 +30,7 @@ (error 'save-teaching-lang-file.rkt "expected the saved file to contain the word 'metadata' in a comment")) (do-execute drr-frame) - (test:menu-select "File" "Close Tab") + (test:menu-select "File" (if (eq? (system-type) 'unix) "Close" "Close Tab")) (use-get/put-dialog (λ () (test:menu-select "File" "Open...")) @@ -40,7 +40,7 @@ drr-frame (send interactions-text paragraph-start-position 2) (send interactions-text last-position))]) - (test:menu-select "File" "Close Tab") + (test:menu-select "File" (if (eq? (system-type) 'unix) "Close" "Close Tab")) (delete-file fn) (unless (equal? result "1\n> ") (error 'save-teaching-lang-file.rkt "expected the program to produce 1 (followed by the prompt), got ~s" result)))))))