| 1 | # Converted from 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 | # @(#) menu.tcl 1.34 94/12/19 17:09:09 |
| 8 | # |
| 9 | # Copyright (c) 1992-1994 The Regents of the University of California. |
| 10 | # Copyright (c) 1994 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 | package Tk::Menu; |
| 16 | require Tk; |
| 17 | require Tk::Widget; |
| 18 | require Tk::Wm; |
| 19 | require Tk::Derived; |
| 20 | require Tk::Menu::Item; |
| 21 | |
| 22 | |
| 23 | use vars qw($VERSION); |
| 24 | $VERSION = '3.045'; # $Id: //depot/Tk8/Tk/Menu.pm#45 $ |
| 25 | |
| 26 | use strict; |
| 27 | |
| 28 | use base qw(Tk::Wm Tk::Derived Tk::Widget); |
| 29 | |
| 30 | Construct Tk::Widget 'Menu'; |
| 31 | |
| 32 | sub Tk_cmd { \&Tk::_menu } |
| 33 | |
| 34 | Tk::Methods('activate','add','clone','delete','entrycget','entryconfigure', |
| 35 | 'index','insert','invoke','post','postcascade','type', |
| 36 | 'unpost','yposition'); |
| 37 | |
| 38 | import Tk qw(Ev); |
| 39 | |
| 40 | sub CreateArgs |
| 41 | { |
| 42 | my ($package,$parent,$args) = @_; |
| 43 | # Remove from hash %$args any configure-like |
| 44 | # options which only apply at create time (e.g. -class for Frame) |
| 45 | # return these as a list of -key => value pairs |
| 46 | my @result = (); |
| 47 | my $opt; |
| 48 | foreach $opt (qw(-type -screen -visual -colormap)) |
| 49 | { |
| 50 | my $val = delete $args->{$opt}; |
| 51 | push(@result, $opt => $val) if (defined $val); |
| 52 | } |
| 53 | return @result; |
| 54 | } |
| 55 | |
| 56 | sub InitObject |
| 57 | { |
| 58 | my ($menu,$args) = @_; |
| 59 | my $menuitems = delete $args->{-menuitems}; |
| 60 | $menu->SUPER::InitObject($args); |
| 61 | if (defined $menuitems) |
| 62 | { |
| 63 | # If any other args do configure now |
| 64 | if (%$args) |
| 65 | { |
| 66 | $menu->configure(%$args); |
| 67 | %$args = (); |
| 68 | } |
| 69 | $menu->AddItems(@$menuitems) |
| 70 | } |
| 71 | } |
| 72 | |
| 73 | sub AddItems |
| 74 | { |
| 75 | my $menu = shift; |
| 76 | ITEM: |
| 77 | while (@_) |
| 78 | { |
| 79 | my $item = shift; |
| 80 | if (!ref($item)) |
| 81 | { |
| 82 | $menu->separator; # A separator |
| 83 | } |
| 84 | else |
| 85 | { |
| 86 | my ($kind,$name,%minfo) = ( @$item ); |
| 87 | my $invoke = delete $minfo{'-invoke'}; |
| 88 | if (defined $name) |
| 89 | { |
| 90 | $minfo{-label} = $name unless defined($minfo{-label}); |
| 91 | $menu->$kind(%minfo); |
| 92 | } |
| 93 | else |
| 94 | { |
| 95 | $menu->BackTrace("Don't recognize " . join(' ',@$item)); |
| 96 | } |
| 97 | } # A non-separator |
| 98 | } |
| 99 | } |
| 100 | |
| 101 | # |
| 102 | #------------------------------------------------------------------------- |
| 103 | # Elements of tkPriv that are used in this file: |
| 104 | # |
| 105 | # cursor - Saves the -cursor option for the posted menubutton. |
| 106 | # focus - Saves the focus during a menu selection operation. |
| 107 | # Focus gets restored here when the menu is unposted. |
| 108 | # inMenubutton - The name of the menubutton widget containing |
| 109 | # the mouse, or an empty string if the mouse is |
| 110 | # not over any menubutton. |
| 111 | # popup - If a menu has been popped up via tk_popup, this |
| 112 | # gives the name of the menu. Otherwise this |
| 113 | # value is empty. |
| 114 | # postedMb - Name of the menubutton whose menu is currently |
| 115 | # posted, or an empty string if nothing is posted |
| 116 | # A grab is set on this widget. |
| 117 | # relief - Used to save the original relief of the current |
| 118 | # menubutton. |
| 119 | # window - When the mouse is over a menu, this holds the |
| 120 | # name of the menu; it's cleared when the mouse |
| 121 | # leaves the menu. |
| 122 | #------------------------------------------------------------------------- |
| 123 | #------------------------------------------------------------------------- |
| 124 | # Overall note: |
| 125 | # This file is tricky because there are four different ways that menus |
| 126 | # can be used: |
| 127 | # |
| 128 | # 1. As a pulldown from a menubutton. This is the most common usage. |
| 129 | # In this style, the variable tkPriv(postedMb) identifies the posted |
| 130 | # menubutton. |
| 131 | # 2. As a torn-off menu copied from some other menu. In this style |
| 132 | # tkPriv(postedMb) is empty, and the top-level menu is no |
| 133 | # override-redirect. |
| 134 | # 3. As an option menu, triggered from an option menubutton. In thi |
| 135 | # style tkPriv(postedMb) identifies the posted menubutton. |
| 136 | # 4. As a popup menu. In this style tkPriv(postedMb) is empty and |
| 137 | # the top-level menu is override-redirect. |
| 138 | # |
| 139 | # The various binding procedures use the state described above to |
| 140 | # distinguish the various cases and take different actions in each |
| 141 | # case. |
| 142 | #------------------------------------------------------------------------- |
| 143 | # Bind -- |
| 144 | # This procedure is invoked the first time the mouse enters a menubutton |
| 145 | # widget or a menubutton widget receives the input focus. It creates |
| 146 | # all of the class bindings for both menubuttons and menus. |
| 147 | # |
| 148 | # Arguments: |
| 149 | # w - The widget that was just entered or just received |
| 150 | # the input focus. |
| 151 | # event - Indicates which event caused the procedure to be invoked |
| 152 | # (Enter or FocusIn). It is used so that we can carry out |
| 153 | # the functions of that event in addition to setting up |
| 154 | # bindings. |
| 155 | sub ClassInit |
| 156 | { |
| 157 | my ($class,$mw) = @_; |
| 158 | # Must set focus when mouse enters a menu, in order to allow |
| 159 | # mixed-mode processing using both the mouse and the keyboard. |
| 160 | $mw->bind($class,'<FocusIn>', 'NoOp'); |
| 161 | $mw->bind($class,'<Enter>', 'Enter'); |
| 162 | $mw->bind($class,'<Leave>', ['Leave',Ev('X'),Ev('Y'),Ev('s')]); |
| 163 | $mw->bind($class,'<Motion>', ['Motion',Ev('x'),Ev('y'),Ev('s')]); |
| 164 | $mw->bind($class,'<ButtonPress>','ButtonDown'); |
| 165 | $mw->bind($class,'<ButtonRelease>',['Invoke',1]); |
| 166 | $mw->bind($class,'<space>',['Invoke',0]); |
| 167 | $mw->bind($class,'<Return>',['Invoke',0]); |
| 168 | $mw->bind($class,'<Escape>','Escape'); |
| 169 | $mw->bind($class,'<Left>','LeftArrow'); |
| 170 | $mw->bind($class,'<Right>','RightArrow'); |
| 171 | $mw->bind($class,'<Up>','UpArrow'); |
| 172 | $mw->bind($class,'<Down>','DownArrow'); |
| 173 | $mw->bind($class,'<KeyPress>', ['TraverseWithinMenu',Ev('K')]); |
| 174 | $mw->bind($class,'<Alt-KeyPress>', ['TraverseWithinMenu',Ev('K')]); |
| 175 | return $class; |
| 176 | } |
| 177 | |
| 178 | sub UpArrow |
| 179 | { |
| 180 | my $menu = shift; |
| 181 | if ($menu->cget('-type') eq 'menubar') |
| 182 | { |
| 183 | $menu->NextMenu('left'); |
| 184 | } |
| 185 | else |
| 186 | { |
| 187 | $menu->NextEntry(-1); |
| 188 | } |
| 189 | } |
| 190 | |
| 191 | sub DownArrow |
| 192 | { |
| 193 | my $menu = shift; |
| 194 | if ($menu->cget('-type') eq 'menubar') |
| 195 | { |
| 196 | $menu->NextMenu('right'); |
| 197 | } |
| 198 | else |
| 199 | { |
| 200 | $menu->NextEntry(1); |
| 201 | } |
| 202 | } |
| 203 | |
| 204 | sub LeftArrow |
| 205 | { |
| 206 | my $menu = shift; |
| 207 | if ($menu->cget('-type') eq 'menubar') |
| 208 | { |
| 209 | $menu->NextEntry(-1); |
| 210 | } |
| 211 | else |
| 212 | { |
| 213 | $menu->NextMenu('left'); |
| 214 | } |
| 215 | } |
| 216 | |
| 217 | sub RightArrow |
| 218 | { |
| 219 | my $menu = shift; |
| 220 | if ($menu->cget('-type') eq 'menubar') |
| 221 | { |
| 222 | $menu->NextEntry(1); |
| 223 | } |
| 224 | else |
| 225 | { |
| 226 | $menu->NextMenu('right'); |
| 227 | } |
| 228 | } |
| 229 | |
| 230 | |
| 231 | |
| 232 | # Unpost -- |
| 233 | # This procedure unposts a given menu, plus all of its ancestors up |
| 234 | # to (and including) a menubutton, if any. It also restores various |
| 235 | # values to what they were before the menu was posted, and releases |
| 236 | # a grab if there's a menubutton involved. Special notes: |
| 237 | # 1. It's important to unpost all menus before releasing the grab, so |
| 238 | # that any Enter-Leave events (e.g. from menu back to main |
| 239 | # application) have mode NotifyGrab. |
| 240 | # 2. Be sure to enclose various groups of commands in "catch" so that |
| 241 | # the procedure will complete even if the menubutton or the menu |
| 242 | # or the grab window has been deleted. |
| 243 | # |
| 244 | # Arguments: |
| 245 | # menu - Name of a menu to unpost. Ignored if there |
| 246 | # is a posted menubutton. |
| 247 | sub Unpost |
| 248 | { |
| 249 | my $menu = shift; |
| 250 | my $mb = $Tk::postedMb; |
| 251 | |
| 252 | # Restore focus right away (otherwise X will take focus away when |
| 253 | # the menu is unmapped and under some window managers (e.g. olvwm) |
| 254 | # we'll lose the focus completely). |
| 255 | |
| 256 | eval {local $SIG{__DIE__}; $Tk::focus->focus() } if (defined $Tk::focus); |
| 257 | undef $Tk::focus; |
| 258 | |
| 259 | # Unpost menu(s) and restore some stuff that's dependent on |
| 260 | # what was posted. |
| 261 | eval {local $SIG{__DIE__}; |
| 262 | if (defined $mb) |
| 263 | { |
| 264 | $menu = $mb->cget('-menu'); |
| 265 | $menu->unpost(); |
| 266 | $Tk::postedMb = undef; |
| 267 | $mb->configure('-cursor',$Tk::cursor); |
| 268 | $mb->configure('-relief',$Tk::relief) |
| 269 | } |
| 270 | elsif (defined $Tk::popup) |
| 271 | { |
| 272 | $Tk::popup->unpost(); |
| 273 | my $grab = $Tk::popup->grabCurrent; |
| 274 | $grab->grabRelease if (defined $grab); |
| 275 | |
| 276 | undef $Tk::popup; |
| 277 | } |
| 278 | elsif (defined $menu && ref $menu && |
| 279 | $menu->cget('-type') ne 'menubar' && |
| 280 | $menu->cget('-type') ne 'tearoff' |
| 281 | ) |
| 282 | { |
| 283 | # We're in a cascaded sub-menu from a torn-off menu or popup. |
| 284 | # Unpost all the menus up to the toplevel one (but not |
| 285 | # including the top-level torn-off one) and deactivate the |
| 286 | # top-level torn off menu if there is one. |
| 287 | while (1) |
| 288 | { |
| 289 | my $parent = $menu->parent; |
| 290 | last if (!$parent->IsMenu || !$parent->ismapped); |
| 291 | $parent->postcascade('none'); |
| 292 | $parent->GenerateMenuSelect; |
| 293 | $parent->activate('none'); |
| 294 | my $type = $parent->cget('-type'); |
| 295 | last if ($type eq 'menubar' || $type eq 'tearoff'); |
| 296 | $menu = $parent |
| 297 | } |
| 298 | $menu->unpost() if ($menu->cget('-type') ne 'menubar'); |
| 299 | } |
| 300 | }; |
| 301 | warn "$@" if ($@); |
| 302 | if ($Tk::tearoff || $Tk::menubar) |
| 303 | { |
| 304 | # Release grab, if any. |
| 305 | if (defined $menu && ref $menu) |
| 306 | { |
| 307 | my $grab = $menu->grabCurrent; |
| 308 | $grab->grabRelease if (defined $grab); |
| 309 | } |
| 310 | RestoreOldGrab(); |
| 311 | if ($Tk::menubar) |
| 312 | { |
| 313 | $Tk::menubar->configure(-cursor => $Tk::cursor); |
| 314 | undef $Tk::menubar; |
| 315 | } |
| 316 | if ($Tk::platform ne 'unix') |
| 317 | { |
| 318 | undef $Tk::tearoff; |
| 319 | } |
| 320 | } |
| 321 | } |
| 322 | |
| 323 | sub RestoreOldGrab |
| 324 | { |
| 325 | if (defined $Tk::oldGrab) |
| 326 | { |
| 327 | eval |
| 328 | { |
| 329 | local $SIG{__DIE__}; |
| 330 | if ($Tk::grabStatus eq 'global') |
| 331 | { |
| 332 | $Tk::oldGrab->grabGlobal; |
| 333 | } |
| 334 | else |
| 335 | { |
| 336 | $Tk::oldGrab->grab; |
| 337 | } |
| 338 | }; |
| 339 | undef $Tk::oldGrab; |
| 340 | } |
| 341 | } |
| 342 | |
| 343 | sub typeIS |
| 344 | {my $w = shift; |
| 345 | my $type = $w->type(shift); |
| 346 | return defined $type && $type eq shift; |
| 347 | } |
| 348 | |
| 349 | # Motion -- |
| 350 | # This procedure is called to handle mouse motion events for menus. |
| 351 | # It does two things. First, it resets the active element in the |
| 352 | # menu, if the mouse is over the menu. Second, if a mouse button |
| 353 | # is down, it posts and unposts cascade entries to match the mouse |
| 354 | # position. |
| 355 | # |
| 356 | # Arguments: |
| 357 | # menu - The menu window. |
| 358 | # y - The y position of the mouse. |
| 359 | # state - Modifier state (tells whether buttons are down). |
| 360 | sub Motion |
| 361 | { |
| 362 | my $menu = shift; |
| 363 | my $x = shift; |
| 364 | my $y = shift; |
| 365 | my $state = shift; |
| 366 | my $t = $menu->cget('-type'); |
| 367 | |
| 368 | if ($menu->IS($Tk::window)) |
| 369 | { |
| 370 | if ($menu->cget('-type') eq 'menubar') |
| 371 | { |
| 372 | # if (defined($Tk::focus) && $Tk::focus != $menu) |
| 373 | { |
| 374 | $menu->activate("\@$x,$y"); |
| 375 | $menu->GenerateMenuSelect; |
| 376 | } |
| 377 | } |
| 378 | else |
| 379 | { |
| 380 | $menu->activate("\@$x,$y"); |
| 381 | $menu->GenerateMenuSelect; |
| 382 | } |
| 383 | } |
| 384 | if (($state & 0x1f00) != 0) |
| 385 | { |
| 386 | $menu->postcascade('active') |
| 387 | } |
| 388 | } |
| 389 | # ButtonDown -- |
| 390 | # Handles button presses in menus. There are a couple of tricky things |
| 391 | # here: |
| 392 | # 1. Change the posted cascade entry (if any) to match the mouse position. |
| 393 | # 2. If there is a posted menubutton, must grab to the menubutton so |
| 394 | # that it can track mouse motions over other menubuttons and change |
| 395 | # the posted menu. |
| 396 | # 3. If there's no posted menubutton (e.g. because we're a torn-off menu |
| 397 | # or one of its descendants) must grab to the top-level menu so that |
| 398 | # we can track mouse motions across the entire menu hierarchy. |
| 399 | |
| 400 | # |
| 401 | # Arguments: |
| 402 | # menu - The menu window. |
| 403 | sub ButtonDown |
| 404 | { |
| 405 | my $menu = shift; |
| 406 | $menu->postcascade('active'); |
| 407 | if (defined $Tk::postedMb) |
| 408 | { |
| 409 | $Tk::postedMb->grabGlobal |
| 410 | } |
| 411 | else |
| 412 | { |
| 413 | while ($menu->cget('-type') eq 'normal' |
| 414 | && $menu->parent->IsMenu |
| 415 | && $menu->parent->ismapped |
| 416 | ) |
| 417 | { |
| 418 | $menu = $menu->parent; |
| 419 | } |
| 420 | |
| 421 | if (!defined $Tk::menuBar) |
| 422 | { |
| 423 | $Tk::menuBar = $menu; |
| 424 | $Tk::cursor = $menu->cget('-cursor'); |
| 425 | $menu->configure(-cursor => 'arrow'); |
| 426 | } |
| 427 | |
| 428 | # Don't update grab information if the grab window isn't changing. |
| 429 | # Otherwise, we'll get an error when we unpost the menus and |
| 430 | # restore the grab, since the old grab window will not be viewable |
| 431 | # anymore. |
| 432 | |
| 433 | $menu->SaveGrabInfo unless ($menu->IS($menu->grabCurrent)); |
| 434 | |
| 435 | # Must re-grab even if the grab window hasn't changed, in order |
| 436 | # to release the implicit grab from the button press. |
| 437 | |
| 438 | $menu->grabGlobal if ($Tk::platform eq 'unix'); |
| 439 | } |
| 440 | } |
| 441 | |
| 442 | sub Enter |
| 443 | { |
| 444 | my $w = shift; |
| 445 | my $ev = $w->XEvent; |
| 446 | $Tk::window = $w; |
| 447 | if ($w->cget('-type') eq 'tearoff') |
| 448 | { |
| 449 | if ($ev->m ne 'NotifyUngrab') |
| 450 | { |
| 451 | $w->SetFocus if ($Tk::platform eq 'unix'); |
| 452 | } |
| 453 | } |
| 454 | $w->Motion($ev->x, $ev->y, $ev->s); |
| 455 | } |
| 456 | |
| 457 | # Leave -- |
| 458 | # This procedure is invoked to handle Leave events for a menu. It |
| 459 | # deactivates everything unless the active element is a cascade element |
| 460 | # and the mouse is now over the submenu. |
| 461 | # |
| 462 | # Arguments: |
| 463 | # menu - The menu window. |
| 464 | # rootx, rooty - Root coordinates of mouse. |
| 465 | # state - Modifier state. |
| 466 | sub Leave |
| 467 | { |
| 468 | my $menu = shift; |
| 469 | my $rootx = shift; |
| 470 | my $rooty = shift; |
| 471 | my $state = shift; |
| 472 | undef $Tk::window; |
| 473 | return if ($menu->index('active') eq 'none'); |
| 474 | if ($menu->typeIS('active','cascade')) |
| 475 | { |
| 476 | my $c = $menu->Containing($rootx,$rooty); |
| 477 | return if (defined $c && $menu->entrycget('active','-menu')->IS($c)); |
| 478 | } |
| 479 | $menu->activate('none'); |
| 480 | $menu->GenerateMenuSelect; |
| 481 | } |
| 482 | |
| 483 | # Invoke -- |
| 484 | # This procedure is invoked when button 1 is released over a menu. |
| 485 | # It invokes the appropriate menu action and unposts the menu if |
| 486 | # it came from a menubutton. |
| 487 | # |
| 488 | # Arguments: |
| 489 | # w - Name of the menu widget. |
| 490 | sub Invoke |
| 491 | { |
| 492 | my $w = shift; |
| 493 | my $release = shift; |
| 494 | |
| 495 | if ($release && !defined($Tk::window)) |
| 496 | { |
| 497 | # Mouse was pressed over a menu without a menu button, then |
| 498 | # dragged off the menu (possibly with a cascade posted) and |
| 499 | # released. Unpost everything and quit. |
| 500 | |
| 501 | $w->postcascade('none'); |
| 502 | $w->activate('none'); |
| 503 | $w->eventGenerate('<<MenuSelect>>'); |
| 504 | $w->Unpost; |
| 505 | return; |
| 506 | } |
| 507 | |
| 508 | my $type = $w->type('active'); |
| 509 | if ($w->typeIS('active','cascade')) |
| 510 | { |
| 511 | $w->postcascade('active'); |
| 512 | my $menu = $w->entrycget('active','-menu'); |
| 513 | $menu->FirstEntry() if (defined $menu); |
| 514 | } |
| 515 | elsif ($w->typeIS('active','tearoff')) |
| 516 | { |
| 517 | $w->Unpost(); |
| 518 | $w->tearOffMenu(); |
| 519 | } |
| 520 | elsif ($w->typeIS('active','menubar')) |
| 521 | { |
| 522 | $w->postcascade('none'); |
| 523 | $w->activate('none'); |
| 524 | $w->eventGenerate('<<MenuSelect>>'); |
| 525 | $w->Unpost; |
| 526 | } |
| 527 | else |
| 528 | { |
| 529 | $w->Unpost(); |
| 530 | $w->invoke('active') |
| 531 | } |
| 532 | } |
| 533 | # Escape -- |
| 534 | # This procedure is invoked for the Cancel (or Escape) key. It unposts |
| 535 | # the given menu and, if it is the top-level menu for a menu button, |
| 536 | # unposts the menu button as well. |
| 537 | # |
| 538 | # Arguments: |
| 539 | # menu - Name of the menu window. |
| 540 | sub Escape |
| 541 | { |
| 542 | my $menu = shift; |
| 543 | my $parent = $menu->parent; |
| 544 | if (!$parent->IsMenu) |
| 545 | { |
| 546 | $menu->Unpost() |
| 547 | } |
| 548 | elsif ($parent->cget('-type') eq 'menubar') |
| 549 | { |
| 550 | $menu->Unpost; |
| 551 | RestoreOldGrab(); |
| 552 | } |
| 553 | else |
| 554 | { |
| 555 | $menu->NextMenu(-1) |
| 556 | } |
| 557 | } |
| 558 | # LeftRight -- |
| 559 | # This procedure is invoked to handle "left" and "right" traversal |
| 560 | # motions in menus. It traverses to the next menu in a menu bar, |
| 561 | # or into or out of a cascaded menu. |
| 562 | # |
| 563 | # Arguments: |
| 564 | # menu - The menu that received the keyboard |
| 565 | # event. |
| 566 | # direction - Direction in which to move: "left" or "right" |
| 567 | sub NextMenu |
| 568 | { |
| 569 | my $menu = shift; |
| 570 | my $direction = shift; |
| 571 | # First handle traversals into and out of cascaded menus. |
| 572 | my $count; |
| 573 | if ($direction eq 'right') |
| 574 | { |
| 575 | $count = 1; |
| 576 | if ($menu->typeIS('active','cascade')) |
| 577 | { |
| 578 | $menu->postcascade('active'); |
| 579 | my $m2 = $menu->entrycget('active','-menu'); |
| 580 | $m2->FirstEntry if (defined $m2); |
| 581 | return; |
| 582 | } |
| 583 | else |
| 584 | { |
| 585 | my $parent = $menu->parent; |
| 586 | while ($parent->PathName ne '.') |
| 587 | { |
| 588 | if ($parent->IsMenu && $parent->cget('-type') eq 'menubar') |
| 589 | { |
| 590 | $parent->SetFocus; |
| 591 | $parent->NextEntry(1); |
| 592 | return; |
| 593 | } |
| 594 | $parent = $parent->parent; |
| 595 | } |
| 596 | } |
| 597 | } |
| 598 | else |
| 599 | { |
| 600 | $count = -1; |
| 601 | my $m2 = $menu->parent; |
| 602 | if ($m2->IsMenu) |
| 603 | { |
| 604 | if ($m2->cget('-type') ne 'menubar') |
| 605 | { |
| 606 | $menu->activate('none'); |
| 607 | $menu->GenerateMenuSelect; |
| 608 | $m2->SetFocus; |
| 609 | # This code unposts any posted submenu in the parent. |
| 610 | my $tmp = $m2->index('active'); |
| 611 | $m2->activate('none'); |
| 612 | $m2->activate($tmp); |
| 613 | return; |
| 614 | } |
| 615 | } |
| 616 | } |
| 617 | # Can't traverse into or out of a cascaded menu. Go to the next |
| 618 | # or previous menubutton, if that makes sense. |
| 619 | |
| 620 | my $m2 = $menu->parent; |
| 621 | if ($m2->IsMenu) |
| 622 | { |
| 623 | if ($m2->cget('-type') eq 'menubar') |
| 624 | { |
| 625 | $m2->SetFocus; |
| 626 | $m2->NextEntry(-1); |
| 627 | return; |
| 628 | } |
| 629 | } |
| 630 | |
| 631 | my $w = $Tk::postedMb; |
| 632 | return unless defined $w; |
| 633 | my @buttons = $w->parent->children; |
| 634 | my $length = @buttons; |
| 635 | my $i = Tk::lsearch(\@buttons,$w)+$count; |
| 636 | my $mb; |
| 637 | while (1) |
| 638 | { |
| 639 | while ($i < 0) |
| 640 | { |
| 641 | $i += $length |
| 642 | } |
| 643 | while ($i >= $length) |
| 644 | { |
| 645 | $i += -$length |
| 646 | } |
| 647 | $mb = $buttons[$i]; |
| 648 | last if ($mb->IsMenubutton && $mb->cget('-state') ne 'disabled' |
| 649 | && defined($mb->cget('-menu')) |
| 650 | && $mb->cget('-menu')->index('last') ne 'none' |
| 651 | ); |
| 652 | return if ($mb == $w); |
| 653 | $i += $count |
| 654 | } |
| 655 | $mb->PostFirst(); |
| 656 | } |
| 657 | # NextEntry -- |
| 658 | # Activate the next higher or lower entry in the posted menu, |
| 659 | # wrapping around at the ends. Disabled entries are skipped. |
| 660 | # |
| 661 | # Arguments: |
| 662 | # menu - Menu window that received the keystroke. |
| 663 | # count - 1 means go to the next lower entry, |
| 664 | # -1 means go to the next higher entry. |
| 665 | sub NextEntry |
| 666 | { |
| 667 | my $menu = shift; |
| 668 | my $count = shift; |
| 669 | if ($menu->index('last') eq 'none') |
| 670 | { |
| 671 | return; |
| 672 | } |
| 673 | my $length = $menu->index('last')+1; |
| 674 | my $quitAfter = $length; |
| 675 | my $active = $menu->index('active'); |
| 676 | my $i = ($active eq 'none') ? 0 : $active+$count; |
| 677 | while (1) |
| 678 | { |
| 679 | return if ($quitAfter <= 0); |
| 680 | while ($i < 0) |
| 681 | { |
| 682 | $i += $length |
| 683 | } |
| 684 | while ($i >= $length) |
| 685 | { |
| 686 | $i += -$length |
| 687 | } |
| 688 | my $state = eval {local $SIG{__DIE__}; $menu->entrycget($i,'-state') }; |
| 689 | last if (defined($state) && $state ne 'disabled'); |
| 690 | return if ($i == $active); |
| 691 | $i += $count; |
| 692 | $quitAfter -= 1; |
| 693 | } |
| 694 | $menu->activate($i); |
| 695 | $menu->GenerateMenuSelect; |
| 696 | if ($menu->type($i) eq 'cascade') |
| 697 | { |
| 698 | my $cascade = $menu->entrycget($i, '-menu'); |
| 699 | $menu->postcascade($i); |
| 700 | $cascade->FirstEntry if (defined $cascade); |
| 701 | } |
| 702 | } |
| 703 | |
| 704 | |
| 705 | # tkTraverseWithinMenu |
| 706 | # This procedure implements keyboard traversal within a menu. It |
| 707 | # searches for an entry in the menu that has "char" underlined. If |
| 708 | # such an entry is found, it is invoked and the menu is unposted. |
| 709 | # |
| 710 | # Arguments: |
| 711 | # w - The name of the menu widget. |
| 712 | # char - The character to look for; case is |
| 713 | # ignored. If the string is empty then |
| 714 | # nothing happens. |
| 715 | sub TraverseWithinMenu |
| 716 | { |
| 717 | my $w = shift; |
| 718 | my $char = shift; |
| 719 | return unless (defined $char); |
| 720 | $char = "\L$char"; |
| 721 | my $last = $w->index('last'); |
| 722 | return if ($last eq 'none'); |
| 723 | for (my $i = 0;$i <= $last;$i += 1) |
| 724 | { |
| 725 | my $label = eval {local $SIG{__DIE__}; $w->entrycget($i,'-label') }; |
| 726 | next unless defined($label); |
| 727 | my $ul = $w->entrycget($i,'-underline'); |
| 728 | if (defined $ul && $ul >= 0) |
| 729 | { |
| 730 | $label = substr("\L$label",$ul,1); |
| 731 | if (defined($label) && $label eq $char) |
| 732 | { |
| 733 | if ($w->type($i) eq 'cascade') |
| 734 | { |
| 735 | $w->postcascade($i); |
| 736 | $w->activate($i); |
| 737 | my $m2 = $w->entrycget($i,'-menu'); |
| 738 | $m2->FirstEntry if (defined $m2); |
| 739 | } |
| 740 | else |
| 741 | { |
| 742 | $w->Unpost(); |
| 743 | $w->invoke($i); |
| 744 | } |
| 745 | return; |
| 746 | } |
| 747 | } |
| 748 | } |
| 749 | } |
| 750 | |
| 751 | sub FindMenu |
| 752 | { |
| 753 | my ($menu,$char) = @_; |
| 754 | if ($menu->cget('-type') eq 'menubar') |
| 755 | { |
| 756 | if (!defined($char) || $char eq '') |
| 757 | { |
| 758 | $menu->FirstEntry; |
| 759 | } |
| 760 | else |
| 761 | { |
| 762 | $menu->TraverseWithinMenu($char); |
| 763 | } |
| 764 | return $menu; |
| 765 | } |
| 766 | return undef; |
| 767 | } |
| 768 | |
| 769 | |
| 770 | # FirstEntry -- |
| 771 | # Given a menu, this procedure finds the first entry that isn't |
| 772 | # disabled or a tear-off or separator, and activates that entry. |
| 773 | # However, if there is already an active entry in the menu (e.g., |
| 774 | # because of a previous call to tkPostOverPoint) then the active |
| 775 | # entry isn't changed. This procedure also sets the input focus |
| 776 | # to the menu. |
| 777 | # |
| 778 | # Arguments: |
| 779 | # menu - Name of the menu window (possibly empty). |
| 780 | sub FirstEntry |
| 781 | { |
| 782 | my $menu = shift; |
| 783 | return if (!defined($menu) || $menu eq '' || !ref($menu)); |
| 784 | $menu->SetFocus; |
| 785 | return if ($menu->index('active') ne 'none'); |
| 786 | my $last = $menu->index('last'); |
| 787 | return if ($last eq 'none'); |
| 788 | for (my $i = 0;$i <= $last;$i += 1) |
| 789 | { |
| 790 | my $state = eval {local $SIG{__DIE__}; $menu->entrycget($i,'-state') }; |
| 791 | if (defined $state && $state ne 'disabled' && !$menu->typeIS($i,'tearoff')) |
| 792 | { |
| 793 | $menu->activate($i); |
| 794 | $menu->GenerateMenuSelect; |
| 795 | if ($menu->type($i) eq 'cascade') |
| 796 | { |
| 797 | my $cascade = $menu->entrycget($i,'-menu'); |
| 798 | if (defined $cascade) |
| 799 | { |
| 800 | $menu->postcascade($i); |
| 801 | $cascade->FirstEntry; |
| 802 | } |
| 803 | } |
| 804 | return; |
| 805 | } |
| 806 | } |
| 807 | } |
| 808 | |
| 809 | # FindName -- |
| 810 | # Given a menu and a text string, return the index of the menu entry |
| 811 | # that displays the string as its label. If there is no such entry, |
| 812 | # return an empty string. This procedure is tricky because some names |
| 813 | # like "active" have a special meaning in menu commands, so we can't |
| 814 | # always use the "index" widget command. |
| 815 | # |
| 816 | # Arguments: |
| 817 | # menu - Name of the menu widget. |
| 818 | # s - String to look for. |
| 819 | sub FindName |
| 820 | { |
| 821 | my $menu = shift; |
| 822 | my $s = shift; |
| 823 | my $i = undef; |
| 824 | if ($s !~ /^active$|^last$|^none$|^[0-9]|^@/) |
| 825 | { |
| 826 | $i = eval {local $SIG{__DIE__}; $menu->index($s) }; |
| 827 | return $i; |
| 828 | } |
| 829 | my $last = $menu->index('last'); |
| 830 | return if ($last eq 'none'); |
| 831 | for ($i = 0;$i <= $last;$i += 1) |
| 832 | { |
| 833 | my $label = eval {local $SIG{__DIE__}; $menu->entrycget($i,'-label') }; |
| 834 | return $i if (defined $label && $label eq $s); |
| 835 | } |
| 836 | return undef; |
| 837 | } |
| 838 | # PostOverPoint -- |
| 839 | # This procedure posts a given menu such that a given entry in the |
| 840 | # menu is centered over a given point in the root window. It also |
| 841 | # activates the given entry. |
| 842 | # |
| 843 | # Arguments: |
| 844 | # menu - Menu to post. |
| 845 | # x, y - Root coordinates of point. |
| 846 | # entry - Index of entry within menu to center over (x,y). |
| 847 | # If omitted or specified as {}, then the menu's |
| 848 | # upper-left corner goes at (x,y). |
| 849 | sub PostOverPoint |
| 850 | { |
| 851 | my $menu = shift; |
| 852 | my $x = shift; |
| 853 | my $y = shift; |
| 854 | my $entry = shift; |
| 855 | if (defined $entry) |
| 856 | { |
| 857 | if ($entry == $menu->index('last')) |
| 858 | { |
| 859 | $y -= ($menu->yposition($entry)+$menu->height)/2; |
| 860 | } |
| 861 | else |
| 862 | { |
| 863 | $y -= ($menu->yposition($entry)+$menu->yposition($entry+1))/2; |
| 864 | } |
| 865 | $x -= $menu->reqwidth/2; |
| 866 | } |
| 867 | $menu->post($x,$y); |
| 868 | if (defined($entry) && $menu->entrycget($entry,'-state') ne 'disabled') |
| 869 | { |
| 870 | $menu->activate($entry); |
| 871 | $menu->GenerateMenuSelect; |
| 872 | } |
| 873 | } |
| 874 | # tk_popup -- |
| 875 | # This procedure pops up a menu and sets things up for traversing |
| 876 | # the menu and its submenus. |
| 877 | # |
| 878 | # Arguments: |
| 879 | # menu - Name of the menu to be popped up. |
| 880 | # x, y - Root coordinates at which to pop up the |
| 881 | # menu. |
| 882 | # entry - Index of a menu entry to center over (x,y). |
| 883 | # If omitted or specified as {}, then menu's |
| 884 | # upper-left corner goes at (x,y). |
| 885 | sub Post |
| 886 | { |
| 887 | my $menu = shift; |
| 888 | return unless (defined $menu); |
| 889 | my $x = shift; |
| 890 | my $y = shift; |
| 891 | my $entry = shift; |
| 892 | Unpost(undef) if (defined($Tk::popup) || defined($Tk::postedMb)); |
| 893 | $menu->PostOverPoint($x,$y,$entry); |
| 894 | $menu->grabGlobal; |
| 895 | $Tk::popup = $menu; |
| 896 | $Tk::focus = $menu->focusCurrent; |
| 897 | $menu->focus(); |
| 898 | } |
| 899 | |
| 900 | sub SetFocus |
| 901 | { |
| 902 | my $menu = shift; |
| 903 | $Tk::focus = $menu->focusCurrent if (!defined($Tk::focus)); |
| 904 | $menu->focus; |
| 905 | } |
| 906 | |
| 907 | sub GenerateMenuSelect |
| 908 | { |
| 909 | my $menu = shift; |
| 910 | $Tk::activeMenu = $menu; |
| 911 | $Tk::activeItem = $menu->index('active'); |
| 912 | $menu->eventGenerate('<<MenuSelect>>'); # FIXME |
| 913 | } |
| 914 | |
| 915 | # Converted from tearoff.tcl -- |
| 916 | # |
| 917 | # This file contains procedures that implement tear-off menus. |
| 918 | # |
| 919 | # @(#) tearoff.tcl 1.3 94/12/17 16:05:25 |
| 920 | # |
| 921 | # Copyright (c) 1994 The Regents of the University of California. |
| 922 | # Copyright (c) 1994 Sun Microsystems, Inc. |
| 923 | # |
| 924 | # See the file "license.terms" for information on usage and redistribution |
| 925 | # of this file, and for a DISCLAIMER OF ALL WARRANTIES. |
| 926 | # |
| 927 | # tkTearoffMenu -- |
| 928 | # Given the name of a menu, this procedure creates a torn-off menu |
| 929 | # that is identical to the given menu (including nested submenus). |
| 930 | # The new torn-off menu exists as a toplevel window managed by the |
| 931 | # window manager. The return value is the name of the new menu. |
| 932 | # |
| 933 | # Arguments: |
| 934 | # w - The menu to be torn-off (duplicated). |
| 935 | sub tearOffMenu |
| 936 | { |
| 937 | my $w = shift; |
| 938 | my $x = (@_) ? shift : 0; |
| 939 | my $y = (@_) ? shift : 0; |
| 940 | |
| 941 | $x = $w->rootx if $x == 0; |
| 942 | $y = $w->rooty if $y == 0; |
| 943 | |
| 944 | # Find a unique name to use for the torn-off menu. Find the first |
| 945 | # ancestor of w that is a toplevel but not a menu, and use this as |
| 946 | # the parent of the new menu. This guarantees that the torn off |
| 947 | # menu will be on the same screen as the original menu. By making |
| 948 | # it a child of the ancestor, rather than a child of the menu, it |
| 949 | # can continue to live even if the menu is deleted; it will go |
| 950 | # away when the toplevel goes away. |
| 951 | |
| 952 | my $parent = $w->parent; |
| 953 | while ($parent->toplevel != $parent || $parent->IsMenu) |
| 954 | { |
| 955 | $parent = $parent->parent; |
| 956 | } |
| 957 | my $menu = $w->clone($parent,'tearoff'); |
| 958 | |
| 959 | # Pick a title for the new menu by looking at the parent of the |
| 960 | # original: if the parent is a menu, then use the text of the active |
| 961 | # entry. If it's a menubutton then use its text. |
| 962 | my $title = $menu->cget('-title'); |
| 963 | unless (defined $title && length($title)) |
| 964 | { |
| 965 | $parent = $w->parent; |
| 966 | if ($parent->IsMenubutton) |
| 967 | { |
| 968 | $title = $parent->cget('-text'); |
| 969 | } |
| 970 | elsif ($parent->IsMenu) |
| 971 | { |
| 972 | $title = $parent->entrycget('active','-label'); |
| 973 | } |
| 974 | } |
| 975 | $menu->title($title) if (defined $title && length($title)); |
| 976 | $menu->post($x,$y); |
| 977 | # Set tkPriv(focus) on entry: otherwise the focus will get lost |
| 978 | # after keyboard invocation of a sub-menu (it will stay on the |
| 979 | # submenu). |
| 980 | $menu->bind('<Enter>','EnterFocus'); |
| 981 | $menu->Callback('-tearoffcommand'); |
| 982 | return $menu; |
| 983 | } |
| 984 | |
| 985 | # tkMenuDup -- |
| 986 | # Given a menu (hierarchy), create a duplicate menu (hierarchy) |
| 987 | # in a given window. |
| 988 | # |
| 989 | # Arguments: |
| 990 | # src - Source window. Must be a menu. It and its |
| 991 | # menu descendants will be duplicated at dst. |
| 992 | # dst - Name to use for topmost menu in duplicate |
| 993 | # hierarchy. |
| 994 | sub MenuDup |
| 995 | { |
| 996 | my $src = shift; |
| 997 | my $parent = shift; |
| 998 | my $type = (@_) ? shift : 'normal'; |
| 999 | my %args = (-type => $type) ; |
| 1000 | foreach my $option ($src->configure()) |
| 1001 | { |
| 1002 | next if (@$option == 2); |
| 1003 | $args{$$option[0]} = $$option[4] unless exists $args{$$option[0]}; |
| 1004 | } |
| 1005 | my $dst = ref($src)->new($parent,%args); |
| 1006 | if ($type eq 'tearoff') |
| 1007 | { |
| 1008 | $dst->transient($parent->MainWindow); |
| 1009 | } |
| 1010 | my $last = $src->index('last'); |
| 1011 | if ($last ne 'none') |
| 1012 | { |
| 1013 | for (my $i = $src->cget('-tearoff'); $i <= $last; $i++) |
| 1014 | { |
| 1015 | my $type = $src->type($i); |
| 1016 | if (defined $type) |
| 1017 | { |
| 1018 | my @args = (); |
| 1019 | foreach my $option ($src->entryconfigure($i)) |
| 1020 | { |
| 1021 | next if (@$option == 2); |
| 1022 | push(@args,$$option[0],$$option[4]) if (defined $$option[4]); |
| 1023 | } |
| 1024 | $dst->add($type,@args); |
| 1025 | } |
| 1026 | } |
| 1027 | } |
| 1028 | # Duplicate the binding tags and bindings from the source menu. |
| 1029 | my @bindtags = $src->bindtags; |
| 1030 | my $path = $src->PathName; |
| 1031 | foreach (@bindtags) |
| 1032 | { |
| 1033 | $_ = $dst if ($_ eq $path); |
| 1034 | } |
| 1035 | $dst->bindtags([@bindtags]); |
| 1036 | foreach my $event ($src->bind) |
| 1037 | { |
| 1038 | my $cb = $src->bind($event); |
| 1039 | $dst->bind($event,$cb->Substitute($src,$dst)); |
| 1040 | } |
| 1041 | return $dst; |
| 1042 | } |
| 1043 | |
| 1044 | |
| 1045 | |
| 1046 | # Some convenience methods |
| 1047 | |
| 1048 | sub separator { require Tk::Menu::Item; shift->Separator(@_); } |
| 1049 | sub cascade { require Tk::Menu::Item; shift->Cascade(@_); } |
| 1050 | sub checkbutton { require Tk::Menu::Item; shift->Checkbutton(@_); } |
| 1051 | sub radiobutton { require Tk::Menu::Item; shift->Radiobutton(@_); } |
| 1052 | |
| 1053 | sub command |
| 1054 | { |
| 1055 | my ($menu,%args) = @_; |
| 1056 | require Tk::Menu::Item; |
| 1057 | if (exists $args{-button}) |
| 1058 | { |
| 1059 | # Backward compatible stuff from 'Menubar' |
| 1060 | my $button = delete $args{-button}; |
| 1061 | $button = ['Misc', -underline => 0 ] unless (defined $button); |
| 1062 | my @bargs = (); |
| 1063 | ($button,@bargs) = @$button if (ref($button) && ref $button eq 'ARRAY'); |
| 1064 | $menu = $menu->Menubutton(-label => $button, @bargs); |
| 1065 | } |
| 1066 | $menu->Command(%args); |
| 1067 | } |
| 1068 | |
| 1069 | sub Menubutton |
| 1070 | { |
| 1071 | my ($menu,%args) = @_; |
| 1072 | my $name = delete($args{'-text'}) || $args{'-label'};; |
| 1073 | $args{'-label'} = $name if (defined $name); |
| 1074 | my $items = delete $args{'-menuitems'}; |
| 1075 | foreach my $opt (qw(-pack -after -before -side -padx -ipadx -pady -ipady -fill)) |
| 1076 | { |
| 1077 | delete $args{$opt}; |
| 1078 | } |
| 1079 | if (defined($name) && !defined($args{-underline})) |
| 1080 | { |
| 1081 | my $underline = ($name =~ s/^(.*)~/$1/) ? length($1): undef; |
| 1082 | if (defined($underline) && ($underline >= 0)) |
| 1083 | { |
| 1084 | $args{-underline} = $underline; |
| 1085 | $args{-label} = $name; |
| 1086 | } |
| 1087 | } |
| 1088 | my $hash = $menu->TkHash('MenuButtons'); |
| 1089 | my $mb = $hash->{$name}; |
| 1090 | if (defined $mb) |
| 1091 | { |
| 1092 | delete $args{'-tearoff'}; # too late! |
| 1093 | $mb->configure(%args) if %args; |
| 1094 | } |
| 1095 | else |
| 1096 | { |
| 1097 | $mb = $menu->cascade(%args); |
| 1098 | $hash->{$name} = $mb; |
| 1099 | } |
| 1100 | $mb->menu->AddItems(@$items) if defined($items) && @$items; |
| 1101 | return $mb; |
| 1102 | } |
| 1103 | |
| 1104 | sub BalloonInfo |
| 1105 | { |
| 1106 | my ($menu,$balloon,$X,$Y,@opt) = @_; |
| 1107 | my $i = $menu->index('active'); |
| 1108 | if ($i eq 'none') |
| 1109 | { |
| 1110 | my $y = $Y - $menu->rooty; |
| 1111 | $i = $menu->index("\@$y"); |
| 1112 | } |
| 1113 | foreach my $opt (@opt) |
| 1114 | { |
| 1115 | my $info = $balloon->GetOption($opt,$menu); |
| 1116 | if ($opt =~ /^-(statusmsg|balloonmsg)$/ && UNIVERSAL::isa($info,'ARRAY')) |
| 1117 | { |
| 1118 | $balloon->Subclient($i); |
| 1119 | return '' if $i eq 'none'; |
| 1120 | return ${$info}[$i] || ''; |
| 1121 | } |
| 1122 | return $info; |
| 1123 | } |
| 1124 | } |
| 1125 | |
| 1126 | 1; |
| 1127 | |
| 1128 | __END__ |
| 1129 | |
| 1130 | |