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