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