menu.tcl –

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.5 2007/11/09 06:26:54 das 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.

Copyright (c) 2007 Daniel A. Steffen das(at)users.sourceforge.net

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

a global one.

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

grab previously set.

popup - If a menu has been popped up via tk_popup, this

gives the name of the menu. Otherwise this

value is empty.

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

menubutton.

window - When the mouse is over a menu, this holds the

name of the menu; it’s cleared when the mouse

leaves the menu.

tearoff - Whether the last menu posted was a tearoff or not.

This is true always for unix, for tearoffs for Mac

and Windows.

activeMenu - This is the last active menu for use

with the <> virtual event.

activeItem - This is the last active menu item for

use with the <> virtual event.

#———————————————————————––

#———————————————————————––

Overall note:

This file is tricky because there are five different ways that menus

can be used:

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

case.

#———————————————————————––

#———————————————————————––

The code below creates the default class bindings for menus

and menubuttons.

#———————————————————————––

bind Menubutton {}
bind Menubutton {
tk::MbEnter %W
}
bind Menubutton {
tk::MbLeave %W
}
bind Menubutton <1> {
if {$tk::Priv(inMenubutton) ne “”} {
tk::MbPost $tk::Priv(inMenubutton) %X %Y
}
}
bind Menubutton {
tk::MbMotion %W up %X %Y
}
bind Menubutton {
tk::MbMotion %W down %X %Y
}
bind Menubutton {
tk::MbButtonUp %W
}
bind Menubutton {
tk::MbPost %W
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.

bind Menu {}

bind Menu {
set tk::Priv(window) %W
if {[%W cget -type] eq “tearoff”} {
if {”%m” ne “NotifyUngrab”} {
if {[tk windowingsystem] eq “x11”} {
tk_menuSetFocus %W
}
}
}
tk::MenuMotion %W %x %y %s
}

bind Menu {
tk::MenuLeave %W %X %Y %s
}
bind Menu {
tk::MenuMotion %W %x %y %s
}
bind Menu {
tk::MenuButtonDown %W
}
bind Menu {
tk::MenuInvoke %W 1
}
bind Menu {
tk::MenuInvoke %W 0
}
bind Menu {
tk::MenuInvoke %W 0
}
bind Menu {
tk::MenuEscape %W
}
bind Menu {
tk::MenuLeftArrow %W
}
bind Menu {
tk::MenuRightArrow %W
}
bind Menu {
tk::MenuUpArrow %W
}
bind Menu {
tk::MenuDownArrow %W
}
bind Menu {
tk::TraverseWithinMenu %W %A
}

The following bindings apply to all windows, and are used to

implement keyboard menu traversal.

if {[tk windowingsystem] eq “x11”} {
bind all {
tk::TraverseToMenu %W %A
}

bind all <F10> {
tk::FirstMenu %W
}

} else {
bind Menubutton {
tk::TraverseToMenu %W %A
}

bind Menubutton <F10> {
tk::FirstMenu %W
}

}

::tk::MbEnter –

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.

Arguments:

w - The name of the widget.

proc ::tk::MbEnter w {
variable ::tk::Priv

if {$Priv(inMenubutton) ne ""} {
MbLeave $Priv(inMenubutton)
}
set Priv(inMenubutton) $w
if {[$w cget -state] ne "disabled" && [tk windowingsystem] ne "aqua"} {
$w configure -state active
}

}

::tk::MbLeave –

This procedure is invoked when the mouse leaves a menubutton widget.

It de-activates the widget, if the widget still exists.

Arguments:

w - The name of the widget.

proc ::tk::MbLeave w {
variable ::tk::Priv

set Priv(inMenubutton) {}
if {![winfo exists $w]} {
return
}
if {[$w cget -state] eq "active" && [tk windowingsystem] ne "aqua"} {
$w configure -state normal
}

}

::tk::MbPost –

Given a menubutton, this procedure does all the work of posting

its associated menu and unposting any other menu that is currently

posted.

Arguments:

w - The name of the menubutton widget whose menu

is to be posted.

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 {}}} {
global errorInfo
variable ::tk::Priv
global tcl_platform

if {[$w cget -state] eq "disabled" || $w eq $Priv(postedMb)} {
return
}
set menu [$w cget -menu]
if {$menu eq ""} {
return
}
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)"
}
set cur $Priv(postedMb)
if {$cur ne ""} {
MenuUnpost {}
}
set Priv(cursor) [$w cget -cursor]
$w configure -cursor arrow
if {[tk windowingsystem] ne "aqua"} {
set Priv(relief) [$w cget -relief]
$w configure -relief raised
} else {
$w configure -state active
}

