diff options
Diffstat (limited to 'tk8.6/library/menu.tcl')
-rw-r--r-- | tk8.6/library/menu.tcl | 1354 |
1 files changed, 1354 insertions, 0 deletions
diff --git a/tk8.6/library/menu.tcl b/tk8.6/library/menu.tcl new file mode 100644 index 0000000..e1c94c9 --- /dev/null +++ b/tk8.6/library/menu.tcl @@ -0,0 +1,1354 @@ +# 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. +# +# 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@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 <<MenuSelect>> virtual event. +# activeItem - This is the last active menu item for +# use with the <<MenuSelect>> 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 <FocusIn> {} +bind Menubutton <Enter> { + tk::MbEnter %W +} +bind Menubutton <Leave> { + tk::MbLeave %W +} +bind Menubutton <1> { + if {$tk::Priv(inMenubutton) ne ""} { + tk::MbPost $tk::Priv(inMenubutton) %X %Y + } +} +bind Menubutton <Motion> { + tk::MbMotion %W up %X %Y +} +bind Menubutton <B1-Motion> { + tk::MbMotion %W down %X %Y +} +bind Menubutton <ButtonRelease-1> { + tk::MbButtonUp %W +} +bind Menubutton <space> { + tk::MbPost %W + tk::MenuFirstEntry [%W cget -menu] +} +bind Menubutton <<Invoke>> { + 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 <FocusIn> {} + +bind Menu <Enter> { + 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 <Leave> { + tk::MenuLeave %W %X %Y %s +} +bind Menu <Motion> { + tk::MenuMotion %W %x %y %s +} +bind Menu <ButtonPress> { + tk::MenuButtonDown %W +} +bind Menu <ButtonRelease> { + tk::MenuInvoke %W 1 +} +bind Menu <space> { + tk::MenuInvoke %W 0 +} +bind Menu <<Invoke>> { + tk::MenuInvoke %W 0 +} +bind Menu <Return> { + tk::MenuInvoke %W 0 +} +bind Menu <Escape> { + tk::MenuEscape %W +} +bind Menu <<PrevChar>> { + tk::MenuLeftArrow %W +} +bind Menu <<NextChar>> { + tk::MenuRightArrow %W +} +bind Menu <<PrevLine>> { + tk::MenuUpArrow %W +} +bind Menu <<NextLine>> { + tk::MenuDownArrow %W +} +bind Menu <KeyPress> { + tk::TraverseWithinMenu %W %A + break +} + +# The following bindings apply to all windows, and are used to +# implement keyboard menu traversal. + +if {[tk windowingsystem] eq "x11"} { + bind all <Alt-KeyPress> { + tk::TraverseToMenu %W %A + } + + bind all <F10> { + tk::FirstMenu %W + } +} else { + bind Menubutton <Alt-KeyPress> { + 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 + + 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} { + return -code error -errorcode {TK MENUBUTTON POST_NONCHILD} \ + "can't post $menu: it isn't a descendant of $w" + } + set cur $Priv(postedMb) + if {$cur ne ""} { + MenuUnpost {} + } + if {$::tk_strictMotif} { + 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 < [winfo vrooty $w]} { + set y [expr {[winfo vrooty $w] + [winfo rooty $w] + [winfo reqheight $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 vrooty $w] + [winfo vrootheight $w])} { + set y [expr {[winfo vrooty $w] + [winfo vrootheight $w] + [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 {$entry eq ""} { + set entry 0 + } + 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 {$entry eq ""} { + set entry 0 + } + 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 opt]} { + # Error posting menu (e.g. bogus -postcommand). Unpost it and + # reflect the error. + + MenuUnpost {} + return -options $opt $msg + } + + 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 { + 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. + + after cancel [array get Priv menuActivatedTimer] + unset -nocomplain Priv(menuActivated) + after cancel [array get Priv menuDeactivatedTimer] + unset -nocomplain Priv(menuDeactivated) + + catch { + if {$mb ne ""} { + set menu [$mb cget -menu] + $menu unpost + set Priv(postedMb) {} + if {$::tk_strictMotif} { + $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 ""} { + if {$::tk_strictMotif} { + $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 + + 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)} { + set activeindex [$menu index active] + 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 + } + set index [$menu index @$x,$y] + if {[info exists Priv(menuActivated)] \ + && $index ne "none" \ + && $index ne $activeindex} { + set mode [option get $menu clickToFocus ClickToFocus] + if {[string is false $mode]} { + set delay [expr {[$menu cget -type] eq "menubar" ? 0 : 50}] + if {[$menu type $index] eq "cascade"} { + set Priv(menuActivatedTimer) \ + [after $delay [list $menu postcascade active]] + } else { + set Priv(menuDeactivatedTimer) \ + [after $delay [list $menu postcascade none]] + } + } + } + } +} + +# ::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 + + if {![winfo viewable $menu]} { + return + } + if {[$menu index active] eq "none"} { + set Priv(window) {} + 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 + if {$::tk_strictMotif} { + set Priv(cursor) [$menu cget -cursor] + $menu configure -cursor arrow + } + if {[$menu type active] eq "cascade"} { + set Priv(menuActivated) 1 + } + } + + # 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" && [$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 {![winfo exists $w] || $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 {}}} { + 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 {[tk windowingsystem] eq "win32"} { + # osVersion is not available in safe interps + set ver 5 + if {[info exists ::tcl_platform(osVersion)]} { + scan $::tcl_platform(osVersion) %d ver + } + + # 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. + # NOTE: this issue appears to have been resolved in the Window + # manager provided with Vista and Windows 7. + if {$ver < 6} { + set yoffset [expr {[winfo screenheight $menu] \ + - $y - [winfo reqheight $menu] - 10}] + if {$yoffset < [winfo vrooty $menu]} { + # The bottom of the menu is offscreen, so adjust upwards + incr y [expr {$yoffset - [winfo vrooty $menu]}] + } + # 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 < [winfo vrooty $menu]} { + set y [winfo vrooty $menu] + } + } + } + $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 + 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 + set Priv(window) $menu + set Priv(menuActivated) 1 + tk_menuSetFocus $menu + } +} |