home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / tkisrc04.zip / lib / tk / menu.tcl < prev    next >
Text File  |  1998-09-09  |  25KB  |  922 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. # SCCS: @(#) menu.tcl 1.65 96/04/16 09:02:01
  8. #
  9. # Copyright (c) 1992-1994 The Regents of the University of California.
  10. # Copyright (c) 1994-1996 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. # oldGrab -        Window that had the grab before a menu was posted.
  31. #            Used to restore the grab state after the menu
  32. #            is unposted.  Empty string means there was no
  33. #            grab previously set.
  34. # popup -        If a menu has been popped up via tk_popup, this
  35. #            gives the name of the menu.  Otherwise this
  36. #            value is empty.
  37. # postedMb -        Name of the menubutton whose menu is currently
  38. #            posted, or an empty string if nothing is posted
  39. #            A grab is set on this widget.
  40. # relief -        Used to save the original relief of the current
  41. #            menubutton.
  42. # window -        When the mouse is over a menu, this holds the
  43. #            name of the menu;  it's cleared when the mouse
  44. #            leaves the menu.
  45. #-------------------------------------------------------------------------
  46.  
  47. #-------------------------------------------------------------------------
  48. # Overall note:
  49. # This file is tricky because there are four different ways that menus
  50. # can be used:
  51. #
  52. # 1. As a pulldown from a menubutton.  This is the most common usage.
  53. #    In this style, the variable tkPriv(postedMb) identifies the posted
  54. #    menubutton.
  55. # 2. As a torn-off menu copied from some other menu.  In this style
  56. #    tkPriv(postedMb) is empty, and the top-level menu is no
  57. #    override-redirect.
  58. # 3. As an option menu, triggered from an option menubutton.  In thi
  59. #    style tkPriv(postedMb) identifies the posted menubutton.
  60. # 4. As a popup menu.  In this style tkPriv(postedMb) is empty and
  61. #    the top-level menu is override-redirect.
  62. #
  63. # The various binding procedures use the  state described above to
  64. # distinguish the various cases and take different actions in each
  65. # case.
  66. #-------------------------------------------------------------------------
  67.  
  68. #-------------------------------------------------------------------------
  69. # The code below creates the default class bindings for menus
  70. # and menubuttons.
  71. #-------------------------------------------------------------------------
  72.  
  73. bind Menubutton <FocusIn> {}
  74. bind Menubutton <Enter> {
  75.     tkMbEnter %W
  76. }
  77. bind Menubutton <Leave> {
  78.     tkMbLeave %W
  79. }
  80. bind Menubutton <1> {
  81.     if {$tkPriv(inMenubutton) != ""} {
  82.     tkMbPost $tkPriv(inMenubutton) %X %Y
  83.     }
  84. }
  85. bind Menubutton <Motion> {
  86.     tkMbMotion %W up %X %Y
  87. }
  88. bind Menubutton <B1-Motion> {
  89.     tkMbMotion %W down %X %Y
  90. }
  91. bind Menubutton <ButtonRelease-1> {
  92.     tkMbButtonUp %W
  93. }
  94. bind Menubutton <space> {
  95.     tkMbPost %W
  96.     tkMenuFirstEntry [%W cget -menu]
  97. }
  98.  
  99. # Must set focus when mouse enters a menu, in order to allow
  100. # mixed-mode processing using both the mouse and the keyboard.
  101. # Don't set the focus if the event comes from a grab release,
  102. # though:  such an event can happen after as part of unposting
  103. # a cascaded chain of menus, after the focus has already been
  104. # restored to wherever it was before menu selection started.
  105.  
  106. bind Menu <FocusIn> {}
  107. bind Menu <Enter> {
  108.     set tkPriv(window) %W
  109.     if {"%m" != "NotifyUngrab"} {
  110.     focus %W
  111.     }
  112. }
  113. bind Menu <Leave> {
  114.     tkMenuLeave %W %X %Y %s
  115. }
  116. bind Menu <Motion> {
  117.     tkMenuMotion %W %y %s
  118. }
  119. bind Menu <ButtonPress> {
  120.     tkMenuButtonDown %W
  121. }
  122. bind Menu <ButtonRelease> {
  123.     tkMenuInvoke %W 1
  124. }
  125. bind Menu <space> {
  126.     tkMenuInvoke %W 0
  127. }
  128. bind Menu <Return> {
  129.     tkMenuInvoke %W 0
  130. }
  131. bind Menu <Escape> {
  132.     tkMenuEscape %W
  133. }
  134. bind Menu <Left> {
  135.     tkMenuLeftRight %W left
  136. }
  137. bind Menu <Right> {
  138.     tkMenuLeftRight %W right
  139. }
  140. bind Menu <Up> {
  141.     tkMenuNextEntry %W -1
  142. }
  143. bind Menu <Down> {
  144.     tkMenuNextEntry %W +1
  145. }
  146. bind Menu <KeyPress> {
  147.     tkTraverseWithinMenu %W %A
  148. }
  149.  
  150. # The following bindings apply to all windows, and are used to
  151. # implement keyboard menu traversal.
  152.  
  153. bind all <Alt-KeyPress> {
  154.     tkTraverseToMenu %W %A
  155. }
  156. bind all <F10> {
  157.     tkFirstMenu %W
  158. }
  159.  
  160. # tkMbEnter --
  161. # This procedure is invoked when the mouse enters a menubutton
  162. # widget.  It activates the widget unless it is disabled.  Note:
  163. # this procedure is only invoked when mouse button 1 is *not* down.
  164. # The procedure tkMbB1Enter is invoked if the button is down.
  165. #
  166. # Arguments:
  167. # w -            The  name of the widget.
  168.  
  169. proc tkMbEnter w {
  170.     global tkPriv
  171.  
  172.     if {$tkPriv(inMenubutton) != ""} {
  173.     tkMbLeave $tkPriv(inMenubutton)
  174.     }
  175.     set tkPriv(inMenubutton) $w
  176.     if {[$w cget -state] != "disabled"} {
  177.     $w configure -state active
  178.     }
  179. }
  180.  
  181. # tkMbLeave --
  182. # This procedure is invoked when the mouse leaves a menubutton widget.
  183. # It de-activates the widget, if the widget still exists.
  184. #
  185. # Arguments:
  186. # w -            The  name of the widget.
  187.  
  188. proc tkMbLeave w {
  189.     global tkPriv
  190.  
  191.     set tkPriv(inMenubutton) {}
  192.     if ![winfo exists $w] {
  193.     return
  194.     }
  195.     if {[$w cget -state] == "active"} {
  196.     $w configure -state normal
  197.     }
  198. }
  199.  
  200. # tkMbPost --
  201. # Given a menubutton, this procedure does all the work of posting
  202. # its associated menu and unposting any other menu that is currently
  203. # posted.
  204. #
  205. # Arguments:
  206. # w -            The name of the menubutton widget whose menu
  207. #            is to be posted.
  208. # x, y -        Root coordinates of cursor, used for positioning
  209. #            option menus.  If not specified, then the center
  210. #            of the menubutton is used for an option menu.
  211.  
  212. proc tkMbPost {w {x {}} {y {}}} {
  213.     global tkPriv
  214.     if {([$w cget -state] == "disabled") || ($w == $tkPriv(postedMb))} {
  215.     return
  216.     }
  217.     set menu [$w cget -menu]
  218.     if {$menu == ""} {
  219.     return
  220.     }
  221.     if ![string match $w.* $menu] {
  222.     error "can't post $menu:  it isn't a descendant of $w (this is a new requirement in Tk versions 3.0 and later)"
  223.     }
  224.     set cur $tkPriv(postedMb)
  225.     if {$cur != ""} {
  226.     tkMenuUnpost {}
  227.     }
  228.     set tkPriv(cursor) [$w cget -cursor]
  229.     set tkPriv(relief) [$w cget -relief]
  230.     $w configure -cursor arrow
  231.     $w configure -relief raised
  232.     set tkPriv(postedMb) $w
  233.     set tkPriv(focus) [focus]
  234.     $menu activate none
  235.  
  236.     # If this looks like an option menubutton then post the menu so
  237.     # that the current entry is on top of the mouse.  Otherwise post
  238.     # the menu just below the menubutton, as for a pull-down.
  239.  
  240.     if [$w cget -indicatoron] {
  241.     if {$y == ""} {
  242.         set x [expr [winfo rootx $w] + [winfo width $w]/2]
  243.         set y [expr [winfo rooty $w] + [winfo height $w]/2]
  244.     }
  245.     tkPostOverPoint $menu $x $y [tkMenuFindName $menu [$w cget -text]]
  246.     } else {
  247.     $menu post [winfo rootx $w] [expr [winfo rooty $w]+[winfo height $w]]
  248.     }
  249.     focus $menu
  250.     tkSaveGrabInfo $w
  251.     grab -global $w
  252. }
  253.  
  254. # tkMenuUnpost --
  255. # This procedure unposts a given menu, plus all of its ancestors up
  256. # to (and including) a menubutton, if any.  It also restores various
  257. # values to what they were before the menu was posted, and releases
  258. # a grab if there's a menubutton involved.  Special notes:
  259. # 1. It's important to unpost all menus before releasing the grab, so
  260. #    that any Enter-Leave events (e.g. from menu back to main
  261. #    application) have mode NotifyGrab.
  262. # 2. Be sure to enclose various groups of commands in "catch" so that
  263. #    the procedure will complete even if the menubutton or the menu
  264. #    or the grab window has been deleted.
  265. #
  266. # Arguments:
  267. # menu -        Name of a menu to unpost.  Ignored if there
  268. #            is a posted menubutton.
  269.  
  270. proc tkMenuUnpost menu {
  271.     global tkPriv
  272.     set mb $tkPriv(postedMb)
  273.  
  274.     # Restore focus right away (otherwise X will take focus away when
  275.     # the menu is unmapped and under some window managers (e.g. olvwm)
  276.     # we'll lose the focus completely).
  277.  
  278.     catch {focus $tkPriv(focus)}
  279.     set tkPriv(focus) ""
  280.  
  281.     # Unpost menu(s) and restore some stuff that's dependent on
  282.     # what was posted.
  283.  
  284.     catch {
  285.     if {$mb != ""} {
  286.         set menu [$mb cget -menu]
  287.         $menu unpost
  288.         set tkPriv(postedMb) {}
  289.         $mb configure -cursor $tkPriv(cursor)
  290.         $mb configure -relief $tkPriv(relief)
  291.     } elseif {$tkPriv(popup) != ""} {
  292.         $tkPriv(popup) unpost
  293.         set tkPriv(popup) {}
  294.     } elseif {[wm overrideredirect $menu]} {
  295.         # We're in a cascaded sub-menu from a torn-off menu or popup.
  296.         # Unpost all the menus up to the toplevel one (but not
  297.         # including the top-level torn-off one) and deactivate the
  298.         # top-level torn off menu if there is one.
  299.  
  300.         while 1 {
  301.         set parent [winfo parent $menu]
  302.         if {([winfo class $parent] != "Menu")
  303.             || ![winfo ismapped $parent]} {
  304.             break
  305.         }
  306.         $parent activate none
  307.         $parent postcascade none
  308.         if {![wm overrideredirect $parent]} {
  309.             break
  310.         }
  311.         set menu $parent
  312.         }
  313.         $menu unpost
  314.     }
  315.     }
  316.  
  317.     # Release grab, if any, and restore the previous grab, if there
  318.     # was one.
  319.  
  320.     if {$menu != ""} {
  321.     set grab [grab current $menu]
  322.     if {$grab != ""} {
  323.         grab release $grab
  324.     }
  325.     }
  326.     if {$tkPriv(oldGrab) != ""} {
  327.  
  328.     # Be careful restoring the old grab, since it's window may not
  329.     # be visible anymore.
  330.  
  331.     catch {
  332.         if {$tkPriv(grabStatus) == "global"} {
  333.         grab set -global $tkPriv(oldGrab)
  334.         } else {
  335.         grab set $tkPriv(oldGrab)
  336.         }
  337.     }
  338.     set tkPriv(oldGrab) ""
  339.     }
  340. }
  341.  
  342. # tkMbMotion --
  343. # This procedure handles mouse motion events inside menubuttons, and
  344. # also outside menubuttons when a menubutton has a grab (e.g. when a
  345. # menu selection operation is in progress).
  346. #
  347. # Arguments:
  348. # w -            The name of the menubutton widget.
  349. # upDown -         "down" means button 1 is pressed, "up" means
  350. #            it isn't.
  351. # rootx, rooty -    Coordinates of mouse, in (virtual?) root window.
  352.  
  353. proc tkMbMotion {w upDown rootx rooty} {
  354.     global tkPriv
  355.  
  356.     if {$tkPriv(inMenubutton) == $w} {
  357.     return
  358.     }
  359.     set new [winfo containing $rootx $rooty]
  360.     if {($new != $tkPriv(inMenubutton)) && (($new == "")
  361.         || ([winfo toplevel $new] == [winfo toplevel $w]))} {
  362.     if {$tkPriv(inMenubutton) != ""} {
  363.         tkMbLeave $tkPriv(inMenubutton)
  364.     }
  365.     if {($new != "") && ([winfo class $new] == "Menubutton")
  366.         && ([$new cget -indicatoron] == 0)
  367.         && ([$w cget -indicatoron] == 0)} {
  368.         if {$upDown == "down"} {
  369.         tkMbPost $new $rootx $rooty
  370.         } else {
  371.         tkMbEnter $new
  372.         }
  373.     }
  374.     }
  375. }
  376.  
  377. # tkMbButtonUp --
  378. # This procedure is invoked to handle button 1 releases for menubuttons.
  379. # If the release happens inside the menubutton then leave its menu
  380. # posted with element 0 activated.  Otherwise, unpost the menu.
  381. #
  382. # Arguments:
  383. # w -            The name of the menubutton widget.
  384.  
  385. proc tkMbButtonUp w {
  386.     global tkPriv
  387.  
  388.     if  {($tkPriv(postedMb) == $w) && ($tkPriv(inMenubutton) == $w)} {
  389.     tkMenuFirstEntry [$tkPriv(postedMb) cget -menu]
  390.     } else {
  391.     tkMenuUnpost {}
  392.     }
  393. }
  394.  
  395. # tkMenuMotion --
  396. # This procedure is called to handle mouse motion events for menus.
  397. # It does two things.  First, it resets the active element in the
  398. # menu, if the mouse is over the menu.  Second, if a mouse button
  399. # is down, it posts and unposts cascade entries to match the mouse
  400. # position.
  401. #
  402. # Arguments:
  403. # menu -        The menu window.
  404. # y -            The y position of the mouse.
  405. # state -        Modifier state (tells whether buttons are down).
  406.  
  407. proc tkMenuMotion {menu y state} {
  408.     global tkPriv
  409.     if {$menu == $tkPriv(window)} {
  410.     $menu activate @$y
  411.     }
  412.     if {($state & 0x1f00) != 0} {
  413.     $menu postcascade active
  414.     }
  415. }
  416.  
  417. # tkMenuButtonDown --
  418. # Handles button presses in menus.  There are a couple of tricky things
  419. # here:
  420. # 1. Change the posted cascade entry (if any) to match the mouse position.
  421. # 2. If there is a posted menubutton, must grab to the menubutton;  this
  422. #    overrrides the implicit grab on button press, so that the menu
  423. #    button can track mouse motions over other menubuttons and change
  424. #    the posted menu.
  425. # 3. If there's no posted menubutton (e.g. because we're a torn-off menu
  426. #    or one of its descendants) must grab to the top-level menu so that
  427. #    we can track mouse motions across the entire menu hierarchy.
  428. #
  429. # Arguments:
  430. # menu -        The menu window.
  431.  
  432. proc tkMenuButtonDown menu {
  433.     global tkPriv
  434.     $menu postcascade active
  435.     if {$tkPriv(postedMb) != ""} {
  436.     grab -global $tkPriv(postedMb)
  437.     } else {
  438.     while {[wm overrideredirect $menu]
  439.         && ([winfo class [winfo parent $menu]] == "Menu")
  440.         && [winfo ismapped [winfo parent $menu]]} {
  441.         set menu [winfo parent $menu]
  442.     }
  443.  
  444.     # Don't update grab information if the grab window isn't changing.
  445.     # Otherwise, we'll get an error when we unpost the menus and
  446.     # restore the grab, since the old grab window will not be viewable
  447.     # anymore.
  448.  
  449.     if {$menu != [grab current $menu]} {
  450.         tkSaveGrabInfo $menu
  451.     }
  452.  
  453.     # Must re-grab even if the grab window hasn't changed, in order
  454.     # to release the implicit grab from the button press.
  455.  
  456.     grab -global $menu
  457.     }
  458. }
  459.  
  460. # tkMenuLeave --
  461. # This procedure is invoked to handle Leave events for a menu.  It
  462. # deactivates everything unless the active element is a cascade element
  463. # and the mouse is now over the submenu.
  464. #
  465. # Arguments:
  466. # menu -        The menu window.
  467. # rootx, rooty -    Root coordinates of mouse.
  468. # state -        Modifier state.
  469.  
  470. proc tkMenuLeave {menu rootx rooty state} {
  471.     global tkPriv
  472.     set tkPriv(window) {}
  473.     if {[$menu index active] == "none"} {
  474.     return
  475.     }
  476.     if {([$menu type active] == "cascade")
  477.         && ([winfo containing $rootx $rooty]
  478.         == [$menu entrycget active -menu])} {
  479.     return
  480.     }
  481.     $menu activate none
  482. }
  483.  
  484. # tkMenuInvoke --
  485. # This procedure is invoked when button 1 is released over a menu.
  486. # It invokes the appropriate menu action and unposts the menu if
  487. # it came from a menubutton.
  488. #
  489. # Arguments:
  490. # w -            Name of the menu widget.
  491. # buttonRelease -    1 means this procedure is called because of
  492. #            a button release;  0 means because of keystroke.
  493.  
  494. proc tkMenuInvoke {w buttonRelease} {
  495.     global tkPriv
  496.  
  497.     if {$buttonRelease && ($tkPriv(window) == "")} {
  498.     # Mouse was pressed over a menu without a menu button, then
  499.     # dragged off the menu (possibly with a cascade posted) and
  500.     # released.  Unpost everything and quit.
  501.  
  502.     $w postcascade none
  503.     $w activate none
  504.     tkMenuUnpost $w
  505.     return
  506.     }
  507.     if {[$w type active] == "cascade"} {
  508.     $w postcascade active
  509.     set menu [$w entrycget active -menu]
  510.     tkMenuFirstEntry $menu
  511.     } elseif {[$w type active] == "tearoff"} {
  512.     tkMenuUnpost $w
  513.     tkTearOffMenu $w
  514.     } else {
  515.     tkMenuUnpost $w
  516.     uplevel #0 [list $w invoke active]
  517.     }
  518. }
  519.  
  520. # tkMenuEscape --
  521. # This procedure is invoked for the Cancel (or Escape) key.  It unposts
  522. # the given menu and, if it is the top-level menu for a menu button,
  523. # unposts the menu button as well.
  524. #
  525. # Arguments:
  526. # menu -        Name of the menu window.
  527.  
  528. proc tkMenuEscape menu {
  529.     if {[winfo class [winfo parent $menu]] != "Menu"} {
  530.     tkMenuUnpost $menu
  531.     } else {
  532.     tkMenuLeftRight $menu -1
  533.     }
  534. }
  535.  
  536. # tkMenuLeftRight --
  537. # This procedure is invoked to handle "left" and "right" traversal
  538. # motions in menus.  It traverses to the next menu in a menu bar,
  539. # or into or out of a cascaded menu.
  540. #
  541. # Arguments:
  542. # menu -        The menu that received the keyboard
  543. #            event.
  544. # direction -        Direction in which to move: "left" or "right"
  545.  
  546. proc tkMenuLeftRight {menu direction} {
  547.     global tkPriv
  548.  
  549.     # First handle traversals into and out of cascaded menus.
  550.  
  551.     if {$direction == "right"} {
  552.     set count 1
  553.     if {[$menu type active] == "cascade"} {
  554.         $menu postcascade active
  555.         set m2 [$menu entrycget active -menu]
  556.         if {$m2 != ""} {
  557.         tkMenuFirstEntry $m2
  558.         }
  559.         return
  560.     }
  561.     } else {
  562.     set count -1
  563.     set m2 [winfo parent $menu]
  564.     if {[winfo class $m2] == "Menu"} {
  565.         $menu activate none
  566.         focus $m2
  567.  
  568.         # This code unposts any posted submenu in the parent.
  569.  
  570.         set tmp [$m2 index active]
  571.         $m2 activate none
  572.         $m2 activate $tmp
  573.         return
  574.     }
  575.     }
  576.  
  577.     # Can't traverse into or out of a cascaded menu.  Go to the next
  578.     # or previous menubutton, if that makes sense.
  579.  
  580.     set w $tkPriv(postedMb)
  581.     if {$w == ""} {
  582.     return
  583.     }
  584.     set buttons [winfo children [winfo parent $w]]
  585.     set length [llength $buttons]
  586.     set i [expr [lsearch -exact $buttons $w] + $count]
  587.     while 1 {
  588.     while {$i < 0} {
  589.         incr i $length
  590.     }
  591.     while {$i >= $length} {
  592.         incr i -$length
  593.     }
  594.     set mb [lindex $buttons $i]
  595.     if {([winfo class $mb] == "Menubutton")
  596.         && ([$mb cget -state] != "disabled")
  597.         && ([$mb cget -menu] != "")
  598.         && ([[$mb cget -menu] index last] != "none")} {
  599.         break
  600.     }
  601.     if {$mb == $w} {
  602.         return
  603.     }
  604.     incr i $count
  605.     }
  606.     tkMbPost $mb
  607.     tkMenuFirstEntry [$mb cget -menu]
  608. }
  609.  
  610. # tkMenuNextEntry --
  611. # Activate the next higher or lower entry in the posted menu,
  612. # wrapping around at the ends.  Disabled entries are skipped.
  613. #
  614. # Arguments:
  615. # menu -            Menu window that received the keystroke.
  616. # count -            1 means go to the next lower entry,
  617. #                -1 means go to the next higher entry.
  618.  
  619. proc tkMenuNextEntry {menu count} {
  620.     global tkPriv
  621.     if {[$menu index last] == "none"} {
  622.     return
  623.     }
  624.     set length [expr [$menu index last]+1]
  625.     set quitAfter $length
  626.     set active [$menu index active]
  627.     if {$active == "none"} {
  628.     set i 0
  629.     } else {
  630.     set i [expr $active + $count]
  631.     }
  632.     while 1 {
  633.     if {$quitAfter <= 0} {
  634.         # We've tried every entry in the menu.  Either there are
  635.         # none, or they're all disabled.  Just give up.
  636.  
  637.         return
  638.     }
  639.     while {$i < 0} {
  640.         incr i $length
  641.     }
  642.     while {$i >= $length} {
  643.         incr i -$length
  644.     }
  645.     if {[catch {$menu entrycget $i -state} state] == 0} {
  646.         if {$state != "disabled"} {
  647.         break
  648.         }
  649.     }
  650.     if {$i == $active} {
  651.         return
  652.     }
  653.     incr i $count
  654.     incr quitAfter -1
  655.     }
  656.     $menu activate $i
  657.     $menu postcascade $i
  658. }
  659.  
  660. # tkMenuFind --
  661. # This procedure searches the entire window hierarchy under w for
  662. # a menubutton that isn't disabled and whose underlined character
  663. # is "char".  It returns the name of that window, if found, or an
  664. # empty string if no matching window was found.  If "char" is an
  665. # empty string then the procedure returns the name of the first
  666. # menubutton found that isn't disabled.
  667. #
  668. # Arguments:
  669. # w -                Name of window where key was typed.
  670. # char -            Underlined character to search for;
  671. #                may be either upper or lower case, and
  672. #                will match either upper or lower case.
  673.  
  674. proc tkMenuFind {w char} {
  675.     global tkPriv
  676.     set char [string tolower $char]
  677.  
  678.     foreach child [winfo child $w] {
  679.     switch [winfo class $child] {
  680.         Menubutton {
  681.         set char2 [string index [$child cget -text] \
  682.             [$child cget -underline]]
  683.         if {([string compare $char [string tolower $char2]] == 0)
  684.             || ($char == "")} {
  685.             if {[$child cget -state] != "disabled"} {
  686.             return $child
  687.             }
  688.         }
  689.         }
  690.         Frame {
  691.         set match [tkMenuFind $child $char]
  692.         if {$match != ""} {
  693.             return $match
  694.         }
  695.         }
  696.     }
  697.     }
  698.     return {}
  699. }
  700.  
  701. # tkTraverseToMenu --
  702. # This procedure implements keyboard traversal of menus.  Given an
  703. # ASCII character "char", it looks for a menubutton with that character
  704. # underlined.  If one is found, it posts the menubutton's menu
  705. #
  706. # Arguments:
  707. # w -                Window in which the key was typed (selects
  708. #                a toplevel window).
  709. # char -            Character that selects a menu.  The case
  710. #                is ignored.  If an empty string, nothing
  711. #                happens.
  712.  
  713. proc tkTraverseToMenu {w char} {
  714.     global tkPriv
  715.     if {$char == ""} {
  716.     return
  717.     }
  718.     while {[winfo class $w] == "Menu"} {
  719.     if {$tkPriv(postedMb) == ""} {
  720.         return
  721.     }
  722.     set w [winfo parent $w]
  723.     }
  724.     set w [tkMenuFind [winfo toplevel $w] $char]
  725.     if {$w != ""} {
  726.     tkMbPost $w
  727.     tkMenuFirstEntry [$w cget -menu]
  728.     }
  729. }
  730.  
  731. # tkFirstMenu --
  732. # This procedure traverses to the first menubutton in the toplevel
  733. # for a given window, and posts that menubutton's menu.
  734. #
  735. # Arguments:
  736. # w -                Name of a window.  Selects which toplevel
  737. #                to search for menubuttons.
  738.  
  739. proc tkFirstMenu w {
  740.     set w [tkMenuFind [winfo toplevel $w] ""]
  741.     if {$w != ""} {
  742.     tkMbPost $w
  743.     tkMenuFirstEntry [$w cget -menu]
  744.     }
  745. }
  746.  
  747. # tkTraverseWithinMenu
  748. # This procedure implements keyboard traversal within a menu.  It
  749. # searches for an entry in the menu that has "char" underlined.  If
  750. # such an entry is found, it is invoked and the menu is unposted.
  751. #
  752. # Arguments:
  753. # w -                The name of the menu widget.
  754. # char -            The character to look for;  case is
  755. #                ignored.  If the string is empty then
  756. #                nothing happens.
  757.  
  758. proc tkTraverseWithinMenu {w char} {
  759.     if {$char == ""} {
  760.     return
  761.     }
  762.     set char [string tolower $char]
  763.     set last [$w index last]
  764.     if {$last == "none"} {
  765.     return
  766.     }
  767.     for {set i 0} {$i <= $last} {incr i} {
  768.     if [catch {set char2 [string index \
  769.         [$w entrycget $i -label] \
  770.         [$w entrycget $i -underline]]}] {
  771.         continue
  772.     }
  773.     if {[string compare $char [string tolower $char2]] == 0} {
  774.         if {[$w type $i] == "cascade"} {
  775.         $w postcascade $i
  776.         $w activate $i
  777.         set m2 [$w entrycget $i -menu]
  778.         if {$m2 != ""} {
  779.             tkMenuFirstEntry $m2
  780.         }
  781.         } else {
  782.         tkMenuUnpost $w
  783.         uplevel #0 [list $w invoke $i]
  784.         }
  785.         return
  786.     }
  787.     }
  788. }
  789.  
  790. # tkMenuFirstEntry --
  791. # Given a menu, this procedure finds the first entry that isn't
  792. # disabled or a tear-off or separator, and activates that entry.
  793. # However, if there is already an active entry in the menu (e.g.,
  794. # because of a previous call to tkPostOverPoint) then the active
  795. # entry isn't changed.  This procedure also sets the input focus
  796. # to the menu.
  797. #
  798. # Arguments:
  799. # menu -        Name of the menu window (possibly empty).
  800.  
  801. proc tkMenuFirstEntry menu {
  802.     if {$menu == ""} {
  803.     return
  804.     }
  805.     focus $menu
  806.     if {[$menu index active] != "none"} {
  807.     return
  808.     }
  809.     set last [$menu index last]
  810.     if {$last == "none"} {
  811.     return
  812.     }
  813.     for {set i 0} {$i <= $last} {incr i} {
  814.     if {([catch {set state [$menu entrycget $i -state]}] == 0)
  815.         && ($state != "disabled") && ([$menu type $i] != "tearoff")} {
  816.         $menu activate $i
  817.         return
  818.     }
  819.     }
  820. }
  821.  
  822. # tkMenuFindName --
  823. # Given a menu and a text string, return the index of the menu entry
  824. # that displays the string as its label.  If there is no such entry,
  825. # return an empty string.  This procedure is tricky because some names
  826. # like "active" have a special meaning in menu commands, so we can't
  827. # always use the "index" widget command.
  828. #
  829. # Arguments:
  830. # menu -        Name of the menu widget.
  831. # s -            String to look for.
  832.  
  833. proc tkMenuFindName {menu s} {
  834.     set i ""
  835.     if {![regexp {^active$|^last$|^none$|^[0-9]|^@} $s]} {
  836.     catch {set i [$menu index $s]}
  837.     return $i
  838.     }
  839.     set last [$menu index last]
  840.     if {$last == "none"} {
  841.     return
  842.     }
  843.     for {set i 0} {$i <= $last} {incr i} {
  844.     if ![catch {$menu entrycget $i -label} label] {
  845.         if {$label == $s} {
  846.         return $i
  847.         }
  848.     }
  849.     }
  850.     return ""
  851. }
  852.  
  853. # tkPostOverPoint --
  854. # This procedure posts a given menu such that a given entry in the
  855. # menu is centered over a given point in the root window.  It also
  856. # activates the given entry.
  857. #
  858. # Arguments:
  859. # menu -        Menu to post.
  860. # x, y -        Root coordinates of point.
  861. # entry -        Index of entry within menu to center over (x,y).
  862. #            If omitted or specified as {}, then the menu's
  863. #            upper-left corner goes at (x,y).
  864.  
  865. proc tkPostOverPoint {menu x y {entry {}}}  {
  866.     if {$entry != {}} {
  867.     if {$entry == [$menu index last]} {
  868.         incr y [expr -([$menu yposition $entry] \
  869.             + [winfo reqheight $menu])/2]
  870.     } else {
  871.         incr y [expr -([$menu yposition $entry] \
  872.             + [$menu yposition [expr $entry+1]])/2]
  873.     }
  874.     incr x [expr -[winfo reqwidth $menu]/2]
  875.     }
  876.     $menu post $x $y
  877.     if {($entry != {}) && ([$menu entrycget $entry -state] != "disabled")} {
  878.     $menu activate $entry
  879.     }
  880. }
  881.  
  882. # tkSaveGrabInfo --
  883. # Sets the variables tkPriv(oldGrab) and tkPriv(grabStatus) to record
  884. # the state of any existing grab on the w's display.
  885. #
  886. # Arguments:
  887. # w -            Name of a window;  used to select the display
  888. #            whose grab information is to be recorded.
  889.  
  890. proc tkSaveGrabInfo w {
  891.     global tkPriv
  892.     set tkPriv(oldGrab) [grab current $w]
  893.     if {$tkPriv(oldGrab) != ""} {
  894.     set tkPriv(grabStatus) [grab status $tkPriv(oldGrab)]
  895.     }
  896. }
  897.  
  898. # tk_popup --
  899. # This procedure pops up a menu and sets things up for traversing
  900. # the menu and its submenus.
  901. #
  902. # Arguments:
  903. # menu -        Name of the menu to be popped up.
  904. # x, y -        Root coordinates at which to pop up the
  905. #            menu.
  906. # entry -        Index of a menu entry to center over (x,y).
  907. #            If omitted or specified as {}, then menu's
  908. #            upper-left corner goes at (x,y).
  909.  
  910. proc tk_popup {menu x y {entry {}}} {
  911.     global tkPriv
  912.     if {($tkPriv(popup) != "") || ($tkPriv(postedMb) != "")} {
  913.     tkMenuUnpost {}
  914.     }
  915.     tkPostOverPoint $menu $x $y $entry
  916.     tkSaveGrabInfo $menu
  917.     grab -global $menu
  918.     set tkPriv(popup) $menu
  919.     set tkPriv(focus) [focus]
  920.     focus $menu
  921. }
  922.