set Priv(postedMb) $w
set Priv(focus) [focus]
$menu activate none
GenerateMenuSelect $menu

# 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.

update idletasks
if {[catch {
switch [$w cget -direction] {
	    above {
	    	set x [winfo rootx $w]
	    	set y [expr {[winfo rooty $w] - [winfo reqheight $menu]}]
	# if we go offscreen to the top, show as 'below'
	if {$y < 0} {
	    set y [expr {[winfo rooty $w] + [winfo height $w]}]
	}
	PostOverPoint $menu $x $y
	    }
	    below {
	    	set x [winfo rootx $w]
	    	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
	    }
	    left {
	    	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}]
	    } else {
	    	incr y [expr {-([$menu yposition $entry] \
		        + [$menu yposition [expr {$entry+1}]])/2}]
	    }
	    	}
	PostOverPoint $menu $x $y
	if {$entry ne "" \
		&& [$menu entrycget $entry -state] ne "disabled"} {
	    	    $menu activate $entry
	    GenerateMenuSelect $menu
	    	}
	    }
	    right {
	    	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}]
	    } else {
	    	incr y [expr {-([$menu yposition $entry] \
		        + [$menu yposition [expr {$entry+1}]])/2}]
	    }
	    	}
	PostOverPoint $menu $x $y
	if {$entry ne "" \
		&& [$menu entrycget $entry -state] ne "disabled"} {
	    	    $menu activate $entry
	    GenerateMenuSelect $menu
	    	}
	    }
	    default {
	    	if {[$w cget -indicatoron]} {
	    if {$y eq ""} {
		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]]
	} else {
	    PostOverPoint $menu [winfo rootx $w] [expr {[winfo rooty $w]+[winfo height $w]}]
	    	}
	    }
}
} msg]} {
# Error posting menu (e.g. bogus -postcommand). Unpost it and
# reflect the error.

set savedInfo $errorInfo
MenuUnpost {}
error $msg $savedInfo

}

set Priv(tearoff) $tearoff
if {$tearoff != 0} {
	focus $menu
if {[winfo viewable $w]} {
    SaveGrabInfo $w
    grab -global $w
}
}

}

::tk::MenuUnpost –

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.

Arguments:

menu - Name of a menu to unpost. Ignored if there

is a posted menubutton.

proc ::tk::MenuUnpost menu {
global tcl_platform
variable ::tk::Priv
set mb $Priv(postedMb)

# 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)}
set Priv(focus) ""

# Unpost menu(s) and restore some stuff that's dependent on
# what was posted.

catch {
if {$mb ne ""} {
    set menu [$mb cget -menu]
    $menu unpost
    set Priv(postedMb) {}
    $mb configure -cursor $Priv(cursor)
    if {[tk windowingsystem] ne "aqua"} {
	$mb configure -relief $Priv(relief)
    } else {
	$mb configure -state normal
    }
} elseif {$Priv(popup) ne ""} {
    $Priv(popup) unpost
    set Priv(popup) {}
} elseif {[$menu cget -type] ne "menubar" && [$menu cget -type] ne "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.

    while {1} {
	set parent [winfo parent $menu]
	if {[winfo class $parent] ne "Menu" || ![winfo ismapped $parent]} {
	    break
	}
	$parent activate none
	$parent postcascade none
	GenerateMenuSelect $parent
	set type [$parent cget -type]
	if {$type eq "menubar" || $type eq "tearoff"} {
	    break
	}
	set menu $parent
    }
    if {[$menu cget -type] ne "menubar"} {
	$menu unpost
    }
}
}

if {($Priv(tearoff) != 0) || $Priv(menuBar) ne ""} {
	# Release grab, if any, and restore the previous grab, if there
	# was one.
if {$menu ne ""} {
    set grab [grab current $menu]
    if {$grab ne ""} {
	grab release $grab
    }
}
RestoreOldGrab
if {$Priv(menuBar) ne ""} {
    $Priv(menuBar) configure -cursor $Priv(cursor)
    set Priv(menuBar) {}
}
if {[tk windowingsystem] ne "x11"} {
    set Priv(tearoff) 0
}
}

}

