# 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.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 # 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 {[string equal [tk windowingsystem] "x11"]} { bind all { tk::TraverseToMenu %W %A } bind all { tk::FirstMenu %W } } else { bind Menubutton { tk::TraverseToMenu %W %A } bind Menubutton { 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 {[string compare $Priv(inMenubutton) ""]} { MbLeave $Priv(inMenubutton) } set Priv(inMenubutton) $w if {[string compare [$w cget -state] "disabled"]} { $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 {[string equal [$w cget -state] "active"]} { $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 {[string equal $menu ""]} { 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 {[string compare $cur ""]} { MenuUnpost {} } set Priv(cursor) [$w cget -cursor] set Priv(relief) [$w cget -relief] $w configure -cursor arrow $w configure -relief raised 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 {[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]] } 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 {[string compare $mb ""]} { set menu [$mb cget -menu] $menu unpost set Priv(postedMb) {} $mb configure -cursor $Priv(cursor) $mb configure -relief $Priv(relief) } elseif {[string compare $Priv(popup) ""]} { $Priv(popup) unpost set 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. while {1} { set parent [winfo parent $menu] if {[string compare [winfo class $parent] "Menu"] \ || ![winfo ismapped $parent]} { break } $parent activate none $parent postcascade none GenerateMenuSelect $parent set type [$parent cget -type] if {[string equal $type "menubar"] || \ [string equal $type "tearoff"]} { break } set menu $parent } if {[string compare [$menu cget -type] "menubar"]} { $menu unpost } } } if {($Priv(tearoff) != 0) || $Priv(menuBar) ne ""} { # Release grab, if any, and restore the previous grab, if there # was one. if {[string compare $menu ""]} { set grab [grab current $menu] if {[string compare $grab ""]} { 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 {[string equal $Priv(inMenubutton) $w]} { return } 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 } 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 {[string equal $menu $Priv(window)]} { if {[string equal [$menu cget -type] "menubar"]} { if {[info exists Priv(focus)] && \ [string compare $menu $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 {[string compare $Priv(postedMb) ""] && \ [winfo viewable $Priv(postedMb)]} { grab -global $Priv(postedMb) } else { 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(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 {[string compare $menu [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 {[string equal [tk windowingsystem] "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 {[string equal [$menu index active] "none"]} { return } if {[string equal [$menu type active] "cascade"] && [string equal [winfo containing $rootx $rooty] \ [$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 && [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. $w postcascade none $w activate none event generate $w <> MenuUnpost $w return } if {[string equal [$w type active] "cascade"]} { $w postcascade active set menu [$w entrycget active -menu] MenuFirstEntry $menu } elseif {[string equal [$w type active] "tearoff"]} { ::tk::TearOffMenu $w MenuUnpost $w } elseif {[string equal [$w cget -type] "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 <> } 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 {[string compare [winfo class $parent] "Menu"]} { MenuUnpost $menu } elseif {[string equal [$parent cget -type] "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 {[string equal [$menu cget -type] "menubar"]} { MenuNextMenu $menu left } else { MenuNextEntry $menu -1 } } proc ::tk::MenuDownArrow {menu} { if {[string equal [$menu cget -type] "menubar"]} { MenuNextMenu $menu right } else { MenuNextEntry $menu 1 } } proc ::tk::MenuLeftArrow {menu} { if {[string equal [$menu cget -type] "menubar"]} { MenuNextEntry $menu -1 } else { MenuNextMenu $menu left } } proc ::tk::MenuRightArrow {menu} { if {[string equal [$menu cget -type] "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 {[string equal $direction "right"]} { set count 1 set parent [winfo parent $menu] set class [winfo class $parent] if {[string equal [$menu type active] "cascade"]} { $menu postcascade active set m2 [$menu entrycget active -menu] if {[string compare $m2 ""]} { MenuFirstEntry $m2 } return } else { set parent [winfo parent $menu] while {[string compare $parent "."]} { if {[string equal [winfo class $parent] "Menu"] \ && [string equal [$parent cget -type] "menubar"]} { tk_menuSetFocus $parent MenuNextEntry $parent 1 return } set parent [winfo parent $parent] } } } else { set count -1 set m2 [winfo parent $menu] if {[string equal [winfo class $m2] "Menu"]} { $menu activate none GenerateMenuSelect $menu tk_menuSetFocus $m2 $m2 postcascade none if {[string compare [$m2 cget -type] "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 {[string equal [winfo class $m2] "Menu"]} { if {[string equal [$m2 cget -type] "menubar"]} { tk_menuSetFocus $m2 MenuNextEntry $m2 -1 return } } set w $Priv(postedMb) if {[string equal $w ""]} { 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 {[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"]} { break } if {[string equal $mb $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 {[string equal [$menu index last] "none"]} { return } set length [expr {[$menu index last]+1}] set quitAfter $length set active [$menu index active] if {[string equal $active "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 {[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. $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 {[string compare [winfo toplevel $w] [winfo toplevel $child]]} { continue } if {[string equal [winfo class $child] "Menu"] && \ [string equal [$child cget -type] "menubar"]} { if {[string equal $char ""]} { return $child } set last [$child index last] for {set i [$child cget -tearoff]} {$i <= $last} {incr i} { if {[string equal [$child type $i] "separator"]} { continue } 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"]} { return $child } } } } } foreach child $windowlist { # Don't descend into other toplevels. if {[string compare [winfo toplevel $w] [winfo toplevel $child]]} { continue } switch [winfo class $child] { Menubutton { 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"]} { return $child } } } default { set match [MenuFind $child $char] if {[string compare $match ""]} { 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 {[string equal $char ""]} { return } while {[string equal [winfo class $w] "Menu"]} { if {[string compare [$w cget -type] "menubar"] \ && [string equal $Priv(postedMb) ""]} { return } if {[string equal [$w cget -type] "menubar"]} { break } set w [winfo parent $w] } set w [MenuFind [winfo toplevel $w] $char] if {[string compare $w ""]} { if {[string equal [winfo class $w] "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 {[string compare $w ""]} { if {[string equal [winfo class $w] "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 {[string equal $char ""]} { return } set char [string tolower $char] set last [$w index last] if {[string equal $last "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 {[string equal $char [string tolower $char2]]} { if {[string equal [$w type $i] "cascade"]} { $w activate $i $w postcascade active event generate $w <> set m2 [$w entrycget $i -menu] if {[string compare $m2 ""]} { 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 {[string equal $menu ""]} { return } tk_menuSetFocus $menu if {[string compare [$menu index active] "none"]} { return } set last [$menu index last] if {[string equal $last "none"]} { return } 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"]} { $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 {[string equal [$menu type $i] "cascade"] && \ [string equal [$menu cget -type] "menubar"]} { set cascade [$menu entrycget $i -menu] if {[string compare $cascade ""]} { $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 {[string equal $last "none"]} { return } for {set i 0} {$i <= $last} {incr i} { if {![catch {$menu entrycget $i -label} label]} { if {[string equal $label $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 {[string compare $entry {}]} { 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) == "windows"} { # We need to fix some problems with menu posting on Windows. set yoffset [expr {[winfo screenheight $menu] \ - $y - [winfo reqheight $menu]}] 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 {[string equal $Priv(grabStatus) "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)] || [string equal $Priv(focus) {}]} { set Priv(focus) [focus] } focus $menu } proc ::tk::GenerateMenuSelect {menu} { variable ::tk::Priv if {[string equal $Priv(activeMenu) $menu] \ && [string equal $Priv(activeItem) [$menu index active]]} { return } set Priv(activeMenu) $menu set Priv(activeItem) [$menu index active] event generate $menu <> } # ::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 } }