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