::tk::MbMotion –

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).

Arguments:

w - The name of the menubutton widget.

upDown - “down” means button 1 is pressed, “up” means

it isn’t.

rootx, rooty - Coordinates of mouse, in (virtual?) root window.

proc ::tk::MbMotion {w upDown rootx rooty} {
variable ::tk::Priv

if {$Priv(inMenubutton) eq $w} {
return
}
set new [winfo containing $rootx $rooty]
if {$new ne $Priv(inMenubutton) \
    && ($new eq "" || [winfo toplevel $new] eq [winfo toplevel $w])} {
if {$Priv(inMenubutton) ne ""} {
    MbLeave $Priv(inMenubutton)
}
if {$new ne "" \
	&& [winfo class $new] eq "Menubutton" \
	&& ([$new cget -indicatoron] == 0) \
	&& ([$w cget -indicatoron] == 0)} {
    if {$upDown eq "down"} {
	MbPost $new $rootx $rooty
    } else {
	MbEnter $new
    }
}
}

}

::tk::MbButtonUp –

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.

Arguments:

w - The name of the menubutton widget.

proc ::tk::MbButtonUp w {
variable ::tk::Priv
global tcl_platform

set menu [$w cget -menu]
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]
} else {
MenuUnpost {}
}

}

::tk::MenuMotion –

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

position.

Arguments:

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} {
variable ::tk::Priv
if {$menu eq Priv(window)} { if {[menu cget -type] eq “menubar”} {
if {[info exists Priv(focus)] && $menu ne $Priv(focus)} {
menu activate @x,$y
GenerateMenuSelect $menu
}
} else {
menu activate @x,$y
GenerateMenuSelect menu } } if {(state & 0x1f00) != 0} {
$menu postcascade active
}
}

::tk::MenuButtonDown –

Handles button presses in menus. There are a couple of tricky things

here:

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

the posted menu.

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.

Arguments:

menu - The menu window.

proc ::tk::MenuButtonDown menu {
variable ::tk::Priv
global tcl_platform

if {![winfo viewable $menu]} {
    return
}
$menu postcascade active
if {$Priv(postedMb) ne "" && [winfo viewable $Priv(postedMb)]} {
grab -global $Priv(postedMb)
} else {
while {[$menu cget -type] eq "normal" \
	&& [winfo class [winfo parent $menu]] eq "Menu" \
	&& [winfo ismapped [winfo parent $menu]]} {
    set menu [winfo parent $menu]
}

if {$Priv(menuBar) eq ""} {
    set Priv(menuBar) $menu
    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
# anymore.

if {$menu ne [grab current $menu]} {
    SaveGrabInfo $menu
}

# Must re-grab even if the grab window hasn't changed, in order
# to release the implicit grab from the button press.

if {[tk windowingsystem] eq "x11"} {
    grab -global $menu
}
}

}

::tk::MenuLeave –

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.

Arguments:

menu - The menu window.

rootx, rooty - Root coordinates of mouse.

state - Modifier state.

proc ::tk::MenuLeave {menu rootx rooty state} {
variable ::tk::Priv
set Priv(window) {}
if {[menu index active] eq "none"} { return } if {[menu type active] eq “cascade”
&& [winfo containing $rootx rooty] eq [menu entrycget active -menu]} {
return
}
$menu activate none
GenerateMenuSelect $menu
}

::tk::MenuInvoke –

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.

Arguments:

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} {
variable ::tk::Priv

if {$buttonRelease && $Priv(window) eq ""} {
# 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.

$w postcascade none
$w activate none
event generate $w <<MenuSelect>>
MenuUnpost $w
return
}
if {[$w type active] eq "cascade"} {
$w postcascade active
set menu [$w entrycget active -menu]
MenuFirstEntry $menu
} elseif {[$w type active] eq "tearoff"} {
::tk::TearOffMenu $w
MenuUnpost $w
} elseif {[$w cget -type] eq "menubar"} {
$w postcascade none
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

if { $isCascade } {
    $w activate none
    event generate $w <<MenuSelect>>
}

MenuUnpost $w

# If the active item is not a cascade, invoke it.  This enables
# the use of checkbuttons/commands/etc. on menubars (which is legal,
# but not recommended)

if { !$isCascade } {
    uplevel #0 [list $w invoke $active]
}
} else {
set active [$w index active]
if {$Priv(popup) eq "" || $active ne "none"} {
    MenuUnpost $w
}
uplevel #0 [list $w invoke active]
}

}

