5a59c870594e9178873fd42456c24fd4416f02fb
# This file defines the default bindings for Tk menus and menubuttons.
# It also implements keyboard traversal of menus and implements a few
# other utility procedures related to menus.
# RCS: @(#) $Id: menu.tcl,v 1.18.2.2 2005/05/27 18:00:59 tmh Exp $
# Copyright (c) 1992-1994 The Regents of the University of California.
# Copyright (c) 1994-1997 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#-------------------------------------------------------------------------
# Elements of tk::Priv that are used in this file:
# cursor - Saves the -cursor option for the posted menubutton.
# focus - Saves the focus during a menu selection operation.
# Focus gets restored here when the menu is unposted.
# grabGlobal - Used in conjunction with tk::Priv(oldGrab): if
# tk::Priv(oldGrab) is non-empty, then tk::Priv(grabGlobal)
# contains either an empty string or "-global" to
# indicate whether the old grab was a local one or
# inMenubutton - The name of the menubutton widget containing
# the mouse, or an empty string if the mouse is
# not over any menubutton.
# menuBar - The name of the menubar that is the root
# of the cascade hierarchy which is currently
# posted. This is null when there is no menu currently
# being pulled down from a menu bar.
# oldGrab - Window that had the grab before a menu was posted.
# Used to restore the grab state after the menu
# is unposted. Empty string means there was no
# popup - If a menu has been popped up via tk_popup, this
# gives the name of the menu. Otherwise this
# postedMb - Name of the menubutton whose menu is currently
# posted, or an empty string if nothing is posted
# A grab is set on this widget.
# relief - Used to save the original relief of the current
# window - When the mouse is over a menu, this holds the
# name of the menu; it's cleared when the mouse
# tearoff - Whether the last menu posted was a tearoff or not.
# This is true always for unix, for tearoffs for Mac
# activeMenu - This is the last active menu for use
# with the <<MenuSelect>> virtual event.
# activeItem - This is the last active menu item for
# use with the <<MenuSelect>> virtual event.
#-------------------------------------------------------------------------
#-------------------------------------------------------------------------
# This file is tricky because there are five different ways that menus
# 1. As a pulldown from a menubutton. In this style, the variable
# tk::Priv(postedMb) identifies the posted menubutton.
# 2. As a torn-off menu copied from some other menu. In this style
# tk::Priv(postedMb) is empty, and menu's type is "tearoff".
# 3. As an option menu, triggered from an option menubutton. In this
# style tk::Priv(postedMb) identifies the posted menubutton.
# 4. As a popup menu. In this style tk::Priv(postedMb) is empty and
# the top-level menu's type is "normal".
# 5. As a pulldown from a menubar. The variable tk::Priv(menubar) has
# the owning menubar, and the menu itself is of type "normal".
# The various binding procedures use the state described above to
# distinguish the various cases and take different actions in each
#-------------------------------------------------------------------------
#-------------------------------------------------------------------------
# The code below creates the default class bindings for menus
#-------------------------------------------------------------------------
bind Menubutton
<FocusIn
> {}
bind Menubutton
<Enter
> {
bind Menubutton
<Leave
> {
if {$tk::Priv(inMenubutton
) ne
""} {
tk::MbPost $tk::Priv(inMenubutton
) %X
%Y
bind Menubutton
<Motion
> {
bind Menubutton
<B1-Motion
> {
tk::MbMotion %W down
%X
%Y
bind Menubutton
<ButtonRelease-1
> {
bind Menubutton
<space
> {
tk::MenuFirstEntry [%W cget
-menu]
# Must set focus when mouse enters a menu, in order to allow
# mixed-mode processing using both the mouse and the keyboard.
# Don't set the focus if the event comes from a grab release,
# though: such an event can happen after as part of unposting
# a cascaded chain of menus, after the focus has already been
# restored to wherever it was before menu selection started.
if {[%W cget
-type] eq
"tearoff"} {
if {"%m" ne
"NotifyUngrab"} {
if {[tk windowingsystem
] eq
"x11"} {
tk::MenuMotion %W
%x
%y
%s
tk::MenuLeave %W
%X
%Y
%s
tk::MenuMotion %W
%x
%y
%s
bind Menu
<ButtonPress
> {
bind Menu
<ButtonRelease
> {
tk::TraverseWithinMenu %W
%A
# The following bindings apply to all windows, and are used to
# implement keyboard menu traversal.
if {[string equal
[tk windowingsystem
] "x11"]} {
bind all
<Alt-KeyPress
> {
bind Menubutton
<Alt-KeyPress
> {
# This procedure is invoked when the mouse enters a menubutton
# widget. It activates the widget unless it is disabled. Note:
# this procedure is only invoked when mouse button 1 is *not* down.
# The procedure ::tk::MbB1Enter is invoked if the button is down.
# w - The name of the widget.
if {[string compare
$Priv(inMenubutton
) ""]} {
MbLeave
$Priv(inMenubutton
)
set Priv
(inMenubutton
) $w
if {[string compare
[$w cget
-state] "disabled"]} {
$w configure
-state active
# This procedure is invoked when the mouse leaves a menubutton widget.
# It de-activates the widget, if the widget still exists.
# w - The name of the widget.
set Priv
(inMenubutton
) {}
if {![winfo exists
$w]} {
if {[string equal
[$w cget
-state] "active"]} {
$w configure
-state normal
# Given a menubutton, this procedure does all the work of posting
# its associated menu and unposting any other menu that is currently
# w - The name of the menubutton widget whose menu
# x, y - Root coordinates of cursor, used for positioning
# option menus. If not specified, then the center
# of the menubutton is used for an option menu.
proc ::tk::MbPost {w
{x
{}} {y
{}}} {
if {[$w cget
-state] eq
"disabled" ||
$w eq
$Priv(postedMb
)} {
if {[string equal
$menu ""]} {
set tearoff
[expr {[tk windowingsystem
] eq
"x11" \
||
[$menu cget
-type] eq
"tearoff"}]
if {[string first
$w $menu] != 0} {
error "can't post $menu: it isn't a descendant of $w (this is a new requirement in Tk versions 3.0 and later)"
if {[string compare
$cur ""]} {
set Priv
(cursor
) [$w cget
-cursor]
set Priv
(relief
) [$w cget
-relief]
$w configure
-cursor arrow
$w configure
-relief raised
# If this looks like an option menubutton then post the menu so
# that the current entry is on top of the mouse. Otherwise post
# the menu just below the menubutton, as for a pull-down.
switch [$w cget
-direction] {
set y
[expr {[winfo rooty
$w] - [winfo reqheight
$menu]}]
# if we go offscreen to the top, show as 'below'
set y
[expr {[winfo rooty
$w] + [winfo height
$w]}]
PostOverPoint
$menu $x $y
set y
[expr {[winfo rooty
$w] + [winfo height
$w]}]
# if we go offscreen to the bottom, show as 'above'
set mh
[winfo reqheight
$menu]
if {($y + $mh) > [winfo screenheight
$w]} {
set y
[expr {[winfo rooty
$w] - $mh}]
PostOverPoint
$menu $x $y
set x
[expr {[winfo rootx
$w] - [winfo reqwidth
$menu]}]
set y
[expr {(2 * [winfo rooty
$w] + [winfo height
$w]) / 2}]
set entry [MenuFindName
$menu [$w cget
-text]]
if {[$w cget
-indicatoron]} {
if {$entry == [$menu index last
]} {
incr y
[expr {-([$menu yposition
$entry] \
+ [winfo reqheight
$menu])/2}]
incr y
[expr {-([$menu yposition
$entry] \
+ [$menu yposition
[expr {$entry+1}]])/2}]
PostOverPoint
$menu $x $y
&& [$menu entrycget
$entry -state] ne
"disabled"} {
set x
[expr {[winfo rootx
$w] + [winfo width
$w]}]
set y
[expr {(2 * [winfo rooty
$w] + [winfo height
$w]) / 2}]
set entry [MenuFindName
$menu [$w cget
-text]]
if {[$w cget
-indicatoron]} {
if {$entry == [$menu index last
]} {
incr y
[expr {-([$menu yposition
$entry] \
+ [winfo reqheight
$menu])/2}]
incr y
[expr {-([$menu yposition
$entry] \
+ [$menu yposition
[expr {$entry+1}]])/2}]
PostOverPoint
$menu $x $y
&& [$menu entrycget
$entry -state] ne
"disabled"} {
if {[$w cget
-indicatoron]} {
if {[string equal
$y {}]} {
set x
[expr {[winfo rootx
$w] + [winfo width
$w]/2}]
set y
[expr {[winfo rooty
$w] + [winfo height
$w]/2}]
PostOverPoint
$menu $x $y [MenuFindName
$menu [$w cget
-text]]
PostOverPoint
$menu [winfo rootx
$w] [expr {[winfo rooty
$w]+[winfo height
$w]}]
# Error posting menu (e.g. bogus -postcommand). Unpost it and
set Priv
(tearoff
) $tearoff
if {[winfo viewable
$w]} {
# This procedure unposts a given menu, plus all of its ancestors up
# to (and including) a menubutton, if any. It also restores various
# values to what they were before the menu was posted, and releases
# a grab if there's a menubutton involved. Special notes:
# 1. It's important to unpost all menus before releasing the grab, so
# that any Enter-Leave events (e.g. from menu back to main
# application) have mode NotifyGrab.
# 2. Be sure to enclose various groups of commands in "catch" so that
# the procedure will complete even if the menubutton or the menu
# or the grab window has been deleted.
# menu - Name of a menu to unpost. Ignored if there
# is a posted menubutton.
proc ::tk::MenuUnpost menu {
# Restore focus right away (otherwise X will take focus away when
# the menu is unmapped and under some window managers (e.g. olvwm)
# we'll lose the focus completely).
catch {focus $Priv(focus)}
# Unpost menu(s) and restore some stuff that's dependent on
if {[string compare
$mb ""]} {
set menu [$mb cget
-menu]
$mb configure
-cursor $Priv(cursor
)
$mb configure
-relief $Priv(relief
)
} elseif
{[string compare
$Priv(popup
) ""]} {
} elseif
{[string compare
[$menu cget
-type] "menubar"] \
&& [string compare
[$menu cget
-type] "tearoff"]} {
# We're in a cascaded sub-menu from a torn-off menu or popup.
# Unpost all the menus up to the toplevel one (but not
# including the top-level torn-off one) and deactivate the
# top-level torn off menu if there is one.
set parent
[winfo parent
$menu]
if {[string compare
[winfo class
$parent] "Menu"] \
||
![winfo ismapped
$parent]} {
GenerateMenuSelect
$parent
set type
[$parent cget
-type]
if {[string equal
$type "menubar"] ||
\
[string equal
$type "tearoff"]} {
if {[string compare
[$menu cget
-type] "menubar"]} {
if {($Priv(tearoff
) != 0) ||
$Priv(menuBar
) ne
""} {
# Release grab, if any, and restore the previous grab, if there
if {[string compare
$menu ""]} {
set grab [grab current
$menu]
if {[string compare
$grab ""]} {
if {$Priv(menuBar
) ne
""} {
$Priv(menuBar
) configure
-cursor $Priv(cursor
)
if {[tk windowingsystem
] ne
"x11"} {
# This procedure handles mouse motion events inside menubuttons, and
# also outside menubuttons when a menubutton has a grab (e.g. when a
# menu selection operation is in progress).
# w - The name of the menubutton widget.
# upDown - "down" means button 1 is pressed, "up" means
# rootx, rooty - Coordinates of mouse, in (virtual?) root window.
proc ::tk::MbMotion {w upDown rootx rooty
} {
if {[string equal
$Priv(inMenubutton
) $w]} {
set new
[winfo containing
$rootx $rooty]
if {[string compare
$new $Priv(inMenubutton
)] \
&& ([string equal
$new ""] \
||
[string equal
[winfo toplevel $new] [winfo toplevel $w]])} {
if {[string compare
$Priv(inMenubutton
) ""]} {
MbLeave
$Priv(inMenubutton
)
if {[string compare
$new ""] \
&& [string equal
[winfo class
$new] "Menubutton"] \
&& ([$new cget
-indicatoron] == 0) \
&& ([$w cget
-indicatoron] == 0)} {
if {[string equal
$upDown "down"]} {
MbPost
$new $rootx $rooty
# This procedure is invoked to handle button 1 releases for menubuttons.
# If the release happens inside the menubutton then leave its menu
# posted with element 0 activated. Otherwise, unpost the menu.
# w - The name of the menubutton widget.
proc ::tk::MbButtonUp w
{
set tearoff
[expr {[tk windowingsystem
] eq
"x11" ||
\
($menu ne
"" && [$menu cget
-type] eq
"tearoff")}]
if {($tearoff != 0) && $Priv(postedMb
) eq
$w \
&& $Priv(inMenubutton
) eq
$w} {
MenuFirstEntry
[$Priv(postedMb
) cget
-menu]
# This procedure is called to handle mouse motion events for menus.
# It does two things. First, it resets the active element in the
# menu, if the mouse is over the menu. Second, if a mouse button
# is down, it posts and unposts cascade entries to match the mouse
# menu - The menu window.
# x - The x position of the mouse.
# y - The y position of the mouse.
# state - Modifier state (tells whether buttons are down).
proc ::tk::MenuMotion {menu x y state
} {
if {[string equal
$menu $Priv(window
)]} {
if {[string equal
[$menu cget
-type] "menubar"]} {
if {[info exists Priv
(focus)] && \
[string compare
$menu $Priv(focus)]} {
if {($state & 0x1f00) != 0} {
# ::tk::MenuButtonDown --
# Handles button presses in menus. There are a couple of tricky things
# 1. Change the posted cascade entry (if any) to match the mouse position.
# 2. If there is a posted menubutton, must grab to the menubutton; this
# overrrides the implicit grab on button press, so that the menu
# button can track mouse motions over other menubuttons and change
# 3. If there's no posted menubutton (e.g. because we're a torn-off menu
# or one of its descendants) must grab to the top-level menu so that
# we can track mouse motions across the entire menu hierarchy.
# menu - The menu window.
proc ::tk::MenuButtonDown menu {
if {![winfo viewable
$menu]} {
if {[string compare
$Priv(postedMb
) ""] && \
[winfo viewable
$Priv(postedMb
)]} {
grab -global $Priv(postedMb
)
while {[string equal
[$menu cget
-type] "normal"] \
&& [string equal
[winfo class
[winfo parent
$menu]] "Menu"] \
&& [winfo ismapped
[winfo parent
$menu]]} {
set menu [winfo parent
$menu]
if {[string equal
$Priv(menuBar
) {}]} {
set Priv
(cursor
) [$menu cget
-cursor]
$menu configure
-cursor arrow
# Don't update grab information if the grab window isn't changing.
# Otherwise, we'll get an error when we unpost the menus and
# restore the grab, since the old grab window will not be viewable
if {[string compare
$menu [grab current
$menu]]} {
# Must re-grab even if the grab window hasn't changed, in order
# to release the implicit grab from the button press.
if {[string equal
[tk windowingsystem
] "x11"]} {
# This procedure is invoked to handle Leave events for a menu. It
# deactivates everything unless the active element is a cascade element
# and the mouse is now over the submenu.
# menu - The menu window.
# rootx, rooty - Root coordinates of mouse.
# state - Modifier state.
proc ::tk::MenuLeave {menu rootx rooty state
} {
if {[string equal
[$menu index active
] "none"]} {
if {[string equal
[$menu type active
] "cascade"]
&& [string equal
[winfo containing
$rootx $rooty] \
[$menu entrycget active
-menu]]} {
# This procedure is invoked when button 1 is released over a menu.
# It invokes the appropriate menu action and unposts the menu if
# it came from a menubutton.
# w - Name of the menu widget.
# buttonRelease - 1 means this procedure is called because of
# a button release; 0 means because of keystroke.
proc ::tk::MenuInvoke {w buttonRelease
} {
if {$buttonRelease && [string equal
$Priv(window
) {}]} {
# Mouse was pressed over a menu without a menu button, then
# dragged off the menu (possibly with a cascade posted) and
# released. Unpost everything and quit.
event generate
$w <<MenuSelect
>>
if {[string equal
[$w type active
] "cascade"]} {
set menu [$w entrycget active
-menu]
} elseif
{[string equal
[$w type active
] "tearoff"]} {
} elseif
{[string equal
[$w cget
-type] "menubar"]} {
set active
[$w index active
]
set isCascade
[string equal
[$w type
$active] "cascade"]
# Only de-activate the active item if it's a cascade; this prevents
# the annoying "activation flicker" you otherwise get with
# checkbuttons/commands/etc. on menubars
event generate
$w <<MenuSelect
>>
# If the active item is not a cascade, invoke it. This enables
# the use of checkbuttons/commands/etc. on menubars (which is legal,
uplevel #0 [list $w invoke $active]
set active
[$w index active
]
if {$Priv(popup
) eq
"" ||
$active ne
"none"} {
uplevel #0 [list $w invoke active]
# This procedure is invoked for the Cancel (or Escape) key. It unposts
# the given menu and, if it is the top-level menu for a menu button,
# unposts the menu button as well.
# menu - Name of the menu window.
proc ::tk::MenuEscape menu {
set parent
[winfo parent
$menu]
if {[string compare
[winfo class
$parent] "Menu"]} {
} elseif
{[string equal
[$parent cget
-type] "menubar"]} {
# The following routines handle arrow keys. Arrow keys behave
# differently depending on whether the menu is a menu bar or not.
proc ::tk::MenuUpArrow {menu} {
if {[string equal
[$menu cget
-type] "menubar"]} {
proc ::tk::MenuDownArrow {menu} {
if {[string equal
[$menu cget
-type] "menubar"]} {
proc ::tk::MenuLeftArrow {menu} {
if {[string equal
[$menu cget
-type] "menubar"]} {
proc ::tk::MenuRightArrow {menu} {
if {[string equal
[$menu cget
-type] "menubar"]} {
# This procedure is invoked to handle "left" and "right" traversal
# motions in menus. It traverses to the next menu in a menu bar,
# or into or out of a cascaded menu.
# menu - The menu that received the keyboard
# direction - Direction in which to move: "left" or "right"
proc ::tk::MenuNextMenu {menu direction
} {
# First handle traversals into and out of cascaded menus.
if {[string equal
$direction "right"]} {
set parent
[winfo parent
$menu]
set class
[winfo class
$parent]
if {[string equal
[$menu type active
] "cascade"]} {
set m2
[$menu entrycget active
-menu]
if {[string compare
$m2 ""]} {
set parent
[winfo parent
$menu]
while {[string compare
$parent "."]} {
if {[string equal
[winfo class
$parent] "Menu"] \
&& [string equal
[$parent cget
-type] "menubar"]} {
set parent
[winfo parent
$parent]
set m2
[winfo parent
$menu]
if {[string equal
[winfo class
$m2] "Menu"]} {
if {[string compare
[$m2 cget
-type] "menubar"]} {
# Can't traverse into or out of a cascaded menu. Go to the next
# or previous menubutton, if that makes sense.
set m2
[winfo parent
$menu]
if {[string equal
[winfo class
$m2] "Menu"]} {
if {[string equal
[$m2 cget
-type] "menubar"]} {
if {[string equal
$w ""]} {
set buttons
[winfo children
[winfo parent
$w]]
set length
[llength $buttons]
set i
[expr {[lsearch -exact $buttons $w] + $count}]
set mb
[lindex $buttons $i]
if {[string equal
[winfo class
$mb] "Menubutton"] \
&& [string compare
[$mb cget
-state] "disabled"] \
&& [string compare
[$mb cget
-menu] ""] \
&& [string compare
[[$mb cget
-menu] index last
] "none"]} {
if {[string equal
$mb $w]} {
MenuFirstEntry
[$mb cget
-menu]
# Activate the next higher or lower entry in the posted menu,
# wrapping around at the ends. Disabled entries are skipped.
# menu - Menu window that received the keystroke.
# count - 1 means go to the next lower entry,
# -1 means go to the next higher entry.
proc ::tk::MenuNextEntry {menu count
} {
if {[string equal
[$menu index last
] "none"]} {
set length
[expr {[$menu index last
]+1}]
set active
[$menu index active
]
if {[string equal
$active "none"]} {
set i
[expr {$active + $count}]
# We've tried every entry in the menu. Either there are
# none, or they're all disabled. Just give up.
if {[catch {$menu entrycget
$i -state} state
] == 0} {
if {$state ne
"disabled" && \
($i!=0 ||
[$menu cget
-type] ne
"tearoff" \
||
[$menu type
0] ne
"tearoff")} {
if {[string equal
[$menu type
$i] "cascade"] \
&& [string equal
[$menu cget
-type] "menubar"]} {
set cascade
[$menu entrycget
$i -menu]
if {[string compare
$cascade ""]} {
# Here we auto-post a cascade. This is necessary when
# we traverse left/right in the menubar, but undesirable when
# we traverse up/down in a menu.
# This procedure searches the entire window hierarchy under w for
# a menubutton that isn't disabled and whose underlined character
# is "char" or an entry in a menubar that isn't disabled and whose
# underlined character is "char".
# It returns the name of that window, if found, or an
# empty string if no matching window was found. If "char" is an
# empty string then the procedure returns the name of the first
# menubutton found that isn't disabled.
# w - Name of window where key was typed.
# char - Underlined character to search for;
# may be either upper or lower case, and
# will match either upper or lower case.
proc ::tk::MenuFind {w char
} {
set char
[string tolower
$char]
set windowlist
[winfo child
$w]
foreach child
$windowlist {
# Don't descend into other toplevels.
if {[string compare
[winfo toplevel $w] [winfo toplevel $child]]} {
if {[string equal
[winfo class
$child] "Menu"] && \
[string equal
[$child cget
-type] "menubar"]} {
if {[string equal
$char ""]} {
set last
[$child index last
]
for {set i
[$child cget
-tearoff]} {$i <= $last} {incr i
} {
if {[string equal
[$child type
$i] "separator"]} {
set char2
[string index
[$child entrycget
$i -label] \
[$child entrycget
$i -underline]]
if {[string equal
$char [string tolower
$char2]] \
||
[string equal
$char ""]} {
if {[string compare
[$child entrycget
$i -state] "disabled"]} {
foreach child
$windowlist {
# Don't descend into other toplevels.
if {[string compare
[winfo toplevel $w] [winfo toplevel $child]]} {
switch [winfo class
$child] {
set char2
[string index
[$child cget
-text] \
[$child cget
-underline]]
if {[string equal
$char [string tolower
$char2]] \
||
[string equal
$char ""]} {
if {[string compare
[$child cget
-state] "disabled"]} {
set match
[MenuFind
$child $char]
if {[string compare
$match ""]} {
# ::tk::TraverseToMenu --
# This procedure implements keyboard traversal of menus. Given an
# ASCII character "char", it looks for a menubutton with that character
# underlined. If one is found, it posts the menubutton's menu
# w - Window in which the key was typed (selects
# char - Character that selects a menu. The case
# is ignored. If an empty string, nothing
proc ::tk::TraverseToMenu {w char
} {
if {[string equal
$char ""]} {
while {[string equal
[winfo class
$w] "Menu"]} {
if {[string compare
[$w cget
-type] "menubar"] \
&& [string equal
$Priv(postedMb
) ""]} {
if {[string equal
[$w cget
-type] "menubar"]} {
set w
[MenuFind
[winfo toplevel $w] $char]
if {[string compare
$w ""]} {
if {[string equal
[winfo class
$w] "Menu"]} {
TraverseWithinMenu
$w $char
MenuFirstEntry
[$w cget
-menu]
# This procedure traverses to the first menubutton in the toplevel
# for a given window, and posts that menubutton's menu.
# w - Name of a window. Selects which toplevel
# to search for menubuttons.
set w
[MenuFind
[winfo toplevel $w] ""]
if {[string compare
$w ""]} {
if {[string equal
[winfo class
$w] "Menu"]} {
MenuFirstEntry
[$w cget
-menu]
# ::tk::TraverseWithinMenu
# This procedure implements keyboard traversal within a menu. It
# searches for an entry in the menu that has "char" underlined. If
# such an entry is found, it is invoked and the menu is unposted.
# w - The name of the menu widget.
# char - The character to look for; case is
# ignored. If the string is empty then
proc ::tk::TraverseWithinMenu {w char
} {
if {[string equal
$char ""]} {
set char
[string tolower
$char]
if {[string equal
$last "none"]} {
for {set i
0} {$i <= $last} {incr i
} {
if {[catch {set char2
[string index
\
[$w entrycget
$i -label] [$w entrycget
$i -underline]]}]} {
if {[string equal
$char [string tolower
$char2]]} {
if {[string equal
[$w type
$i] "cascade"]} {
event generate
$w <<MenuSelect
>>
set m2
[$w entrycget
$i -menu]
if {[string compare
$m2 ""]} {
uplevel #0 [list $w invoke $i]
# ::tk::MenuFirstEntry --
# Given a menu, this procedure finds the first entry that isn't
# disabled or a tear-off or separator, and activates that entry.
# However, if there is already an active entry in the menu (e.g.,
# because of a previous call to tk::PostOverPoint) then the active
# entry isn't changed. This procedure also sets the input focus
# menu - Name of the menu window (possibly empty).
proc ::tk::MenuFirstEntry menu {
if {[string equal
$menu ""]} {
if {[string compare
[$menu index active
] "none"]} {
set last
[$menu index last
]
if {[string equal
$last "none"]} {
for {set i
0} {$i <= $last} {incr i
} {
if {([catch {set state
[$menu entrycget
$i -state]}] == 0) \
&& [string compare
$state "disabled"] \
&& [string compare
[$menu type
$i] "tearoff"]} {
# Only post the cascade if the current menu is a menubar;
# otherwise, if the first entry of the cascade is a cascade,
# we can get an annoying cascading effect resulting in a bunch of
# menus getting posted (bug 676)
if {[string equal
[$menu type
$i] "cascade"] && \
[string equal
[$menu cget
-type] "menubar"]} {
set cascade
[$menu entrycget
$i -menu]
if {[string compare
$cascade ""]} {
# Given a menu and a text string, return the index of the menu entry
# that displays the string as its label. If there is no such entry,
# return an empty string. This procedure is tricky because some names
# like "active" have a special meaning in menu commands, so we can't
# always use the "index" widget command.
# menu - Name of the menu widget.
# s - String to look for.
proc ::tk::MenuFindName {menu s
} {
if {![regexp {^active
$|^last
$|^none
$|^
[0-9]|^
@} $s]} {
catch {set i
[$menu index
$s]}
set last
[$menu index last
]
if {[string equal
$last "none"]} {
for {set i
0} {$i <= $last} {incr i
} {
if {![catch {$menu entrycget
$i -label} label]} {
if {[string equal
$label $s]} {
# This procedure posts a given menu such that a given entry in the
# menu is centered over a given point in the root window. It also
# activates the given entry.
# x, y - Root coordinates of point.
# entry - Index of entry within menu to center over (x,y).
# If omitted or specified as {}, then the menu's
# upper-left corner goes at (x,y).
proc ::tk::PostOverPoint {menu x y
{entry {}}} {
if {[string compare
$entry {}]} {
if {$entry == [$menu index last
]} {
incr y
[expr {-([$menu yposition
$entry] \
+ [winfo reqheight
$menu])/2}]
incr y
[expr {-([$menu yposition
$entry] \
+ [$menu yposition
[expr {$entry+1}]])/2}]
incr x
[expr {-[winfo reqwidth
$menu]/2}]
if {$tcl_platform(platform
) == "windows"} {
# We need to fix some problems with menu posting on Windows.
set yoffset
[expr {[winfo screenheight
$menu] \
- $y - [winfo reqheight
$menu]}]
# The bottom of the menu is offscreen, so adjust upwards
# If we're off the top of the screen (either because we were
# originally or because we just adjusted too far upwards),
# then make the menu popup on the top edge.
if {$entry ne
"" && [$menu entrycget
$entry -state] ne
"disabled"} {
# Sets the variables tk::Priv(oldGrab) and tk::Priv(grabStatus) to record
# the state of any existing grab on the w's display.
# w - Name of a window; used to select the display
# whose grab information is to be recorded.
proc tk::SaveGrabInfo w
{
set Priv
(oldGrab
) [grab current
$w]
if {$Priv(oldGrab
) ne
""} {
set Priv
(grabStatus
) [grab status
$Priv(oldGrab
)]
# ::tk::RestoreOldGrab --
# Restores the grab to what it was before TkSaveGrabInfo was called.
proc ::tk::RestoreOldGrab {} {
if {$Priv(oldGrab
) ne
""} {
# Be careful restoring the old grab, since it's window may not
if {[string equal
$Priv(grabStatus
) "global"]} {
grab set -global $Priv(oldGrab
)
proc ::tk_menuSetFocus {menu} {
if {![info exists Priv
(focus)] ||
[string equal
$Priv(focus) {}]} {
proc ::tk::GenerateMenuSelect {menu} {
if {[string equal
$Priv(activeMenu
) $menu] \
&& [string equal
$Priv(activeItem
) [$menu index active
]]} {
set Priv
(activeMenu
) $menu
set Priv
(activeItem
) [$menu index active
]
event generate
$menu <<MenuSelect
>>
# This procedure pops up a menu and sets things up for traversing
# the menu and its submenus.
# menu - Name of the menu to be popped up.
# x, y - Root coordinates at which to pop up the
# entry - Index of a menu entry to center over (x,y).
# If omitted or specified as {}, then menu's
# upper-left corner goes at (x,y).
proc ::tk_popup {menu x y
{entry {}}} {
if {$Priv(popup
) ne
"" ||
$Priv(postedMb
) ne
""} {
tk::PostOverPoint $menu $x $y $entry
if {[tk windowingsystem
] eq
"x11" && [winfo viewable
$menu]} {