From a447a2af040884d98bb44ad282f21f3192b354e7 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 6 Jun 2000 21:56:07 +0000 Subject: [PATCH] . original commit: 96e7873d80fcc1751ebb4f43dcc2cb4daf4823a3 --- src/mred/wrap/mred.ss | 216 +++++++++++++++++++++++++++--------------- 1 file changed, 142 insertions(+), 74 deletions(-) diff --git a/src/mred/wrap/mred.ss b/src/mred/wrap/mred.ss index 61a57a6a..23b9e6a1 100644 --- a/src/mred/wrap/mred.ss +++ b/src/mred/wrap/mred.ss @@ -1591,7 +1591,15 @@ (case x [(#\tab #\return escape) (and (not tabable?) (not single-line-canvas?))] - [else (not meta?)]))]) + [else (not meta?)]))] + + + [popup-for-editor (entry-point-2 + (lambda (e m) + (let ([mwx (mred->wx m)]) + (and (send mwx popup-grab e) + (as-exit (lambda () (send m on-demand) #t)) + mwx))))]) (public [set-tabable (lambda (on?) (set! tabable? on?))] [is-tabable? (lambda () tabable?)] @@ -2448,7 +2456,7 @@ ;-------------------- Text control simulation ------------------------- (define text-field-text% - (class text% (cb return-cb control) + (class text% (cb return-cb control set-cb-mgrs!) (rename [super-after-insert after-insert] [super-after-delete after-delete] [super-on-char on-char]) @@ -2481,17 +2489,15 @@ (lambda () (as-exit (lambda () (apply super-after-delete args))) (callback 'text-field))))]) - (public - [callback-ready - (lambda () - (set! block-callback 0))] - [without-callback + (sequence + (set-cb-mgrs! (lambda (thunk) (dynamic-wind (lambda () (set! block-callback (add1 block-callback))) thunk - (lambda () (set! block-callback (sub1 block-callback)))))]) - (sequence + (lambda () (set! block-callback (sub1 block-callback))))) + (lambda () + (set! block-callback 0))) (super-init)))) (define wx-text-editor-canvas% @@ -2517,13 +2523,18 @@ ; Make text field first because we'll have to exit ; for keymap initializer (private + [without-callback #f] + [callback-ready #f] [e (make-object text-field-text% func (lambda (do-cb) (if multi? #f (do-cb))) - this)]) + this + (lambda (wc cr) + (set! without-callback wc) + (set! callback-ready cr)))]) (sequence (as-exit (lambda () @@ -2540,8 +2551,8 @@ [get-editor (lambda () e)] [get-value (lambda () (send e get-text))] - [set-value (lambda (v) (send e without-callback - (lambda () (send e insert v 0 (send e last-position)))))] + [set-value (lambda (v) (without-callback + (lambda () (send e insert v 0 (send e last-position)))))] [set-label (lambda (str) (when l (send l set-label str)))]) (override @@ -2639,7 +2650,7 @@ (let ([min-size (get-min-size)]) (set-min-width (car min-size)) (set-min-height (cadr min-size))) - (send e callback-ready)))) + (callback-ready)))) ;;;;;;;;;;;;;;;;;;;;;;;;; mred Class Construction ;;;;;;;;;;;;;;;;;;;;;;;;; @@ -3539,10 +3550,11 @@ (lambda (m x y) (check-instance '(method canvas<%> popup-menu) popup-menu% 'popup-menu% #f m) (let ([mwx (mred->wx m)]) - (as-exit - (lambda () - (send m on-demand) - (send wx popup-menu mwx x y))))))] + (and (send mwx popup-grab this) + (as-exit + (lambda () + (send m on-demand) + (send wx popup-menu mwx x y)))))))] [warp-pointer (entry-point-2 (lambda (x y) (send wx warp-pointer x y)))] [get-dc (entry-point (lambda () (send wx get-dc)))]) @@ -3899,7 +3911,8 @@ (class* wx:menu% (wx<%>) (mred popup-label popup-callback) (private [items null] - [keymap (make-object wx:keymap%)]) + [keymap (make-object wx:keymap%)] + [popup-grabber #f]) (inherit delete-by-position) (rename [super-delete delete] [super-enable enable]) @@ -3920,7 +3933,16 @@ (set! items (remq i items)))] [swap-item-keymap (lambda (old-k new-k) (when old-k (send keymap remove-chained-keymap old-k)) - (when new-k (send keymap chain-to-keymap new-k #f)))]) + (when new-k (send keymap chain-to-keymap new-k #f)))] + + [popup-grab (lambda (c) + (if popup-grabber + #f + (begin + (set! popup-grabber c) + #t)))] + [popup-release (lambda () (set! popup-grabber #f))] + [get-popup-grabber (lambda () popup-grabber)]) (override [delete (lambda (id i) (super-delete id) @@ -4196,22 +4218,6 @@ (define menu-item-container<%> (interface () get-items on-demand)) (define internal-menu<%> (interface ())) -(define basic-menu% - (class* mred% (menu-item-container<%> internal-menu<%>) (popup-label callback) - (public - [get-items (entry-point (lambda () (send wx get-items)))] - [on-demand (lambda () - (for-each - (lambda (i) - (when (is-a? i labelled-menu-item<%>) - (send i on-demand))) - (send wx get-items)))]) - (private - [wx #f]) - (sequence - (set! wx (make-object wx-menu% this popup-label callback)) - (super-init wx)))) - (define menu% (class* basic-labelled-menu-item% (menu-item-container<%> internal-menu<%>) (label parent [help-string #f]) (sequence @@ -4239,21 +4245,39 @@ (send wx-item set-wx-menu wx-menu))))))) (define popup-menu% - (class basic-menu% ([title #f][popdown-callback void]) + (class* mred% (menu-item-container<%> internal-menu<%>) ([title #f][popdown-callback void]) + (public + [get-popup-target + (lambda () + (send wx get-popup-grabber))] + [get-items (entry-point (lambda () (send wx get-items)))] + [on-demand (lambda () + (for-each + (lambda (i) + (when (is-a? i labelled-menu-item<%>) + (send i on-demand))) + (send wx get-items)))]) + (private + [wx #f]) (sequence (check-string/false '(constructor popup-menu) title) (check-callback '(constructor popup-menu) popdown-callback) (as-entry (lambda () - (super-init title - (lambda (m e) - (let ([wx (wx:id-to-menu-item (send e get-menu-id))]) - (when wx - (send (wx->mred wx) command (make-object wx:control-event% 'menu))) - (popdown-callback this (make-object wx:control-event% - (if wx - 'menu-popdown - 'menu-popdown-none))))))))))) + (set! wx (make-object wx-menu% this title + (lambda (mwx e) + (let ([wx (wx:id-to-menu-item (send e get-menu-id))]) + (when wx + (send (wx->mred wx) command (make-object wx:control-event% 'menu))) + (dynamic-wind + void + (lambda () + (popdown-callback this (make-object wx:control-event% + (if wx + 'menu-popdown + 'menu-popdown-none)))) + (lambda () (send mwx popup-release))))))) + (super-init wx)))))) (define menu-bar% (class* mred% (menu-item-container<%>) (parent) @@ -4280,6 +4304,8 @@ (send wx-parent set-menu-bar wx) (send wx-parent self-redraw-request)))))) +(wx:set-menu-tester (lambda (m) (is-a? m popup-menu%))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;; END SECURE LEVEL ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Everything past this point is written at the user's level, so there @@ -4304,9 +4330,26 @@ eol-box)]) (send edit set-position click-pos)))] [else (void)]) - (send edit paste)))]) + (send edit paste)))] + [mouse-popup-menu (lambda (edit event) + (let ([a (send edit get-admin)]) + (when a + (let ([m (make-object popup-menu% "Edit")]) + (append-editor-operation-menu-items m) + ;; Remove shortcut indicators (because they might not be correct) + (for-each + (lambda (i) + (when (is-a? i selectable-menu-item<%>) + (send i set-shortcut #f))) + (send m get-items)) + (let-values ([(x y) (send edit + dc-location-to-editor-location + (send event get-x) + (send event get-y))]) + (send a popup-menu m x y))))))]) (wx:add-text-keymap-functions k) (send k add-function "mouse-paste" mouse-paste) + (send k add-function "mouse-popup-menu" mouse-popup-menu) (map (lambda (key func) (send k map-function key func)) (append @@ -4317,6 +4360,7 @@ '(":middlebutton")) '("copy-clipboard" "cut-clipboard" "paste-clipboard" "delete-to-end-of-line" "undo" "select-all" "mouse-paste")) + (send k map-function ":rightbutton" "mouse-popup-menu") (when (eq? (system-type) 'unix) (send k map-function ":c:a" "beginning-of-line") (send k map-function ":c:e" "end-of-line"))) @@ -4334,7 +4378,10 @@ (make-parameter (let ([default-text-keymap-initializer (lambda (k) (check-instance 'default-text-keymap-initializer wx:keymap% 'keymap% #f k) - (send k chain-to-keymap std-keymap #f))]) + ;; Level of indirection to protect std-keymap: + (let ([naya (make-object wx:keymap%)]) + (send naya chain-to-keymap std-keymap #f) + (send k chain-to-keymap naya #f)))]) default-text-keymap-initializer) (check-installer 'default-text-keymap-initializer))) @@ -4540,16 +4587,17 @@ [(message parent pss-in style) (define _ (begin + ;; Calls from C++ have wrong kind of window: + (when (is-a? parent wx:window%) + (set! parent (as-entry (lambda () (wx->mred parent))))) + (check-string/false 'get-ps-setup-from-user message) - (unless (is-a? parent wx:window%) - (check-top-level-parent/false 'get-ps-setup-from-user parent)) + (check-top-level-parent/false 'get-ps-setup-from-user parent) (check-instance 'get-ps-setup-from-user wx:ps-setup% 'ps-setup% #t pss-in) (check-style 'get-ps-setup-from-user #f null style))) (define pss (or pss-in (wx:current-ps-setup))) - (define f (make-object dialog% "PostScript Setup" (if (is-a? parent wx:window%) - (wx->mred parent) - parent))) + (define f (make-object dialog% "PostScript Setup" parent)) (define papers '("A4 210 x 297 mm" "A3 297 x 420 mm" "Letter 8 1/2 x 11 in" "Legal 8 1/2 x 14 in")) (define p (make-object horizontal-pane% f)) @@ -4732,6 +4780,10 @@ (define (mk-file-selector who put? multi?) (lambda (message parent directory filename extension style) + ;; Calls from C++ have wrong kind of window: + (when (is-a? parent wx:window%) + (set! parent (as-entry (lambda () (wx->mred parent))))) + (check-string/false who message) (check-top-level-parent/false who parent) (check-string/false who directory) (check-string/false who filename) (check-string/false who extension) @@ -5073,28 +5125,46 @@ (let ([p (and parent (mred->wx parent))]) (as-exit (lambda () (super-init p))))))))) -(define (find-item-frame item) - (let loop ([i item]) - (let ([p (send i get-parent)]) - (cond - [(not p) #f] - [(is-a? p menu%) (loop p)] - [else (send p get-frame)])))) +(define (find-item-editor item) + (let ([o (let loop ([i item]) + (let ([p (send i get-parent)]) + (cond + [(not p) #f] + [(is-a? p popup-menu%) + (let ([p (send p get-popup-target)]) + (if (is-a? p window<%>) + (let ([f (send p get-top-level-window)]) + (and f (send f get-edit-target-object))) + p))] + [(is-a? p menu%) (loop p)] + [else (let ([f (send p get-frame)]) + (and f (send f get-edit-target-object)))])))]) + (and (is-a? o wx:editor<%>) + o))) (define append-editor-operation-menu-items (case-lambda [(m) (append-editor-operation-menu-items m #t)] [(m text-only?) - (check-instance 'append-editor-operation-menu-items menu% 'menu% #f m) - (let ([mk (lambda (name key op) - (make-object menu-item% name m - (lambda (i e) - (let* ([f (find-item-frame i)] - [o (and f (send f get-edit-target-object))]) - (and o (is-a? o wx:editor<%>) - (send o do-edit-operation op)))) - key))] - [mk-sep (lambda () (make-object separator-menu-item% m))]) + (menu-parent-only 'append-editor-operation-menu-items m) + (let* ([mk (lambda (name key op) + (make-object (class menu-item% () + (inherit enable) + (override + [on-demand + (lambda () + (let ([o (find-item-editor this)]) + (enable (and o + (send o can-do-edit-operation? op)))))]) + (sequence + (super-init + name m + (lambda (i e) + (let* ([o (find-item-editor i)]) + (and o + (send o do-edit-operation op)))) + key)))))] + [mk-sep (lambda () (make-object separator-menu-item% m))]) (mk "&Undo" #\z 'undo) (mk "Redo" #f 'redo) (mk-sep) @@ -5113,14 +5183,12 @@ (void))])) (define (append-editor-font-menu-items m) - (check-instance 'append-editor-font-menu-items menu% 'menu% #f m) + (menu-parent-only 'append-editor-font-menu-items m) (let ([mk (lambda (name m cb) (make-object menu-item% name m (lambda (i e) - (let* ([f (find-item-frame i)] - [o (and f (send f get-edit-target-object))]) - (and o (is-a? o wx:editor<%>) - (cb o))))))] + (let* ([o (find-item-editor i)]) + (and o (cb o))))))] [mk-sep (lambda (m) (make-object separator-menu-item% m))] [mk-menu (lambda (name) (make-object menu% name m))]) (let ([family (mk-menu "Font")]