::tk::MenuEscape –

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.

Arguments:

menu - Name of the menu window.

proc ::tk::MenuEscape menu {
set parent [winfo parent $menu]
if {[winfo class $parent] ne “Menu”} {
MenuUnpost menu } elseif {[parent cget -type] eq “menubar”} {
MenuUnpost $menu
RestoreOldGrab
} else {
MenuNextMenu $menu left
}
}

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 {[$menu cget -type] eq “menubar”} {
MenuNextMenu $menu left
} else {
MenuNextEntry $menu -1
}
}

proc ::tk::MenuDownArrow {menu} {
if {[$menu cget -type] eq “menubar”} {
MenuNextMenu $menu right
} else {
MenuNextEntry $menu 1
}
}

proc ::tk::MenuLeftArrow {menu} {
if {[$menu cget -type] eq “menubar”} {
MenuNextEntry $menu -1
} else {
MenuNextMenu $menu left
}
}

proc ::tk::MenuRightArrow {menu} {
if {[$menu cget -type] eq “menubar”} {
MenuNextEntry $menu 1
} else {
MenuNextMenu $menu right
}
}

::tk::MenuNextMenu –

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.

Arguments:

menu - The menu that received the keyboard

event.

direction - Direction in which to move: “left” or “right”

proc ::tk::MenuNextMenu {menu direction} {
variable ::tk::Priv

# First handle traversals into and out of cascaded menus.

if {$direction eq "right"} {
set count 1
set parent [winfo parent $menu]
set class [winfo class $parent]
if {[$menu type active] eq "cascade"} {
    $menu postcascade active
    set m2 [$menu entrycget active -menu]
    if {$m2 ne ""} {
	MenuFirstEntry $m2
    }
    return
} else {
    set parent [winfo parent $menu]
    while {$parent ne "."} {
	if {[winfo class $parent] eq "Menu" && [$parent cget -type] eq "menubar"} {
	    tk_menuSetFocus $parent
	    MenuNextEntry $parent 1
	    return
	}
	set parent [winfo parent $parent]
    }
}
} else {
set count -1
set m2 [winfo parent $menu]
if {[winfo class $m2] eq "Menu"} {
    $menu activate none
    GenerateMenuSelect $menu
    tk_menuSetFocus $m2

    $m2 postcascade none

    if {[$m2 cget -type] ne "menubar"} {
	return
    }
}
}

# 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 {[winfo class $m2] eq "Menu"} {
if {[$m2 cget -type] eq "menubar"} {
    tk_menuSetFocus $m2
    MenuNextEntry $m2 -1
    return
}
}

set w $Priv(postedMb)
if {$w eq ""} {
return
}
set buttons [winfo children [winfo parent $w]]
set length [llength $buttons]
set i [expr {[lsearch -exact $buttons $w] + $count}]
while {1} {
while {$i < 0} {
    incr i $length
}
while {$i >= $length} {
    incr i -$length
}
set mb [lindex $buttons $i]
if {[winfo class $mb] eq "Menubutton" \
	&& [$mb cget -state] ne "disabled" \
	&& [$mb cget -menu] ne "" \
	&& [[$mb cget -menu] index last] ne "none"} {
    break
}
if {$mb eq $w} {
    return
}
incr i $count
}
MbPost $mb
MenuFirstEntry [$mb cget -menu]

}

::tk::MenuNextEntry –

Activate the next higher or lower entry in the posted menu,

wrapping around at the ends. Disabled entries are skipped.

Arguments:

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 {[menu index last] eq "none"} { return } set length [expr {[menu index last]+1}]
set quitAfter length set active [menu index active]
if {active eq "none"} { set i 0 } else { set i [expr {active + count}] } while {1} { if {quitAfter <= 0} {
# We’ve tried every entry in the menu. Either there are
# none, or they’re all disabled. Just give up.

    return
}
while {$i < 0} {
    incr i $length
}
while {$i >= $length} {
    incr i -$length
}
if {[catch {$menu entrycget $i -state} state] == 0} {
    if {$state ne "disabled" && \
	    ($i!=0 || [$menu cget -type] ne "tearoff" \
	    || [$menu type 0] ne "tearoff")} {
	break
    }
}
if {$i == $active} {
    return
}
incr i $count
incr quitAfter -1
}
$menu activate $i
GenerateMenuSelect $menu

