Commit | Line | Data |
---|---|---|
920dae64 AT |
1 | # menu.tcl -- |
2 | # | |
3 | # This file defines the default bindings for Tk menus and menubuttons. | |
4 | # It also implements keyboard traversal of menus and implements a few | |
5 | # other utility procedures related to menus. | |
6 | # | |
7 | # RCS: @(#) $Id: menu.tcl,v 1.18.2.2 2005/05/27 18:00:59 tmh Exp $ | |
8 | # | |
9 | # Copyright (c) 1992-1994 The Regents of the University of California. | |
10 | # Copyright (c) 1994-1997 Sun Microsystems, Inc. | |
11 | # Copyright (c) 1998-1999 by Scriptics Corporation. | |
12 | # | |
13 | # See the file "license.terms" for information on usage and redistribution | |
14 | # of this file, and for a DISCLAIMER OF ALL WARRANTIES. | |
15 | # | |
16 | ||
17 | #------------------------------------------------------------------------- | |
18 | # Elements of tk::Priv that are used in this file: | |
19 | # | |
20 | # cursor - Saves the -cursor option for the posted menubutton. | |
21 | # focus - Saves the focus during a menu selection operation. | |
22 | # Focus gets restored here when the menu is unposted. | |
23 | # grabGlobal - Used in conjunction with tk::Priv(oldGrab): if | |
24 | # tk::Priv(oldGrab) is non-empty, then tk::Priv(grabGlobal) | |
25 | # contains either an empty string or "-global" to | |
26 | # indicate whether the old grab was a local one or | |
27 | # a global one. | |
28 | # inMenubutton - The name of the menubutton widget containing | |
29 | # the mouse, or an empty string if the mouse is | |
30 | # not over any menubutton. | |
31 | # menuBar - The name of the menubar that is the root | |
32 | # of the cascade hierarchy which is currently | |
33 | # posted. This is null when there is no menu currently | |
34 | # being pulled down from a menu bar. | |
35 | # oldGrab - Window that had the grab before a menu was posted. | |
36 | # Used to restore the grab state after the menu | |
37 | # is unposted. Empty string means there was no | |
38 | # grab previously set. | |
39 | # popup - If a menu has been popped up via tk_popup, this | |
40 | # gives the name of the menu. Otherwise this | |
41 | # value is empty. | |
42 | # postedMb - Name of the menubutton whose menu is currently | |
43 | # posted, or an empty string if nothing is posted | |
44 | # A grab is set on this widget. | |
45 | # relief - Used to save the original relief of the current | |
46 | # menubutton. | |
47 | # window - When the mouse is over a menu, this holds the | |
48 | # name of the menu; it's cleared when the mouse | |
49 | # leaves the menu. | |
50 | # tearoff - Whether the last menu posted was a tearoff or not. | |
51 | # This is true always for unix, for tearoffs for Mac | |
52 | # and Windows. | |
53 | # activeMenu - This is the last active menu for use | |
54 | # with the <<MenuSelect>> virtual event. | |
55 | # activeItem - This is the last active menu item for | |
56 | # use with the <<MenuSelect>> virtual event. | |
57 | #------------------------------------------------------------------------- | |
58 | ||
59 | #------------------------------------------------------------------------- | |
60 | # Overall note: | |
61 | # This file is tricky because there are five different ways that menus | |
62 | # can be used: | |
63 | # | |
64 | # 1. As a pulldown from a menubutton. In this style, the variable | |
65 | # tk::Priv(postedMb) identifies the posted menubutton. | |
66 | # 2. As a torn-off menu copied from some other menu. In this style | |
67 | # tk::Priv(postedMb) is empty, and menu's type is "tearoff". | |
68 | # 3. As an option menu, triggered from an option menubutton. In this | |
69 | # style tk::Priv(postedMb) identifies the posted menubutton. | |
70 | # 4. As a popup menu. In this style tk::Priv(postedMb) is empty and | |
71 | # the top-level menu's type is "normal". | |
72 | # 5. As a pulldown from a menubar. The variable tk::Priv(menubar) has | |
73 | # the owning menubar, and the menu itself is of type "normal". | |
74 | # | |
75 | # The various binding procedures use the state described above to | |
76 | # distinguish the various cases and take different actions in each | |
77 | # case. | |
78 | #------------------------------------------------------------------------- | |
79 | ||
80 | #------------------------------------------------------------------------- | |
81 | # The code below creates the default class bindings for menus | |
82 | # and menubuttons. | |
83 | #------------------------------------------------------------------------- | |
84 | ||
85 | bind Menubutton <FocusIn> {} | |
86 | bind Menubutton <Enter> { | |
87 | tk::MbEnter %W | |
88 | } | |
89 | bind Menubutton <Leave> { | |
90 | tk::MbLeave %W | |
91 | } | |
92 | bind Menubutton <1> { | |
93 | if {$tk::Priv(inMenubutton) ne ""} { | |
94 | tk::MbPost $tk::Priv(inMenubutton) %X %Y | |
95 | } | |
96 | } | |
97 | bind Menubutton <Motion> { | |
98 | tk::MbMotion %W up %X %Y | |
99 | } | |
100 | bind Menubutton <B1-Motion> { | |
101 | tk::MbMotion %W down %X %Y | |
102 | } | |
103 | bind Menubutton <ButtonRelease-1> { | |
104 | tk::MbButtonUp %W | |
105 | } | |
106 | bind Menubutton <space> { | |
107 | tk::MbPost %W | |
108 | tk::MenuFirstEntry [%W cget -menu] | |
109 | } | |
110 | ||
111 | # Must set focus when mouse enters a menu, in order to allow | |
112 | # mixed-mode processing using both the mouse and the keyboard. | |
113 | # Don't set the focus if the event comes from a grab release, | |
114 | # though: such an event can happen after as part of unposting | |
115 | # a cascaded chain of menus, after the focus has already been | |
116 | # restored to wherever it was before menu selection started. | |
117 | ||
118 | bind Menu <FocusIn> {} | |
119 | ||
120 | bind Menu <Enter> { | |
121 | set tk::Priv(window) %W | |
122 | if {[%W cget -type] eq "tearoff"} { | |
123 | if {"%m" ne "NotifyUngrab"} { | |
124 | if {[tk windowingsystem] eq "x11"} { | |
125 | tk_menuSetFocus %W | |
126 | } | |
127 | } | |
128 | } | |
129 | tk::MenuMotion %W %x %y %s | |
130 | } | |
131 | ||
132 | bind Menu <Leave> { | |
133 | tk::MenuLeave %W %X %Y %s | |
134 | } | |
135 | bind Menu <Motion> { | |
136 | tk::MenuMotion %W %x %y %s | |
137 | } | |
138 | bind Menu <ButtonPress> { | |
139 | tk::MenuButtonDown %W | |
140 | } | |
141 | bind Menu <ButtonRelease> { | |
142 | tk::MenuInvoke %W 1 | |
143 | } | |
144 | bind Menu <space> { | |
145 | tk::MenuInvoke %W 0 | |
146 | } | |
147 | bind Menu <Return> { | |
148 | tk::MenuInvoke %W 0 | |
149 | } | |
150 | bind Menu <Escape> { | |
151 | tk::MenuEscape %W | |
152 | } | |
153 | bind Menu <Left> { | |
154 | tk::MenuLeftArrow %W | |
155 | } | |
156 | bind Menu <Right> { | |
157 | tk::MenuRightArrow %W | |
158 | } | |
159 | bind Menu <Up> { | |
160 | tk::MenuUpArrow %W | |
161 | } | |
162 | bind Menu <Down> { | |
163 | tk::MenuDownArrow %W | |
164 | } | |
165 | bind Menu <KeyPress> { | |
166 | tk::TraverseWithinMenu %W %A | |
167 | } | |
168 | ||
169 | # The following bindings apply to all windows, and are used to | |
170 | # implement keyboard menu traversal. | |
171 | ||
172 | if {[string equal [tk windowingsystem] "x11"]} { | |
173 | bind all <Alt-KeyPress> { | |
174 | tk::TraverseToMenu %W %A | |
175 | } | |
176 | ||
177 | bind all <F10> { | |
178 | tk::FirstMenu %W | |
179 | } | |
180 | } else { | |
181 | bind Menubutton <Alt-KeyPress> { | |
182 | tk::TraverseToMenu %W %A | |
183 | } | |
184 | ||
185 | bind Menubutton <F10> { | |
186 | tk::FirstMenu %W | |
187 | } | |
188 | } | |
189 | ||
190 | # ::tk::MbEnter -- | |
191 | # This procedure is invoked when the mouse enters a menubutton | |
192 | # widget. It activates the widget unless it is disabled. Note: | |
193 | # this procedure is only invoked when mouse button 1 is *not* down. | |
194 | # The procedure ::tk::MbB1Enter is invoked if the button is down. | |
195 | # | |
196 | # Arguments: | |
197 | # w - The name of the widget. | |
198 | ||
199 | proc ::tk::MbEnter w { | |
200 | variable ::tk::Priv | |
201 | ||
202 | if {[string compare $Priv(inMenubutton) ""]} { | |
203 | MbLeave $Priv(inMenubutton) | |
204 | } | |
205 | set Priv(inMenubutton) $w | |
206 | if {[string compare [$w cget -state] "disabled"]} { | |
207 | $w configure -state active | |
208 | } | |
209 | } | |
210 | ||
211 | # ::tk::MbLeave -- | |
212 | # This procedure is invoked when the mouse leaves a menubutton widget. | |
213 | # It de-activates the widget, if the widget still exists. | |
214 | # | |
215 | # Arguments: | |
216 | # w - The name of the widget. | |
217 | ||
218 | proc ::tk::MbLeave w { | |
219 | variable ::tk::Priv | |
220 | ||
221 | set Priv(inMenubutton) {} | |
222 | if {![winfo exists $w]} { | |
223 | return | |
224 | } | |
225 | if {[string equal [$w cget -state] "active"]} { | |
226 | $w configure -state normal | |
227 | } | |
228 | } | |
229 | ||
230 | # ::tk::MbPost -- | |
231 | # Given a menubutton, this procedure does all the work of posting | |
232 | # its associated menu and unposting any other menu that is currently | |
233 | # posted. | |
234 | # | |
235 | # Arguments: | |
236 | # w - The name of the menubutton widget whose menu | |
237 | # is to be posted. | |
238 | # x, y - Root coordinates of cursor, used for positioning | |
239 | # option menus. If not specified, then the center | |
240 | # of the menubutton is used for an option menu. | |
241 | ||
242 | proc ::tk::MbPost {w {x {}} {y {}}} { | |
243 | global errorInfo | |
244 | variable ::tk::Priv | |
245 | global tcl_platform | |
246 | ||
247 | if {[$w cget -state] eq "disabled" || $w eq $Priv(postedMb)} { | |
248 | return | |
249 | } | |
250 | set menu [$w cget -menu] | |
251 | if {[string equal $menu ""]} { | |
252 | return | |
253 | } | |
254 | set tearoff [expr {[tk windowingsystem] eq "x11" \ | |
255 | || [$menu cget -type] eq "tearoff"}] | |
256 | if {[string first $w $menu] != 0} { | |
257 | error "can't post $menu: it isn't a descendant of $w (this is a new requirement in Tk versions 3.0 and later)" | |
258 | } | |
259 | set cur $Priv(postedMb) | |
260 | if {[string compare $cur ""]} { | |
261 | MenuUnpost {} | |
262 | } | |
263 | set Priv(cursor) [$w cget -cursor] | |
264 | set Priv(relief) [$w cget -relief] | |
265 | $w configure -cursor arrow | |
266 | $w configure -relief raised | |
267 | ||
268 | set Priv(postedMb) $w | |
269 | set Priv(focus) [focus] | |
270 | $menu activate none | |
271 | GenerateMenuSelect $menu | |
272 | ||
273 | # If this looks like an option menubutton then post the menu so | |
274 | # that the current entry is on top of the mouse. Otherwise post | |
275 | # the menu just below the menubutton, as for a pull-down. | |
276 | ||
277 | update idletasks | |
278 | if {[catch { | |
279 | switch [$w cget -direction] { | |
280 | above { | |
281 | set x [winfo rootx $w] | |
282 | set y [expr {[winfo rooty $w] - [winfo reqheight $menu]}] | |
283 | # if we go offscreen to the top, show as 'below' | |
284 | if {$y < 0} { | |
285 | set y [expr {[winfo rooty $w] + [winfo height $w]}] | |
286 | } | |
287 | PostOverPoint $menu $x $y | |
288 | } | |
289 | below { | |
290 | set x [winfo rootx $w] | |
291 | set y [expr {[winfo rooty $w] + [winfo height $w]}] | |
292 | # if we go offscreen to the bottom, show as 'above' | |
293 | set mh [winfo reqheight $menu] | |
294 | if {($y + $mh) > [winfo screenheight $w]} { | |
295 | set y [expr {[winfo rooty $w] - $mh}] | |
296 | } | |
297 | PostOverPoint $menu $x $y | |
298 | } | |
299 | left { | |
300 | set x [expr {[winfo rootx $w] - [winfo reqwidth $menu]}] | |
301 | set y [expr {(2 * [winfo rooty $w] + [winfo height $w]) / 2}] | |
302 | set entry [MenuFindName $menu [$w cget -text]] | |
303 | if {[$w cget -indicatoron]} { | |
304 | if {$entry == [$menu index last]} { | |
305 | incr y [expr {-([$menu yposition $entry] \ | |
306 | + [winfo reqheight $menu])/2}] | |
307 | } else { | |
308 | incr y [expr {-([$menu yposition $entry] \ | |
309 | + [$menu yposition [expr {$entry+1}]])/2}] | |
310 | } | |
311 | } | |
312 | PostOverPoint $menu $x $y | |
313 | if {$entry ne "" \ | |
314 | && [$menu entrycget $entry -state] ne "disabled"} { | |
315 | $menu activate $entry | |
316 | GenerateMenuSelect $menu | |
317 | } | |
318 | } | |
319 | right { | |
320 | set x [expr {[winfo rootx $w] + [winfo width $w]}] | |
321 | set y [expr {(2 * [winfo rooty $w] + [winfo height $w]) / 2}] | |
322 | set entry [MenuFindName $menu [$w cget -text]] | |
323 | if {[$w cget -indicatoron]} { | |
324 | if {$entry == [$menu index last]} { | |
325 | incr y [expr {-([$menu yposition $entry] \ | |
326 | + [winfo reqheight $menu])/2}] | |
327 | } else { | |
328 | incr y [expr {-([$menu yposition $entry] \ | |
329 | + [$menu yposition [expr {$entry+1}]])/2}] | |
330 | } | |
331 | } | |
332 | PostOverPoint $menu $x $y | |
333 | if {$entry ne "" \ | |
334 | && [$menu entrycget $entry -state] ne "disabled"} { | |
335 | $menu activate $entry | |
336 | GenerateMenuSelect $menu | |
337 | } | |
338 | } | |
339 | default { | |
340 | if {[$w cget -indicatoron]} { | |
341 | if {[string equal $y {}]} { | |
342 | set x [expr {[winfo rootx $w] + [winfo width $w]/2}] | |
343 | set y [expr {[winfo rooty $w] + [winfo height $w]/2}] | |
344 | } | |
345 | PostOverPoint $menu $x $y [MenuFindName $menu [$w cget -text]] | |
346 | } else { | |
347 | PostOverPoint $menu [winfo rootx $w] [expr {[winfo rooty $w]+[winfo height $w]}] | |
348 | } | |
349 | } | |
350 | } | |
351 | } msg]} { | |
352 | # Error posting menu (e.g. bogus -postcommand). Unpost it and | |
353 | # reflect the error. | |
354 | ||
355 | set savedInfo $errorInfo | |
356 | MenuUnpost {} | |
357 | error $msg $savedInfo | |
358 | ||
359 | } | |
360 | ||
361 | set Priv(tearoff) $tearoff | |
362 | if {$tearoff != 0} { | |
363 | focus $menu | |
364 | if {[winfo viewable $w]} { | |
365 | SaveGrabInfo $w | |
366 | grab -global $w | |
367 | } | |
368 | } | |
369 | } | |
370 | ||
371 | # ::tk::MenuUnpost -- | |
372 | # This procedure unposts a given menu, plus all of its ancestors up | |
373 | # to (and including) a menubutton, if any. It also restores various | |
374 | # values to what they were before the menu was posted, and releases | |
375 | # a grab if there's a menubutton involved. Special notes: | |
376 | # 1. It's important to unpost all menus before releasing the grab, so | |
377 | # that any Enter-Leave events (e.g. from menu back to main | |
378 | # application) have mode NotifyGrab. | |
379 | # 2. Be sure to enclose various groups of commands in "catch" so that | |
380 | # the procedure will complete even if the menubutton or the menu | |
381 | # or the grab window has been deleted. | |
382 | # | |
383 | # Arguments: | |
384 | # menu - Name of a menu to unpost. Ignored if there | |
385 | # is a posted menubutton. | |
386 | ||
387 | proc ::tk::MenuUnpost menu { | |
388 | global tcl_platform | |
389 | variable ::tk::Priv | |
390 | set mb $Priv(postedMb) | |
391 | ||
392 | # Restore focus right away (otherwise X will take focus away when | |
393 | # the menu is unmapped and under some window managers (e.g. olvwm) | |
394 | # we'll lose the focus completely). | |
395 | ||
396 | catch {focus $Priv(focus)} | |
397 | set Priv(focus) "" | |
398 | ||
399 | # Unpost menu(s) and restore some stuff that's dependent on | |
400 | # what was posted. | |
401 | ||
402 | catch { | |
403 | if {[string compare $mb ""]} { | |
404 | set menu [$mb cget -menu] | |
405 | $menu unpost | |
406 | set Priv(postedMb) {} | |
407 | $mb configure -cursor $Priv(cursor) | |
408 | $mb configure -relief $Priv(relief) | |
409 | } elseif {[string compare $Priv(popup) ""]} { | |
410 | $Priv(popup) unpost | |
411 | set Priv(popup) {} | |
412 | } elseif {[string compare [$menu cget -type] "menubar"] \ | |
413 | && [string compare [$menu cget -type] "tearoff"]} { | |
414 | # We're in a cascaded sub-menu from a torn-off menu or popup. | |
415 | # Unpost all the menus up to the toplevel one (but not | |
416 | # including the top-level torn-off one) and deactivate the | |
417 | # top-level torn off menu if there is one. | |
418 | ||
419 | while {1} { | |
420 | set parent [winfo parent $menu] | |
421 | if {[string compare [winfo class $parent] "Menu"] \ | |
422 | || ![winfo ismapped $parent]} { | |
423 | break | |
424 | } | |
425 | $parent activate none | |
426 | $parent postcascade none | |
427 | GenerateMenuSelect $parent | |
428 | set type [$parent cget -type] | |
429 | if {[string equal $type "menubar"] || \ | |
430 | [string equal $type "tearoff"]} { | |
431 | break | |
432 | } | |
433 | set menu $parent | |
434 | } | |
435 | if {[string compare [$menu cget -type] "menubar"]} { | |
436 | $menu unpost | |
437 | } | |
438 | } | |
439 | } | |
440 | ||
441 | if {($Priv(tearoff) != 0) || $Priv(menuBar) ne ""} { | |
442 | # Release grab, if any, and restore the previous grab, if there | |
443 | # was one. | |
444 | if {[string compare $menu ""]} { | |
445 | set grab [grab current $menu] | |
446 | if {[string compare $grab ""]} { | |
447 | grab release $grab | |
448 | } | |
449 | } | |
450 | RestoreOldGrab | |
451 | if {$Priv(menuBar) ne ""} { | |
452 | $Priv(menuBar) configure -cursor $Priv(cursor) | |
453 | set Priv(menuBar) {} | |
454 | } | |
455 | if {[tk windowingsystem] ne "x11"} { | |
456 | set Priv(tearoff) 0 | |
457 | } | |
458 | } | |
459 | } | |
460 | ||
461 | # ::tk::MbMotion -- | |
462 | # This procedure handles mouse motion events inside menubuttons, and | |
463 | # also outside menubuttons when a menubutton has a grab (e.g. when a | |
464 | # menu selection operation is in progress). | |
465 | # | |
466 | # Arguments: | |
467 | # w - The name of the menubutton widget. | |
468 | # upDown - "down" means button 1 is pressed, "up" means | |
469 | # it isn't. | |
470 | # rootx, rooty - Coordinates of mouse, in (virtual?) root window. | |
471 | ||
472 | proc ::tk::MbMotion {w upDown rootx rooty} { | |
473 | variable ::tk::Priv | |
474 | ||
475 | if {[string equal $Priv(inMenubutton) $w]} { | |
476 | return | |
477 | } | |
478 | set new [winfo containing $rootx $rooty] | |
479 | if {[string compare $new $Priv(inMenubutton)] \ | |
480 | && ([string equal $new ""] \ | |
481 | || [string equal [winfo toplevel $new] [winfo toplevel $w]])} { | |
482 | if {[string compare $Priv(inMenubutton) ""]} { | |
483 | MbLeave $Priv(inMenubutton) | |
484 | } | |
485 | if {[string compare $new ""] \ | |
486 | && [string equal [winfo class $new] "Menubutton"] \ | |
487 | && ([$new cget -indicatoron] == 0) \ | |
488 | && ([$w cget -indicatoron] == 0)} { | |
489 | if {[string equal $upDown "down"]} { | |
490 | MbPost $new $rootx $rooty | |
491 | } else { | |
492 | MbEnter $new | |
493 | } | |
494 | } | |
495 | } | |
496 | } | |
497 | ||
498 | # ::tk::MbButtonUp -- | |
499 | # This procedure is invoked to handle button 1 releases for menubuttons. | |
500 | # If the release happens inside the menubutton then leave its menu | |
501 | # posted with element 0 activated. Otherwise, unpost the menu. | |
502 | # | |
503 | # Arguments: | |
504 | # w - The name of the menubutton widget. | |
505 | ||
506 | proc ::tk::MbButtonUp w { | |
507 | variable ::tk::Priv | |
508 | global tcl_platform | |
509 | ||
510 | set menu [$w cget -menu] | |
511 | set tearoff [expr {[tk windowingsystem] eq "x11" || \ | |
512 | ($menu ne "" && [$menu cget -type] eq "tearoff")}] | |
513 | if {($tearoff != 0) && $Priv(postedMb) eq $w \ | |
514 | && $Priv(inMenubutton) eq $w} { | |
515 | MenuFirstEntry [$Priv(postedMb) cget -menu] | |
516 | } else { | |
517 | MenuUnpost {} | |
518 | } | |
519 | } | |
520 | ||
521 | # ::tk::MenuMotion -- | |
522 | # This procedure is called to handle mouse motion events for menus. | |
523 | # It does two things. First, it resets the active element in the | |
524 | # menu, if the mouse is over the menu. Second, if a mouse button | |
525 | # is down, it posts and unposts cascade entries to match the mouse | |
526 | # position. | |
527 | # | |
528 | # Arguments: | |
529 | # menu - The menu window. | |
530 | # x - The x position of the mouse. | |
531 | # y - The y position of the mouse. | |
532 | # state - Modifier state (tells whether buttons are down). | |
533 | ||
534 | proc ::tk::MenuMotion {menu x y state} { | |
535 | variable ::tk::Priv | |
536 | if {[string equal $menu $Priv(window)]} { | |
537 | if {[string equal [$menu cget -type] "menubar"]} { | |
538 | if {[info exists Priv(focus)] && \ | |
539 | [string compare $menu $Priv(focus)]} { | |
540 | $menu activate @$x,$y | |
541 | GenerateMenuSelect $menu | |
542 | } | |
543 | } else { | |
544 | $menu activate @$x,$y | |
545 | GenerateMenuSelect $menu | |
546 | } | |
547 | } | |
548 | if {($state & 0x1f00) != 0} { | |
549 | $menu postcascade active | |
550 | } | |
551 | } | |
552 | ||
553 | # ::tk::MenuButtonDown -- | |
554 | # Handles button presses in menus. There are a couple of tricky things | |
555 | # here: | |
556 | # 1. Change the posted cascade entry (if any) to match the mouse position. | |
557 | # 2. If there is a posted menubutton, must grab to the menubutton; this | |
558 | # overrrides the implicit grab on button press, so that the menu | |
559 | # button can track mouse motions over other menubuttons and change | |
560 | # the posted menu. | |
561 | # 3. If there's no posted menubutton (e.g. because we're a torn-off menu | |
562 | # or one of its descendants) must grab to the top-level menu so that | |
563 | # we can track mouse motions across the entire menu hierarchy. | |
564 | # | |
565 | # Arguments: | |
566 | # menu - The menu window. | |
567 | ||
568 | proc ::tk::MenuButtonDown menu { | |
569 | variable ::tk::Priv | |
570 | global tcl_platform | |
571 | ||
572 | if {![winfo viewable $menu]} { | |
573 | return | |
574 | } | |
575 | $menu postcascade active | |
576 | if {[string compare $Priv(postedMb) ""] && \ | |
577 | [winfo viewable $Priv(postedMb)]} { | |
578 | grab -global $Priv(postedMb) | |
579 | } else { | |
580 | while {[string equal [$menu cget -type] "normal"] \ | |
581 | && [string equal [winfo class [winfo parent $menu]] "Menu"] \ | |
582 | && [winfo ismapped [winfo parent $menu]]} { | |
583 | set menu [winfo parent $menu] | |
584 | } | |
585 | ||
586 | if {[string equal $Priv(menuBar) {}]} { | |
587 | set Priv(menuBar) $menu | |
588 | set Priv(cursor) [$menu cget -cursor] | |
589 | $menu configure -cursor arrow | |
590 | } | |
591 | ||
592 | # Don't update grab information if the grab window isn't changing. | |
593 | # Otherwise, we'll get an error when we unpost the menus and | |
594 | # restore the grab, since the old grab window will not be viewable | |
595 | # anymore. | |
596 | ||
597 | if {[string compare $menu [grab current $menu]]} { | |
598 | SaveGrabInfo $menu | |
599 | } | |
600 | ||
601 | # Must re-grab even if the grab window hasn't changed, in order | |
602 | # to release the implicit grab from the button press. | |
603 | ||
604 | if {[string equal [tk windowingsystem] "x11"]} { | |
605 | grab -global $menu | |
606 | } | |
607 | } | |
608 | } | |
609 | ||
610 | # ::tk::MenuLeave -- | |
611 | # This procedure is invoked to handle Leave events for a menu. It | |
612 | # deactivates everything unless the active element is a cascade element | |
613 | # and the mouse is now over the submenu. | |
614 | # | |
615 | # Arguments: | |
616 | # menu - The menu window. | |
617 | # rootx, rooty - Root coordinates of mouse. | |
618 | # state - Modifier state. | |
619 | ||
620 | proc ::tk::MenuLeave {menu rootx rooty state} { | |
621 | variable ::tk::Priv | |
622 | set Priv(window) {} | |
623 | if {[string equal [$menu index active] "none"]} { | |
624 | return | |
625 | } | |
626 | if {[string equal [$menu type active] "cascade"] | |
627 | && [string equal [winfo containing $rootx $rooty] \ | |
628 | [$menu entrycget active -menu]]} { | |
629 | return | |
630 | } | |
631 | $menu activate none | |
632 | GenerateMenuSelect $menu | |
633 | } | |
634 | ||
635 | # ::tk::MenuInvoke -- | |
636 | # This procedure is invoked when button 1 is released over a menu. | |
637 | # It invokes the appropriate menu action and unposts the menu if | |
638 | # it came from a menubutton. | |
639 | # | |
640 | # Arguments: | |
641 | # w - Name of the menu widget. | |
642 | # buttonRelease - 1 means this procedure is called because of | |
643 | # a button release; 0 means because of keystroke. | |
644 | ||
645 | proc ::tk::MenuInvoke {w buttonRelease} { | |
646 | variable ::tk::Priv | |
647 | ||
648 | if {$buttonRelease && [string equal $Priv(window) {}]} { | |
649 | # Mouse was pressed over a menu without a menu button, then | |
650 | # dragged off the menu (possibly with a cascade posted) and | |
651 | # released. Unpost everything and quit. | |
652 | ||
653 | $w postcascade none | |
654 | $w activate none | |
655 | event generate $w <<MenuSelect>> | |
656 | MenuUnpost $w | |
657 | return | |
658 | } | |
659 | if {[string equal [$w type active] "cascade"]} { | |
660 | $w postcascade active | |
661 | set menu [$w entrycget active -menu] | |
662 | MenuFirstEntry $menu | |
663 | } elseif {[string equal [$w type active] "tearoff"]} { | |
664 | ::tk::TearOffMenu $w | |
665 | MenuUnpost $w | |
666 | } elseif {[string equal [$w cget -type] "menubar"]} { | |
667 | $w postcascade none | |
668 | set active [$w index active] | |
669 | set isCascade [string equal [$w type $active] "cascade"] | |
670 | ||
671 | # Only de-activate the active item if it's a cascade; this prevents | |
672 | # the annoying "activation flicker" you otherwise get with | |
673 | # checkbuttons/commands/etc. on menubars | |
674 | ||
675 | if { $isCascade } { | |
676 | $w activate none | |
677 | event generate $w <<MenuSelect>> | |
678 | } | |
679 | ||
680 | MenuUnpost $w | |
681 | ||
682 | # If the active item is not a cascade, invoke it. This enables | |
683 | # the use of checkbuttons/commands/etc. on menubars (which is legal, | |
684 | # but not recommended) | |
685 | ||
686 | if { !$isCascade } { | |
687 | uplevel #0 [list $w invoke $active] | |
688 | } | |
689 | } else { | |
690 | set active [$w index active] | |
691 | if {$Priv(popup) eq "" || $active ne "none"} { | |
692 | MenuUnpost $w | |
693 | } | |
694 | uplevel #0 [list $w invoke active] | |
695 | } | |
696 | } | |
697 | ||
698 | # ::tk::MenuEscape -- | |
699 | # This procedure is invoked for the Cancel (or Escape) key. It unposts | |
700 | # the given menu and, if it is the top-level menu for a menu button, | |
701 | # unposts the menu button as well. | |
702 | # | |
703 | # Arguments: | |
704 | # menu - Name of the menu window. | |
705 | ||
706 | proc ::tk::MenuEscape menu { | |
707 | set parent [winfo parent $menu] | |
708 | if {[string compare [winfo class $parent] "Menu"]} { | |
709 | MenuUnpost $menu | |
710 | } elseif {[string equal [$parent cget -type] "menubar"]} { | |
711 | MenuUnpost $menu | |
712 | RestoreOldGrab | |
713 | } else { | |
714 | MenuNextMenu $menu left | |
715 | } | |
716 | } | |
717 | ||
718 | # The following routines handle arrow keys. Arrow keys behave | |
719 | # differently depending on whether the menu is a menu bar or not. | |
720 | ||
721 | proc ::tk::MenuUpArrow {menu} { | |
722 | if {[string equal [$menu cget -type] "menubar"]} { | |
723 | MenuNextMenu $menu left | |
724 | } else { | |
725 | MenuNextEntry $menu -1 | |
726 | } | |
727 | } | |
728 | ||
729 | proc ::tk::MenuDownArrow {menu} { | |
730 | if {[string equal [$menu cget -type] "menubar"]} { | |
731 | MenuNextMenu $menu right | |
732 | } else { | |
733 | MenuNextEntry $menu 1 | |
734 | } | |
735 | } | |
736 | ||
737 | proc ::tk::MenuLeftArrow {menu} { | |
738 | if {[string equal [$menu cget -type] "menubar"]} { | |
739 | MenuNextEntry $menu -1 | |
740 | } else { | |
741 | MenuNextMenu $menu left | |
742 | } | |
743 | } | |
744 | ||
745 | proc ::tk::MenuRightArrow {menu} { | |
746 | if {[string equal [$menu cget -type] "menubar"]} { | |
747 | MenuNextEntry $menu 1 | |
748 | } else { | |
749 | MenuNextMenu $menu right | |
750 | } | |
751 | } | |
752 | ||
753 | # ::tk::MenuNextMenu -- | |
754 | # This procedure is invoked to handle "left" and "right" traversal | |
755 | # motions in menus. It traverses to the next menu in a menu bar, | |
756 | # or into or out of a cascaded menu. | |
757 | # | |
758 | # Arguments: | |
759 | # menu - The menu that received the keyboard | |
760 | # event. | |
761 | # direction - Direction in which to move: "left" or "right" | |
762 | ||
763 | proc ::tk::MenuNextMenu {menu direction} { | |
764 | variable ::tk::Priv | |
765 | ||
766 | # First handle traversals into and out of cascaded menus. | |
767 | ||
768 | if {[string equal $direction "right"]} { | |
769 | set count 1 | |
770 | set parent [winfo parent $menu] | |
771 | set class [winfo class $parent] | |
772 | if {[string equal [$menu type active] "cascade"]} { | |
773 | $menu postcascade active | |
774 | set m2 [$menu entrycget active -menu] | |
775 | if {[string compare $m2 ""]} { | |
776 | MenuFirstEntry $m2 | |
777 | } | |
778 | return | |
779 | } else { | |
780 | set parent [winfo parent $menu] | |
781 | while {[string compare $parent "."]} { | |
782 | if {[string equal [winfo class $parent] "Menu"] \ | |
783 | && [string equal [$parent cget -type] "menubar"]} { | |
784 | tk_menuSetFocus $parent | |
785 | MenuNextEntry $parent 1 | |
786 | return | |
787 | } | |
788 | set parent [winfo parent $parent] | |
789 | } | |
790 | } | |
791 | } else { | |
792 | set count -1 | |
793 | set m2 [winfo parent $menu] | |
794 | if {[string equal [winfo class $m2] "Menu"]} { | |
795 | $menu activate none | |
796 | GenerateMenuSelect $menu | |
797 | tk_menuSetFocus $m2 | |
798 | ||
799 | $m2 postcascade none | |
800 | ||
801 | if {[string compare [$m2 cget -type] "menubar"]} { | |
802 | return | |
803 | } | |
804 | } | |
805 | } | |
806 | ||
807 | # Can't traverse into or out of a cascaded menu. Go to the next | |
808 | # or previous menubutton, if that makes sense. | |
809 | ||
810 | set m2 [winfo parent $menu] | |
811 | if {[string equal [winfo class $m2] "Menu"]} { | |
812 | if {[string equal [$m2 cget -type] "menubar"]} { | |
813 | tk_menuSetFocus $m2 | |
814 | MenuNextEntry $m2 -1 | |
815 | return | |
816 | } | |
817 | } | |
818 | ||
819 | set w $Priv(postedMb) | |
820 | if {[string equal $w ""]} { | |
821 | return | |
822 | } | |
823 | set buttons [winfo children [winfo parent $w]] | |
824 | set length [llength $buttons] | |
825 | set i [expr {[lsearch -exact $buttons $w] + $count}] | |
826 | while {1} { | |
827 | while {$i < 0} { | |
828 | incr i $length | |
829 | } | |
830 | while {$i >= $length} { | |
831 | incr i -$length | |
832 | } | |
833 | set mb [lindex $buttons $i] | |
834 | if {[string equal [winfo class $mb] "Menubutton"] \ | |
835 | && [string compare [$mb cget -state] "disabled"] \ | |
836 | && [string compare [$mb cget -menu] ""] \ | |
837 | && [string compare [[$mb cget -menu] index last] "none"]} { | |
838 | break | |
839 | } | |
840 | if {[string equal $mb $w]} { | |
841 | return | |
842 | } | |
843 | incr i $count | |
844 | } | |
845 | MbPost $mb | |
846 | MenuFirstEntry [$mb cget -menu] | |
847 | } | |
848 | ||
849 | # ::tk::MenuNextEntry -- | |
850 | # Activate the next higher or lower entry in the posted menu, | |
851 | # wrapping around at the ends. Disabled entries are skipped. | |
852 | # | |
853 | # Arguments: | |
854 | # menu - Menu window that received the keystroke. | |
855 | # count - 1 means go to the next lower entry, | |
856 | # -1 means go to the next higher entry. | |
857 | ||
858 | proc ::tk::MenuNextEntry {menu count} { | |
859 | ||
860 | if {[string equal [$menu index last] "none"]} { | |
861 | return | |
862 | } | |
863 | set length [expr {[$menu index last]+1}] | |
864 | set quitAfter $length | |
865 | set active [$menu index active] | |
866 | if {[string equal $active "none"]} { | |
867 | set i 0 | |
868 | } else { | |
869 | set i [expr {$active + $count}] | |
870 | } | |
871 | while {1} { | |
872 | if {$quitAfter <= 0} { | |
873 | # We've tried every entry in the menu. Either there are | |
874 | # none, or they're all disabled. Just give up. | |
875 | ||
876 | return | |
877 | } | |
878 | while {$i < 0} { | |
879 | incr i $length | |
880 | } | |
881 | while {$i >= $length} { | |
882 | incr i -$length | |
883 | } | |
884 | if {[catch {$menu entrycget $i -state} state] == 0} { | |
885 | if {$state ne "disabled" && \ | |
886 | ($i!=0 || [$menu cget -type] ne "tearoff" \ | |
887 | || [$menu type 0] ne "tearoff")} { | |
888 | break | |
889 | } | |
890 | } | |
891 | if {$i == $active} { | |
892 | return | |
893 | } | |
894 | incr i $count | |
895 | incr quitAfter -1 | |
896 | } | |
897 | $menu activate $i | |
898 | GenerateMenuSelect $menu | |
899 | ||
900 | if {[string equal [$menu type $i] "cascade"] \ | |
901 | && [string equal [$menu cget -type] "menubar"]} { | |
902 | set cascade [$menu entrycget $i -menu] | |
903 | if {[string compare $cascade ""]} { | |
904 | # Here we auto-post a cascade. This is necessary when | |
905 | # we traverse left/right in the menubar, but undesirable when | |
906 | # we traverse up/down in a menu. | |
907 | $menu postcascade $i | |
908 | MenuFirstEntry $cascade | |
909 | } | |
910 | } | |
911 | } | |
912 | ||
913 | # ::tk::MenuFind -- | |
914 | # This procedure searches the entire window hierarchy under w for | |
915 | # a menubutton that isn't disabled and whose underlined character | |
916 | # is "char" or an entry in a menubar that isn't disabled and whose | |
917 | # underlined character is "char". | |
918 | # It returns the name of that window, if found, or an | |
919 | # empty string if no matching window was found. If "char" is an | |
920 | # empty string then the procedure returns the name of the first | |
921 | # menubutton found that isn't disabled. | |
922 | # | |
923 | # Arguments: | |
924 | # w - Name of window where key was typed. | |
925 | # char - Underlined character to search for; | |
926 | # may be either upper or lower case, and | |
927 | # will match either upper or lower case. | |
928 | ||
929 | proc ::tk::MenuFind {w char} { | |
930 | set char [string tolower $char] | |
931 | set windowlist [winfo child $w] | |
932 | ||
933 | foreach child $windowlist { | |
934 | # Don't descend into other toplevels. | |
935 | if {[string compare [winfo toplevel $w] [winfo toplevel $child]]} { | |
936 | continue | |
937 | } | |
938 | if {[string equal [winfo class $child] "Menu"] && \ | |
939 | [string equal [$child cget -type] "menubar"]} { | |
940 | if {[string equal $char ""]} { | |
941 | return $child | |
942 | } | |
943 | set last [$child index last] | |
944 | for {set i [$child cget -tearoff]} {$i <= $last} {incr i} { | |
945 | if {[string equal [$child type $i] "separator"]} { | |
946 | continue | |
947 | } | |
948 | set char2 [string index [$child entrycget $i -label] \ | |
949 | [$child entrycget $i -underline]] | |
950 | if {[string equal $char [string tolower $char2]] \ | |
951 | || [string equal $char ""]} { | |
952 | if {[string compare [$child entrycget $i -state] "disabled"]} { | |
953 | return $child | |
954 | } | |
955 | } | |
956 | } | |
957 | } | |
958 | } | |
959 | ||
960 | foreach child $windowlist { | |
961 | # Don't descend into other toplevels. | |
962 | if {[string compare [winfo toplevel $w] [winfo toplevel $child]]} { | |
963 | continue | |
964 | } | |
965 | switch [winfo class $child] { | |
966 | Menubutton { | |
967 | set char2 [string index [$child cget -text] \ | |
968 | [$child cget -underline]] | |
969 | if {[string equal $char [string tolower $char2]] \ | |
970 | || [string equal $char ""]} { | |
971 | if {[string compare [$child cget -state] "disabled"]} { | |
972 | return $child | |
973 | } | |
974 | } | |
975 | } | |
976 | ||
977 | default { | |
978 | set match [MenuFind $child $char] | |
979 | if {[string compare $match ""]} { | |
980 | return $match | |
981 | } | |
982 | } | |
983 | } | |
984 | } | |
985 | return {} | |
986 | } | |
987 | ||
988 | # ::tk::TraverseToMenu -- | |
989 | # This procedure implements keyboard traversal of menus. Given an | |
990 | # ASCII character "char", it looks for a menubutton with that character | |
991 | # underlined. If one is found, it posts the menubutton's menu | |
992 | # | |
993 | # Arguments: | |
994 | # w - Window in which the key was typed (selects | |
995 | # a toplevel window). | |
996 | # char - Character that selects a menu. The case | |
997 | # is ignored. If an empty string, nothing | |
998 | # happens. | |
999 | ||
1000 | proc ::tk::TraverseToMenu {w char} { | |
1001 | variable ::tk::Priv | |
1002 | if {[string equal $char ""]} { | |
1003 | return | |
1004 | } | |
1005 | while {[string equal [winfo class $w] "Menu"]} { | |
1006 | if {[string compare [$w cget -type] "menubar"] \ | |
1007 | && [string equal $Priv(postedMb) ""]} { | |
1008 | return | |
1009 | } | |
1010 | if {[string equal [$w cget -type] "menubar"]} { | |
1011 | break | |
1012 | } | |
1013 | set w [winfo parent $w] | |
1014 | } | |
1015 | set w [MenuFind [winfo toplevel $w] $char] | |
1016 | if {[string compare $w ""]} { | |
1017 | if {[string equal [winfo class $w] "Menu"]} { | |
1018 | tk_menuSetFocus $w | |
1019 | set Priv(window) $w | |
1020 | SaveGrabInfo $w | |
1021 | grab -global $w | |
1022 | TraverseWithinMenu $w $char | |
1023 | } else { | |
1024 | MbPost $w | |
1025 | MenuFirstEntry [$w cget -menu] | |
1026 | } | |
1027 | } | |
1028 | } | |
1029 | ||
1030 | # ::tk::FirstMenu -- | |
1031 | # This procedure traverses to the first menubutton in the toplevel | |
1032 | # for a given window, and posts that menubutton's menu. | |
1033 | # | |
1034 | # Arguments: | |
1035 | # w - Name of a window. Selects which toplevel | |
1036 | # to search for menubuttons. | |
1037 | ||
1038 | proc ::tk::FirstMenu w { | |
1039 | variable ::tk::Priv | |
1040 | set w [MenuFind [winfo toplevel $w] ""] | |
1041 | if {[string compare $w ""]} { | |
1042 | if {[string equal [winfo class $w] "Menu"]} { | |
1043 | tk_menuSetFocus $w | |
1044 | set Priv(window) $w | |
1045 | SaveGrabInfo $w | |
1046 | grab -global $w | |
1047 | MenuFirstEntry $w | |
1048 | } else { | |
1049 | MbPost $w | |
1050 | MenuFirstEntry [$w cget -menu] | |
1051 | } | |
1052 | } | |
1053 | } | |
1054 | ||
1055 | # ::tk::TraverseWithinMenu | |
1056 | # This procedure implements keyboard traversal within a menu. It | |
1057 | # searches for an entry in the menu that has "char" underlined. If | |
1058 | # such an entry is found, it is invoked and the menu is unposted. | |
1059 | # | |
1060 | # Arguments: | |
1061 | # w - The name of the menu widget. | |
1062 | # char - The character to look for; case is | |
1063 | # ignored. If the string is empty then | |
1064 | # nothing happens. | |
1065 | ||
1066 | proc ::tk::TraverseWithinMenu {w char} { | |
1067 | if {[string equal $char ""]} { | |
1068 | return | |
1069 | } | |
1070 | set char [string tolower $char] | |
1071 | set last [$w index last] | |
1072 | if {[string equal $last "none"]} { | |
1073 | return | |
1074 | } | |
1075 | for {set i 0} {$i <= $last} {incr i} { | |
1076 | if {[catch {set char2 [string index \ | |
1077 | [$w entrycget $i -label] [$w entrycget $i -underline]]}]} { | |
1078 | continue | |
1079 | } | |
1080 | if {[string equal $char [string tolower $char2]]} { | |
1081 | if {[string equal [$w type $i] "cascade"]} { | |
1082 | $w activate $i | |
1083 | $w postcascade active | |
1084 | event generate $w <<MenuSelect>> | |
1085 | set m2 [$w entrycget $i -menu] | |
1086 | if {[string compare $m2 ""]} { | |
1087 | MenuFirstEntry $m2 | |
1088 | } | |
1089 | } else { | |
1090 | MenuUnpost $w | |
1091 | uplevel #0 [list $w invoke $i] | |
1092 | } | |
1093 | return | |
1094 | } | |
1095 | } | |
1096 | } | |
1097 | ||
1098 | # ::tk::MenuFirstEntry -- | |
1099 | # Given a menu, this procedure finds the first entry that isn't | |
1100 | # disabled or a tear-off or separator, and activates that entry. | |
1101 | # However, if there is already an active entry in the menu (e.g., | |
1102 | # because of a previous call to tk::PostOverPoint) then the active | |
1103 | # entry isn't changed. This procedure also sets the input focus | |
1104 | # to the menu. | |
1105 | # | |
1106 | # Arguments: | |
1107 | # menu - Name of the menu window (possibly empty). | |
1108 | ||
1109 | proc ::tk::MenuFirstEntry menu { | |
1110 | if {[string equal $menu ""]} { | |
1111 | return | |
1112 | } | |
1113 | tk_menuSetFocus $menu | |
1114 | if {[string compare [$menu index active] "none"]} { | |
1115 | return | |
1116 | } | |
1117 | set last [$menu index last] | |
1118 | if {[string equal $last "none"]} { | |
1119 | return | |
1120 | } | |
1121 | for {set i 0} {$i <= $last} {incr i} { | |
1122 | if {([catch {set state [$menu entrycget $i -state]}] == 0) \ | |
1123 | && [string compare $state "disabled"] \ | |
1124 | && [string compare [$menu type $i] "tearoff"]} { | |
1125 | $menu activate $i | |
1126 | GenerateMenuSelect $menu | |
1127 | # Only post the cascade if the current menu is a menubar; | |
1128 | # otherwise, if the first entry of the cascade is a cascade, | |
1129 | # we can get an annoying cascading effect resulting in a bunch of | |
1130 | # menus getting posted (bug 676) | |
1131 | if {[string equal [$menu type $i] "cascade"] && \ | |
1132 | [string equal [$menu cget -type] "menubar"]} { | |
1133 | set cascade [$menu entrycget $i -menu] | |
1134 | if {[string compare $cascade ""]} { | |
1135 | $menu postcascade $i | |
1136 | MenuFirstEntry $cascade | |
1137 | } | |
1138 | } | |
1139 | return | |
1140 | } | |
1141 | } | |
1142 | } | |
1143 | ||
1144 | # ::tk::MenuFindName -- | |
1145 | # Given a menu and a text string, return the index of the menu entry | |
1146 | # that displays the string as its label. If there is no such entry, | |
1147 | # return an empty string. This procedure is tricky because some names | |
1148 | # like "active" have a special meaning in menu commands, so we can't | |
1149 | # always use the "index" widget command. | |
1150 | # | |
1151 | # Arguments: | |
1152 | # menu - Name of the menu widget. | |
1153 | # s - String to look for. | |
1154 | ||
1155 | proc ::tk::MenuFindName {menu s} { | |
1156 | set i "" | |
1157 | if {![regexp {^active$|^last$|^none$|^[0-9]|^@} $s]} { | |
1158 | catch {set i [$menu index $s]} | |
1159 | return $i | |
1160 | } | |
1161 | set last [$menu index last] | |
1162 | if {[string equal $last "none"]} { | |
1163 | return | |
1164 | } | |
1165 | for {set i 0} {$i <= $last} {incr i} { | |
1166 | if {![catch {$menu entrycget $i -label} label]} { | |
1167 | if {[string equal $label $s]} { | |
1168 | return $i | |
1169 | } | |
1170 | } | |
1171 | } | |
1172 | return "" | |
1173 | } | |
1174 | ||
1175 | # ::tk::PostOverPoint -- | |
1176 | # This procedure posts a given menu such that a given entry in the | |
1177 | # menu is centered over a given point in the root window. It also | |
1178 | # activates the given entry. | |
1179 | # | |
1180 | # Arguments: | |
1181 | # menu - Menu to post. | |
1182 | # x, y - Root coordinates of point. | |
1183 | # entry - Index of entry within menu to center over (x,y). | |
1184 | # If omitted or specified as {}, then the menu's | |
1185 | # upper-left corner goes at (x,y). | |
1186 | ||
1187 | proc ::tk::PostOverPoint {menu x y {entry {}}} { | |
1188 | global tcl_platform | |
1189 | ||
1190 | if {[string compare $entry {}]} { | |
1191 | if {$entry == [$menu index last]} { | |
1192 | incr y [expr {-([$menu yposition $entry] \ | |
1193 | + [winfo reqheight $menu])/2}] | |
1194 | } else { | |
1195 | incr y [expr {-([$menu yposition $entry] \ | |
1196 | + [$menu yposition [expr {$entry+1}]])/2}] | |
1197 | } | |
1198 | incr x [expr {-[winfo reqwidth $menu]/2}] | |
1199 | } | |
1200 | if {$tcl_platform(platform) == "windows"} { | |
1201 | # We need to fix some problems with menu posting on Windows. | |
1202 | set yoffset [expr {[winfo screenheight $menu] \ | |
1203 | - $y - [winfo reqheight $menu]}] | |
1204 | if {$yoffset < 0} { | |
1205 | # The bottom of the menu is offscreen, so adjust upwards | |
1206 | incr y $yoffset | |
1207 | if {$y < 0} { set y 0 } | |
1208 | } | |
1209 | # If we're off the top of the screen (either because we were | |
1210 | # originally or because we just adjusted too far upwards), | |
1211 | # then make the menu popup on the top edge. | |
1212 | if {$y < 0} { | |
1213 | set y 0 | |
1214 | } | |
1215 | } | |
1216 | $menu post $x $y | |
1217 | if {$entry ne "" && [$menu entrycget $entry -state] ne "disabled"} { | |
1218 | $menu activate $entry | |
1219 | GenerateMenuSelect $menu | |
1220 | } | |
1221 | } | |
1222 | ||
1223 | # ::tk::SaveGrabInfo -- | |
1224 | # Sets the variables tk::Priv(oldGrab) and tk::Priv(grabStatus) to record | |
1225 | # the state of any existing grab on the w's display. | |
1226 | # | |
1227 | # Arguments: | |
1228 | # w - Name of a window; used to select the display | |
1229 | # whose grab information is to be recorded. | |
1230 | ||
1231 | proc tk::SaveGrabInfo w { | |
1232 | variable ::tk::Priv | |
1233 | set Priv(oldGrab) [grab current $w] | |
1234 | if {$Priv(oldGrab) ne ""} { | |
1235 | set Priv(grabStatus) [grab status $Priv(oldGrab)] | |
1236 | } | |
1237 | } | |
1238 | ||
1239 | # ::tk::RestoreOldGrab -- | |
1240 | # Restores the grab to what it was before TkSaveGrabInfo was called. | |
1241 | # | |
1242 | ||
1243 | proc ::tk::RestoreOldGrab {} { | |
1244 | variable ::tk::Priv | |
1245 | ||
1246 | if {$Priv(oldGrab) ne ""} { | |
1247 | # Be careful restoring the old grab, since it's window may not | |
1248 | # be visible anymore. | |
1249 | ||
1250 | catch { | |
1251 | if {[string equal $Priv(grabStatus) "global"]} { | |
1252 | grab set -global $Priv(oldGrab) | |
1253 | } else { | |
1254 | grab set $Priv(oldGrab) | |
1255 | } | |
1256 | } | |
1257 | set Priv(oldGrab) "" | |
1258 | } | |
1259 | } | |
1260 | ||
1261 | proc ::tk_menuSetFocus {menu} { | |
1262 | variable ::tk::Priv | |
1263 | if {![info exists Priv(focus)] || [string equal $Priv(focus) {}]} { | |
1264 | set Priv(focus) [focus] | |
1265 | } | |
1266 | focus $menu | |
1267 | } | |
1268 | ||
1269 | proc ::tk::GenerateMenuSelect {menu} { | |
1270 | variable ::tk::Priv | |
1271 | ||
1272 | if {[string equal $Priv(activeMenu) $menu] \ | |
1273 | && [string equal $Priv(activeItem) [$menu index active]]} { | |
1274 | return | |
1275 | } | |
1276 | ||
1277 | set Priv(activeMenu) $menu | |
1278 | set Priv(activeItem) [$menu index active] | |
1279 | event generate $menu <<MenuSelect>> | |
1280 | } | |
1281 | ||
1282 | # ::tk_popup -- | |
1283 | # This procedure pops up a menu and sets things up for traversing | |
1284 | # the menu and its submenus. | |
1285 | # | |
1286 | # Arguments: | |
1287 | # menu - Name of the menu to be popped up. | |
1288 | # x, y - Root coordinates at which to pop up the | |
1289 | # menu. | |
1290 | # entry - Index of a menu entry to center over (x,y). | |
1291 | # If omitted or specified as {}, then menu's | |
1292 | # upper-left corner goes at (x,y). | |
1293 | ||
1294 | proc ::tk_popup {menu x y {entry {}}} { | |
1295 | variable ::tk::Priv | |
1296 | global tcl_platform | |
1297 | if {$Priv(popup) ne "" || $Priv(postedMb) ne ""} { | |
1298 | tk::MenuUnpost {} | |
1299 | } | |
1300 | tk::PostOverPoint $menu $x $y $entry | |
1301 | if {[tk windowingsystem] eq "x11" && [winfo viewable $menu]} { | |
1302 | tk::SaveGrabInfo $menu | |
1303 | grab -global $menu | |
1304 | set Priv(popup) $menu | |
1305 | tk_menuSetFocus $menu | |
1306 | } | |
1307 | } |