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 # Copyright (c) 1992-1994 The Regents of the University of California.
   8 # Copyright (c) 1994-1995 Sun Microsystems, Inc.
   9 #
  10 # See the file "license.terms" for information on usage and redistribution
  11 # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  12 #
  13
  14 #-------------------------------------------------------------------------
  15 # Elements of ckPriv that are used in this file:
  16 #
  17 # focus -               Saves the focus during a menu selection operation.
  18 #                       Focus gets restored here when the menu is unposted.
  19 # postedMb -            Name of the menubutton whose menu is currently
  20 #                       posted, or an empty string if nothing is posted
  21 # popup -               If a menu has been popped up via ck_popup, this
  22 #                       gives the name of the menu. Otherwise this value
  23 #                       is empty.
  24 #-------------------------------------------------------------------------
  25
  26 set ckPriv(postedMb) ""
  27 set ckPriv(popup) ""
  28
  29 #-------------------------------------------------------------------------
  30 # The code below creates the default class bindings for menus
  31 # and menubuttons.
  32 #-------------------------------------------------------------------------
  33
  34 bind Menubutton <FocusIn> {}
  35 bind Menubutton <space> {
  36     if {[ckMbPost %W]} {
  37         ckMenuFirstEntry [%W cget -menu]
  38     }
  39 }
  40 bind Menubutton <Return> {
  41     if {[ckMbPost %W]} {
  42         ckMenuFirstEntry [%W cget -menu]
  43     }
  44 }
  45 bind Menubutton <Linefeed> {
  46     if {[ckMbPost %W]} {
  47         ckMenuFirstEntry [%W cget -menu]
  48     }
  49 }
  50 bind Menubutton <Button-1> {
  51     if {[ckMbPost %W]} {
  52         ckMenuFirstEntry [%W cget -menu]
  53     }
  54 }
  55
  56 bind Menu <space> {
  57     ckMenuInvoke %W
  58 }
  59 bind Menu <Return> {
  60     ckMenuInvoke %W
  61 }
  62 bind Menu <Linefeed> {
  63     ckMenuInvoke %W
  64 }
  65 bind Menu <Escape> {
  66     ckMenuEscape %W ; break
  67 }
  68 bind Menu <Left> {
  69     ckMenuLeftRight %W left
  70 }
  71 bind Menu <Right> {
  72     ckMenuLeftRight %W right
  73 }
  74 bind Menu <Up> {
  75     ckMenuNextEntry %W -1
  76 }
  77 bind Menu <Down> {
  78     ckMenuNextEntry %W +1
  79 }
  80 bind Menu <KeyPress> {
  81     ckTraverseWithinMenu %W %A
  82 }
  83 bind Menu <Button-1> {
  84     %W activate @%y
  85     ckMenuInvoke %W
  86 }
  87
  88 bind all <F10> {
  89     ckFirstMenu %W
  90 }
  91
  92 # ckMbPost --
  93 # Given a menubutton, this procedure does all the work of posting
  94 # its associated menu and unposting any other menu that is currently
  95 # posted.
  96 #
  97 # Arguments:
  98 # w -                   The name of the menubutton widget whose menu
  99 #                       is to be posted.
 100 # x, y -                Root coordinates of cursor, used for positioning
 101 #                       option menus.  If not specified, then the center
 102 #                       of the menubutton is used for an option menu.
 103
 104 proc ckMbPost {w {x {}} {y {}}} {
 105     global ckPriv
 106     if {([$w cget -state] == "disabled") || ($w == $ckPriv(postedMb))} {
 107         return 0
 108     }
 109     set menu [$w cget -menu]
 110     if {$menu == ""} {
 111         return 0
 112     }
 113     if ![string match $w.* $menu] {
 114         error "can't post $menu:  it isn't a descendant of $w"
 115     }
 116     set cur $ckPriv(postedMb)
 117     if {$cur != ""} {
 118         ckMenuUnpost {}
 119     }
 120     set ckPriv(postedMb) $w
 121     set ckPriv(focus) [focus]
 122     $menu activate none
 123
 124     # If this looks like an option menubutton then post the menu so
 125     # that the current entry is on top of the mouse.  Otherwise post
 126     # the menu just below the menubutton, as for a pull-down.
 127
 128     if {([$w cget -indicatoron] == 1) && ([$w cget -textvariable] != "")} {
 129         if {$y == ""} {
 130             set x [expr [winfo rootx $w] + [winfo width $w]/2]
 131             set y [expr [winfo rooty $w] + [winfo height $w]/2]
 132         }
 133         ckPostOverPoint $menu $x $y [ckMenuFindName $menu [$w cget -text]]
 134     } else {
 135         $menu post [winfo rootx $w] [expr [winfo rooty $w]+[winfo height $w]]
 136     }
 137     focus $menu
 138     $w configure -state active
 139     return 1
 140 }
 141
 142 # ckMenuUnpost --
 143 # This procedure unposts a given menu, plus all of its ancestors up
 144 # to (and including) a menubutton, if any. It also restores various
 145 # values to what they were before the menu was posted, and releases
 146 # a grab if there's a menubutton involved. Special notes:
 147 # Be sure to enclose various groups of commands in "catch" so that
 148 # the procedure will complete even if the menubutton or the menu
 149 # has been deleted.
 150 #
 151 # Arguments:
 152 # menu -                Name of a menu to unpost.  Ignored if there
 153 #                       is a posted menubutton.
 154
 155 proc ckMenuUnpost menu {
 156     global ckPriv
 157     set mb $ckPriv(postedMb)
 158     catch {
 159         if {$mb != ""} {
 160             $mb configure -state normal
 161             catch {focus $ckPriv(focus)}
 162             set ckPriv(focus) ""
 163             set menu [$mb cget -menu]
 164             $menu unpost
 165             set ckPriv(postedMb) {}
 166         } elseif {[string length $ckPriv(popup)]} {
 167             catch {focus $ckPriv(focus)}
 168             set ckPriv(focus) ""
 169             $ckPriv(popup) unpost
 170             set ckPriv(popup) ""
 171         }
 172     }
 173 }
 174
 175 # ckMenuInvoke --
 176 # This procedure is invoked when button 1 is released over a menu.
 177 # It invokes the appropriate menu action and unposts the menu if
 178 # it came from a menubutton.
 179 #
 180 # Arguments:
 181 # w -                   Name of the menu widget.
 182
 183 proc ckMenuInvoke w {
 184     if {[$w type active] == "cascade"} {
 185         $w postcascade active
 186         set menu [$w entrycget active -menu]
 187         ckMenuFirstEntry $menu
 188     } else {
 189         ckMenuUnpost $w
 190         uplevel #0 [list $w invoke active]
 191     }
 192 }
 193
 194 # ckMenuEscape --
 195 # This procedure is invoked for the Cancel (or Escape) key.  It unposts
 196 # the given menu and, if it is the top-level menu for a menu button,
 197 # unposts the menu button as well.
 198 #
 199 # Arguments:
 200 # menu -                Name of the menu window.
 201
 202 proc ckMenuEscape menu {
 203     if {[winfo class [winfo parent $menu]] != "Menu"} {
 204         ckMenuUnpost $menu
 205     } else {
 206         ckMenuLeftRight $menu -1
 207     }
 208 }
 209
 210 # ckMenuLeftRight --
 211 # This procedure is invoked to handle "left" and "right" traversal
 212 # motions in menus.  It traverses to the next menu in a menu bar,
 213 # or into or out of a cascaded menu.
 214 #
 215 # Arguments:
 216 # menu -                The menu that received the keyboard
 217 #                       event.
 218 # direction -           Direction in which to move: "left" or "right"
 219
 220 proc ckMenuLeftRight {menu direction} {
 221     global ckPriv
 222
 223     # First handle traversals into and out of cascaded menus.
 224
 225     if {$direction == "right"} {
 226         set count 1
 227         if {[$menu type active] == "cascade"} {
 228             $menu postcascade active
 229             set m2 [$menu entrycget active -menu]
 230             if {$m2 != ""} {
 231                 ckMenuFirstEntry $m2
 232             }
 233             return
 234         }
 235     } else {
 236         set count -1
 237         set m2 [winfo parent $menu]
 238         if {[winfo class $m2] == "Menu"} {
 239             focus $m2
 240             $m2 postcascade none
 241             return
 242         }
 243     }
 244
 245     # Can't traverse into or out of a cascaded menu.  Go to the next
 246     # or previous menubutton, if that makes sense.
 247
 248     set w $ckPriv(postedMb)
 249     if {$w == ""} {
 250         return
 251     }
 252     set buttons [winfo children [winfo parent $w]]
 253     set length [llength $buttons]
 254     set i [expr [lsearch -exact $buttons $w] + $count]
 255     while 1 {
 256         while {$i < 0} {
 257             incr i $length
 258         }
 259         while {$i >= $length} {
 260             incr i -$length
 261         }
 262         set mb [lindex $buttons $i]
 263         if {([winfo class $mb] == "Menubutton")
 264                 && ([$mb cget -state] != "disabled")
 265                 && ([$mb cget -menu] != "")
 266                 && ([[$mb cget -menu] index last] != "none")} {
 267             break
 268         }
 269         if {$mb == $w} {
 270             return
 271         }
 272         incr i $count
 273     }
 274     if {[ckMbPost $mb]} {
 275         ckMenuFirstEntry [$mb cget -menu]
 276     }
 277 }
 278
 279 # ckMenuNextEntry --
 280 # Activate the next higher or lower entry in the posted menu,
 281 # wrapping around at the ends.  Disabled entries are skipped.
 282 #
 283 # Arguments:
 284 # menu -                        Menu window that received the keystroke.
 285 # count -                       1 means go to the next lower entry,
 286 #                               -1 means go to the next higher entry.
 287
 288 proc ckMenuNextEntry {menu count} {
 289     global ckPriv
 290     if {[$menu index last] == "none"} {
 291         return
 292     }
 293     set length [expr [$menu index last]+1]
 294     set active [$menu index active]
 295     if {$active == "none"} {
 296         set i 0
 297     } else {
 298         set i [expr $active + $count]
 299     }
 300     while 1 {
 301         while {$i < 0} {
 302             incr i $length
 303         }
 304         while {$i >= $length} {
 305             incr i -$length
 306         }
 307         if {[catch {$menu entrycget $i -state} state] == 0} {
 308             if {$state != "disabled"} {
 309                 break
 310             }
 311         }
 312         if {$i == $active} {
 313             return
 314         }
 315         incr i $count
 316     }
 317     $menu activate $i
 318 }
 319
 320 # ckMenuFind --
 321 # This procedure searches the entire window hierarchy under w for
 322 # a menubutton that isn't disabled and whose underlined character
 323 # is "char".  It returns the name of that window, if found, or an
 324 # empty string if no matching window was found.  If "char" is an
 325 # empty string then the procedure returns the name of the first
 326 # menubutton found that isn't disabled.
 327 #
 328 # Arguments:
 329 # w -                           Name of window where key was typed.
 330 # char -                        Underlined character to search for;
 331 #                               may be either upper or lower case, and
 332 #                               will match either upper or lower case.
 333
 334 proc ckMenuFind {w char} {
 335     global ckPriv
 336     set char [string tolower $char]
 337
 338     foreach child [winfo child $w] {
 339         switch [winfo class $child] {
 340             Menubutton {
 341                 set char2 [string index [$child cget -text] \
 342                         [$child cget -underline]]
 343                 if {([string compare $char [string tolower $char2]] == 0)
 344                         || ($char == "")} {
 345                     if {[$child cget -state] != "disabled"} {
 346                         return $child
 347                     }
 348                 }
 349             }
 350             Frame {
 351                 set match [ckMenuFind $child $char]
 352                 if {$match != ""} {
 353                     return $match
 354                 }
 355             }
 356         }
 357     }
 358     return {}
 359 }
 360
 361 # ckFirstMenu --
 362 # This procedure traverses to the first menubutton in the toplevel
 363 # for a given window, and posts that menubutton's menu.
 364 #
 365 # Arguments:
 366 # w -                           Name of a window.  Selects which toplevel
 367 #                               to search for menubuttons.
 368
 369 proc ckFirstMenu w {
 370     set w [ckMenuFind [winfo toplevel $w] ""]
 371     if {$w != ""} {
 372         if {[ckMbPost $w]} {
 373             ckMenuFirstEntry [$w cget -menu]
 374         }
 375     }
 376 }
 377
 378 # ckTraverseWithinMenu
 379 # This procedure implements keyboard traversal within a menu.  It
 380 # searches for an entry in the menu that has "char" underlined.  If
 381 # such an entry is found, it is invoked and the menu is unposted.
 382 #
 383 # Arguments:
 384 # w -                           The name of the menu widget.
 385 # char -                        The character to look for;  case is
 386 #                               ignored.  If the string is empty then
 387 #                               nothing happens.
 388
 389 proc ckTraverseWithinMenu {w char} {
 390     if {$char == ""} {
 391         return
 392     }
 393     set char [string tolower $char]
 394     set last [$w index last]
 395     if {$last == "none"} {
 396         return
 397     }
 398     for {set i 0} {$i <= $last} {incr i} {
 399         if [catch {set char2 [string index \
 400                 [$w entrycget $i -label] \
 401                 [$w entrycget $i -underline]]}] {
 402             continue
 403         }
 404         if {[string compare $char [string tolower $char2]] == 0} {
 405             if {[$w type $i] == "cascade"} {
 406                 $w postcascade $i
 407                 $w activate $i
 408                 set m2 [$w entrycget $i -menu]
 409                 if {$m2 != ""} {
 410                     tkMenuFirstEntry $m2
 411                 }
 412             } else {
 413                 ckMenuUnpost $w
 414                 uplevel #0 [list $w invoke $i]
 415             }
 416             return
 417         }
 418     }
 419 }
 420
 421 # ckMenuFirstEntry --
 422 # Given a menu, this procedure finds the first entry that isn't
 423 # disabled or a tear-off or separator, and activates that entry.
 424 # However, if there is already an active entry in the menu (e.g.,
 425 # because of a previous call to tkPostOverPoint) then the active
 426 # entry isn't changed.  This procedure also sets the input focus
 427 # to the menu.
 428 #
 429 # Arguments:
 430 # menu -                Name of the menu window (possibly empty).
 431
 432 proc ckMenuFirstEntry menu {
 433     if {$menu == ""} {
 434         return
 435     }
 436     focus $menu
 437     if {[$menu index active] != "none"} {
 438         return
 439     }
 440     set last [$menu index last]
 441     if {$last == "none"} {
 442         return
 443     }
 444     for {set i 0} {$i <= $last} {incr i} {
 445         if {([catch {set state [$menu entrycget $i -state]}] == 0)
 446                 && ($state != "disabled")} {
 447             $menu activate $i
 448             return
 449         }
 450     }
 451 }
 452
 453 # ckMenuFindName --
 454 # Given a menu and a text string, return the index of the menu entry
 455 # that displays the string as its label.  If there is no such entry,
 456 # return an empty string.  This procedure is tricky because some names
 457 # like "active" have a special meaning in menu commands, so we can't
 458 # always use the "index" widget command.
 459 #
 460 # Arguments:
 461 # menu -                Name of the menu widget.
 462 # s -                   String to look for.
 463
 464 proc ckMenuFindName {menu s} {
 465     set i ""
 466     if {![regexp {^active$|^last$|^none$|^[0-9]|^@} $s]} {
 467         catch {set i [$menu index $s]}
 468         return $i
 469     }
 470     set last [$menu index last]
 471     if {$last == "none"} {
 472         return
 473     }
 474     for {set i 0} {$i <= $last} {incr i} {
 475         if ![catch {$menu entrycget $i -label} label] {
 476             if {$label == $s} {
 477                 return $i
 478             }
 479         }
 480     }
 481     return ""
 482 }
 483
 484 # ckPostOverPoint --
 485 # This procedure posts a given menu such that a given entry in the
 486 # menu is centered over a given point in the root window.  It also
 487 # activates the given entry.
 488 #
 489 # Arguments:
 490 # menu -                Menu to post.
 491 # x, y -                Root coordinates of point.
 492 # entry -               Index of entry within menu to center over (x,y).
 493 #                       If omitted or specified as {}, then the menu's
 494 #                       upper-left corner goes at (x,y).
 495
 496 proc ckPostOverPoint {menu x y {entry {}}}  {
 497     if {$entry != {}} {
 498         if {$entry == [$menu index last]} {
 499             incr y [expr -([$menu yposition $entry] \
 500                     + [winfo reqheight $menu])/2]
 501         } else {
 502             incr y [expr -([$menu yposition $entry] \
 503                     + [$menu yposition [expr $entry+1]])/2]
 504         }
 505         incr x [expr -[winfo reqwidth $menu]/2]
 506     }
 507     $menu post $x $y
 508     if {($entry != {}) && ([$menu entrycget $entry -state] != "disabled")} {
 509         $menu activate $entry
 510     }
 511 }
 512
 513 # ck_popup --
 514 # This procedure pops up a menu and sets things up for traversing
 515 # the menu and its submenus.
 516 #
 517 # Arguments:
 518 # menu -                Name of the menu to be popped up.
 519 # x, y -                Root coordinates at which to pop up the
 520 #                       menu.
 521 # entry -               Index of a menu entry to center over (x,y).
 522 #                       If omitted or specified as {}, then menu's
 523 #                       upper-left corner goes at (x,y).
 524
 525 proc ck_popup {menu x y {entry {}}} {
 526     global ckPriv
 527     if {($ckPriv(popup) != "") || ($ckPriv(postedMb) != "")} {
 528         ckMenuUnpost {}
 529     }
 530     ckPostOverPoint $menu $x $y $entry
 531     set ckPriv(focus) [focus]
 532     set ckPriv(popup) $menu
 533     focus $menu
 534 }