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.
7 # Copyright (c) 1992-1994 The Regents of the University of California.
8 # Copyright (c) 1994-1997 Sun Microsystems, Inc.
9 # Copyright (c) 1998-1999 by Scriptics Corporation.
10 # Copyright (c) 2007 Daniel A. Steffen <das@users.sourceforge.net>
12 # See the file "license.terms" for information on usage and redistribution
13 # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
16 #-------------------------------------------------------------------------
17 # Elements of tk::Priv that are used in this file:
19 # cursor - Saves the -cursor option for the posted menubutton.
20 # focus - Saves the focus during a menu selection operation.
21 # Focus gets restored here when the menu is unposted.
22 # grabGlobal - Used in conjunction with tk::Priv(oldGrab): if
23 # tk::Priv(oldGrab) is non-empty, then tk::Priv(grabGlobal)
24 # contains either an empty string or "-global" to
25 # indicate whether the old grab was a local one or
27 # inMenubutton - The name of the menubutton widget containing
28 # the mouse, or an empty string if the mouse is
29 # not over any menubutton.
30 # menuBar - The name of the menubar that is the root
31 # of the cascade hierarchy which is currently
32 # posted. This is null when there is no menu currently
33 # being pulled down from a menu bar.
34 # oldGrab - Window that had the grab before a menu was posted.
35 # Used to restore the grab state after the menu
36 # is unposted. Empty string means there was no
37 # grab previously set.
38 # popup - If a menu has been popped up via tk_popup, this
39 # gives the name of the menu. Otherwise this
41 # postedMb - Name of the menubutton whose menu is currently
42 # posted, or an empty string if nothing is posted
43 # A grab is set on this widget.
44 # relief - Used to save the original relief of the current
46 # window - When the mouse is over a menu, this holds the
47 # name of the menu; it's cleared when the mouse
49 # tearoff - Whether the last menu posted was a tearoff or not.
50 # This is true always for unix, for tearoffs for Mac
52 # activeMenu - This is the last active menu for use
53 # with the <<MenuSelect>> virtual event.
54 # activeItem - This is the last active menu item for
55 # use with the <<MenuSelect>> virtual event.
56 #-------------------------------------------------------------------------
58 #-------------------------------------------------------------------------
60 # This file is tricky because there are five different ways that menus
63 # 1. As a pulldown from a menubutton. In this style, the variable
64 # tk::Priv(postedMb) identifies the posted menubutton.
65 # 2. As a torn-off menu copied from some other menu. In this style
66 # tk::Priv(postedMb) is empty, and menu's type is "tearoff".
67 # 3. As an option menu, triggered from an option menubutton. In this
68 # style tk::Priv(postedMb) identifies the posted menubutton.
69 # 4. As a popup menu. In this style tk::Priv(postedMb) is empty and
70 # the top-level menu's type is "normal".
71 # 5. As a pulldown from a menubar. The variable tk::Priv(menubar) has
72 # the owning menubar, and the menu itself is of type "normal".
74 # The various binding procedures use the state described above to
75 # distinguish the various cases and take different actions in each
77 #-------------------------------------------------------------------------
79 #-------------------------------------------------------------------------
80 # The code below creates the default class bindings for menus
82 #-------------------------------------------------------------------------
84 bind Menubutton
<FocusIn
> {}
85 bind Menubutton
<Enter
> {
88 bind Menubutton
<Leave
> {
92 if {$tk::Priv(inMenubutton
) ne
""} {
93 tk::MbPost $tk::Priv(inMenubutton
) %X
%Y
96 bind Menubutton
<Motion
> {
97 tk::MbMotion %W up
%X
%Y
99 bind Menubutton
<B1-Motion
> {
100 tk::MbMotion %W down
%X
%Y
102 bind Menubutton
<ButtonRelease-1
> {
105 bind Menubutton
<space
> {
107 tk::MenuFirstEntry [%W cget
-menu]
110 # Must set focus when mouse enters a menu, in order to allow
111 # mixed-mode processing using both the mouse and the keyboard.
112 # Don't set the focus if the event comes from a grab release,
113 # though: such an event can happen after as part of unposting
114 # a cascaded chain of menus, after the focus has already been
115 # restored to wherever it was before menu selection started.
117 bind Menu
<FocusIn
> {}
120 set tk::Priv(window
) %W
121 if {[%W cget
-type] eq
"tearoff"} {
122 if {"%m" ne
"NotifyUngrab"} {
123 if {[tk windowingsystem
] eq
"x11"} {
128 tk::MenuMotion %W
%x
%y
%s
132 tk::MenuLeave %W
%X
%Y
%s
135 tk::MenuMotion %W
%x
%y
%s
137 bind Menu
<ButtonPress
> {
138 tk::MenuButtonDown %W
140 bind Menu
<ButtonRelease
> {
156 tk::MenuRightArrow %W
164 bind Menu
<KeyPress
> {
165 tk::TraverseWithinMenu %W
%A
168 # The following bindings apply to all windows, and are used to
169 # implement keyboard menu traversal.
171 if {[tk windowingsystem
] eq
"x11"} {
172 bind all
<Alt-KeyPress
> {
173 tk::TraverseToMenu %W
%A
180 bind Menubutton
<Alt-KeyPress
> {
181 tk::TraverseToMenu %W
%A
184 bind Menubutton
<F10
> {
190 # This procedure is invoked when the mouse enters a menubutton
191 # widget. It activates the widget unless it is disabled. Note:
192 # this procedure is only invoked when mouse button 1 is *not* down.
193 # The procedure ::tk::MbB1Enter is invoked if the button is down.
196 # w - The name of the widget.
198 proc ::tk::MbEnter w
{
201 if {$Priv(inMenubutton
) ne
""} {
202 MbLeave
$Priv(inMenubutton
)
204 set Priv
(inMenubutton
) $w
205 if {[$w cget
-state] ne
"disabled" && [tk windowingsystem
] ne
"aqua"} {
206 $w configure
-state active
211 # This procedure is invoked when the mouse leaves a menubutton widget.
212 # It de-activates the widget, if the widget still exists.
215 # w - The name of the widget.
217 proc ::tk::MbLeave w
{
220 set Priv
(inMenubutton
) {}
221 if {![winfo exists
$w]} {
224 if {[$w cget
-state] eq
"active" && [tk windowingsystem
] ne
"aqua"} {
225 $w configure
-state normal
230 # Given a menubutton, this procedure does all the work of posting
231 # its associated menu and unposting any other menu that is currently
235 # w - The name of the menubutton widget whose menu
237 # x, y - Root coordinates of cursor, used for positioning
238 # option menus. If not specified, then the center
239 # of the menubutton is used for an option menu.
241 proc ::tk::MbPost {w
{x
{}} {y
{}}} {
246 if {[$w cget
-state] eq
"disabled" ||
$w eq
$Priv(postedMb
)} {
249 set menu [$w cget
-menu]
253 set tearoff
[expr {[tk windowingsystem
] eq
"x11" \
254 ||
[$menu cget
-type] eq
"tearoff"}]
255 if {[string first
$w $menu] != 0} {
256 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 set cur
$Priv(postedMb
)
262 if {$::tk_strictMotif} {
263 set Priv
(cursor
) [$w cget
-cursor]
264 $w configure
-cursor arrow
266 if {[tk windowingsystem
] ne
"aqua"} {
267 set Priv
(relief
) [$w cget
-relief]
268 $w configure
-relief raised
270 $w configure
-state active
273 set Priv
(postedMb
) $w
274 set Priv
(focus) [focus]
276 GenerateMenuSelect
$menu
278 # If this looks like an option menubutton then post the menu so
279 # that the current entry is on top of the mouse. Otherwise post
280 # the menu just below the menubutton, as for a pull-down.
284 switch [$w cget
-direction] {
286 set x
[winfo rootx
$w]
287 set y
[expr {[winfo rooty
$w] - [winfo reqheight
$menu]}]
288 # if we go offscreen to the top, show as 'below'
289 if {$y < [winfo vrooty
$w]} {
290 set y
[expr {[winfo vrooty
$w] + [winfo rooty
$w] + [winfo reqheight
$w]}]
292 PostOverPoint
$menu $x $y
295 set x
[winfo rootx
$w]
296 set y
[expr {[winfo rooty
$w] + [winfo height
$w]}]
297 # if we go offscreen to the bottom, show as 'above'
298 set mh
[winfo reqheight
$menu]
299 if {($y + $mh) > ([winfo vrooty
$w] + [winfo vrootheight
$w])} {
300 set y
[expr {[winfo vrooty
$w] + [winfo vrootheight
$w] + [winfo rooty
$w] - $mh}]
302 PostOverPoint
$menu $x $y
305 set x
[expr {[winfo rootx
$w] - [winfo reqwidth
$menu]}]
306 set y
[expr {(2 * [winfo rooty
$w] + [winfo height
$w]) / 2}]
307 set entry [MenuFindName
$menu [$w cget
-text]]
308 if {[$w cget
-indicatoron]} {
309 if {$entry == [$menu index last
]} {
310 incr y
[expr {-([$menu yposition
$entry] \
311 + [winfo reqheight
$menu])/2}]
313 incr y
[expr {-([$menu yposition
$entry] \
314 + [$menu yposition
[expr {$entry+1}]])/2}]
317 PostOverPoint
$menu $x $y
319 && [$menu entrycget
$entry -state] ne
"disabled"} {
320 $menu activate
$entry
321 GenerateMenuSelect
$menu
325 set x
[expr {[winfo rootx
$w] + [winfo width
$w]}]
326 set y
[expr {(2 * [winfo rooty
$w] + [winfo height
$w]) / 2}]
327 set entry [MenuFindName
$menu [$w cget
-text]]
328 if {[$w cget
-indicatoron]} {
329 if {$entry == [$menu index last
]} {
330 incr y
[expr {-([$menu yposition
$entry] \
331 + [winfo reqheight
$menu])/2}]
333 incr y
[expr {-([$menu yposition
$entry] \
334 + [$menu yposition
[expr {$entry+1}]])/2}]
337 PostOverPoint
$menu $x $y
339 && [$menu entrycget
$entry -state] ne
"disabled"} {
340 $menu activate
$entry
341 GenerateMenuSelect
$menu
345 if {[$w cget
-indicatoron]} {
347 set x
[expr {[winfo rootx
$w] + [winfo width
$w]/2}]
348 set y
[expr {[winfo rooty
$w] + [winfo height
$w]/2}]
350 PostOverPoint
$menu $x $y [MenuFindName
$menu [$w cget
-text]]
352 PostOverPoint
$menu [winfo rootx
$w] [expr {[winfo rooty
$w]+[winfo height
$w]}]
357 # Error posting menu (e.g. bogus -postcommand). Unpost it and
360 set savedInfo
$errorInfo
362 error $msg $savedInfo
366 set Priv
(tearoff
) $tearoff
369 if {[winfo viewable
$w]} {
376 # ::tk::MenuUnpost --
377 # This procedure unposts a given menu, plus all of its ancestors up
378 # to (and including) a menubutton, if any. It also restores various
379 # values to what they were before the menu was posted, and releases
380 # a grab if there's a menubutton involved. Special notes:
381 # 1. It's important to unpost all menus before releasing the grab, so
382 # that any Enter-Leave events (e.g. from menu back to main
383 # application) have mode NotifyGrab.
384 # 2. Be sure to enclose various groups of commands in "catch" so that
385 # the procedure will complete even if the menubutton or the menu
386 # or the grab window has been deleted.
389 # menu - Name of a menu to unpost. Ignored if there
390 # is a posted menubutton.
392 proc ::tk::MenuUnpost menu {
395 set mb
$Priv(postedMb
)
397 # Restore focus right away (otherwise X will take focus away when
398 # the menu is unmapped and under some window managers (e.g. olvwm)
399 # we'll lose the focus completely).
401 catch {focus $Priv(focus)}
404 # Unpost menu(s) and restore some stuff that's dependent on
407 after cancel
[array get Priv menuActivatedTimer
]
408 unset -nocomplain Priv
(menuActivated
)
409 after cancel
[array get Priv menuDeactivatedTimer
]
410 unset -nocomplain Priv
(menuDeactivated
)
414 set menu [$mb cget
-menu]
416 set Priv
(postedMb
) {}
417 if {$::tk_strictMotif} {
418 $mb configure
-cursor $Priv(cursor
)
420 if {[tk windowingsystem
] ne
"aqua"} {
421 $mb configure
-relief $Priv(relief
)
423 $mb configure
-state normal
425 } elseif
{$Priv(popup
) ne
""} {
428 } elseif
{[$menu cget
-type] ne
"menubar" && [$menu cget
-type] ne
"tearoff"} {
429 # We're in a cascaded sub-menu from a torn-off menu or popup.
430 # Unpost all the menus up to the toplevel one (but not
431 # including the top-level torn-off one) and deactivate the
432 # top-level torn off menu if there is one.
435 set parent
[winfo parent
$menu]
436 if {[winfo class
$parent] ne
"Menu" ||
![winfo ismapped
$parent]} {
439 $parent activate none
440 $parent postcascade none
441 GenerateMenuSelect
$parent
442 set type
[$parent cget
-type]
443 if {$type eq
"menubar" ||
$type eq
"tearoff"} {
448 if {[$menu cget
-type] ne
"menubar"} {
454 if {($Priv(tearoff
) != 0) ||
$Priv(menuBar
) ne
""} {
455 # Release grab, if any, and restore the previous grab, if there
458 set grab [grab current
$menu]
464 if {$Priv(menuBar
) ne
""} {
465 if {$::tk_strictMotif} {
466 $Priv(menuBar
) configure
-cursor $Priv(cursor
)
470 if {[tk windowingsystem
] ne
"x11"} {
477 # This procedure handles mouse motion events inside menubuttons, and
478 # also outside menubuttons when a menubutton has a grab (e.g. when a
479 # menu selection operation is in progress).
482 # w - The name of the menubutton widget.
483 # upDown - "down" means button 1 is pressed, "up" means
485 # rootx, rooty - Coordinates of mouse, in (virtual?) root window.
487 proc ::tk::MbMotion {w upDown rootx rooty
} {
490 if {$Priv(inMenubutton
) eq
$w} {
493 set new
[winfo containing
$rootx $rooty]
494 if {$new ne
$Priv(inMenubutton
) \
495 && ($new eq
"" ||
[winfo toplevel $new] eq
[winfo toplevel $w])} {
496 if {$Priv(inMenubutton
) ne
""} {
497 MbLeave
$Priv(inMenubutton
)
500 && [winfo class
$new] eq
"Menubutton" \
501 && ([$new cget
-indicatoron] == 0) \
502 && ([$w cget
-indicatoron] == 0)} {
503 if {$upDown eq
"down"} {
504 MbPost
$new $rootx $rooty
512 # ::tk::MbButtonUp --
513 # This procedure is invoked to handle button 1 releases for menubuttons.
514 # If the release happens inside the menubutton then leave its menu
515 # posted with element 0 activated. Otherwise, unpost the menu.
518 # w - The name of the menubutton widget.
520 proc ::tk::MbButtonUp w
{
524 set menu [$w cget
-menu]
525 set tearoff
[expr {[tk windowingsystem
] eq
"x11" ||
\
526 ($menu ne
"" && [$menu cget
-type] eq
"tearoff")}]
527 if {($tearoff != 0) && $Priv(postedMb
) eq
$w \
528 && $Priv(inMenubutton
) eq
$w} {
529 MenuFirstEntry
[$Priv(postedMb
) cget
-menu]
535 # ::tk::MenuMotion --
536 # This procedure is called to handle mouse motion events for menus.
537 # It does two things. First, it resets the active element in the
538 # menu, if the mouse is over the menu. Second, if a mouse button
539 # is down, it posts and unposts cascade entries to match the mouse
543 # menu - The menu window.
544 # x - The x position of the mouse.
545 # y - The y position of the mouse.
546 # state - Modifier state (tells whether buttons are down).
548 proc ::tk::MenuMotion {menu x y state
} {
550 if {$menu eq
$Priv(window
)} {
551 set activeindex
[$menu index active
]
552 if {[$menu cget
-type] eq
"menubar"} {
553 if {[info exists Priv
(focus)] && $menu ne
$Priv(focus)} {
554 $menu activate
@$x,$y
555 GenerateMenuSelect
$menu
558 $menu activate
@$x,$y
559 GenerateMenuSelect
$menu
561 set index
[$menu index
@$x,$y]
562 if {[info exists Priv
(menuActivated
)] \
563 && $index ne
"none" \
564 && $index ne
$activeindex} {
565 set mode
[option get
$menu clickToFocus ClickToFocus
]
566 if {[string is false
$mode]} {
567 set delay
[expr {[$menu cget
-type] eq
"menubar" ?
0 : 50}]
568 if {[$menu type
$index] eq
"cascade"} {
569 set Priv
(menuActivatedTimer
) \
570 [after $delay [list $menu postcascade active
]]
572 set Priv
(menuDeactivatedTimer
) \
573 [after $delay [list $menu postcascade none
]]
580 # ::tk::MenuButtonDown --
581 # Handles button presses in menus. There are a couple of tricky things
583 # 1. Change the posted cascade entry (if any) to match the mouse position.
584 # 2. If there is a posted menubutton, must grab to the menubutton; this
585 # overrrides the implicit grab on button press, so that the menu
586 # button can track mouse motions over other menubuttons and change
588 # 3. If there's no posted menubutton (e.g. because we're a torn-off menu
589 # or one of its descendants) must grab to the top-level menu so that
590 # we can track mouse motions across the entire menu hierarchy.
593 # menu - The menu window.
595 proc ::tk::MenuButtonDown menu {
599 if {![winfo viewable
$menu]} {
602 $menu postcascade active
603 if {$Priv(postedMb
) ne
"" && [winfo viewable
$Priv(postedMb
)]} {
604 grab -global $Priv(postedMb
)
606 while {[$menu cget
-type] eq
"normal" \
607 && [winfo class
[winfo parent
$menu]] eq
"Menu" \
608 && [winfo ismapped
[winfo parent
$menu]]} {
609 set menu [winfo parent
$menu]
612 if {$Priv(menuBar
) eq
{}} {
613 set Priv
(menuBar
) $menu
614 if {$::tk_strictMotif} {
615 set Priv
(cursor
) [$menu cget
-cursor]
616 $menu configure
-cursor arrow
618 if {[$menu type active
] eq
"cascade"} {
619 set Priv
(menuActivated
) 1
623 # Don't update grab information if the grab window isn't changing.
624 # Otherwise, we'll get an error when we unpost the menus and
625 # restore the grab, since the old grab window will not be viewable
628 if {$menu ne
[grab current
$menu]} {
632 # Must re-grab even if the grab window hasn't changed, in order
633 # to release the implicit grab from the button press.
635 if {[tk windowingsystem
] eq
"x11"} {
642 # This procedure is invoked to handle Leave events for a menu. It
643 # deactivates everything unless the active element is a cascade element
644 # and the mouse is now over the submenu.
647 # menu - The menu window.
648 # rootx, rooty - Root coordinates of mouse.
649 # state - Modifier state.
651 proc ::tk::MenuLeave {menu rootx rooty state
} {
654 if {[$menu index active
] eq
"none"} {
657 if {[$menu type active
] eq
"cascade" \
658 && [winfo containing
$rootx $rooty] eq
\
659 [$menu entrycget active
-menu]} {
663 GenerateMenuSelect
$menu
666 # ::tk::MenuInvoke --
667 # This procedure is invoked when button 1 is released over a menu.
668 # It invokes the appropriate menu action and unposts the menu if
669 # it came from a menubutton.
672 # w - Name of the menu widget.
673 # buttonRelease - 1 means this procedure is called because of
674 # a button release; 0 means because of keystroke.
676 proc ::tk::MenuInvoke {w buttonRelease
} {
679 if {$buttonRelease && $Priv(window
) eq
""} {
680 # Mouse was pressed over a menu without a menu button, then
681 # dragged off the menu (possibly with a cascade posted) and
682 # released. Unpost everything and quit.
686 event generate
$w <<MenuSelect
>>
690 if {[$w type active
] eq
"cascade"} {
691 $w postcascade active
692 set menu [$w entrycget active
-menu]
694 } elseif
{[$w type active
] eq
"tearoff"} {
697 } elseif
{[$w cget
-type] eq
"menubar"} {
699 set active
[$w index active
]
700 set isCascade
[string equal
[$w type
$active] "cascade"]
702 # Only de-activate the active item if it's a cascade; this prevents
703 # the annoying "activation flicker" you otherwise get with
704 # checkbuttons/commands/etc. on menubars
708 event generate
$w <<MenuSelect
>>
713 # If the active item is not a cascade, invoke it. This enables
714 # the use of checkbuttons/commands/etc. on menubars (which is legal,
715 # but not recommended)
718 uplevel #0 [list $w invoke $active]
721 set active
[$w index active
]
722 if {$Priv(popup
) eq
"" ||
$active ne
"none"} {
725 uplevel #0 [list $w invoke active]
729 # ::tk::MenuEscape --
730 # This procedure is invoked for the Cancel (or Escape) key. It unposts
731 # the given menu and, if it is the top-level menu for a menu button,
732 # unposts the menu button as well.
735 # menu - Name of the menu window.
737 proc ::tk::MenuEscape menu {
738 set parent
[winfo parent
$menu]
739 if {[winfo class
$parent] ne
"Menu"} {
741 } elseif
{[$parent cget
-type] eq
"menubar"} {
745 MenuNextMenu
$menu left
749 # The following routines handle arrow keys. Arrow keys behave
750 # differently depending on whether the menu is a menu bar or not.
752 proc ::tk::MenuUpArrow {menu} {
753 if {[$menu cget
-type] eq
"menubar"} {
754 MenuNextMenu
$menu left
756 MenuNextEntry
$menu -1
760 proc ::tk::MenuDownArrow {menu} {
761 if {[$menu cget
-type] eq
"menubar"} {
762 MenuNextMenu
$menu right
764 MenuNextEntry
$menu 1
768 proc ::tk::MenuLeftArrow {menu} {
769 if {[$menu cget
-type] eq
"menubar"} {
770 MenuNextEntry
$menu -1
772 MenuNextMenu
$menu left
776 proc ::tk::MenuRightArrow {menu} {
777 if {[$menu cget
-type] eq
"menubar"} {
778 MenuNextEntry
$menu 1
780 MenuNextMenu
$menu right
784 # ::tk::MenuNextMenu --
785 # This procedure is invoked to handle "left" and "right" traversal
786 # motions in menus. It traverses to the next menu in a menu bar,
787 # or into or out of a cascaded menu.
790 # menu - The menu that received the keyboard
792 # direction - Direction in which to move: "left" or "right"
794 proc ::tk::MenuNextMenu {menu direction
} {
797 # First handle traversals into and out of cascaded menus.
799 if {$direction eq
"right"} {
801 set parent
[winfo parent
$menu]
802 set class
[winfo class
$parent]
803 if {[$menu type active
] eq
"cascade"} {
804 $menu postcascade active
805 set m2
[$menu entrycget active
-menu]
811 set parent
[winfo parent
$menu]
812 while {$parent ne
"."} {
813 if {[winfo class
$parent] eq
"Menu" \
814 && [$parent cget
-type] eq
"menubar"} {
815 tk_menuSetFocus $parent
816 MenuNextEntry
$parent 1
819 set parent
[winfo parent
$parent]
824 set m2
[winfo parent
$menu]
825 if {[winfo class
$m2] eq
"Menu"} {
827 GenerateMenuSelect
$menu
832 if {[$m2 cget
-type] ne
"menubar"} {
838 # Can't traverse into or out of a cascaded menu. Go to the next
839 # or previous menubutton, if that makes sense.
841 set m2
[winfo parent
$menu]
842 if {[winfo class
$m2] eq
"Menu" && [$m2 cget
-type] eq
"menubar"} {
848 set w
$Priv(postedMb
)
852 set buttons
[winfo children
[winfo parent
$w]]
853 set length
[llength $buttons]
854 set i
[expr {[lsearch -exact $buttons $w] + $count}]
859 while {$i >= $length} {
862 set mb
[lindex $buttons $i]
863 if {[winfo class
$mb] eq
"Menubutton" \
864 && [$mb cget
-state] ne
"disabled" \
865 && [$mb cget
-menu] ne
"" \
866 && [[$mb cget
-menu] index last
] ne
"none"} {
875 MenuFirstEntry
[$mb cget
-menu]
878 # ::tk::MenuNextEntry --
879 # Activate the next higher or lower entry in the posted menu,
880 # wrapping around at the ends. Disabled entries are skipped.
883 # menu - Menu window that received the keystroke.
884 # count - 1 means go to the next lower entry,
885 # -1 means go to the next higher entry.
887 proc ::tk::MenuNextEntry {menu count
} {
888 if {[$menu index last
] eq
"none"} {
891 set length
[expr {[$menu index last
]+1}]
892 set quitAfter
$length
893 set active
[$menu index active
]
894 if {$active eq
"none"} {
897 set i
[expr {$active + $count}]
900 if {$quitAfter <= 0} {
901 # We've tried every entry in the menu. Either there are
902 # none, or they're all disabled. Just give up.
909 while {$i >= $length} {
912 if {[catch {$menu entrycget
$i -state} state
] == 0} {
913 if {$state ne
"disabled" && \
914 ($i!=0 ||
[$menu cget
-type] ne
"tearoff" \
915 ||
[$menu type
0] ne
"tearoff")} {
926 GenerateMenuSelect
$menu
928 if {[$menu type
$i] eq
"cascade" && [$menu cget
-type] eq
"menubar"} {
929 set cascade
[$menu entrycget
$i -menu]
930 if {$cascade ne
""} {
931 # Here we auto-post a cascade. This is necessary when
932 # we traverse left/right in the menubar, but undesirable when
933 # we traverse up/down in a menu.
935 MenuFirstEntry
$cascade
941 # This procedure searches the entire window hierarchy under w for
942 # a menubutton that isn't disabled and whose underlined character
943 # is "char" or an entry in a menubar that isn't disabled and whose
944 # underlined character is "char".
945 # It returns the name of that window, if found, or an
946 # empty string if no matching window was found. If "char" is an
947 # empty string then the procedure returns the name of the first
948 # menubutton found that isn't disabled.
951 # w - Name of window where key was typed.
952 # char - Underlined character to search for;
953 # may be either upper or lower case, and
954 # will match either upper or lower case.
956 proc ::tk::MenuFind {w char
} {
957 set char
[string tolower
$char]
958 set windowlist
[winfo child
$w]
960 foreach child
$windowlist {
961 # Don't descend into other toplevels.
962 if {[winfo toplevel $w] ne
[winfo toplevel $child]} {
965 if {[winfo class
$child] eq
"Menu" && \
966 [$child cget
-type] eq
"menubar"} {
970 set last
[$child index last
]
971 for {set i
[$child cget
-tearoff]} {$i <= $last} {incr i
} {
972 if {[$child type
$i] eq
"separator"} {
975 set char2
[string index
[$child entrycget
$i -label] \
976 [$child entrycget
$i -underline]]
977 if {$char eq
[string tolower
$char2] ||
$char eq
""} {
978 if {[$child entrycget
$i -state] ne
"disabled"} {
986 foreach child
$windowlist {
987 # Don't descend into other toplevels.
988 if {[winfo toplevel $w] ne
[winfo toplevel $child]} {
991 switch -- [winfo class
$child] {
993 set char2
[string index
[$child cget
-text] \
994 [$child cget
-underline]]
995 if {$char eq
[string tolower
$char2] ||
$char eq
""} {
996 if {[$child cget
-state] ne
"disabled"} {
1003 set match
[MenuFind
$child $char]
1013 # ::tk::TraverseToMenu --
1014 # This procedure implements keyboard traversal of menus. Given an
1015 # ASCII character "char", it looks for a menubutton with that character
1016 # underlined. If one is found, it posts the menubutton's menu
1019 # w - Window in which the key was typed (selects
1020 # a toplevel window).
1021 # char - Character that selects a menu. The case
1022 # is ignored. If an empty string, nothing
1025 proc ::tk::TraverseToMenu {w char
} {
1030 while {[winfo class
$w] eq
"Menu"} {
1031 if {[$w cget
-type] eq
"menubar"} {
1033 } elseif
{$Priv(postedMb
) eq
""} {
1036 set w
[winfo parent
$w]
1038 set w
[MenuFind
[winfo toplevel $w] $char]
1040 if {[winfo class
$w] eq
"Menu"} {
1045 TraverseWithinMenu
$w $char
1048 MenuFirstEntry
[$w cget
-menu]
1053 # ::tk::FirstMenu --
1054 # This procedure traverses to the first menubutton in the toplevel
1055 # for a given window, and posts that menubutton's menu.
1058 # w - Name of a window. Selects which toplevel
1059 # to search for menubuttons.
1061 proc ::tk::FirstMenu w
{
1063 set w
[MenuFind
[winfo toplevel $w] ""]
1065 if {[winfo class
$w] eq
"Menu"} {
1073 MenuFirstEntry
[$w cget
-menu]
1078 # ::tk::TraverseWithinMenu
1079 # This procedure implements keyboard traversal within a menu. It
1080 # searches for an entry in the menu that has "char" underlined. If
1081 # such an entry is found, it is invoked and the menu is unposted.
1084 # w - The name of the menu widget.
1085 # char - The character to look for; case is
1086 # ignored. If the string is empty then
1089 proc ::tk::TraverseWithinMenu {w char
} {
1093 set char
[string tolower
$char]
1094 set last
[$w index last
]
1095 if {$last eq
"none"} {
1098 for {set i
0} {$i <= $last} {incr i
} {
1099 if {[catch {set char2
[string index
\
1100 [$w entrycget
$i -label] [$w entrycget
$i -underline]]}]} {
1103 if {$char eq
[string tolower
$char2]} {
1104 if {[$w type
$i] eq
"cascade"} {
1106 $w postcascade active
1107 event generate
$w <<MenuSelect
>>
1108 set m2
[$w entrycget
$i -menu]
1114 uplevel #0 [list $w invoke $i]
1121 # ::tk::MenuFirstEntry --
1122 # Given a menu, this procedure finds the first entry that isn't
1123 # disabled or a tear-off or separator, and activates that entry.
1124 # However, if there is already an active entry in the menu (e.g.,
1125 # because of a previous call to tk::PostOverPoint) then the active
1126 # entry isn't changed. This procedure also sets the input focus
1130 # menu - Name of the menu window (possibly empty).
1132 proc ::tk::MenuFirstEntry menu {
1136 tk_menuSetFocus $menu
1137 if {[$menu index active
] ne
"none"} {
1140 set last
[$menu index last
]
1141 if {$last eq
"none"} {
1144 for {set i
0} {$i <= $last} {incr i
} {
1145 if {([catch {set state
[$menu entrycget
$i -state]}] == 0) \
1146 && $state ne
"disabled" && [$menu type
$i] ne
"tearoff"} {
1148 GenerateMenuSelect
$menu
1149 # Only post the cascade if the current menu is a menubar;
1150 # otherwise, if the first entry of the cascade is a cascade,
1151 # we can get an annoying cascading effect resulting in a bunch of
1152 # menus getting posted (bug 676)
1153 if {[$menu type
$i] eq
"cascade" && [$menu cget
-type] eq
"menubar"} {
1154 set cascade
[$menu entrycget
$i -menu]
1155 if {$cascade ne
""} {
1156 $menu postcascade
$i
1157 MenuFirstEntry
$cascade
1165 # ::tk::MenuFindName --
1166 # Given a menu and a text string, return the index of the menu entry
1167 # that displays the string as its label. If there is no such entry,
1168 # return an empty string. This procedure is tricky because some names
1169 # like "active" have a special meaning in menu commands, so we can't
1170 # always use the "index" widget command.
1173 # menu - Name of the menu widget.
1174 # s - String to look for.
1176 proc ::tk::MenuFindName {menu s
} {
1178 if {![regexp {^active
$|^last
$|^none
$|^
[0-9]|^
@} $s]} {
1179 catch {set i
[$menu index
$s]}
1182 set last
[$menu index last
]
1183 if {$last eq
"none"} {
1186 for {set i
0} {$i <= $last} {incr i
} {
1187 if {![catch {$menu entrycget
$i -label} label]} {
1196 # ::tk::PostOverPoint --
1197 # This procedure posts a given menu such that a given entry in the
1198 # menu is centered over a given point in the root window. It also
1199 # activates the given entry.
1202 # menu - Menu to post.
1203 # x, y - Root coordinates of point.
1204 # entry - Index of entry within menu to center over (x,y).
1205 # If omitted or specified as {}, then the menu's
1206 # upper-left corner goes at (x,y).
1208 proc ::tk::PostOverPoint {menu x y
{entry {}}} {
1212 if {$entry == [$menu index last
]} {
1213 incr y
[expr {-([$menu yposition
$entry] \
1214 + [winfo reqheight
$menu])/2}]
1216 incr y
[expr {-([$menu yposition
$entry] \
1217 + [$menu yposition
[expr {$entry+1}]])/2}]
1219 incr x
[expr {-[winfo reqwidth
$menu]/2}]
1222 if {[tk windowingsystem
] eq
"win32"} {
1223 # osVersion is not available in safe interps
1225 if {[info exists tcl_platform
(osVersion
)]} {
1226 scan $tcl_platform(osVersion
) %d ver
1229 # We need to fix some problems with menu posting on Windows,
1230 # where, if the menu would overlap top or bottom of screen,
1231 # Windows puts it in the wrong place for us. We must also
1232 # subtract an extra amount for half the height of the current
1233 # entry. To be safe we subtract an extra 10.
1234 # NOTE: this issue appears to have been resolved in the Window
1235 # manager provided with Vista and Windows 7.
1237 set yoffset
[expr {[winfo screenheight
$menu] \
1238 - $y - [winfo reqheight
$menu] - 10}]
1239 if {$yoffset < [winfo vrooty
$menu]} {
1240 # The bottom of the menu is offscreen, so adjust upwards
1241 incr y
[expr {$yoffset - [winfo vrooty
$menu]}]
1243 # If we're off the top of the screen (either because we were
1244 # originally or because we just adjusted too far upwards),
1245 # then make the menu popup on the top edge.
1246 if {$y < [winfo vrooty
$menu]} {
1247 set y
[winfo vrooty
$menu]
1252 if {$entry ne
"" && [$menu entrycget
$entry -state] ne
"disabled"} {
1253 $menu activate
$entry
1254 GenerateMenuSelect
$menu
1258 # ::tk::SaveGrabInfo --
1259 # Sets the variables tk::Priv(oldGrab) and tk::Priv(grabStatus) to record
1260 # the state of any existing grab on the w's display.
1263 # w - Name of a window; used to select the display
1264 # whose grab information is to be recorded.
1266 proc tk::SaveGrabInfo w
{
1268 set Priv
(oldGrab
) [grab current
$w]
1269 if {$Priv(oldGrab
) ne
""} {
1270 set Priv
(grabStatus
) [grab status
$Priv(oldGrab
)]
1274 # ::tk::RestoreOldGrab --
1275 # Restores the grab to what it was before TkSaveGrabInfo was called.
1278 proc ::tk::RestoreOldGrab {} {
1281 if {$Priv(oldGrab
) ne
""} {
1282 # Be careful restoring the old grab, since it's window may not
1283 # be visible anymore.
1286 if {$Priv(grabStatus
) eq
"global"} {
1287 grab set -global $Priv(oldGrab
)
1289 grab set $Priv(oldGrab
)
1292 set Priv
(oldGrab
) ""
1296 proc ::tk_menuSetFocus {menu} {
1298 if {![info exists Priv
(focus)] ||
$Priv(focus) eq
""} {
1299 set Priv
(focus) [focus]
1304 proc ::tk::GenerateMenuSelect {menu} {
1307 if {$Priv(activeMenu
) eq
$menu \
1308 && $Priv(activeItem
) eq
[$menu index active
]} {
1312 set Priv
(activeMenu
) $menu
1313 set Priv
(activeItem
) [$menu index active
]
1314 event generate
$menu <<MenuSelect
>>
1318 # This procedure pops up a menu and sets things up for traversing
1319 # the menu and its submenus.
1322 # menu - Name of the menu to be popped up.
1323 # x, y - Root coordinates at which to pop up the
1325 # entry - Index of a menu entry to center over (x,y).
1326 # If omitted or specified as {}, then menu's
1327 # upper-left corner goes at (x,y).
1329 proc ::tk_popup {menu x y
{entry {}}} {
1332 if {$Priv(popup
) ne
"" ||
$Priv(postedMb
) ne
""} {
1335 tk::PostOverPoint $menu $x $y $entry
1336 if {[tk windowingsystem
] eq
"x11" && [winfo viewable
$menu]} {
1337 tk::SaveGrabInfo $menu
1339 set Priv
(popup
) $menu
1340 set Priv
(menuActivated
) 1
1341 tk_menuSetFocus $menu