if {[$menu type $i] eq "cascade" && [$menu cget -type] eq "menubar"} {
set cascade [$menu entrycget $i -menu]
if {$cascade ne ""} {
    # 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.
    $menu postcascade $i
    MenuFirstEntry $cascade
}
}

}

::tk::MenuFind –

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.

Arguments:

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 {[winfo toplevel $w] ne [winfo toplevel $child]} {
    continue
}
if {[winfo class $child] eq "Menu" && [$child cget -type] eq "menubar"} {
    if {$char eq ""} {
	return $child
    }
    set last [$child index last]
    for {set i [$child cget -tearoff]} {$i <= $last} {incr i} {
	if {[$child type $i] eq "separator"} {
	    continue
	}
	set char2 [string index [$child entrycget $i -label] \
		[$child entrycget $i -underline]]
	if {$char eq [string tolower $char2] || $char eq ""} {
	    if {[$child entrycget $i -state] ne "disabled"} {
		return $child
	    }
	}
    }
}
}

foreach child $windowlist {
# Don't descend into other toplevels.
    if {[winfo toplevel $w] ne [winfo toplevel $child]} {
    continue
}
switch [winfo class $child] {
    Menubutton {
	set char2 [string index [$child cget -text] \
		[$child cget -underline]]
	if {$char eq [string tolower $char2] || $char eq ""} {
	    if {[$child cget -state] ne "disabled"} {
		return $child
	    }
	}
    }

    default {
	set match [MenuFind $child $char]
	if {$match ne ""} {
	    return $match
	}
    }
}
}
return {}

}

::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

Arguments:

w - Window in which the key was typed (selects

a toplevel window).

char - Character that selects a menu. The case

is ignored. If an empty string, nothing

happens.

proc ::tk::TraverseToMenu {w char} {
variable ::tk::Priv
if {$char eq “”} {
return
}
while {[winfo class w] eq "Menu"} { if {[w cget -type] eq “menubar”} {
break
} elseif {$Priv(postedMb) eq “”} {
return
}
set w [winfo parent $w]
}
set w [MenuFind [winfo toplevel $w] char] if {w ne “”} {
if {[winfo class $w] eq “Menu”} {
tk_menuSetFocus $w
set Priv(window) $w
SaveGrabInfo $w
grab -global $w
TraverseWithinMenu $w $char
} else {
MbPost w MenuFirstEntry [w cget -menu]
}
}
}

::tk::FirstMenu –

This procedure traverses to the first menubutton in the toplevel

for a given window, and posts that menubutton’s menu.

Arguments:

w - Name of a window. Selects which toplevel

to search for menubuttons.

