| 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 | |
| 16 | package Tk::Menubutton; |
| 17 | require Tk; |
| 18 | |
| 19 | use vars qw($VERSION); |
| 20 | $VERSION = '3.025'; # $Id: //depot/Tk8/Menubutton/Menubutton.pm#25 $ |
| 21 | |
| 22 | use base qw(Tk::Widget); |
| 23 | |
| 24 | Construct Tk::Widget 'Menubutton'; |
| 25 | |
| 26 | import Tk qw(&Ev $XS_VERSION); |
| 27 | |
| 28 | bootstrap Tk::Menubutton; |
| 29 | |
| 30 | sub Tk_cmd { \&Tk::menubutton } |
| 31 | |
| 32 | sub InitObject |
| 33 | { |
| 34 | my ($mb,$args) = @_; |
| 35 | my $menuitems = delete $args->{-menuitems}; |
| 36 | my $tearoff = delete $args->{-tearoff}; |
| 37 | $mb->SUPER::InitObject($args); |
| 38 | if ((defined($menuitems) || defined($tearoff)) && %$args) |
| 39 | { |
| 40 | $mb->configure(%$args); |
| 41 | %$args = (); |
| 42 | } |
| 43 | $mb->menu(-tearoff => $tearoff) if (defined $tearoff); |
| 44 | $mb->AddItems(@$menuitems) if (defined $menuitems) |
| 45 | } |
| 46 | |
| 47 | |
| 48 | # |
| 49 | #------------------------------------------------------------------------- |
| 50 | # Elements of tkPriv that are used in this file: |
| 51 | # |
| 52 | # cursor - Saves the -cursor option for the posted menubutton. |
| 53 | # focus - Saves the focus during a menu selection operation. |
| 54 | # Focus gets restored here when the menu is unposted. |
| 55 | # inMenubutton - The name of the menubutton widget containing |
| 56 | # the mouse, or an empty string if the mouse is |
| 57 | # not over any menubutton. |
| 58 | # popup - If a menu has been popped up via tk_popup, this |
| 59 | # gives the name of the menu. Otherwise this |
| 60 | # value is empty. |
| 61 | # postedMb - Name of the menubutton whose menu is currently |
| 62 | # posted, or an empty string if nothing is posted |
| 63 | # A grab is set on this widget. |
| 64 | # relief - Used to save the original relief of the current |
| 65 | # menubutton. |
| 66 | # window - When the mouse is over a menu, this holds the |
| 67 | # name of the menu; it's cleared when the mouse |
| 68 | # leaves the menu. |
| 69 | #------------------------------------------------------------------------- |
| 70 | #------------------------------------------------------------------------- |
| 71 | # Overall note: |
| 72 | # This file is tricky because there are four different ways that menus |
| 73 | # can be used: |
| 74 | # |
| 75 | # 1. As a pulldown from a menubutton. This is the most common usage. |
| 76 | # In this style, the variable tkPriv(postedMb) identifies the posted |
| 77 | # menubutton. |
| 78 | # 2. As a torn-off menu copied from some other menu. In this style |
| 79 | # tkPriv(postedMb) is empty, and the top-level menu is no |
| 80 | # override-redirect. |
| 81 | # 3. As an option menu, triggered from an option menubutton. In thi |
| 82 | # style tkPriv(postedMb) identifies the posted menubutton. |
| 83 | # 4. As a popup menu. In this style tkPriv(postedMb) is empty and |
| 84 | # the top-level menu is override-redirect. |
| 85 | # |
| 86 | # The various binding procedures use the state described above to |
| 87 | # distinguish the various cases and take different actions in each |
| 88 | # case. |
| 89 | #------------------------------------------------------------------------- |
| 90 | # Menu::Bind -- |
| 91 | # This procedure is invoked the first time the mouse enters a menubutton |
| 92 | # widget or a menubutton widget receives the input focus. It creates |
| 93 | # all of the class bindings for both menubuttons and menus. |
| 94 | # |
| 95 | # Arguments: |
| 96 | # w - The widget that was just entered or just received |
| 97 | # the input focus. |
| 98 | # event - Indicates which event caused the procedure to be invoked |
| 99 | # (Enter or FocusIn). It is used so that we can carry out |
| 100 | # the functions of that event in addition to setting up |
| 101 | # bindings. |
| 102 | sub ClassInit |
| 103 | { |
| 104 | my ($class,$mw) = @_; |
| 105 | $mw->bind($class,'<FocusIn>','NoOp'); |
| 106 | $mw->bind($class,'<Enter>','Enter'); |
| 107 | $mw->bind($class,'<Leave>','Leave'); |
| 108 | $mw->bind($class,'<1>','ButtonDown'); |
| 109 | $mw->bind($class,'<Motion>',['Motion','up',Ev('X'),Ev('Y')]); |
| 110 | $mw->bind($class,'<B1-Motion>',['Motion','down',Ev('X'),Ev('Y')]); |
| 111 | $mw->bind($class,'<ButtonRelease-1>','ButtonUp'); |
| 112 | $mw->bind($class,'<space>','PostFirst'); |
| 113 | $mw->bind($class,'<Return>','PostFirst'); |
| 114 | return $class; |
| 115 | } |
| 116 | |
| 117 | sub ButtonDown |
| 118 | {my $w = shift; |
| 119 | my $Ev = $w->XEvent; |
| 120 | $Tk::inMenubutton->Post($Ev->X,$Ev->Y) if (defined $Tk::inMenubutton); |
| 121 | } |
| 122 | |
| 123 | sub PostFirst |
| 124 | { |
| 125 | my $w = shift; |
| 126 | my $menu = $w->cget('-menu'); |
| 127 | $w->Post(); |
| 128 | $menu->FirstEntry() if (defined $menu); |
| 129 | } |
| 130 | |
| 131 | |
| 132 | # Enter -- |
| 133 | # This procedure is invoked when the mouse enters a menubutton |
| 134 | # widget. It activates the widget unless it is disabled. Note: |
| 135 | # this procedure is only invoked when mouse button 1 is *not* down. |
| 136 | # The procedure B1Enter is invoked if the button is down. |
| 137 | # |
| 138 | # Arguments: |
| 139 | # w - The name of the widget. |
| 140 | sub Enter |
| 141 | { |
| 142 | my $w = shift; |
| 143 | $Tk::inMenubutton->Leave if (defined $Tk::inMenubutton); |
| 144 | $Tk::inMenubutton = $w; |
| 145 | if ($w->cget('-state') ne 'disabled') |
| 146 | { |
| 147 | $w->configure('-state','active') |
| 148 | } |
| 149 | } |
| 150 | |
| 151 | sub Leave |
| 152 | { |
| 153 | my $w = shift; |
| 154 | $Tk::inMenubutton = undef; |
| 155 | return unless Tk::Exists($w); |
| 156 | if ($w->cget('-state') eq 'active') |
| 157 | { |
| 158 | $w->configure('-state','normal') |
| 159 | } |
| 160 | } |
| 161 | # Post -- |
| 162 | # Given a menubutton, this procedure does all the work of posting |
| 163 | # its associated menu and unposting any other menu that is currently |
| 164 | # posted. |
| 165 | # |
| 166 | # Arguments: |
| 167 | # w - The name of the menubutton widget whose menu |
| 168 | # is to be posted. |
| 169 | # x, y - Root coordinates of cursor, used for positioning |
| 170 | # option menus. If not specified, then the center |
| 171 | # of the menubutton is used for an option menu. |
| 172 | sub Post |
| 173 | { |
| 174 | my $w = shift; |
| 175 | my $x = shift; |
| 176 | my $y = shift; |
| 177 | return if ($w->cget('-state') eq 'disabled'); |
| 178 | return if (defined $Tk::postedMb && $w == $Tk::postedMb); |
| 179 | my $menu = $w->cget('-menu'); |
| 180 | return unless (defined($menu) && $menu->index('last') ne 'none'); |
| 181 | |
| 182 | my $tearoff = $Tk::platform eq 'unix' || $menu->cget('-type') eq 'tearoff'; |
| 183 | |
| 184 | my $wpath = $w->PathName; |
| 185 | my $mpath = $menu->PathName; |
| 186 | unless (index($mpath,"$wpath.") == 0) |
| 187 | { |
| 188 | die "Cannot post $mpath : not a descendant of $wpath"; |
| 189 | } |
| 190 | |
| 191 | my $cur = $Tk::postedMb; |
| 192 | if (defined $cur) |
| 193 | { |
| 194 | Tk::Menu->Unpost(undef); # fixme |
| 195 | } |
| 196 | $Tk::cursor = $w->cget('-cursor'); |
| 197 | $Tk::relief = $w->cget('-relief'); |
| 198 | $w->configure('-cursor','arrow'); |
| 199 | $w->configure('-relief','raised'); |
| 200 | $Tk::postedMb = $w; |
| 201 | $Tk::focus = $w->focusCurrent; |
| 202 | $menu->activate('none'); |
| 203 | $menu->GenerateMenuSelect; |
| 204 | # If this looks like an option menubutton then post the menu so |
| 205 | # that the current entry is on top of the mouse. Otherwise post |
| 206 | # the menu just below the menubutton, as for a pull-down. |
| 207 | |
| 208 | eval |
| 209 | {local $SIG{'__DIE__'}; |
| 210 | my $dir = $w->cget('-direction'); |
| 211 | if ($dir eq 'above') |
| 212 | { |
| 213 | $menu->post($w->rootx, $w->rooty - $menu->ReqHeight); |
| 214 | } |
| 215 | elsif ($dir eq 'below') |
| 216 | { |
| 217 | $menu->post($w->rootx, $w->rooty + $w->Height); |
| 218 | } |
| 219 | elsif ($dir eq 'left') |
| 220 | { |
| 221 | my $x = $w->rootx - $menu->ReqWidth; |
| 222 | my $y = int((2*$w->rooty + $w->Height) / 2); |
| 223 | if ($w->cget('-indicatoron') == 1 && defined($w->cget('-textvariable'))) |
| 224 | { |
| 225 | $menu->PostOverPoint($x,$y,$menu->FindName($w->cget('-text'))) |
| 226 | } |
| 227 | else |
| 228 | { |
| 229 | $menu->post($x,$y); |
| 230 | } |
| 231 | } |
| 232 | elsif ($dir eq 'right') |
| 233 | { |
| 234 | my $x = $w->rootx + $w->Width; |
| 235 | my $y = int((2*$w->rooty + $w->Height) / 2); |
| 236 | if ($w->cget('-indicatoron') == 1 && defined($w->cget('-textvariable'))) |
| 237 | { |
| 238 | $menu->PostOverPoint($x,$y,$menu->FindName($w->cget('-text'))) |
| 239 | } |
| 240 | else |
| 241 | { |
| 242 | $menu->post($x,$y); |
| 243 | } |
| 244 | } |
| 245 | else |
| 246 | { |
| 247 | if ($w->cget('-indicatoron') == 1 && defined($w->cget('-textvariable'))) |
| 248 | { |
| 249 | if (!defined($y)) |
| 250 | { |
| 251 | $x = $w->rootx+$w->width/2; |
| 252 | $y = $w->rooty+$w->height/2 |
| 253 | } |
| 254 | $menu->PostOverPoint($x,$y,$menu->FindName($w->cget('-text'))) |
| 255 | } |
| 256 | else |
| 257 | { |
| 258 | $menu->post($w->rootx,$w->rooty+$w->height); |
| 259 | } |
| 260 | } |
| 261 | }; |
| 262 | if ($@) |
| 263 | { |
| 264 | Tk::Menu->Unpost; |
| 265 | die $@ |
| 266 | } |
| 267 | |
| 268 | $Tk::tearoff = $tearoff; |
| 269 | if ($tearoff) |
| 270 | { |
| 271 | $menu->focus; |
| 272 | $w->SaveGrabInfo; |
| 273 | $w->grabGlobal; |
| 274 | } |
| 275 | } |
| 276 | # Motion -- |
| 277 | # This procedure handles mouse motion events inside menubuttons, and |
| 278 | # also outside menubuttons when a menubutton has a grab (e.g. when a |
| 279 | # menu selection operation is in progress). |
| 280 | # |
| 281 | # Arguments: |
| 282 | # w - The name of the menubutton widget. |
| 283 | # upDown - "down" means button 1 is pressed, "up" means |
| 284 | # it isn't. |
| 285 | # rootx, rooty - Coordinates of mouse, in (virtual?) root window. |
| 286 | sub Motion |
| 287 | { |
| 288 | my $w = shift; |
| 289 | my $upDown = shift; |
| 290 | my $rootx = shift; |
| 291 | my $rooty = shift; |
| 292 | return if (defined($Tk::inMenubutton) && $Tk::inMenubutton == $w); |
| 293 | my $new = $w->Containing($rootx,$rooty); |
| 294 | if (defined($Tk::inMenubutton)) |
| 295 | { |
| 296 | if (!defined($new) || ($new != $Tk::inMenubutton && $w->toplevel != $new->toplevel)) |
| 297 | { |
| 298 | $Tk::inMenubutton->Leave(); |
| 299 | } |
| 300 | } |
| 301 | if (defined($new) && $new->IsMenubutton && $new->cget('-indicatoron') == 0 && |
| 302 | $w->cget('-indicatoron') == 0) |
| 303 | { |
| 304 | if ($upDown eq 'down') |
| 305 | { |
| 306 | $new->Post($rootx,$rooty); |
| 307 | } |
| 308 | else |
| 309 | { |
| 310 | $new->Enter(); |
| 311 | } |
| 312 | } |
| 313 | } |
| 314 | # ButtonUp -- |
| 315 | # This procedure is invoked to handle button 1 releases for menubuttons. |
| 316 | # If the release happens inside the menubutton then leave its menu |
| 317 | # posted with element 0 activated. Otherwise, unpost the menu. |
| 318 | # |
| 319 | # Arguments: |
| 320 | # w - The name of the menubutton widget. |
| 321 | |
| 322 | sub ButtonUp { |
| 323 | my $w = shift; |
| 324 | |
| 325 | my $tearoff = $Tk::platform eq 'unix' || (defined($w->cget('-menu')) && |
| 326 | $w->cget('-menu')->cget('-type') eq 'tearoff'); |
| 327 | if ($tearoff && (defined($Tk::postedMb) && $Tk::postedMb == $w) |
| 328 | && (defined($Tk::inMenubutton) && $Tk::inMenubutton == $w)) { |
| 329 | $Tk::postedMb->cget(-menu)->FirstEntry(); |
| 330 | } else { |
| 331 | Tk::Menu->Unpost(undef); |
| 332 | } |
| 333 | } # end ButtonUp |
| 334 | |
| 335 | # Some convenience methods |
| 336 | |
| 337 | sub menu |
| 338 | { |
| 339 | my ($w,%args) = @_; |
| 340 | my $menu = $w->cget('-menu'); |
| 341 | if (!defined $menu) |
| 342 | { |
| 343 | require Tk::Menu; |
| 344 | $w->ColorOptions(\%args) if ($Tk::platform eq 'unix'); |
| 345 | $menu = $w->Menu(%args); |
| 346 | $w->configure('-menu'=>$menu); |
| 347 | } |
| 348 | else |
| 349 | { |
| 350 | $menu->configure(%args); |
| 351 | } |
| 352 | return $menu; |
| 353 | } |
| 354 | |
| 355 | sub separator { require Tk::Menu::Item; shift->menu->Separator(@_); } |
| 356 | sub command { require Tk::Menu::Item; shift->menu->Command(@_); } |
| 357 | sub cascade { require Tk::Menu::Item; shift->menu->Cascade(@_); } |
| 358 | sub checkbutton { require Tk::Menu::Item; shift->menu->Checkbutton(@_); } |
| 359 | sub radiobutton { require Tk::Menu::Item; shift->menu->Radiobutton(@_); } |
| 360 | |
| 361 | sub AddItems |
| 362 | { |
| 363 | shift->menu->AddItems(@_); |
| 364 | } |
| 365 | |
| 366 | sub entryconfigure |
| 367 | { |
| 368 | shift->menu->entryconfigure(@_); |
| 369 | } |
| 370 | |
| 371 | sub entrycget |
| 372 | { |
| 373 | shift->menu->entrycget(@_); |
| 374 | } |
| 375 | |
| 376 | sub FindMenu |
| 377 | { |
| 378 | my $child = shift; |
| 379 | my $char = shift; |
| 380 | my $ul = $child->cget('-underline'); |
| 381 | if (defined $ul && $ul >= 0 && $child->cget('-state') ne 'disabled') |
| 382 | { |
| 383 | my $char2 = $child->cget('-text'); |
| 384 | $char2 = substr("\L$char2",$ul,1) if (defined $char2); |
| 385 | if (!defined($char) || $char eq '' || (defined($char2) && "\l$char" eq $char2)) |
| 386 | { |
| 387 | $child->PostFirst; |
| 388 | return $child; |
| 389 | } |
| 390 | } |
| 391 | return undef; |
| 392 | } |
| 393 | |
| 394 | 1; |
| 395 | |
| 396 | __END__ |
| 397 | |
| 398 | |