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