proc ::tk::FirstMenu w {
variable ::tk::Priv
set w [MenuFind [winfo toplevel w] ""] if {w ne “”} {
if {[winfo class $w] eq “Menu”} {
tk_menuSetFocus $w
set Priv(window) $w
SaveGrabInfo $w
grab -global $w
MenuFirstEntry $w
} else {
MbPost w 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.

Arguments:

w - The name of the menu widget.

char - The character to look for; case is

ignored. If the string is empty then

nothing happens.

proc ::tk::TraverseWithinMenu {w char} {
if {$char eq “”} {
return
}
set char [string tolower char] set last [w index last]
if {last eq "none"} { return } for {set i 0} {i <= last} {incr i} { if {[catch {set char2 [string index \ [w entrycget i -label] [w entrycget i -underline]]}]} { continue } if {char eq [string tolower char2]} { if {[w type $i] eq “cascade”} {
$w activate $i
$w postcascade active
event generate w <<MenuSelect>> set m2 [w entrycget i -menu] if {m2 ne “”} {
MenuFirstEntry $m2
}
} else {
MenuUnpost $w
uplevel #0 [list $w invoke $i]
}
return
}
}
}

::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

to the menu.

Arguments:

menu - Name of the menu window (possibly empty).

proc ::tk::MenuFirstEntry menu {
if {$menu eq “”} {
return
}
tk_menuSetFocus menu if {[menu index active] ne “none”} {
return
}
set last [menu index last] if {last eq “none”} {
return
}
for {set i 0} {$i <= last} {incr i} { if {([catch {set state [menu entrycget $i -state]}] == 0)
&& state ne "disabled" \ && [menu type $i] ne “tearoff”} {
$menu activate $i
GenerateMenuSelect menu # 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 {[menu type i] eq "cascade" && [menu cget -type] eq “menubar”} {
set cascade [$menu entrycget i -menu] if {cascade ne “”} {
$menu postcascade $i
MenuFirstEntry $cascade
}
}
return
}
}
}

::tk::MenuFindName –

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.

Arguments:

menu - Name of the menu widget.

s - String to look for.

proc ::tk::MenuFindName {menu s} {
set i “”
if {![regexp {^active|^last|^none$|^[0-9]|^@} s]} { catch {set i [menu index $s]}
return i } set last [menu index last]
if {last eq "none"} { return } for {set i 0} {i <= last} {incr i} { if {![catch {menu entrycget i -label} label]} { if {label eq $s} {
return $i
}
}
}
return “”
}

::tk::PostOverPoint –

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.

Arguments:

menu - Menu to post.

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 {}}} {
global tcl_platform

if {$entry ne ""} {
if {$entry == [$menu index last]} {
    incr y [expr {-([$menu yposition $entry] \
	    + [winfo reqheight $menu])/2}]
} else {
    incr y [expr {-([$menu yposition $entry] \
	    + [$menu yposition [expr {$entry+1}]])/2}]
}
incr x [expr {-[winfo reqwidth $menu]/2}]
}
if {$tcl_platform(platform) eq "windows"} {
# We need to fix some problems with menu posting on Windows,
# where, if the menu would overlap top or bottom of screen,
# Windows puts it in the wrong place for us.  We must also
# subtract an extra amount for half the height of the current
# entry.  To be safe we subtract an extra 10.
set yoffset [expr {[winfo screenheight $menu] \
	- $y - [winfo reqheight $menu] - 10}]
if {$yoffset < 0} {
    # The bottom of the menu is offscreen, so adjust upwards
    incr y $yoffset
    if {$y < 0} { set y 0 }
}
# 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 {$y < 0} {
    set y 0
}
}
$menu post $x $y
if {$entry ne "" && [$menu entrycget $entry -state] ne "disabled"} {
$menu activate $entry
GenerateMenuSelect $menu
}

}

::tk::SaveGrabInfo –

Sets the variables tk::Priv(oldGrab) and tk::Priv(grabStatus) to record

the state of any existing grab on the w’s display.

Arguments:

w - Name of a window; used to select the display

whose grab information is to be recorded.

proc tk::SaveGrabInfo w {
variable ::tk::Priv
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 {} {
variable ::tk::Priv

if {$Priv(oldGrab) ne ""} {
	# Be careful restoring the old grab, since it's window may not
# be visible anymore.

catch {
      if {$Priv(grabStatus) eq "global"} {
	grab set -global $Priv(oldGrab)
    } else {
	grab set $Priv(oldGrab)
    }
}
set Priv(oldGrab) ""
}

}

proc ::tk_menuSetFocus {menu} {
variable ::tk::Priv
if {![info exists Priv(focus)] || $Priv(focus) eq “”} {
set Priv(focus) [focus]
}
focus $menu
}

proc ::tk::GenerateMenuSelect {menu} {
variable ::tk::Priv

if {$Priv(activeMenu) eq $menu && $Priv(activeItem) eq [$menu index active]} {
return
}

set Priv(activeMenu) $menu
set Priv(activeItem) [$menu index active]
event generate $menu <<MenuSelect>>

}

::tk_popup –

This procedure pops up a menu and sets things up for traversing

the menu and its submenus.

Arguments:

menu - Name of the menu to be popped up.

x, y - Root coordinates at which to pop up the

menu.

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 {}}} {
variable ::tk::Priv
global tcl_platform
if {$Priv(popup) ne “” || $Priv(postedMb) ne “”} {
tk::MenuUnpost {}
}
tk::PostOverPoint $menu $x $y $entry
if {[tk windowingsystem] eq “x11” && [winfo viewable $menu]} {
tk::SaveGrabInfo $menu
grab -global $menu
set Priv(popup) $menu
tk_menuSetFocus $menu
}
}