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