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