home *** CD-ROM | disk | FTP | other *** search
/ Freelog Special Freeware 31 / FreelogHS31.iso / Texte / scribus / scribus-1.3.3.9-win32-install.exe / tcl / tk8.4 / menu.tcl < prev    next >
Text File  |  2004-02-03  |  37KB  |  1,305 lines
  1. # menu.tcl --
  2. #
  3. # This file defines the default bindings for Tk menus and menubuttons.
  4. # It also implements keyboard traversal of menus and implements a few
  5. # other utility procedures related to menus.
  6. #
  7. # RCS: @(#) $Id: menu.tcl,v 1.18.2.1 2004/02/04 00:23:04 hobbs Exp $
  8. #
  9. # Copyright (c) 1992-1994 The Regents of the University of California.
  10. # Copyright (c) 1994-1997 Sun Microsystems, Inc.
  11. # Copyright (c) 1998-1999 by Scriptics Corporation.
  12. #
  13. # See the file "license.terms" for information on usage and redistribution
  14. # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  15. #
  16.  
  17. #-------------------------------------------------------------------------
  18. # Elements of tk::Priv that are used in this file:
  19. #
  20. # cursor -        Saves the -cursor option for the posted menubutton.
  21. # focus -        Saves the focus during a menu selection operation.
  22. #            Focus gets restored here when the menu is unposted.
  23. # grabGlobal -        Used in conjunction with tk::Priv(oldGrab):  if
  24. #            tk::Priv(oldGrab) is non-empty, then tk::Priv(grabGlobal)
  25. #            contains either an empty string or "-global" to
  26. #            indicate whether the old grab was a local one or
  27. #            a global one.
  28. # inMenubutton -    The name of the menubutton widget containing
  29. #            the mouse, or an empty string if the mouse is
  30. #            not over any menubutton.
  31. # menuBar -        The name of the menubar that is the root
  32. #            of the cascade hierarchy which is currently
  33. #            posted. This is null when there is no menu currently
  34. #            being pulled down from a menu bar.
  35. # oldGrab -        Window that had the grab before a menu was posted.
  36. #            Used to restore the grab state after the menu
  37. #            is unposted.  Empty string means there was no
  38. #            grab previously set.
  39. # popup -        If a menu has been popped up via tk_popup, this
  40. #            gives the name of the menu.  Otherwise this
  41. #            value is empty.
  42. # postedMb -        Name of the menubutton whose menu is currently
  43. #            posted, or an empty string if nothing is posted
  44. #            A grab is set on this widget.
  45. # relief -        Used to save the original relief of the current
  46. #            menubutton.
  47. # window -        When the mouse is over a menu, this holds the
  48. #            name of the menu;  it's cleared when the mouse
  49. #            leaves the menu.
  50. # tearoff -        Whether the last menu posted was a tearoff or not.
  51. #            This is true always for unix, for tearoffs for Mac
  52. #            and Windows.
  53. # activeMenu -        This is the last active menu for use
  54. #            with the <<MenuSelect>> virtual event.
  55. # activeItem -        This is the last active menu item for
  56. #            use with the <<MenuSelect>> virtual event.
  57. #-------------------------------------------------------------------------
  58.  
  59. #-------------------------------------------------------------------------
  60. # Overall note:
  61. # This file is tricky because there are five different ways that menus
  62. # can be used:
  63. #
  64. # 1. As a pulldown from a menubutton. In this style, the variable 
  65. #    tk::Priv(postedMb) identifies the posted menubutton.
  66. # 2. As a torn-off menu copied from some other menu.  In this style
  67. #    tk::Priv(postedMb) is empty, and menu's type is "tearoff".
  68. # 3. As an option menu, triggered from an option menubutton.  In this
  69. #    style tk::Priv(postedMb) identifies the posted menubutton.
  70. # 4. As a popup menu.  In this style tk::Priv(postedMb) is empty and
  71. #    the top-level menu's type is "normal".
  72. # 5. As a pulldown from a menubar. The variable tk::Priv(menubar) has
  73. #    the owning menubar, and the menu itself is of type "normal".
  74. #
  75. # The various binding procedures use the  state described above to
  76. # distinguish the various cases and take different actions in each
  77. # case.
  78. #-------------------------------------------------------------------------
  79.  
  80. #-------------------------------------------------------------------------
  81. # The code below creates the default class bindings for menus
  82. # and menubuttons.
  83. #-------------------------------------------------------------------------
  84.  
  85. bind Menubutton <FocusIn> {}
  86. bind Menubutton <Enter> {
  87.     tk::MbEnter %W
  88. }
  89. bind Menubutton <Leave> {
  90.     tk::MbLeave %W
  91. }
  92. bind Menubutton <1> {
  93.     if {$tk::Priv(inMenubutton) ne ""} {
  94.     tk::MbPost $tk::Priv(inMenubutton) %X %Y
  95.     }
  96. }
  97. bind Menubutton <Motion> {
  98.     tk::MbMotion %W up %X %Y
  99. }
  100. bind Menubutton <B1-Motion> {
  101.     tk::MbMotion %W down %X %Y
  102. }
  103. bind Menubutton <ButtonRelease-1> {
  104.     tk::MbButtonUp %W
  105. }
  106. bind Menubutton <space> {
  107.     tk::MbPost %W
  108.     tk::MenuFirstEntry [%W cget -menu]
  109. }
  110.  
  111. # Must set focus when mouse enters a menu, in order to allow
  112. # mixed-mode processing using both the mouse and the keyboard.
  113. # Don't set the focus if the event comes from a grab release,
  114. # though:  such an event can happen after as part of unposting
  115. # a cascaded chain of menus, after the focus has already been
  116. # restored to wherever it was before menu selection started.
  117.  
  118. bind Menu <FocusIn> {}
  119.  
  120. bind Menu <Enter> {
  121.     set tk::Priv(window) %W
  122.     if {[%W cget -type] eq "tearoff"} {
  123.     if {"%m" ne "NotifyUngrab"} {
  124.         if {[tk windowingsystem] eq "x11"} {
  125.         tk_menuSetFocus %W
  126.         }
  127.     }
  128.     }
  129.     tk::MenuMotion %W %x %y %s
  130. }
  131.  
  132. bind Menu <Leave> {
  133.     tk::MenuLeave %W %X %Y %s
  134. }
  135. bind Menu <Motion> {
  136.     tk::MenuMotion %W %x %y %s
  137. }
  138. bind Menu <ButtonPress> {
  139.     tk::MenuButtonDown %W
  140. }
  141. bind Menu <ButtonRelease> {
  142.    tk::MenuInvoke %W 1
  143. }
  144. bind Menu <space> {
  145.     tk::MenuInvoke %W 0
  146. }
  147. bind Menu <Return> {
  148.     tk::MenuInvoke %W 0
  149. }
  150. bind Menu <Escape> {
  151.     tk::MenuEscape %W
  152. }
  153. bind Menu <Left> {
  154.     tk::MenuLeftArrow %W
  155. }
  156. bind Menu <Right> {
  157.     tk::MenuRightArrow %W
  158. }
  159. bind Menu <Up> {
  160.     tk::MenuUpArrow %W
  161. }
  162. bind Menu <Down> {
  163.     tk::MenuDownArrow %W
  164. }
  165. bind Menu <KeyPress> {
  166.     tk::TraverseWithinMenu %W %A
  167. }
  168.  
  169. # The following bindings apply to all windows, and are used to
  170. # implement keyboard menu traversal.
  171.  
  172. if {[string equal [tk windowingsystem] "x11"]} {
  173.     bind all <Alt-KeyPress> {
  174.     tk::TraverseToMenu %W %A
  175.     }
  176.  
  177.     bind all <F10> {
  178.     tk::FirstMenu %W
  179.     }
  180. } else {
  181.     bind Menubutton <Alt-KeyPress> {
  182.     tk::TraverseToMenu %W %A
  183.     }
  184.  
  185.     bind Menubutton <F10> {
  186.     tk::FirstMenu %W
  187.     }
  188. }
  189.  
  190. # ::tk::MbEnter --
  191. # This procedure is invoked when the mouse enters a menubutton
  192. # widget.  It activates the widget unless it is disabled.  Note:
  193. # this procedure is only invoked when mouse button 1 is *not* down.
  194. # The procedure ::tk::MbB1Enter is invoked if the button is down.
  195. #
  196. # Arguments:
  197. # w -            The  name of the widget.
  198.  
  199. proc ::tk::MbEnter w {
  200.     variable ::tk::Priv
  201.  
  202.     if {[string compare $Priv(inMenubutton) ""]} {
  203.     MbLeave $Priv(inMenubutton)
  204.     }
  205.     set Priv(inMenubutton) $w
  206.     if {[string compare [$w cget -state] "disabled"]} {
  207.     $w configure -state active
  208.     }
  209. }
  210.  
  211. # ::tk::MbLeave --
  212. # This procedure is invoked when the mouse leaves a menubutton widget.
  213. # It de-activates the widget, if the widget still exists.
  214. #
  215. # Arguments:
  216. # w -            The  name of the widget.
  217.  
  218. proc ::tk::MbLeave w {
  219.     variable ::tk::Priv
  220.  
  221.     set Priv(inMenubutton) {}
  222.     if {![winfo exists $w]} {
  223.     return
  224.     }
  225.     if {[string equal [$w cget -state] "active"]} {
  226.     $w configure -state normal
  227.     }
  228. }
  229.  
  230. # ::tk::MbPost --
  231. # Given a menubutton, this procedure does all the work of posting
  232. # its associated menu and unposting any other menu that is currently
  233. # posted.
  234. #
  235. # Arguments:
  236. # w -            The name of the menubutton widget whose menu
  237. #            is to be posted.
  238. # x, y -        Root coordinates of cursor, used for positioning
  239. #            option menus.  If not specified, then the center
  240. #            of the menubutton is used for an option menu.
  241.  
  242. proc ::tk::MbPost {w {x {}} {y {}}} {
  243.     global errorInfo
  244.     variable ::tk::Priv
  245.     global tcl_platform
  246.  
  247.     if {[$w cget -state] eq "disabled" || $w eq $Priv(postedMb)} {
  248.     return
  249.     }
  250.     set menu [$w cget -menu]
  251.     if {[string equal $menu ""]} {
  252.     return
  253.     }
  254.     set tearoff [expr {[tk windowingsystem] eq "x11" \
  255.         || [$menu cget -type] eq "tearoff"}]
  256.     if {[string first $w $menu] != 0} {
  257.     error "can't post $menu:  it isn't a descendant of $w (this is a new requirement in Tk versions 3.0 and later)"
  258.     }
  259.     set cur $Priv(postedMb)
  260.     if {[string compare $cur ""]} {
  261.     MenuUnpost {}
  262.     }
  263.     set Priv(cursor) [$w cget -cursor]
  264.     set Priv(relief) [$w cget -relief]
  265.     $w configure -cursor arrow
  266.     $w configure -relief raised
  267.  
  268.     set Priv(postedMb) $w
  269.     set Priv(focus) [focus]
  270.     $menu activate none
  271.     GenerateMenuSelect $menu
  272.  
  273.     # If this looks like an option menubutton then post the menu so
  274.     # that the current entry is on top of the mouse.  Otherwise post
  275.     # the menu just below the menubutton, as for a pull-down.
  276.  
  277.     update idletasks
  278.     if {[catch {
  279.     switch [$w cget -direction] {
  280.             above {
  281.                 set x [winfo rootx $w]
  282.                 set y [expr {[winfo rooty $w] - [winfo reqheight $menu]}]
  283.         # if we go offscreen to the top, show as 'below'
  284.         if {$y < 0} {
  285.             set y [expr {[winfo rooty $w] + [winfo height $w]}]
  286.         }
  287.         PostOverPoint $menu $x $y
  288.             }
  289.             below {
  290.                 set x [winfo rootx $w]
  291.                 set y [expr {[winfo rooty $w] + [winfo height $w]}]
  292.         # if we go offscreen to the bottom, show as 'above'
  293.         set mh [winfo reqheight $menu]
  294.         if {($y + $mh) > [winfo screenheight $w]} {
  295.             set y [expr {[winfo rooty $w] - $mh}]
  296.         }
  297.         PostOverPoint $menu $x $y
  298.             }
  299.             left {
  300.                 set x [expr {[winfo rootx $w] - [winfo reqwidth $menu]}]
  301.                 set y [expr {(2 * [winfo rooty $w] + [winfo height $w]) / 2}]
  302.                 set entry [MenuFindName $menu [$w cget -text]]
  303.                 if {[$w cget -indicatoron]} {
  304.             if {$entry == [$menu index last]} {
  305.                 incr y [expr {-([$menu yposition $entry] \
  306.                     + [winfo reqheight $menu])/2}]
  307.             } else {
  308.                 incr y [expr {-([$menu yposition $entry] \
  309.                     + [$menu yposition [expr {$entry+1}]])/2}]
  310.             }
  311.                 }
  312.         PostOverPoint $menu $x $y
  313.         if {$entry ne "" \
  314.             && [$menu entrycget $entry -state] ne "disabled"} {
  315.                     $menu activate $entry
  316.             GenerateMenuSelect $menu
  317.                 }
  318.             }
  319.             right {
  320.                 set x [expr {[winfo rootx $w] + [winfo width $w]}]
  321.                 set y [expr {(2 * [winfo rooty $w] + [winfo height $w]) / 2}]
  322.                 set entry [MenuFindName $menu [$w cget -text]]
  323.                 if {[$w cget -indicatoron]} {
  324.             if {$entry == [$menu index last]} {
  325.                 incr y [expr {-([$menu yposition $entry] \
  326.                     + [winfo reqheight $menu])/2}]
  327.             } else {
  328.                 incr y [expr {-([$menu yposition $entry] \
  329.                     + [$menu yposition [expr {$entry+1}]])/2}]
  330.             }
  331.                 }
  332.         PostOverPoint $menu $x $y
  333.         if {$entry ne "" \
  334.             && [$menu entrycget $entry -state] ne "disabled"} {
  335.                     $menu activate $entry
  336.             GenerateMenuSelect $menu
  337.                 }
  338.             }
  339.             default {
  340.                 if {[$w cget -indicatoron]} {
  341.             if {[string equal $y {}]} {
  342.             set x [expr {[winfo rootx $w] + [winfo width $w]/2}]
  343.             set y [expr {[winfo rooty $w] + [winfo height $w]/2}]
  344.                 }
  345.                 PostOverPoint $menu $x $y [MenuFindName $menu [$w cget -text]]
  346.         } else {
  347.             PostOverPoint $menu [winfo rootx $w] [expr {[winfo rooty $w]+[winfo height $w]}]
  348.                 }
  349.             }
  350.     }
  351.     } msg]} {
  352.     # Error posting menu (e.g. bogus -postcommand). Unpost it and
  353.     # reflect the error.
  354.     
  355.     set savedInfo $errorInfo
  356.     MenuUnpost {}
  357.     error $msg $savedInfo
  358.  
  359.     }
  360.  
  361.     set Priv(tearoff) $tearoff
  362.     if {$tearoff != 0} {
  363.         focus $menu
  364.     if {[winfo viewable $w]} {
  365.         SaveGrabInfo $w
  366.         grab -global $w
  367.     }
  368.     }
  369. }
  370.  
  371. # ::tk::MenuUnpost --
  372. # This procedure unposts a given menu, plus all of its ancestors up
  373. # to (and including) a menubutton, if any.  It also restores various
  374. # values to what they were before the menu was posted, and releases
  375. # a grab if there's a menubutton involved.  Special notes:
  376. # 1. It's important to unpost all menus before releasing the grab, so
  377. #    that any Enter-Leave events (e.g. from menu back to main
  378. #    application) have mode NotifyGrab.
  379. # 2. Be sure to enclose various groups of commands in "catch" so that
  380. #    the procedure will complete even if the menubutton or the menu
  381. #    or the grab window has been deleted.
  382. #
  383. # Arguments:
  384. # menu -        Name of a menu to unpost.  Ignored if there
  385. #            is a posted menubutton.
  386.  
  387. proc ::tk::MenuUnpost menu {
  388.     global tcl_platform
  389.     variable ::tk::Priv
  390.     set mb $Priv(postedMb)
  391.  
  392.     # Restore focus right away (otherwise X will take focus away when
  393.     # the menu is unmapped and under some window managers (e.g. olvwm)
  394.     # we'll lose the focus completely).
  395.  
  396.     catch {focus $Priv(focus)}
  397.     set Priv(focus) ""
  398.  
  399.     # Unpost menu(s) and restore some stuff that's dependent on
  400.     # what was posted.
  401.  
  402.     catch {
  403.     if {[string compare $mb ""]} {
  404.         set menu [$mb cget -menu]
  405.         $menu unpost
  406.         set Priv(postedMb) {}
  407.         $mb configure -cursor $Priv(cursor)
  408.         $mb configure -relief $Priv(relief)
  409.     } elseif {[string compare $Priv(popup) ""]} {
  410.         $Priv(popup) unpost
  411.         set Priv(popup) {}
  412.     } elseif {[string compare [$menu cget -type] "menubar"] \
  413.         && [string compare [$menu cget -type] "tearoff"]} {
  414.         # We're in a cascaded sub-menu from a torn-off menu or popup.
  415.         # Unpost all the menus up to the toplevel one (but not
  416.         # including the top-level torn-off one) and deactivate the
  417.         # top-level torn off menu if there is one.
  418.  
  419.         while {1} {
  420.         set parent [winfo parent $menu]
  421.         if {[string compare [winfo class $parent] "Menu"] \
  422.             || ![winfo ismapped $parent]} {
  423.             break
  424.         }
  425.         $parent activate none
  426.         $parent postcascade none
  427.         GenerateMenuSelect $parent
  428.         set type [$parent cget -type]
  429.         if {[string equal $type "menubar"] || \
  430.             [string equal $type "tearoff"]} {
  431.             break
  432.         }
  433.         set menu $parent
  434.         }
  435.         if {[string compare [$menu cget -type] "menubar"]} {
  436.         $menu unpost
  437.         }
  438.     }
  439.     }
  440.  
  441.     if {($Priv(tearoff) != 0) || $Priv(menuBar) ne ""} {
  442.         # Release grab, if any, and restore the previous grab, if there
  443.         # was one.
  444.     if {[string compare $menu ""]} {
  445.         set grab [grab current $menu]
  446.         if {[string compare $grab ""]} {
  447.         grab release $grab
  448.         }
  449.     }
  450.     RestoreOldGrab
  451.     if {$Priv(menuBar) ne ""} {
  452.         $Priv(menuBar) configure -cursor $Priv(cursor)
  453.         set Priv(menuBar) {}
  454.     }
  455.     if {[tk windowingsystem] ne "x11"} {
  456.         set Priv(tearoff) 0
  457.     }
  458.     }
  459. }
  460.  
  461. # ::tk::MbMotion --
  462. # This procedure handles mouse motion events inside menubuttons, and
  463. # also outside menubuttons when a menubutton has a grab (e.g. when a
  464. # menu selection operation is in progress).
  465. #
  466. # Arguments:
  467. # w -            The name of the menubutton widget.
  468. # upDown -         "down" means button 1 is pressed, "up" means
  469. #            it isn't.
  470. # rootx, rooty -    Coordinates of mouse, in (virtual?) root window.
  471.  
  472. proc ::tk::MbMotion {w upDown rootx rooty} {
  473.     variable ::tk::Priv
  474.  
  475.     if {[string equal $Priv(inMenubutton) $w]} {
  476.     return
  477.     }
  478.     set new [winfo containing $rootx $rooty]
  479.     if {[string compare $new $Priv(inMenubutton)] \
  480.         && ([string equal $new ""] \
  481.         || [string equal [winfo toplevel $new] [winfo toplevel $w]])} {
  482.     if {[string compare $Priv(inMenubutton) ""]} {
  483.         MbLeave $Priv(inMenubutton)
  484.     }
  485.     if {[string compare $new ""] \
  486.         && [string equal [winfo class $new] "Menubutton"] \
  487.         && ([$new cget -indicatoron] == 0) \
  488.         && ([$w cget -indicatoron] == 0)} {
  489.         if {[string equal $upDown "down"]} {
  490.         MbPost $new $rootx $rooty
  491.         } else {
  492.         MbEnter $new
  493.         }
  494.     }
  495.     }
  496. }
  497.  
  498. # ::tk::MbButtonUp --
  499. # This procedure is invoked to handle button 1 releases for menubuttons.
  500. # If the release happens inside the menubutton then leave its menu
  501. # posted with element 0 activated.  Otherwise, unpost the menu.
  502. #
  503. # Arguments:
  504. # w -            The name of the menubutton widget.
  505.  
  506. proc ::tk::MbButtonUp w {
  507.     variable ::tk::Priv
  508.     global tcl_platform
  509.  
  510.     set menu [$w cget -menu]
  511.     set tearoff [expr {[tk windowingsystem] eq "x11" || \
  512.         ($menu ne "" && [$menu cget -type] eq "tearoff")}]
  513.     if {($tearoff != 0) && $Priv(postedMb) eq $w \
  514.         && $Priv(inMenubutton) eq $w} {
  515.     MenuFirstEntry [$Priv(postedMb) cget -menu]
  516.     } else {
  517.     MenuUnpost {}
  518.     }
  519. }
  520.  
  521. # ::tk::MenuMotion --
  522. # This procedure is called to handle mouse motion events for menus.
  523. # It does two things.  First, it resets the active element in the
  524. # menu, if the mouse is over the menu.  Second, if a mouse button
  525. # is down, it posts and unposts cascade entries to match the mouse
  526. # position.
  527. #
  528. # Arguments:
  529. # menu -        The menu window.
  530. # x -            The x position of the mouse.
  531. # y -            The y position of the mouse.
  532. # state -        Modifier state (tells whether buttons are down).
  533.  
  534. proc ::tk::MenuMotion {menu x y state} {
  535.     variable ::tk::Priv
  536.     if {[string equal $menu $Priv(window)]} {
  537.     if {[string equal [$menu cget -type] "menubar"]} {
  538.         if {[info exists Priv(focus)] && \
  539.             [string compare $menu $Priv(focus)]} {
  540.         $menu activate @$x,$y
  541.         GenerateMenuSelect $menu
  542.         }
  543.     } else {
  544.         $menu activate @$x,$y
  545.         GenerateMenuSelect $menu
  546.     }
  547.     }
  548.     if {($state & 0x1f00) != 0} {
  549.     $menu postcascade active
  550.     }
  551. }
  552.  
  553. # ::tk::MenuButtonDown --
  554. # Handles button presses in menus.  There are a couple of tricky things
  555. # here:
  556. # 1. Change the posted cascade entry (if any) to match the mouse position.
  557. # 2. If there is a posted menubutton, must grab to the menubutton;  this
  558. #    overrrides the implicit grab on button press, so that the menu
  559. #    button can track mouse motions over other menubuttons and change
  560. #    the posted menu.
  561. # 3. If there's no posted menubutton (e.g. because we're a torn-off menu
  562. #    or one of its descendants) must grab to the top-level menu so that
  563. #    we can track mouse motions across the entire menu hierarchy.
  564. #
  565. # Arguments:
  566. # menu -        The menu window.
  567.  
  568. proc ::tk::MenuButtonDown menu {
  569.     variable ::tk::Priv
  570.     global tcl_platform
  571.  
  572.     if {![winfo viewable $menu]} {
  573.         return
  574.     }
  575.     $menu postcascade active
  576.     if {[string compare $Priv(postedMb) ""] && \
  577.         [winfo viewable $Priv(postedMb)]} {
  578.     grab -global $Priv(postedMb)
  579.     } else {
  580.     while {[string equal [$menu cget -type] "normal"] \
  581.         && [string equal [winfo class [winfo parent $menu]] "Menu"] \
  582.         && [winfo ismapped [winfo parent $menu]]} {
  583.         set menu [winfo parent $menu]
  584.     }
  585.  
  586.     if {[string equal $Priv(menuBar) {}]} {
  587.         set Priv(menuBar) $menu
  588.         set Priv(cursor) [$menu cget -cursor]
  589.         $menu configure -cursor arrow
  590.         }
  591.  
  592.     # Don't update grab information if the grab window isn't changing.
  593.     # Otherwise, we'll get an error when we unpost the menus and
  594.     # restore the grab, since the old grab window will not be viewable
  595.     # anymore.
  596.  
  597.     if {[string compare $menu [grab current $menu]]} {
  598.         SaveGrabInfo $menu
  599.     }
  600.  
  601.     # Must re-grab even if the grab window hasn't changed, in order
  602.     # to release the implicit grab from the button press.
  603.  
  604.     if {[string equal [tk windowingsystem] "x11"]} {
  605.         grab -global $menu
  606.     }
  607.     }
  608. }
  609.  
  610. # ::tk::MenuLeave --
  611. # This procedure is invoked to handle Leave events for a menu.  It
  612. # deactivates everything unless the active element is a cascade element
  613. # and the mouse is now over the submenu.
  614. #
  615. # Arguments:
  616. # menu -        The menu window.
  617. # rootx, rooty -    Root coordinates of mouse.
  618. # state -        Modifier state.
  619.  
  620. proc ::tk::MenuLeave {menu rootx rooty state} {
  621.     variable ::tk::Priv
  622.     set Priv(window) {}
  623.     if {[string equal [$menu index active] "none"]} {
  624.     return
  625.     }
  626.     if {[string equal [$menu type active] "cascade"]
  627.           && [string equal [winfo containing $rootx $rooty] \
  628.                   [$menu entrycget active -menu]]} {
  629.     return
  630.     }
  631.     $menu activate none
  632.     GenerateMenuSelect $menu
  633. }
  634.  
  635. # ::tk::MenuInvoke --
  636. # This procedure is invoked when button 1 is released over a menu.
  637. # It invokes the appropriate menu action and unposts the menu if
  638. # it came from a menubutton.
  639. #
  640. # Arguments:
  641. # w -            Name of the menu widget.
  642. # buttonRelease -    1 means this procedure is called because of
  643. #            a button release;  0 means because of keystroke.
  644.  
  645. proc ::tk::MenuInvoke {w buttonRelease} {
  646.     variable ::tk::Priv
  647.  
  648.     if {$buttonRelease && [string equal $Priv(window) {}]} {
  649.     # Mouse was pressed over a menu without a menu button, then
  650.     # dragged off the menu (possibly with a cascade posted) and
  651.     # released.  Unpost everything and quit.
  652.  
  653.     $w postcascade none
  654.     $w activate none
  655.     event generate $w <<MenuSelect>>
  656.     MenuUnpost $w
  657.     return
  658.     }
  659.     if {[string equal [$w type active] "cascade"]} {
  660.     $w postcascade active
  661.     set menu [$w entrycget active -menu]
  662.     MenuFirstEntry $menu
  663.     } elseif {[string equal [$w type active] "tearoff"]} {
  664.     ::tk::TearOffMenu $w
  665.     MenuUnpost $w
  666.     } elseif {[string equal [$w cget -type] "menubar"]} {
  667.     $w postcascade none
  668.     set active [$w index active]
  669.     set isCascade [string equal [$w type $active] "cascade"]
  670.  
  671.     # Only de-activate the active item if it's a cascade; this prevents
  672.     # the annoying "activation flicker" you otherwise get with 
  673.     # checkbuttons/commands/etc. on menubars
  674.  
  675.     if { $isCascade } {
  676.         $w activate none
  677.         event generate $w <<MenuSelect>>
  678.     }
  679.  
  680.     MenuUnpost $w
  681.  
  682.     # If the active item is not a cascade, invoke it.  This enables
  683.     # the use of checkbuttons/commands/etc. on menubars (which is legal,
  684.     # but not recommended)
  685.  
  686.     if { !$isCascade } {
  687.         uplevel #0 [list $w invoke $active]
  688.     }
  689.     } else {
  690.     MenuUnpost $w
  691.     uplevel #0 [list $w invoke active]
  692.     }
  693. }
  694.  
  695. # ::tk::MenuEscape --
  696. # This procedure is invoked for the Cancel (or Escape) key.  It unposts
  697. # the given menu and, if it is the top-level menu for a menu button,
  698. # unposts the menu button as well.
  699. #
  700. # Arguments:
  701. # menu -        Name of the menu window.
  702.  
  703. proc ::tk::MenuEscape menu {
  704.     set parent [winfo parent $menu]
  705.     if {[string compare [winfo class $parent] "Menu"]} {
  706.     MenuUnpost $menu
  707.     } elseif {[string equal [$parent cget -type] "menubar"]} {
  708.     MenuUnpost $menu
  709.     RestoreOldGrab
  710.     } else {
  711.     MenuNextMenu $menu left
  712.     }
  713. }
  714.  
  715. # The following routines handle arrow keys. Arrow keys behave
  716. # differently depending on whether the menu is a menu bar or not.
  717.  
  718. proc ::tk::MenuUpArrow {menu} {
  719.     if {[string equal [$menu cget -type] "menubar"]} {
  720.     MenuNextMenu $menu left
  721.     } else {
  722.     MenuNextEntry $menu -1
  723.     }
  724. }
  725.  
  726. proc ::tk::MenuDownArrow {menu} {
  727.     if {[string equal [$menu cget -type] "menubar"]} {
  728.     MenuNextMenu $menu right
  729.     } else {
  730.     MenuNextEntry $menu 1
  731.     }
  732. }
  733.  
  734. proc ::tk::MenuLeftArrow {menu} {
  735.     if {[string equal [$menu cget -type] "menubar"]} {
  736.     MenuNextEntry $menu -1
  737.     } else {
  738.     MenuNextMenu $menu left
  739.     }
  740. }
  741.  
  742. proc ::tk::MenuRightArrow {menu} {
  743.     if {[string equal [$menu cget -type] "menubar"]} {
  744.     MenuNextEntry $menu 1
  745.     } else {
  746.     MenuNextMenu $menu right
  747.     }
  748. }
  749.  
  750. # ::tk::MenuNextMenu --
  751. # This procedure is invoked to handle "left" and "right" traversal
  752. # motions in menus.  It traverses to the next menu in a menu bar,
  753. # or into or out of a cascaded menu.
  754. #
  755. # Arguments:
  756. # menu -        The menu that received the keyboard
  757. #            event.
  758. # direction -        Direction in which to move: "left" or "right"
  759.  
  760. proc ::tk::MenuNextMenu {menu direction} {
  761.     variable ::tk::Priv
  762.  
  763.     # First handle traversals into and out of cascaded menus.
  764.  
  765.     if {[string equal $direction "right"]} {
  766.     set count 1
  767.     set parent [winfo parent $menu]
  768.     set class [winfo class $parent]
  769.     if {[string equal [$menu type active] "cascade"]} {
  770.         $menu postcascade active
  771.         set m2 [$menu entrycget active -menu]
  772.         if {[string compare $m2 ""]} {
  773.         MenuFirstEntry $m2
  774.         }
  775.         return
  776.     } else {
  777.         set parent [winfo parent $menu]
  778.         while {[string compare $parent "."]} {
  779.         if {[string equal [winfo class $parent] "Menu"] \
  780.             && [string equal [$parent cget -type] "menubar"]} {
  781.             tk_menuSetFocus $parent
  782.             MenuNextEntry $parent 1
  783.             return
  784.         }
  785.         set parent [winfo parent $parent]
  786.         }
  787.     }
  788.     } else {
  789.     set count -1
  790.     set m2 [winfo parent $menu]
  791.     if {[string equal [winfo class $m2] "Menu"]} {
  792.         $menu activate none
  793.         GenerateMenuSelect $menu
  794.         tk_menuSetFocus $m2
  795.  
  796.         $m2 postcascade none
  797.  
  798.         if {[string compare [$m2 cget -type] "menubar"]} {
  799.         return
  800.         }
  801.     }
  802.     }
  803.  
  804.     # Can't traverse into or out of a cascaded menu.  Go to the next
  805.     # or previous menubutton, if that makes sense.
  806.  
  807.     set m2 [winfo parent $menu]
  808.     if {[string equal [winfo class $m2] "Menu"]} {
  809.     if {[string equal [$m2 cget -type] "menubar"]} {
  810.         tk_menuSetFocus $m2
  811.         MenuNextEntry $m2 -1
  812.         return
  813.     }
  814.     }
  815.  
  816.     set w $Priv(postedMb)
  817.     if {[string equal $w ""]} {
  818.     return
  819.     }
  820.     set buttons [winfo children [winfo parent $w]]
  821.     set length [llength $buttons]
  822.     set i [expr {[lsearch -exact $buttons $w] + $count}]
  823.     while {1} {
  824.     while {$i < 0} {
  825.         incr i $length
  826.     }
  827.     while {$i >= $length} {
  828.         incr i -$length
  829.     }
  830.     set mb [lindex $buttons $i]
  831.     if {[string equal [winfo class $mb] "Menubutton"] \
  832.         && [string compare [$mb cget -state] "disabled"] \
  833.         && [string compare [$mb cget -menu] ""] \
  834.         && [string compare [[$mb cget -menu] index last] "none"]} {
  835.         break
  836.     }
  837.     if {[string equal $mb $w]} {
  838.         return
  839.     }
  840.     incr i $count
  841.     }
  842.     MbPost $mb
  843.     MenuFirstEntry [$mb cget -menu]
  844. }
  845.  
  846. # ::tk::MenuNextEntry --
  847. # Activate the next higher or lower entry in the posted menu,
  848. # wrapping around at the ends.  Disabled entries are skipped.
  849. #
  850. # Arguments:
  851. # menu -            Menu window that received the keystroke.
  852. # count -            1 means go to the next lower entry,
  853. #                -1 means go to the next higher entry.
  854.  
  855. proc ::tk::MenuNextEntry {menu count} {
  856.  
  857.     if {[string equal [$menu index last] "none"]} {
  858.     return
  859.     }
  860.     set length [expr {[$menu index last]+1}]
  861.     set quitAfter $length
  862.     set active [$menu index active]
  863.     if {[string equal $active "none"]} {
  864.     set i 0
  865.     } else {
  866.     set i [expr {$active + $count}]
  867.     }
  868.     while {1} {
  869.     if {$quitAfter <= 0} {
  870.         # We've tried every entry in the menu.  Either there are
  871.         # none, or they're all disabled.  Just give up.
  872.  
  873.         return
  874.     }
  875.     while {$i < 0} {
  876.         incr i $length
  877.     }
  878.     while {$i >= $length} {
  879.         incr i -$length
  880.     }
  881.     if {[catch {$menu entrycget $i -state} state] == 0} {
  882.         if {$state ne "disabled" && \
  883.             ($i!=0 || [$menu cget -type] ne "tearoff" \
  884.             || [$menu type 0] ne "tearoff")} {
  885.         break
  886.         }
  887.     }
  888.     if {$i == $active} {
  889.         return
  890.     }
  891.     incr i $count
  892.     incr quitAfter -1
  893.     }
  894.     $menu activate $i
  895.     GenerateMenuSelect $menu
  896.  
  897.     if {[string equal [$menu type $i] "cascade"] \
  898.         && [string equal [$menu cget -type] "menubar"]} {
  899.     set cascade [$menu entrycget $i -menu]
  900.     if {[string compare $cascade ""]} {
  901.         # Here we auto-post a cascade.  This is necessary when
  902.         # we traverse left/right in the menubar, but undesirable when
  903.         # we traverse up/down in a menu.
  904.         $menu postcascade $i
  905.         MenuFirstEntry $cascade
  906.     }
  907.     }
  908. }
  909.  
  910. # ::tk::MenuFind --
  911. # This procedure searches the entire window hierarchy under w for
  912. # a menubutton that isn't disabled and whose underlined character
  913. # is "char" or an entry in a menubar that isn't disabled and whose
  914. # underlined character is "char".
  915. # It returns the name of that window, if found, or an
  916. # empty string if no matching window was found.  If "char" is an
  917. # empty string then the procedure returns the name of the first
  918. # menubutton found that isn't disabled.
  919. #
  920. # Arguments:
  921. # w -                Name of window where key was typed.
  922. # char -            Underlined character to search for;
  923. #                may be either upper or lower case, and
  924. #                will match either upper or lower case.
  925.  
  926. proc ::tk::MenuFind {w char} {
  927.     set char [string tolower $char]
  928.     set windowlist [winfo child $w]
  929.  
  930.     foreach child $windowlist {
  931.     # Don't descend into other toplevels.
  932.         if {[string compare [winfo toplevel $w] [winfo toplevel $child]]} {
  933.         continue
  934.     }
  935.     if {[string equal [winfo class $child] "Menu"] && \
  936.         [string equal [$child cget -type] "menubar"]} {
  937.         if {[string equal $char ""]} {
  938.         return $child
  939.         }
  940.         set last [$child index last]
  941.         for {set i [$child cget -tearoff]} {$i <= $last} {incr i} {
  942.         if {[string equal [$child type $i] "separator"]} {
  943.             continue
  944.         }
  945.         set char2 [string index [$child entrycget $i -label] \
  946.             [$child entrycget $i -underline]]
  947.         if {[string equal $char [string tolower $char2]] \
  948.             || [string equal $char ""]} {
  949.             if {[string compare [$child entrycget $i -state] "disabled"]} {
  950.             return $child
  951.             }
  952.         }
  953.         }
  954.     }
  955.     }
  956.  
  957.     foreach child $windowlist {
  958.     # Don't descend into other toplevels.
  959.         if {[string compare [winfo toplevel $w] [winfo toplevel $child]]} {
  960.         continue
  961.     }
  962.     switch [winfo class $child] {
  963.         Menubutton {
  964.         set char2 [string index [$child cget -text] \
  965.             [$child cget -underline]]
  966.         if {[string equal $char [string tolower $char2]] \
  967.             || [string equal $char ""]} {
  968.             if {[string compare [$child cget -state] "disabled"]} {
  969.             return $child
  970.             }
  971.         }
  972.         }
  973.  
  974.         default {
  975.         set match [MenuFind $child $char]
  976.         if {[string compare $match ""]} {
  977.             return $match
  978.         }
  979.         }
  980.     }
  981.     }
  982.     return {}
  983. }
  984.  
  985. # ::tk::TraverseToMenu --
  986. # This procedure implements keyboard traversal of menus.  Given an
  987. # ASCII character "char", it looks for a menubutton with that character
  988. # underlined.  If one is found, it posts the menubutton's menu
  989. #
  990. # Arguments:
  991. # w -                Window in which the key was typed (selects
  992. #                a toplevel window).
  993. # char -            Character that selects a menu.  The case
  994. #                is ignored.  If an empty string, nothing
  995. #                happens.
  996.  
  997. proc ::tk::TraverseToMenu {w char} {
  998.     variable ::tk::Priv
  999.     if {[string equal $char ""]} {
  1000.     return
  1001.     }
  1002.     while {[string equal [winfo class $w] "Menu"]} {
  1003.     if {[string compare [$w cget -type] "menubar"] \
  1004.         && [string equal $Priv(postedMb) ""]} {
  1005.         return
  1006.     }
  1007.     if {[string equal [$w cget -type] "menubar"]} {
  1008.         break
  1009.     }
  1010.     set w [winfo parent $w]
  1011.     }
  1012.     set w [MenuFind [winfo toplevel $w] $char]
  1013.     if {[string compare $w ""]} {
  1014.     if {[string equal [winfo class $w] "Menu"]} {
  1015.         tk_menuSetFocus $w
  1016.         set Priv(window) $w
  1017.         SaveGrabInfo $w
  1018.         grab -global $w
  1019.         TraverseWithinMenu $w $char
  1020.     } else {
  1021.         MbPost $w
  1022.         MenuFirstEntry [$w cget -menu]
  1023.     }
  1024.     }
  1025. }
  1026.  
  1027. # ::tk::FirstMenu --
  1028. # This procedure traverses to the first menubutton in the toplevel
  1029. # for a given window, and posts that menubutton's menu.
  1030. #
  1031. # Arguments:
  1032. # w -                Name of a window.  Selects which toplevel
  1033. #                to search for menubuttons.
  1034.  
  1035. proc ::tk::FirstMenu w {
  1036.     variable ::tk::Priv
  1037.     set w [MenuFind [winfo toplevel $w] ""]
  1038.     if {[string compare $w ""]} {
  1039.     if {[string equal [winfo class $w] "Menu"]} {
  1040.         tk_menuSetFocus $w
  1041.         set Priv(window) $w
  1042.         SaveGrabInfo $w
  1043.         grab -global $w
  1044.         MenuFirstEntry $w
  1045.     } else {
  1046.         MbPost $w
  1047.         MenuFirstEntry [$w cget -menu]
  1048.     }
  1049.     }
  1050. }
  1051.  
  1052. # ::tk::TraverseWithinMenu
  1053. # This procedure implements keyboard traversal within a menu.  It
  1054. # searches for an entry in the menu that has "char" underlined.  If
  1055. # such an entry is found, it is invoked and the menu is unposted.
  1056. #
  1057. # Arguments:
  1058. # w -                The name of the menu widget.
  1059. # char -            The character to look for;  case is
  1060. #                ignored.  If the string is empty then
  1061. #                nothing happens.
  1062.  
  1063. proc ::tk::TraverseWithinMenu {w char} {
  1064.     if {[string equal $char ""]} {
  1065.     return
  1066.     }
  1067.     set char [string tolower $char]
  1068.     set last [$w index last]
  1069.     if {[string equal $last "none"]} {
  1070.     return
  1071.     }
  1072.     for {set i 0} {$i <= $last} {incr i} {
  1073.     if {[catch {set char2 [string index \
  1074.         [$w entrycget $i -label] [$w entrycget $i -underline]]}]} {
  1075.         continue
  1076.     }
  1077.     if {[string equal $char [string tolower $char2]]} {
  1078.         if {[string equal [$w type $i] "cascade"]} {
  1079.         $w activate $i
  1080.         $w postcascade active
  1081.         event generate $w <<MenuSelect>>
  1082.         set m2 [$w entrycget $i -menu]
  1083.         if {[string compare $m2 ""]} {
  1084.             MenuFirstEntry $m2
  1085.         }
  1086.         } else {
  1087.         MenuUnpost $w
  1088.         uplevel #0 [list $w invoke $i]
  1089.         }
  1090.         return
  1091.     }
  1092.     }
  1093. }
  1094.  
  1095. # ::tk::MenuFirstEntry --
  1096. # Given a menu, this procedure finds the first entry that isn't
  1097. # disabled or a tear-off or separator, and activates that entry.
  1098. # However, if there is already an active entry in the menu (e.g.,
  1099. # because of a previous call to tk::PostOverPoint) then the active
  1100. # entry isn't changed.  This procedure also sets the input focus
  1101. # to the menu.
  1102. #
  1103. # Arguments:
  1104. # menu -        Name of the menu window (possibly empty).
  1105.  
  1106. proc ::tk::MenuFirstEntry menu {
  1107.     if {[string equal $menu ""]} {
  1108.     return
  1109.     }
  1110.     tk_menuSetFocus $menu
  1111.     if {[string compare [$menu index active] "none"]} {
  1112.     return
  1113.     }
  1114.     set last [$menu index last]
  1115.     if {[string equal $last "none"]} {
  1116.     return
  1117.     }
  1118.     for {set i 0} {$i <= $last} {incr i} {
  1119.     if {([catch {set state [$menu entrycget $i -state]}] == 0) \
  1120.         && [string compare $state "disabled"] \
  1121.         && [string compare [$menu type $i] "tearoff"]} {
  1122.         $menu activate $i
  1123.         GenerateMenuSelect $menu
  1124.         # Only post the cascade if the current menu is a menubar;
  1125.         # otherwise, if the first entry of the cascade is a cascade,
  1126.         # we can get an annoying cascading effect resulting in a bunch of
  1127.         # menus getting posted (bug 676)
  1128.         if {[string equal [$menu type $i] "cascade"] && \
  1129.         [string equal [$menu cget -type] "menubar"]} {
  1130.         set cascade [$menu entrycget $i -menu]
  1131.         if {[string compare $cascade ""]} {
  1132.             $menu postcascade $i
  1133.             MenuFirstEntry $cascade
  1134.         }
  1135.         }
  1136.         return
  1137.     }
  1138.     }
  1139. }
  1140.  
  1141. # ::tk::MenuFindName --
  1142. # Given a menu and a text string, return the index of the menu entry
  1143. # that displays the string as its label.  If there is no such entry,
  1144. # return an empty string.  This procedure is tricky because some names
  1145. # like "active" have a special meaning in menu commands, so we can't
  1146. # always use the "index" widget command.
  1147. #
  1148. # Arguments:
  1149. # menu -        Name of the menu widget.
  1150. # s -            String to look for.
  1151.  
  1152. proc ::tk::MenuFindName {menu s} {
  1153.     set i ""
  1154.     if {![regexp {^active$|^last$|^none$|^[0-9]|^@} $s]} {
  1155.     catch {set i [$menu index $s]}
  1156.     return $i
  1157.     }
  1158.     set last [$menu index last]
  1159.     if {[string equal $last "none"]} {
  1160.     return
  1161.     }
  1162.     for {set i 0} {$i <= $last} {incr i} {
  1163.     if {![catch {$menu entrycget $i -label} label]} {
  1164.         if {[string equal $label $s]} {
  1165.         return $i
  1166.         }
  1167.     }
  1168.     }
  1169.     return ""
  1170. }
  1171.  
  1172. # ::tk::PostOverPoint --
  1173. # This procedure posts a given menu such that a given entry in the
  1174. # menu is centered over a given point in the root window.  It also
  1175. # activates the given entry.
  1176. #
  1177. # Arguments:
  1178. # menu -        Menu to post.
  1179. # x, y -        Root coordinates of point.
  1180. # entry -        Index of entry within menu to center over (x,y).
  1181. #            If omitted or specified as {}, then the menu's
  1182. #            upper-left corner goes at (x,y).
  1183.  
  1184. proc ::tk::PostOverPoint {menu x y {entry {}}}  {
  1185.     global tcl_platform
  1186.     
  1187.     if {[string compare $entry {}]} {
  1188.     if {$entry == [$menu index last]} {
  1189.         incr y [expr {-([$menu yposition $entry] \
  1190.             + [winfo reqheight $menu])/2}]
  1191.     } else {
  1192.         incr y [expr {-([$menu yposition $entry] \
  1193.             + [$menu yposition [expr {$entry+1}]])/2}]
  1194.     }
  1195.     incr x [expr {-[winfo reqwidth $menu]/2}]
  1196.     }
  1197.     if {$tcl_platform(platform) == "windows"} {
  1198.     # We need to fix some problems with menu posting on Windows.
  1199.     set yoffset [expr {[winfo screenheight $menu] \
  1200.         - $y - [winfo reqheight $menu]}]
  1201.     if {$yoffset < 0} {
  1202.         # The bottom of the menu is offscreen, so adjust upwards
  1203.         incr y $yoffset
  1204.         if {$y < 0} { set y 0 }
  1205.     }
  1206.     # If we're off the top of the screen (either because we were
  1207.     # originally or because we just adjusted too far upwards),
  1208.     # then make the menu popup on the top edge.
  1209.     if {$y < 0} {
  1210.         set y 0
  1211.     }
  1212.     }
  1213.     $menu post $x $y
  1214.     if {$entry ne "" && [$menu entrycget $entry -state] ne "disabled"} {
  1215.     $menu activate $entry
  1216.     GenerateMenuSelect $menu
  1217.     }
  1218. }
  1219.  
  1220. # ::tk::SaveGrabInfo --
  1221. # Sets the variables tk::Priv(oldGrab) and tk::Priv(grabStatus) to record
  1222. # the state of any existing grab on the w's display.
  1223. #
  1224. # Arguments:
  1225. # w -            Name of a window;  used to select the display
  1226. #            whose grab information is to be recorded.
  1227.  
  1228. proc tk::SaveGrabInfo w {
  1229.     variable ::tk::Priv
  1230.     set Priv(oldGrab) [grab current $w]
  1231.     if {$Priv(oldGrab) ne ""} {
  1232.     set Priv(grabStatus) [grab status $Priv(oldGrab)]
  1233.     }
  1234. }
  1235.  
  1236. # ::tk::RestoreOldGrab --
  1237. # Restores the grab to what it was before TkSaveGrabInfo was called.
  1238. #
  1239.  
  1240. proc ::tk::RestoreOldGrab {} {
  1241.     variable ::tk::Priv
  1242.  
  1243.     if {$Priv(oldGrab) ne ""} {
  1244.         # Be careful restoring the old grab, since it's window may not
  1245.     # be visible anymore.
  1246.  
  1247.     catch {
  1248.           if {[string equal $Priv(grabStatus) "global"]} {
  1249.         grab set -global $Priv(oldGrab)
  1250.         } else {
  1251.         grab set $Priv(oldGrab)
  1252.         }
  1253.     }
  1254.     set Priv(oldGrab) ""
  1255.     }
  1256. }
  1257.  
  1258. proc ::tk_menuSetFocus {menu} {
  1259.     variable ::tk::Priv
  1260.     if {![info exists Priv(focus)] || [string equal $Priv(focus) {}]} {
  1261.     set Priv(focus) [focus]
  1262.     }
  1263.     focus $menu
  1264. }
  1265.     
  1266. proc ::tk::GenerateMenuSelect {menu} {
  1267.     variable ::tk::Priv
  1268.  
  1269.     if {[string equal $Priv(activeMenu) $menu] \
  1270.           && [string equal $Priv(activeItem) [$menu index active]]} {
  1271.     return
  1272.     }
  1273.  
  1274.     set Priv(activeMenu) $menu
  1275.     set Priv(activeItem) [$menu index active]
  1276.     event generate $menu <<MenuSelect>>
  1277. }
  1278.  
  1279. # ::tk_popup --
  1280. # This procedure pops up a menu and sets things up for traversing
  1281. # the menu and its submenus.
  1282. #
  1283. # Arguments:
  1284. # menu -        Name of the menu to be popped up.
  1285. # x, y -        Root coordinates at which to pop up the
  1286. #            menu.
  1287. # entry -        Index of a menu entry to center over (x,y).
  1288. #            If omitted or specified as {}, then menu's
  1289. #            upper-left corner goes at (x,y).
  1290.  
  1291. proc ::tk_popup {menu x y {entry {}}} {
  1292.     variable ::tk::Priv
  1293.     global tcl_platform
  1294.     if {$Priv(popup) ne "" || $Priv(postedMb) ne ""} {
  1295.     tk::MenuUnpost {}
  1296.     }
  1297.     tk::PostOverPoint $menu $x $y $entry
  1298.     if {[tk windowingsystem] eq "x11" && [winfo viewable $menu]} {
  1299.         tk::SaveGrabInfo $menu
  1300.     grab -global $menu
  1301.     set Priv(popup) $menu
  1302.     tk_menuSetFocus $menu
  1303.     }
  1304. }
  1305.