home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / tk42r2x.zip / TclTk / lib / tk4.2 / menu.tcl.orig < prev    next >
Text File  |  1999-07-27  |  26KB  |  936 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.69 96/09/17 08:32:27
  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 errorInfo
  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 first $w $menu] != 0} {
  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 [catch {
  241.     if [$w cget -indicatoron] {
  242.         if {$y == ""} {
  243.         set x [expr [winfo rootx $w] + [winfo width $w]/2]
  244.         set y [expr [winfo rooty $w] + [winfo height $w]/2]
  245.         }
  246.         tkPostOverPoint $menu $x $y [tkMenuFindName $menu [$w cget -text]]
  247.     } else {
  248.         $menu post [winfo rootx $w] [expr [winfo rooty $w] + \
  249.             [winfo height $w]]
  250.     }
  251.     } msg] {
  252.     # Error posting menu (e.g. bogus -postcommand).  Unpost it and
  253.     # reflect the error.
  254.  
  255.     tkMenuUnpost {}
  256.     error $msg $errorInfo
  257.     }
  258.     focus $menu
  259.     tkSaveGrabInfo $w
  260.     grab -global $w
  261. }
  262.  
  263. # tkMenuUnpost --
  264. # This procedure unposts a given menu, plus all of its ancestors up
  265. # to (and including) a menubutton, if any.  It also restores various
  266. # values to what they were before the menu was posted, and releases
  267. # a grab if there's a menubutton involved.  Special notes:
  268. # 1. It's important to unpost all menus before releasing the grab, so
  269. #    that any Enter-Leave events (e.g. from menu back to main
  270. #    application) have mode NotifyGrab.
  271. # 2. Be sure to enclose various groups of commands in "catch" so that
  272. #    the procedure will complete even if the menubutton or the menu
  273. #    or the grab window has been deleted.
  274. #
  275. # Arguments:
  276. # menu -        Name of a menu to unpost.  Ignored if there
  277. #            is a posted menubutton.
  278.  
  279. proc tkMenuUnpost menu {
  280.     global tkPriv
  281.     set mb $tkPriv(postedMb)
  282.  
  283.     # Restore focus right away (otherwise X will take focus away when
  284.     # the menu is unmapped and under some window managers (e.g. olvwm)
  285.     # we'll lose the focus completely).
  286.  
  287.     catch {focus $tkPriv(focus)}
  288.     set tkPriv(focus) ""
  289.  
  290.     # Unpost menu(s) and restore some stuff that's dependent on
  291.     # what was posted.
  292.  
  293.     catch {
  294.     if {$mb != ""} {
  295.         set menu [$mb cget -menu]
  296.         $menu unpost
  297.         set tkPriv(postedMb) {}
  298.         $mb configure -cursor $tkPriv(cursor)
  299.         $mb configure -relief $tkPriv(relief)
  300.     } elseif {$tkPriv(popup) != ""} {
  301.         $tkPriv(popup) unpost
  302.         set tkPriv(popup) {}
  303.     } elseif {[wm overrideredirect $menu]} {
  304.         # We're in a cascaded sub-menu from a torn-off menu or popup.
  305.         # Unpost all the menus up to the toplevel one (but not
  306.         # including the top-level torn-off one) and deactivate the
  307.         # top-level torn off menu if there is one.
  308.  
  309.         while 1 {
  310.         set parent [winfo parent $menu]
  311.         if {([winfo class $parent] != "Menu")
  312.             || ![winfo ismapped $parent]} {
  313.             break
  314.         }
  315.         $parent activate none
  316.         $parent postcascade none
  317.         if {![wm overrideredirect $parent]} {
  318.             break
  319.         }
  320.         set menu $parent
  321.         }
  322.         $menu unpost
  323.     }
  324.     }
  325.  
  326.     # Release grab, if any, and restore the previous grab, if there
  327.     # was one.
  328.  
  329.     if {$menu != ""} {
  330.     set grab [grab current $menu]
  331.     if {$grab != ""} {
  332.         grab release $grab
  333.     }
  334.     }
  335.     if {$tkPriv(oldGrab) != ""} {
  336.  
  337.     # Be careful restoring the old grab, since it's window may not
  338.     # be visible anymore.
  339.  
  340.     catch {
  341.         if {$tkPriv(grabStatus) == "global"} {
  342.         grab set -global $tkPriv(oldGrab)
  343.         } else {
  344.         grab set $tkPriv(oldGrab)
  345.         }
  346.     }
  347.     set tkPriv(oldGrab) ""
  348.     }
  349. }
  350.  
  351. # tkMbMotion --
  352. # This procedure handles mouse motion events inside menubuttons, and
  353. # also outside menubuttons when a menubutton has a grab (e.g. when a
  354. # menu selection operation is in progress).
  355. #
  356. # Arguments:
  357. # w -            The name of the menubutton widget.
  358. # upDown -         "down" means button 1 is pressed, "up" means
  359. #            it isn't.
  360. # rootx, rooty -    Coordinates of mouse, in (virtual?) root window.
  361.  
  362. proc tkMbMotion {w upDown rootx rooty} {
  363.     global tkPriv
  364.  
  365.     if {$tkPriv(inMenubutton) == $w} {
  366.     return
  367.     }
  368.     set new [winfo containing $rootx $rooty]
  369.     if {($new != $tkPriv(inMenubutton)) && (($new == "")
  370.         || ([winfo toplevel $new] == [winfo toplevel $w]))} {
  371.     if {$tkPriv(inMenubutton) != ""} {
  372.         tkMbLeave $tkPriv(inMenubutton)
  373.     }
  374.     if {($new != "") && ([winfo class $new] == "Menubutton")
  375.         && ([$new cget -indicatoron] == 0)
  376.         && ([$w cget -indicatoron] == 0)} {
  377.         if {$upDown == "down"} {
  378.         tkMbPost $new $rootx $rooty
  379.         } else {
  380.         tkMbEnter $new
  381.         }
  382.     }
  383.     }
  384. }
  385.  
  386. # tkMbButtonUp --
  387. # This procedure is invoked to handle button 1 releases for menubuttons.
  388. # If the release happens inside the menubutton then leave its menu
  389. # posted with element 0 activated.  Otherwise, unpost the menu.
  390. #
  391. # Arguments:
  392. # w -            The name of the menubutton widget.
  393.  
  394. proc tkMbButtonUp w {
  395.     global tkPriv
  396.  
  397.     if  {($tkPriv(postedMb) == $w) && ($tkPriv(inMenubutton) == $w)} {
  398.     tkMenuFirstEntry [$tkPriv(postedMb) cget -menu]
  399.     } else {
  400.     tkMenuUnpost {}
  401.     }
  402. }
  403.  
  404. # tkMenuMotion --
  405. # This procedure is called to handle mouse motion events for menus.
  406. # It does two things.  First, it resets the active element in the
  407. # menu, if the mouse is over the menu.  Second, if a mouse button
  408. # is down, it posts and unposts cascade entries to match the mouse
  409. # position.
  410. #
  411. # Arguments:
  412. # menu -        The menu window.
  413. # y -            The y position of the mouse.
  414. # state -        Modifier state (tells whether buttons are down).
  415.  
  416. proc tkMenuMotion {menu y state} {
  417.     global tkPriv
  418.     if {$menu == $tkPriv(window)} {
  419.     $menu activate @$y
  420.     }
  421.     if {($state & 0x1f00) != 0} {
  422.     $menu postcascade active
  423.     }
  424. }
  425.  
  426. # tkMenuButtonDown --
  427. # Handles button presses in menus.  There are a couple of tricky things
  428. # here:
  429. # 1. Change the posted cascade entry (if any) to match the mouse position.
  430. # 2. If there is a posted menubutton, must grab to the menubutton;  this
  431. #    overrrides the implicit grab on button press, so that the menu
  432. #    button can track mouse motions over other menubuttons and change
  433. #    the posted menu.
  434. # 3. If there's no posted menubutton (e.g. because we're a torn-off menu
  435. #    or one of its descendants) must grab to the top-level menu so that
  436. #    we can track mouse motions across the entire menu hierarchy.
  437. #
  438. # Arguments:
  439. # menu -        The menu window.
  440.  
  441. proc tkMenuButtonDown menu {
  442.     global tkPriv
  443.     $menu postcascade active
  444.     if {$tkPriv(postedMb) != ""} {
  445.     grab -global $tkPriv(postedMb)
  446.     } else {
  447.     while {[wm overrideredirect $menu]
  448.         && ([winfo class [winfo parent $menu]] == "Menu")
  449.         && [winfo ismapped [winfo parent $menu]]} {
  450.         set menu [winfo parent $menu]
  451.     }
  452.  
  453.     # Don't update grab information if the grab window isn't changing.
  454.     # Otherwise, we'll get an error when we unpost the menus and
  455.     # restore the grab, since the old grab window will not be viewable
  456.     # anymore.
  457.  
  458.     if {$menu != [grab current $menu]} {
  459.         tkSaveGrabInfo $menu
  460.     }
  461.  
  462.     # Must re-grab even if the grab window hasn't changed, in order
  463.     # to release the implicit grab from the button press.
  464.  
  465.     grab -global $menu
  466.     }
  467. }
  468.  
  469. # tkMenuLeave --
  470. # This procedure is invoked to handle Leave events for a menu.  It
  471. # deactivates everything unless the active element is a cascade element
  472. # and the mouse is now over the submenu.
  473. #
  474. # Arguments:
  475. # menu -        The menu window.
  476. # rootx, rooty -    Root coordinates of mouse.
  477. # state -        Modifier state.
  478.  
  479. proc tkMenuLeave {menu rootx rooty state} {
  480.     global tkPriv
  481.     set tkPriv(window) {}
  482.     if {[$menu index active] == "none"} {
  483.     return
  484.     }
  485.     if {([$menu type active] == "cascade")
  486.         && ([winfo containing $rootx $rooty]
  487.         == [$menu entrycget active -menu])} {
  488.     return
  489.     }
  490.     $menu activate none
  491. }
  492.  
  493. # tkMenuInvoke --
  494. # This procedure is invoked when button 1 is released over a menu.
  495. # It invokes the appropriate menu action and unposts the menu if
  496. # it came from a menubutton.
  497. #
  498. # Arguments:
  499. # w -            Name of the menu widget.
  500. # buttonRelease -    1 means this procedure is called because of
  501. #            a button release;  0 means because of keystroke.
  502.  
  503. proc tkMenuInvoke {w buttonRelease} {
  504.     global tkPriv
  505.  
  506.     if {$buttonRelease && ($tkPriv(window) == "")} {
  507.     # Mouse was pressed over a menu without a menu button, then
  508.     # dragged off the menu (possibly with a cascade posted) and
  509.     # released.  Unpost everything and quit.
  510.  
  511.     $w postcascade none
  512.     $w activate none
  513.     tkMenuUnpost $w
  514.     return
  515.     }
  516.     if {[$w type active] == "cascade"} {
  517.     $w postcascade active
  518.     set menu [$w entrycget active -menu]
  519.     tkMenuFirstEntry $menu
  520.     } elseif {[$w type active] == "tearoff"} {
  521.     tkMenuUnpost $w
  522.     tkTearOffMenu $w
  523.     } else {
  524.     tkMenuUnpost $w
  525.     uplevel #0 [list $w invoke active]
  526.     }
  527. }
  528.  
  529. # tkMenuEscape --
  530. # This procedure is invoked for the Cancel (or Escape) key.  It unposts
  531. # the given menu and, if it is the top-level menu for a menu button,
  532. # unposts the menu button as well.
  533. #
  534. # Arguments:
  535. # menu -        Name of the menu window.
  536.  
  537. proc tkMenuEscape menu {
  538.     if {[winfo class [winfo parent $menu]] != "Menu"} {
  539.     tkMenuUnpost $menu
  540.     } else {
  541.     tkMenuLeftRight $menu -1
  542.     }
  543. }
  544.  
  545. # tkMenuLeftRight --
  546. # This procedure is invoked to handle "left" and "right" traversal
  547. # motions in menus.  It traverses to the next menu in a menu bar,
  548. # or into or out of a cascaded menu.
  549. #
  550. # Arguments:
  551. # menu -        The menu that received the keyboard
  552. #            event.
  553. # direction -        Direction in which to move: "left" or "right"
  554.  
  555. proc tkMenuLeftRight {menu direction} {
  556.     global tkPriv
  557.  
  558.     # First handle traversals into and out of cascaded menus.
  559.  
  560.     if {$direction == "right"} {
  561.     set count 1
  562.     if {[$menu type active] == "cascade"} {
  563.         $menu postcascade active
  564.         set m2 [$menu entrycget active -menu]
  565.         if {$m2 != ""} {
  566.         tkMenuFirstEntry $m2
  567.         }
  568.         return
  569.     }
  570.     } else {
  571.     set count -1
  572.     set m2 [winfo parent $menu]
  573.     if {[winfo class $m2] == "Menu"} {
  574.         $menu activate none
  575.         focus $m2
  576.  
  577.         # This code unposts any posted submenu in the parent.
  578.  
  579.         set tmp [$m2 index active]
  580.         $m2 activate none
  581.         $m2 activate $tmp
  582.         return
  583.     }
  584.     }
  585.  
  586.     # Can't traverse into or out of a cascaded menu.  Go to the next
  587.     # or previous menubutton, if that makes sense.
  588.  
  589.     set w $tkPriv(postedMb)
  590.     if {$w == ""} {
  591.     return
  592.     }
  593.     set buttons [winfo children [winfo parent $w]]
  594.     set length [llength $buttons]
  595.     set i [expr [lsearch -exact $buttons $w] + $count]
  596.     while 1 {
  597.     while {$i < 0} {
  598.         incr i $length
  599.     }
  600.     while {$i >= $length} {
  601.         incr i -$length
  602.     }
  603.     set mb [lindex $buttons $i]
  604.     if {([winfo class $mb] == "Menubutton")
  605.         && ([$mb cget -state] != "disabled")
  606.         && ([$mb cget -menu] != "")
  607.         && ([[$mb cget -menu] index last] != "none")} {
  608.         break
  609.     }
  610.     if {$mb == $w} {
  611.         return
  612.     }
  613.     incr i $count
  614.     }
  615.     tkMbPost $mb
  616.     tkMenuFirstEntry [$mb cget -menu]
  617. }
  618.  
  619. # tkMenuNextEntry --
  620. # Activate the next higher or lower entry in the posted menu,
  621. # wrapping around at the ends.  Disabled entries are skipped.
  622. #
  623. # Arguments:
  624. # menu -            Menu window that received the keystroke.
  625. # count -            1 means go to the next lower entry,
  626. #                -1 means go to the next higher entry.
  627.  
  628. proc tkMenuNextEntry {menu count} {
  629.     global tkPriv
  630.     if {[$menu index last] == "none"} {
  631.     return
  632.     }
  633.     set length [expr [$menu index last]+1]
  634.     set quitAfter $length
  635.     set active [$menu index active]
  636.     if {$active == "none"} {
  637.     set i 0
  638.     } else {
  639.     set i [expr $active + $count]
  640.     }
  641.     while 1 {
  642.     if {$quitAfter <= 0} {
  643.         # We've tried every entry in the menu.  Either there are
  644.         # none, or they're all disabled.  Just give up.
  645.  
  646.         return
  647.     }
  648.     while {$i < 0} {
  649.         incr i $length
  650.     }
  651.     while {$i >= $length} {
  652.         incr i -$length
  653.     }
  654.     if {[catch {$menu entrycget $i -state} state] == 0} {
  655.         if {$state != "disabled"} {
  656.         break
  657.         }
  658.     }
  659.     if {$i == $active} {
  660.         return
  661.     }
  662.     incr i $count
  663.     incr quitAfter -1
  664.     }
  665.     $menu activate $i
  666.     $menu postcascade $i
  667. }
  668.  
  669. # tkMenuFind --
  670. # This procedure searches the entire window hierarchy under w for
  671. # a menubutton that isn't disabled and whose underlined character
  672. # is "char".  It returns the name of that window, if found, or an
  673. # empty string if no matching window was found.  If "char" is an
  674. # empty string then the procedure returns the name of the first
  675. # menubutton found that isn't disabled.
  676. #
  677. # Arguments:
  678. # w -                Name of window where key was typed.
  679. # char -            Underlined character to search for;
  680. #                may be either upper or lower case, and
  681. #                will match either upper or lower case.
  682.  
  683. proc tkMenuFind {w char} {
  684.     global tkPriv
  685.     set char [string tolower $char]
  686.  
  687.     foreach child [winfo child $w] {
  688.     switch [winfo class $child] {
  689.         Menubutton {
  690.         set char2 [string index [$child cget -text] \
  691.             [$child cget -underline]]
  692.         if {([string compare $char [string tolower $char2]] == 0)
  693.             || ($char == "")} {
  694.             if {[$child cget -state] != "disabled"} {
  695.             return $child
  696.             }
  697.         }
  698.         }
  699.  
  700.         # The tag below used to be "Frame", but it was changed so
  701.         # that the code would work with Itcl 2.0, which apparently
  702.         # uses other classes of widgets to hold menubuttons.
  703.  
  704.         default {
  705.         set match [tkMenuFind $child $char]
  706.         if {$match != ""} {
  707.             return $match
  708.         }
  709.         }
  710.     }
  711.     }
  712.     return {}
  713. }
  714.  
  715. # tkTraverseToMenu --
  716. # This procedure implements keyboard traversal of menus.  Given an
  717. # ASCII character "char", it looks for a menubutton with that character
  718. # underlined.  If one is found, it posts the menubutton's menu
  719. #
  720. # Arguments:
  721. # w -                Window in which the key was typed (selects
  722. #                a toplevel window).
  723. # char -            Character that selects a menu.  The case
  724. #                is ignored.  If an empty string, nothing
  725. #                happens.
  726.  
  727. proc tkTraverseToMenu {w char} {
  728.     global tkPriv
  729.     if {$char == ""} {
  730.     return
  731.     }
  732.     while {[winfo class $w] == "Menu"} {
  733.     if {$tkPriv(postedMb) == ""} {
  734.         return
  735.     }
  736.     set w [winfo parent $w]
  737.     }
  738.     set w [tkMenuFind [winfo toplevel $w] $char]
  739.     if {$w != ""} {
  740.     tkMbPost $w
  741.     tkMenuFirstEntry [$w cget -menu]
  742.     }
  743. }
  744.  
  745. # tkFirstMenu --
  746. # This procedure traverses to the first menubutton in the toplevel
  747. # for a given window, and posts that menubutton's menu.
  748. #
  749. # Arguments:
  750. # w -                Name of a window.  Selects which toplevel
  751. #                to search for menubuttons.
  752.  
  753. proc tkFirstMenu w {
  754.     set w [tkMenuFind [winfo toplevel $w] ""]
  755.     if {$w != ""} {
  756.     tkMbPost $w
  757.     tkMenuFirstEntry [$w cget -menu]
  758.     }
  759. }
  760.  
  761. # tkTraverseWithinMenu
  762. # This procedure implements keyboard traversal within a menu.  It
  763. # searches for an entry in the menu that has "char" underlined.  If
  764. # such an entry is found, it is invoked and the menu is unposted.
  765. #
  766. # Arguments:
  767. # w -                The name of the menu widget.
  768. # char -            The character to look for;  case is
  769. #                ignored.  If the string is empty then
  770. #                nothing happens.
  771.  
  772. proc tkTraverseWithinMenu {w char} {
  773.     if {$char == ""} {
  774.     return
  775.     }
  776.     set char [string tolower $char]
  777.     set last [$w index last]
  778.     if {$last == "none"} {
  779.     return
  780.     }
  781.     for {set i 0} {$i <= $last} {incr i} {
  782.     if [catch {set char2 [string index \
  783.         [$w entrycget $i -label] \
  784.         [$w entrycget $i -underline]]}] {
  785.         continue
  786.     }
  787.     if {[string compare $char [string tolower $char2]] == 0} {
  788.         if {[$w type $i] == "cascade"} {
  789.         $w postcascade $i
  790.         $w activate $i
  791.         set m2 [$w entrycget $i -menu]
  792.         if {$m2 != ""} {
  793.             tkMenuFirstEntry $m2
  794.         }
  795.         } else {
  796.         tkMenuUnpost $w
  797.         uplevel #0 [list $w invoke $i]
  798.         }
  799.         return
  800.     }
  801.     }
  802. }
  803.  
  804. # tkMenuFirstEntry --
  805. # Given a menu, this procedure finds the first entry that isn't
  806. # disabled or a tear-off or separator, and activates that entry.
  807. # However, if there is already an active entry in the menu (e.g.,
  808. # because of a previous call to tkPostOverPoint) then the active
  809. # entry isn't changed.  This procedure also sets the input focus
  810. # to the menu.
  811. #
  812. # Arguments:
  813. # menu -        Name of the menu window (possibly empty).
  814.  
  815. proc tkMenuFirstEntry menu {
  816.     if {$menu == ""} {
  817.     return
  818.     }
  819.     focus $menu
  820.     if {[$menu index active] != "none"} {
  821.     return
  822.     }
  823.     set last [$menu index last]
  824.     if {$last == "none"} {
  825.     return
  826.     }
  827.     for {set i 0} {$i <= $last} {incr i} {
  828.     if {([catch {set state [$menu entrycget $i -state]}] == 0)
  829.         && ($state != "disabled") && ([$menu type $i] != "tearoff")} {
  830.         $menu activate $i
  831.         return
  832.     }
  833.     }
  834. }
  835.  
  836. # tkMenuFindName --
  837. # Given a menu and a text string, return the index of the menu entry
  838. # that displays the string as its label.  If there is no such entry,
  839. # return an empty string.  This procedure is tricky because some names
  840. # like "active" have a special meaning in menu commands, so we can't
  841. # always use the "index" widget command.
  842. #
  843. # Arguments:
  844. # menu -        Name of the menu widget.
  845. # s -            String to look for.
  846.  
  847. proc tkMenuFindName {menu s} {
  848.     set i ""
  849.     if {![regexp {^active$|^last$|^none$|^[0-9]|^@} $s]} {
  850.     catch {set i [$menu index $s]}
  851.     return $i
  852.     }
  853.     set last [$menu index last]
  854.     if {$last == "none"} {
  855.     return
  856.     }
  857.     for {set i 0} {$i <= $last} {incr i} {
  858.     if ![catch {$menu entrycget $i -label} label] {
  859.         if {$label == $s} {
  860.         return $i
  861.         }
  862.     }
  863.     }
  864.     return ""
  865. }
  866.  
  867. # tkPostOverPoint --
  868. # This procedure posts a given menu such that a given entry in the
  869. # menu is centered over a given point in the root window.  It also
  870. # activates the given entry.
  871. #
  872. # Arguments:
  873. # menu -        Menu to post.
  874. # x, y -        Root coordinates of point.
  875. # entry -        Index of entry within menu to center over (x,y).
  876. #            If omitted or specified as {}, then the menu's
  877. #            upper-left corner goes at (x,y).
  878.  
  879. proc tkPostOverPoint {menu x y {entry {}}}  {
  880.     if {$entry != {}} {
  881.     if {$entry == [$menu index last]} {
  882.         incr y [expr -([$menu yposition $entry] \
  883.             + [winfo reqheight $menu])/2]
  884.     } else {
  885.         incr y [expr -([$menu yposition $entry] \
  886.             + [$menu yposition [expr $entry+1]])/2]
  887.     }
  888.     incr x [expr -[winfo reqwidth $menu]/2]
  889.     }
  890.     $menu post $x $y
  891.     if {($entry != {}) && ([$menu entrycget $entry -state] != "disabled")} {
  892.     $menu activate $entry
  893.     }
  894. }
  895.  
  896. # tkSaveGrabInfo --
  897. # Sets the variables tkPriv(oldGrab) and tkPriv(grabStatus) to record
  898. # the state of any existing grab on the w's display.
  899. #
  900. # Arguments:
  901. # w -            Name of a window;  used to select the display
  902. #            whose grab information is to be recorded.
  903.  
  904. proc tkSaveGrabInfo w {
  905.     global tkPriv
  906.     set tkPriv(oldGrab) [grab current $w]
  907.     if {$tkPriv(oldGrab) != ""} {
  908.     set tkPriv(grabStatus) [grab status $tkPriv(oldGrab)]
  909.     }
  910. }
  911.  
  912. # tk_popup --
  913. # This procedure pops up a menu and sets things up for traversing
  914. # the menu and its submenus.
  915. #
  916. # Arguments:
  917. # menu -        Name of the menu to be popped up.
  918. # x, y -        Root coordinates at which to pop up the
  919. #            menu.
  920. # entry -        Index of a menu entry to center over (x,y).
  921. #            If omitted or specified as {}, then menu's
  922. #            upper-left corner goes at (x,y).
  923.  
  924. proc tk_popup {menu x y {entry {}}} {
  925.     global tkPriv
  926.     if {($tkPriv(popup) != "") || ($tkPriv(postedMb) != "")} {
  927.     tkMenuUnpost {}
  928.     }
  929.     tkPostOverPoint $menu $x $y $entry
  930.     tkSaveGrabInfo $menu
  931.     grab -global $menu
  932.     set tkPriv(popup) $menu
  933.     set tkPriv(focus) [focus]
  934.     focus $menu
  935. }
  936.