package Tk::Menubutton;
require Tk;
use vars qw($VERSION);
$VERSION = '3.025'; # $Id: //depot/Tk8/Menubutton/Menubutton.pm#25 $
use base  qw(Tk::Widget);
Construct Tk::Widget 'Menubutton';
import Tk qw(&Ev $XS_VERSION);
bootstrap Tk::Menubutton;
sub Tk_cmd{\&Tk::menubutton}sub InitObject{my($mb,$args)=@_;
my$menuitems=delete$args->{-menuitems};
my$tearoff=delete$args->{-tearoff};
$mb->SUPER::InitObject($args);
if((defined($menuitems)||defined($tearoff))&&%$args){$mb->configure(%$args);
%$args=();}$mb->menu(-tearoff=>$tearoff)if(defined$tearoff);
$mb->AddItems(@$menuitems)if(defined$menuitems)}sub ClassInit{my($class,$mw)=@_;
$mw->bind($class,'<FocusIn>','NoOp');
$mw->bind($class,'<Enter>','Enter');
$mw->bind($class,'<Leave>','Leave');
$mw->bind($class,'<1>','ButtonDown');
$mw->bind($class,'<Motion>',['Motion','up',Ev('X'),Ev('Y')]);
$mw->bind($class,'<B1-Motion>',['Motion','down',Ev('X'),Ev('Y')]);
$mw->bind($class,'<ButtonRelease-1>','ButtonUp');
$mw->bind($class,'<space>','PostFirst');
$mw->bind($class,'<Return>','PostFirst');
return$class;}sub ButtonDown{my$w=shift;
my$Ev=$w->XEvent;
$Tk::inMenubutton->Post($Ev->X,$Ev->Y)if(defined$Tk::inMenubutton);}sub PostFirst{my$w=shift;
my$menu=$w->cget('-menu');
$w->Post();
$menu->FirstEntry()if(defined$menu);}sub Enter{my$w=shift;
$Tk::inMenubutton->Leave if(defined$Tk::inMenubutton);
$Tk::inMenubutton=$w;
if($w->cget('-state')ne 'disabled'){$w->configure('-state','active')}}sub Leave{my$w=shift;
$Tk::inMenubutton=undef;
return unless Tk::Exists($w);
if($w->cget('-state')eq 'active'){$w->configure('-state','normal')}}sub Post{my$w=shift;
my$x=shift;
my$y=shift;
return if($w->cget('-state')eq 'disabled');
return if(defined$Tk::postedMb&&$w==$Tk::postedMb);
my$menu=$w->cget('-menu');
return unless(defined($menu)&&$menu->index('last')ne 'none');
my$tearoff=$Tk::platform eq 'unix'||$menu->cget('-type')eq 'tearoff';
my$wpath=$w->PathName;
my$mpath=$menu->PathName;
unless(index($mpath,"$wpath.")==0){die"Cannot post $mpath : not a descendant of $wpath";}my$cur=$Tk::postedMb;
if(defined$cur){Tk::Menu->Unpost(undef);}$Tk::cursor=$w->cget('-cursor');
$Tk::relief=$w->cget('-relief');
$w->configure('-cursor','arrow');
$w->configure('-relief','raised');
$Tk::postedMb=$w;
$Tk::focus=$w->focusCurrent;
$menu->activate('none');
$menu->GenerateMenuSelect;
eval{local$SIG{'__DIE__'};
my$dir=$w->cget('-direction');
if($dir eq 'above'){$menu->post($w->rootx,$w->rooty-$menu->ReqHeight);}elsif($dir eq 'below'){$menu->post($w->rootx,$w->rooty+$w->Height);}elsif($dir eq 'left'){my$x=$w->rootx-$menu->ReqWidth;
my$y=int((2*$w->rooty+$w->Height)/2);
if($w->cget('-indicatoron')==1&&defined($w->cget('-textvariable'))){$menu->PostOverPoint($x,$y,$menu->FindName($w->cget('-text')))}else{$menu->post($x,$y);}}elsif($dir eq 'right'){my$x=$w->rootx+$w->Width;
my$y=int((2*$w->rooty+$w->Height)/2);
if($w->cget('-indicatoron')==1&&defined($w->cget('-textvariable'))){$menu->PostOverPoint($x,$y,$menu->FindName($w->cget('-text')))}else{$menu->post($x,$y);}}else{if($w->cget('-indicatoron')==1&&defined($w->cget('-textvariable'))){if(!defined($y)){$x=$w->rootx+$w->width/2;
$y=$w->rooty+$w->height/2}$menu->PostOverPoint($x,$y,$menu->FindName($w->cget('-text')))}else{$menu->post($w->rootx,$w->rooty+$w->height);}}};
if($@){Tk::Menu->Unpost;
die$@}$Tk::tearoff=$tearoff;
if($tearoff){$menu->focus;
$w->SaveGrabInfo;
$w->grabGlobal;}}sub Motion{my$w=shift;
my$upDown=shift;
my$rootx=shift;
my$rooty=shift;
return if(defined($Tk::inMenubutton)&&$Tk::inMenubutton==$w);
my$new=$w->Containing($rootx,$rooty);
if(defined($Tk::inMenubutton)){if(!defined($new)||($new!=$Tk::inMenubutton&&$w->toplevel!=$new->toplevel)){$Tk::inMenubutton->Leave();}}if(defined($new)&&$new->IsMenubutton&&$new->cget('-indicatoron')==0&&$w->cget('-indicatoron')==0){if($upDown eq 'down'){$new->Post($rootx,$rooty);}else{$new->Enter();}}}sub ButtonUp{my$w=shift;
my$tearoff=$Tk::platform eq 'unix'||(defined($w->cget('-menu'))&&$w->cget('-menu')->cget('-type')eq 'tearoff');
if($tearoff&&(defined($Tk::postedMb)&&$Tk::postedMb==$w)&&(defined($Tk::inMenubutton)&&$Tk::inMenubutton==$w)){$Tk::postedMb->cget(-menu)->FirstEntry();}else{Tk::Menu->Unpost(undef);}}sub menu{my($w,%args)=@_;
my$menu=$w->cget('-menu');
if(!defined$menu){require Tk::Menu;
$w->ColorOptions(\%args)if($Tk::platform eq 'unix');
$menu=$w->Menu(%args);
$w->configure('-menu'=>$menu);}else{$menu->configure(%args);}return$menu;}sub separator{require Tk::Menu::Item;shift->menu->Separator(@_);}sub command{require Tk::Menu::Item;shift->menu->Command(@_);}sub cascade{require Tk::Menu::Item;shift->menu->Cascade(@_);}sub checkbutton{require Tk::Menu::Item;shift->menu->Checkbutton(@_);}sub radiobutton{require Tk::Menu::Item;shift->menu->Radiobutton(@_);}sub AddItems{shift->menu->AddItems(@_);}sub entryconfigure{shift->menu->entryconfigure(@_);}sub entrycget{shift->menu->entrycget(@_);}sub FindMenu{my$child=shift;
my$char=shift;
my$ul=$child->cget('-underline');
if(defined$ul&&$ul>=0&&$child->cget('-state')ne 'disabled'){my$char2=$child->cget('-text');
$char2=substr("\L$char2",$ul,1)if(defined$char2);
if(!defined($char)||$char eq ''||(defined($char2)&&"\l$char" eq$char2)){$child->PostFirst;
return$child;}}return undef;}1;
__END__


