menu.tcl 38 KB

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