home *** CD-ROM | disk | FTP | other *** search
/ Freesoft 1999 February / Freesoft_1999-02_cd.bin / Recenz / Utility / DisplayDoctorLinux / scitech-display-doctor-1.0beta-3.i386.rpm / scitech-display-doctor-1.0beta.3.cpio.gz / scitech-display-doctor-1.0beta.3.cpio / usr / lib / nucleus / XF86Setup / tcllib / menu.tcl < prev    next >
Text File  |  1998-09-19  |  25KB  |  922 lines
  1. # $XConsortium: menu.tcl /main/1 1996/09/21 14:15:49 kaleb $
  2. #
  3. #
  4. #
  5. #
  6. # $XFree86: xc/programs/Xserver/hw/xfree86/XF86Setup/tcllib/menu.tcl,v 3.1 1996/12/27 06:55:00 dawes Exp $
  7. #
  8. # menu.tcl --
  9. #
  10. # This file defines the default bindings for Tk menus and menubuttons.
  11. # It also implements keyboard traversal of menus and implements a few
  12. # other utility procedures related to menus.
  13. #
  14. # @(#) menu.tcl 1.59 95/11/24 14:51:37
  15. #
  16. # Copyright (c) 1992-1994 The Regents of the University of California.
  17. # Copyright (c) 1994-1995 Sun Microsystems, Inc.
  18. #
  19. # See the file "license.terms" for information on usage and redistribution
  20. # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  21. #
  22.  
  23. #-------------------------------------------------------------------------
  24. # Elements of tkPriv that are used in this file:
  25. #
  26. # cursor -        Saves the -cursor option for the posted menubutton.
  27. # focus -        Saves the focus during a menu selection operation.
  28. #            Focus gets restored here when the menu is unposted.
  29. # grabGlobal -        Used in conjunction with tkPriv(oldGrab):  if
  30. #            tkPriv(oldGrab) is non-empty, then tkPriv(grabGlobal)
  31. #            contains either an empty string or "-global" to
  32. #            indicate whether the old grab was a local one or
  33. #            a global one.
  34. # inMenubutton -    The name of the menubutton widget containing
  35. #            the mouse, or an empty string if the mouse is
  36. #            not over any menubutton.
  37. # oldGrab -        Window that had the grab before a menu was posted.
  38. #            Used to restore the grab state after the menu
  39. #            is unposted.  Empty string means there was no
  40. #            grab previously set.
  41. # popup -        If a menu has been popped up via tk_popup, this
  42. #            gives the name of the menu.  Otherwise this
  43. #            value is empty.
  44. # postedMb -        Name of the menubutton whose menu is currently
  45. #            posted, or an empty string if nothing is posted
  46. #            A grab is set on this widget.
  47. # relief -        Used to save the original relief of the current
  48. #            menubutton.
  49. # window -        When the mouse is over a menu, this holds the
  50. #            name of the menu;  it's cleared when the mouse
  51. #            leaves the menu.
  52. #-------------------------------------------------------------------------
  53.  
  54. #-------------------------------------------------------------------------
  55. # Overall note:
  56. # This file is tricky because there are four different ways that menus
  57. # can be used:
  58. #
  59. # 1. As a pulldown from a menubutton.  This is the most common usage.
  60. #    In this style, the variable tkPriv(postedMb) identifies the posted
  61. #    menubutton.
  62. # 2. As a torn-off menu copied from some other menu.  In this style
  63. #    tkPriv(postedMb) is empty, and the top-level menu is no
  64. #    override-redirect.
  65. # 3. As an option menu, triggered from an option menubutton.  In thi
  66. #    style tkPriv(postedMb) identifies the posted menubutton.
  67. # 4. As a popup menu.  In this style tkPriv(postedMb) is empty and
  68. #    the top-level menu is override-redirect.
  69. #
  70. # The various binding procedures use the  state described above to
  71. # distinguish the various cases and take different actions in each
  72. # case.
  73. #-------------------------------------------------------------------------
  74.  
  75. #-------------------------------------------------------------------------
  76. # The code below creates the default class bindings for menus
  77. # and menubuttons.
  78. #-------------------------------------------------------------------------
  79.  
  80. bind Menubutton <FocusIn> {}
  81. bind Menubutton <Enter> {
  82.     tkMbEnter %W
  83. }
  84. bind Menubutton <Leave> {
  85.     tkMbLeave %W
  86. }
  87. bind Menubutton <1> {
  88.     if {$tkPriv(inMenubutton) != ""} {
  89.     tkMbPost $tkPriv(inMenubutton) %X %Y
  90.     }
  91. }
  92. bind Menubutton <Motion> {
  93.     tkMbMotion %W up %X %Y
  94. }
  95. bind Menubutton <B1-Motion> {
  96.     tkMbMotion %W down %X %Y
  97. }
  98. bind Menubutton <ButtonRelease-1> {
  99.     tkMbButtonUp %W
  100. }
  101. bind Menubutton <space> {
  102.     tkMbPost %W
  103.     tkMenuFirstEntry [%W cget -menu]
  104. }
  105. bind Menubutton <Return> {
  106.     tkMbPost %W
  107.     tkMenuFirstEntry [%W cget -menu]
  108. }
  109.  
  110. # Must set focus when mouse enters a menu, in order to allow
  111. # mixed-mode processing using both the mouse and the keyboard.
  112. # Don't set the focus if the event comes from a grab release,
  113. # though:  such an event can happen after as part of unposting
  114. # a cascaded chain of menus, after the focus has already been
  115. # restored to wherever it was before menu selection started.
  116.  
  117. bind Menu <FocusIn> {}
  118. bind Menu <Enter> {
  119.     set tkPriv(window) %W
  120.     if {"%m" != "NotifyUngrab"} {
  121.     focus %W
  122.     }
  123. }
  124. bind Menu <Leave> {
  125.     tkMenuLeave %W %X %Y %s
  126. }
  127. bind Menu <Motion> {
  128.     tkMenuMotion %W %y %s
  129. }
  130. bind Menu <ButtonPress> {
  131.     tkMenuButtonDown %W
  132. }
  133. bind Menu <ButtonRelease> {
  134.     tkMenuInvoke %W 1
  135. }
  136. bind Menu <space> {
  137.     tkMenuInvoke %W 0
  138. }
  139. bind Menu <Return> {
  140.     tkMenuInvoke %W 0
  141. }
  142. bind Menu <Escape> {
  143.     tkMenuEscape %W
  144. }
  145. bind Menu <Left> {
  146.     tkMenuLeftRight %W left
  147. }
  148. bind Menu <Right> {
  149.     tkMenuLeftRight %W right
  150. }
  151. bind Menu <Up> {
  152.     tkMenuNextEntry %W -1
  153. }
  154. bind Menu <Down> {
  155.     tkMenuNextEntry %W +1
  156. }
  157. bind Menu <KeyPress> {
  158.     tkTraverseWithinMenu %W %A
  159. }
  160.  
  161. # The following bindings apply to all windows, and are used to
  162. # implement keyboard menu traversal.
  163.  
  164. bind all <Alt-KeyPress> {
  165.     tkTraverseToMenu %W %A
  166. }
  167. bind all <F10> {
  168.     tkFirstMenu %W
  169. }
  170.  
  171. # tkMbEnter --
  172. # This procedure is invoked when the mouse enters a menubutton
  173. # widget.  It activates the widget unless it is disabled.  Note:
  174. # this procedure is only invoked when mouse button 1 is *not* down.
  175. # The procedure tkMbB1Enter is invoked if the button is down.
  176. #
  177. # Arguments:
  178. # w -            The  name of the widget.
  179.  
  180. proc tkMbEnter w {
  181.     global tkPriv
  182.  
  183.     if {$tkPriv(inMenubutton) != ""} {
  184.     tkMbLeave $tkPriv(inMenubutton)
  185.     }
  186.     set tkPriv(inMenubutton) $w
  187.     if {[$w cget -state] != "disabled"} {
  188.     $w configure -state active
  189.     }
  190. }
  191.  
  192. # tkMbLeave --
  193. # This procedure is invoked when the mouse leaves a menubutton widget.
  194. # It de-activates the widget, if the widget still exists.
  195. #
  196. # Arguments:
  197. # w -            The  name of the widget.
  198.  
  199. proc tkMbLeave w {
  200.     global tkPriv
  201.  
  202.     set tkPriv(inMenubutton) {}
  203.     if ![winfo exists $w] {
  204.     return
  205.     }
  206.     if {[$w cget -state] == "active"} {
  207.     $w configure -state normal
  208.     }
  209. }
  210.  
  211. # tkMbPost --
  212. # Given a menubutton, this procedure does all the work of posting
  213. # its associated menu and unposting any other menu that is currently
  214. # posted.
  215. #
  216. # Arguments:
  217. # w -            The name of the menubutton widget whose menu
  218. #            is to be posted.
  219. # x, y -        Root coordinates of cursor, used for positioning
  220. #            option menus.  If not specified, then the center
  221. #            of the menubutton is used for an option menu.
  222.  
  223. proc tkMbPost {w {x {}} {y {}}} {
  224.     global tkPriv
  225.     if {([$w cget -state] == "disabled") || ($w == $tkPriv(postedMb))} {
  226.     return
  227.     }
  228.     set menu [$w cget -menu]
  229.     if {$menu == ""} {
  230.     return
  231.     }
  232.     if ![string match $w.* $menu] {
  233.     error "can't post $menu:  it isn't a descendant of $w (this is a new requirement in Tk versions 3.0 and later)"
  234.     }
  235.     set cur $tkPriv(postedMb)
  236.     if {$cur != ""} {
  237.     tkMenuUnpost {}
  238.     }
  239.     set tkPriv(cursor) [$w cget -cursor]
  240.     set tkPriv(relief) [$w cget -relief]
  241.     $w configure -cursor arrow
  242.     $w configure -relief raised
  243.     set tkPriv(postedMb) $w
  244.     set tkPriv(focus) [focus]
  245.     $menu activate none
  246.  
  247.     # If this looks like an option menubutton then post the menu so
  248.     # that the current entry is on top of the mouse.  Otherwise post
  249.     # the menu just below the menubutton, as for a pull-down.
  250.  
  251.     if {([$w cget -indicatoron] == 1) && ([$w cget -textvariable] != "")} {
  252.     if {$y == ""} {
  253.         set x [expr [winfo rootx $w] + [winfo width $w]/2]
  254.         set y [expr [winfo rooty $w] + [winfo height $w]/2]
  255.     }
  256.     tkPostOverPoint $menu $x $y [tkMenuFindName $menu [$w cget -text]]
  257.     } else {
  258.     $menu post [winfo rootx $w] [expr [winfo rooty $w]+[winfo height $w]]
  259.     }
  260.     focus $menu
  261.     tkSaveGrabInfo $w
  262.     grab -global $w
  263. }
  264.  
  265. # tkMenuUnpost --
  266. # This procedure unposts a given menu, plus all of its ancestors up
  267. # to (and including) a menubutton, if any.  It also restores various
  268. # values to what they were before the menu was posted, and releases
  269. # a grab if there's a menubutton involved.  Special notes:
  270. # 1. It's important to unpost all menus before releasing the grab, so
  271. #    that any Enter-Leave events (e.g. from menu back to main
  272. #    application) have mode NotifyGrab.
  273. # 2. Be sure to enclose various groups of commands in "catch" so that
  274. #    the procedure will complete even if the menubutton or the menu
  275. #    or the grab window has been deleted.
  276. #
  277. # Arguments:
  278. # menu -        Name of a menu to unpost.  Ignored if there
  279. #            is a posted menubutton.
  280.  
  281. proc tkMenuUnpost menu {
  282.     global tkPriv
  283.     set mb $tkPriv(postedMb)
  284.  
  285.     # Restore focus right away (otherwise X will take focus away when
  286.     # the menu is unmapped and under some window managers (e.g. olvwm)
  287.     # we'll lose the focus completely).
  288.  
  289.     catch {focus $tkPriv(focus)}
  290.     set tkPriv(focus) ""
  291.  
  292.     # Unpost menu(s) and restore some stuff that's dependent on
  293.     # what was posted.
  294.  
  295.     catch {
  296.     if {$mb != ""} {
  297.         set menu [$mb cget -menu]
  298.         $menu unpost
  299.         set tkPriv(postedMb) {}
  300.         $mb configure -cursor $tkPriv(cursor)
  301.         $mb configure -relief $tkPriv(relief)
  302.     } elseif {$tkPriv(popup) != ""} {
  303.         $tkPriv(popup) unpost
  304.         set tkPriv(popup) {}
  305.     } elseif {[wm overrideredirect $menu]} {
  306.         # We're in a cascaded sub-menu from a torn-off menu or popup.
  307.         # Unpost all the menus up to the toplevel one (but not
  308.         # including the top-level torn-off one) and deactivate the
  309.         # top-level torn off menu if there is one.
  310.  
  311.         while 1 {
  312.         set parent [winfo parent $menu]
  313.         if {([winfo class $parent] != "Menu")
  314.             || ![winfo ismapped $parent]} {
  315.             break
  316.         }
  317.         $parent activate none
  318.         $parent postcascade none
  319.         if {![wm overrideredirect $parent]} {
  320.             break
  321.         }
  322.         set menu $parent
  323.         }
  324.         $menu unpost
  325.     }
  326.     }
  327.  
  328.     # Release grab, if any, and restore the previous grab, if there
  329.     # was one.
  330.  
  331.     if {$menu != ""} {
  332.     set grab [grab current $menu]
  333.     if {$grab != ""} {
  334.         grab release $grab
  335.     }
  336.     }
  337.     if {$tkPriv(oldGrab) != ""} {
  338.     if {$tkPriv(grabStatus) == "global"} {
  339.         grab set -global $tkPriv(oldGrab)
  340.     } else {
  341.         grab set $tkPriv(oldGrab)
  342.     }
  343.     set tkPriv(oldGrab) ""
  344.     }
  345. }
  346.  
  347. # tkMbMotion --
  348. # This procedure handles mouse motion events inside menubuttons, and
  349. # also outside menubuttons when a menubutton has a grab (e.g. when a
  350. # menu selection operation is in progress).
  351. #
  352. # Arguments:
  353. # w -            The name of the menubutton widget.
  354. # upDown -         "down" means button 1 is pressed, "up" means
  355. #            it isn't.
  356. # rootx, rooty -    Coordinates of mouse, in (virtual?) root window.
  357.  
  358. proc tkMbMotion {w upDown rootx rooty} {
  359.     global tkPriv
  360.  
  361.     if {$tkPriv(inMenubutton) == $w} {
  362.     return
  363.     }
  364.     set new [winfo containing $rootx $rooty]
  365.     if {($new != $tkPriv(inMenubutton)) && (($new == "")
  366.         || ([winfo toplevel $new] == [winfo toplevel $w]))} {
  367.     if {$tkPriv(inMenubutton) != ""} {
  368.         tkMbLeave $tkPriv(inMenubutton)
  369.     }
  370.     if {($new != "") && ([winfo class $new] == "Menubutton")
  371.         && ([$new cget -indicatoron] == 0)} {
  372.         if {$upDown == "down"} {
  373.         tkMbPost $new $rootx $rooty
  374.         } else {
  375.         tkMbEnter $new
  376.         }
  377.     }
  378.     }
  379. }
  380.  
  381. # tkMbButtonUp --
  382. # This procedure is invoked to handle button 1 releases for menubuttons.
  383. # If the release happens inside the menubutton then leave its menu
  384. # posted with element 0 activated.  Otherwise, unpost the menu.
  385. #
  386. # Arguments:
  387. # w -            The name of the menubutton widget.
  388.  
  389. proc tkMbButtonUp w {
  390.     global tkPriv
  391.  
  392.     if  {($tkPriv(postedMb) == $w) && ($tkPriv(inMenubutton) == $w)} {
  393.     tkMenuFirstEntry [$tkPriv(postedMb) cget -menu]
  394.     } else {
  395.     tkMenuUnpost {}
  396.     }
  397. }
  398.  
  399. # tkMenuMotion --
  400. # This procedure is called to handle mouse motion events for menus.
  401. # It does two things.  First, it resets the active element in the
  402. # menu, if the mouse is over the menu.  Second, if a mouse button
  403. # is down, it posts and unposts cascade entries to match the mouse
  404. # position.
  405. #
  406. # Arguments:
  407. # menu -        The menu window.
  408. # y -            The y position of the mouse.
  409. # state -        Modifier state (tells whether buttons are down).
  410.  
  411. proc tkMenuMotion {menu y state} {
  412.     global tkPriv
  413.     if {$menu == $tkPriv(window)} {
  414.     $menu activate @$y
  415.     }
  416.     if {($state & 0x1f00) != 0} {
  417.     $menu postcascade active
  418.     }
  419. }
  420.  
  421. # tkMenuButtonDown --
  422. # Handles button presses in menus.  There are a couple of tricky things
  423. # here:
  424. # 1. Change the posted cascade entry (if any) to match the mouse position.
  425. # 2. If there is a posted menubutton, must grab to the menubutton;  this
  426. #    overrrides the implicit grab on button press, so that the menu
  427. #    button can track mouse motions over other menubuttons and change
  428. #    the posted menu.
  429. # 3. If there's no posted menubutton (e.g. because we're a torn-off menu
  430. #    or one of its descendants) must grab to the top-level menu so that
  431. #    we can track mouse motions across the entire menu hierarchy.
  432. #
  433. # Arguments:
  434. # menu -        The menu window.
  435.  
  436. proc tkMenuButtonDown menu {
  437.     global tkPriv
  438.     $menu postcascade active
  439.     if {$tkPriv(postedMb) != ""} {
  440.     grab -global $tkPriv(postedMb)
  441.     } else {
  442.     while {[wm overrideredirect $menu]
  443.         && ([winfo class [winfo parent $menu]] == "Menu")
  444.         && [winfo ismapped [winfo parent $menu]]} {
  445.         set menu [winfo parent $menu]
  446.     }
  447.  
  448.     # Don't update grab information if the grab window isn't changing.
  449.     # Otherwise, we'll get an error when we unpost the menus and
  450.     # restore the grab, since the old grab window will not be viewable
  451.     # anymore.
  452.  
  453.     if {$menu != [grab current $menu]} {
  454.         tkSaveGrabInfo $menu
  455.     }
  456.  
  457.     # Must re-grab even if the grab window hasn't changed, in order
  458.     # to release the implicit grab from the button press.
  459.  
  460.     grab -global $menu
  461.     }
  462. }
  463.  
  464. # tkMenuLeave --
  465. # This procedure is invoked to handle Leave events for a menu.  It
  466. # deactivates everything unless the active element is a cascade element
  467. # and the mouse is now over the submenu.
  468. #
  469. # Arguments:
  470. # menu -        The menu window.
  471. # rootx, rooty -    Root coordinates of mouse.
  472. # state -        Modifier state.
  473.  
  474. proc tkMenuLeave {menu rootx rooty state} {
  475.     global tkPriv
  476.     set tkPriv(window) {}
  477.     if {[$menu index active] == "none"} {
  478.     return
  479.     }
  480.     if {([$menu type active] == "cascade")
  481.         && ([winfo containing $rootx $rooty]
  482.         == [$menu entrycget active -menu])} {
  483.     return
  484.     }
  485.     $menu activate none
  486. }
  487.  
  488. # tkMenuInvoke --
  489. # This procedure is invoked when button 1 is released over a menu.
  490. # It invokes the appropriate menu action and unposts the menu if
  491. # it came from a menubutton.
  492. #
  493. # Arguments:
  494. # w -            Name of the menu widget.
  495. # buttonRelease -    1 means this procedure is called because of
  496. #            a button release;  0 means because of keystroke.
  497.  
  498. proc tkMenuInvoke {w buttonRelease} {
  499.     global tkPriv
  500.  
  501.     if {$buttonRelease && ($tkPriv(window) == "")} {
  502.     # Mouse was pressed over a menu without a menu button, then
  503.     # dragged off the menu (possibly with a cascade posted) and
  504.     # released.  Unpost everything and quit.
  505.  
  506.     $w postcascade none
  507.     $w activate none
  508.     tkMenuUnpost $w
  509.     return
  510.     }
  511.     if {[$w type active] == "cascade"} {
  512.     $w postcascade active
  513.     set menu [$w entrycget active -menu]
  514.     tkMenuFirstEntry $menu
  515.     } elseif {[$w type active] == "tearoff"} {
  516.     tkMenuUnpost $w
  517.     tkTearOffMenu $w
  518.     } else {
  519.     tkMenuUnpost $w
  520.     uplevel #0 [list $w invoke active]
  521.     }
  522. }
  523.  
  524. # tkMenuEscape --
  525. # This procedure is invoked for the Cancel (or Escape) key.  It unposts
  526. # the given menu and, if it is the top-level menu for a menu button,
  527. # unposts the menu button as well.
  528. #
  529. # Arguments:
  530. # menu -        Name of the menu window.
  531.  
  532. proc tkMenuEscape menu {
  533.     if {[winfo class [winfo parent $menu]] != "Menu"} {
  534.     tkMenuUnpost $menu
  535.     } else {
  536.     tkMenuLeftRight $menu -1
  537.     }
  538. }
  539.  
  540. # tkMenuLeftRight --
  541. # This procedure is invoked to handle "left" and "right" traversal
  542. # motions in menus.  It traverses to the next menu in a menu bar,
  543. # or into or out of a cascaded menu.
  544. #
  545. # Arguments:
  546. # menu -        The menu that received the keyboard
  547. #            event.
  548. # direction -        Direction in which to move: "left" or "right"
  549.  
  550. proc tkMenuLeftRight {menu direction} {
  551.     global tkPriv
  552.  
  553.     # First handle traversals into and out of cascaded menus.
  554.  
  555.     if {$direction == "right"} {
  556.     set count 1
  557.     if {[$menu type active] == "cascade"} {
  558.         $menu postcascade active
  559.         set m2 [$menu entrycget active -menu]
  560.         if {$m2 != ""} {
  561.         tkMenuFirstEntry $m2
  562.         }
  563.         return
  564.     }
  565.     } else {
  566.     set count -1
  567.     set m2 [winfo parent $menu]
  568.     if {[winfo class $m2] == "Menu"} {
  569.         $menu activate none
  570.         focus $m2
  571.  
  572.         # This code unposts any posted submenu in the parent.
  573.  
  574.         set tmp [$m2 index active]
  575.         $m2 activate none
  576.         $m2 activate $tmp
  577.         return
  578.     }
  579.     }
  580.  
  581.     # Can't traverse into or out of a cascaded menu.  Go to the next
  582.     # or previous menubutton, if that makes sense.
  583.  
  584.     set w $tkPriv(postedMb)
  585.     if {$w == ""} {
  586.     return
  587.     }
  588.     set buttons [winfo children [winfo parent $w]]
  589.     set length [llength $buttons]
  590.     set i [expr [lsearch -exact $buttons $w] + $count]
  591.     while 1 {
  592.     while {$i < 0} {
  593.         incr i $length
  594.     }
  595.     while {$i >= $length} {
  596.         incr i -$length
  597.     }
  598.     set mb [lindex $buttons $i]
  599.     if {([winfo class $mb] == "Menubutton")
  600.         && ([$mb cget -state] != "disabled")
  601.         && ([$mb cget -menu] != "")
  602.         && ([[$mb cget -menu] index last] != "none")} {
  603.         break
  604.     }
  605.     if {$mb == $w} {
  606.         return
  607.     }
  608.     incr i $count
  609.     }
  610.     tkMbPost $mb
  611.     tkMenuFirstEntry [$mb cget -menu]
  612. }
  613.  
  614. # tkMenuNextEntry --
  615. # Activate the next higher or lower entry in the posted menu,
  616. # wrapping around at the ends.  Disabled entries are skipped.
  617. #
  618. # Arguments:
  619. # menu -            Menu window that received the keystroke.
  620. # count -            1 means go to the next lower entry,
  621. #                -1 means go to the next higher entry.
  622.  
  623. proc tkMenuNextEntry {menu count} {
  624.     global tkPriv
  625.     if {[$menu index last] == "none"} {
  626.     return
  627.     }
  628.     set length [expr [$menu index last]+1]
  629.     set quitAfter $length
  630.     set active [$menu index active]
  631.     if {$active == "none"} {
  632.     set i 0
  633.     } else {
  634.     set i [expr $active + $count]
  635.     }
  636.     while 1 {
  637.     if {$quitAfter <= 0} {
  638.         # We've tried every entry in the menu.  Either there are
  639.         # none, or they're all disabled.  Just give up.
  640.  
  641.         return
  642.     }
  643.     while {$i < 0} {
  644.         incr i $length
  645.     }
  646.     while {$i >= $length} {
  647.         incr i -$length
  648.     }
  649.     if {[catch {$menu entrycget $i -state} state] == 0} {
  650.         if {$state != "disabled"} {
  651.         break
  652.         }
  653.     }
  654.     if {$i == $active} {
  655.         return
  656.     }
  657.     incr i $count
  658.     incr quitAfter -1
  659.     }
  660.     $menu activate $i
  661.     $menu postcascade $i
  662. }
  663.  
  664. # tkMenuFind --
  665. # This procedure searches the entire window hierarchy under w for
  666. # a menubutton that isn't disabled and whose underlined character
  667. # is "char".  It returns the name of that window, if found, or an
  668. # empty string if no matching window was found.  If "char" is an
  669. # empty string then the procedure returns the name of the first
  670. # menubutton found that isn't disabled.
  671. #
  672. # Arguments:
  673. # w -                Name of window where key was typed.
  674. # char -            Underlined character to search for;
  675. #                may be either upper or lower case, and
  676. #                will match either upper or lower case.
  677.  
  678. proc tkMenuFind {w char} {
  679.     global tkPriv
  680.     set char [string tolower $char]
  681.  
  682.     foreach child [winfo child $w] {
  683.     switch [winfo class $child] {
  684.         Menubutton {
  685.         set char2 [string index [$child cget -text] \
  686.             [$child cget -underline]]
  687.         if {([string compare $char [string tolower $char2]] == 0)
  688.             || ($char == "")} {
  689.             if {[$child cget -state] != "disabled"} {
  690.             return $child
  691.             }
  692.         }
  693.         }
  694.         Frame {
  695.         set match [tkMenuFind $child $char]
  696.         if {$match != ""} {
  697.             return $match
  698.         }
  699.         }
  700.     }
  701.     }
  702.     return {}
  703. }
  704.  
  705. # tkTraverseToMenu --
  706. # This procedure implements keyboard traversal of menus.  Given an
  707. # ASCII character "char", it looks for a menubutton with that character
  708. # underlined.  If one is found, it posts the menubutton's menu
  709. #
  710. # Arguments:
  711. # w -                Window in which the key was typed (selects
  712. #                a toplevel window).
  713. # char -            Character that selects a menu.  The case
  714. #                is ignored.  If an empty string, nothing
  715. #                happens.
  716.  
  717. proc tkTraverseToMenu {w char} {
  718.     if {$char == ""} {
  719.     return
  720.     }
  721.     while {[winfo class $w] == "Menu"} {
  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.