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 16package Tk::Menubutton; 17require Tk; 18 19use vars qw($VERSION); 20$VERSION = '4.005'; # $Id: //depot/Tkutf8/Menubutton/Menubutton.pm#4 $ 21 22use base qw(Tk::Widget); 23 24Construct Tk::Widget 'Menubutton'; 25 26import Tk qw(&Ev $XS_VERSION); 27 28bootstrap Tk::Menubutton; 29 30sub Tk_cmd { \&Tk::menubutton } 31 32sub 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. 102sub 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 117sub ButtonDown 118{my $w = shift; 119 my $Ev = $w->XEvent; 120 $Tk::inMenubutton->Post($Ev->X,$Ev->Y) if (defined $Tk::inMenubutton); 121} 122 123sub 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. 140sub 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 151sub 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. 172sub 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 if ($w->viewable) 273 { 274 $w->SaveGrabInfo; 275 $w->grabGlobal; 276 } 277 } 278} 279# Motion -- 280# This procedure handles mouse motion events inside menubuttons, and 281# also outside menubuttons when a menubutton has a grab (e.g. when a 282# menu selection operation is in progress). 283# 284# Arguments: 285# w - The name of the menubutton widget. 286# upDown - "down" means button 1 is pressed, "up" means 287# it isn't. 288# rootx, rooty - Coordinates of mouse, in (virtual?) root window. 289sub Motion 290{ 291 my $w = shift; 292 my $upDown = shift; 293 my $rootx = shift; 294 my $rooty = shift; 295 return if (defined($Tk::inMenubutton) && $Tk::inMenubutton == $w); 296 my $new = $w->Containing($rootx,$rooty); 297 if (defined($Tk::inMenubutton)) 298 { 299 if (!defined($new) || ($new != $Tk::inMenubutton && $w->toplevel != $new->toplevel)) 300 { 301 $Tk::inMenubutton->Leave(); 302 } 303 } 304 if (defined($new) && $new->IsMenubutton && $new->cget('-indicatoron') == 0 && 305 $w->cget('-indicatoron') == 0) 306 { 307 if ($upDown eq 'down') 308 { 309 $new->Post($rootx,$rooty); 310 } 311 else 312 { 313 $new->Enter(); 314 } 315 } 316} 317# ButtonUp -- 318# This procedure is invoked to handle button 1 releases for menubuttons. 319# If the release happens inside the menubutton then leave its menu 320# posted with element 0 activated. Otherwise, unpost the menu. 321# 322# Arguments: 323# w - The name of the menubutton widget. 324 325sub ButtonUp { 326 my $w = shift; 327 328 my $tearoff = $Tk::platform eq 'unix' || (defined($w->cget('-menu')) && 329 $w->cget('-menu')->cget('-type') eq 'tearoff'); 330 if ($tearoff && (defined($Tk::postedMb) && $Tk::postedMb == $w) 331 && (defined($Tk::inMenubutton) && $Tk::inMenubutton == $w)) { 332 $Tk::postedMb->cget(-menu)->FirstEntry(); 333 } else { 334 Tk::Menu->Unpost(undef); 335 } 336} # end ButtonUp 337 338# Some convenience methods 339 340sub menu 341{ 342 my ($w,%args) = @_; 343 my $menu = $w->cget('-menu'); 344 if (!defined $menu) 345 { 346 require Tk::Menu; 347 $w->ColorOptions(\%args) if ($Tk::platform eq 'unix'); 348 $menu = $w->Menu(%args); 349 $w->configure('-menu'=>$menu); 350 } 351 else 352 { 353 $menu->configure(%args); 354 } 355 return $menu; 356} 357 358sub separator { require Tk::Menu::Item; shift->menu->Separator(@_); } 359sub command { require Tk::Menu::Item; shift->menu->Command(@_); } 360sub cascade { require Tk::Menu::Item; shift->menu->Cascade(@_); } 361sub checkbutton { require Tk::Menu::Item; shift->menu->Checkbutton(@_); } 362sub radiobutton { require Tk::Menu::Item; shift->menu->Radiobutton(@_); } 363 364sub AddItems 365{ 366 shift->menu->AddItems(@_); 367} 368 369sub entryconfigure 370{ 371 shift->menu->entryconfigure(@_); 372} 373 374sub entrycget 375{ 376 shift->menu->entrycget(@_); 377} 378 379sub FindMenu 380{ 381 my $child = shift; 382 my $char = shift; 383 my $ul = $child->cget('-underline'); 384 if (defined $ul && $ul >= 0 && $child->cget('-state') ne 'disabled') 385 { 386 my $char2 = $child->cget('-text'); 387 $char2 = substr("\L$char2",$ul,1) if (defined $char2); 388 if (!defined($char) || $char eq '' || (defined($char2) && "\l$char" eq $char2)) 389 { 390 $child->PostFirst; 391 return $child; 392 } 393 } 394 return undef; 395} 396 3971; 398 399__END__ 400 401 402