开通博客赚积分
发布资源赚积分
分类

源码开发语言/平台
当前位置：首页 > 源码/资料 > Windows编程 > 通讯编程 > 查看源码
menu.tcl
资源名称：ns-allinone-2.33.tar.gz　[点击查看]
上传用户：rrhhcc
上传日期：2015-12-11
资源大小：54129k
文件大小：36k
源码类别：

通讯编程

开发平台：

Visual C++

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