I386LINUX/util/I386LINUX/lib/tk8.4/menu.tcl

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