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