package Tk::Menu;
require Tk;
require Tk::Widget;
require Tk::Wm;
require Tk::Derived;
require Tk::Menu::Item;
use vars qw($VERSION);
$VERSION = '3.045'; # $Id: //depot/Tk8/Tk/Menu.pm#45 $
use strict;
use base  qw(Tk::Wm Tk::Derived Tk::Widget);
Construct Tk::Widget 'Menu';
sub Tk_cmd{\&Tk::_menu}Tk::Methods('activate','add','clone','delete','entrycget','entryconfigure','index','insert','invoke','post','postcascade','type','unpost','yposition');
import Tk qw(Ev);
sub CreateArgs{my($package,$parent,$args)=@_;
my@result=();
my$opt;
foreach$opt(qw(-type -screen -visual -colormap)){my$val=delete$args->{$opt};
push(@result,$opt=>$val)if(defined$val);}return@result;}sub InitObject{my($menu,$args)=@_;
my$menuitems=delete$args->{-menuitems};
$menu->SUPER::InitObject($args);
if(defined$menuitems){if(%$args){$menu->configure(%$args);
%$args=();}$menu->AddItems(@$menuitems)}}sub AddItems{my$menu=shift;
ITEM:
while(@_){my$item=shift;
if(!ref($item)){$menu->separator;}else{my($kind,$name,%minfo)=(@$item);
my$invoke=delete$minfo{'-invoke'};
if(defined$name){$minfo{-label}=$name unless defined($minfo{-label});
$menu->$kind(%minfo);}else{$menu->BackTrace("Don't recognize ".join(' ',@$item));}}}}sub ClassInit{my($class,$mw)=@_;
$mw->bind($class,'<FocusIn>','NoOp');
$mw->bind($class,'<Enter>','Enter');
$mw->bind($class,'<Leave>',['Leave',Ev('X'),Ev('Y'),Ev('s')]);
$mw->bind($class,'<Motion>',['Motion',Ev('x'),Ev('y'),Ev('s')]);
$mw->bind($class,'<ButtonPress>','ButtonDown');
$mw->bind($class,'<ButtonRelease>',['Invoke',1]);
$mw->bind($class,'<space>',['Invoke',0]);
$mw->bind($class,'<Return>',['Invoke',0]);
$mw->bind($class,'<Escape>','Escape');
$mw->bind($class,'<Left>','LeftArrow');
$mw->bind($class,'<Right>','RightArrow');
$mw->bind($class,'<Up>','UpArrow');
$mw->bind($class,'<Down>','DownArrow');
$mw->bind($class,'<KeyPress>',['TraverseWithinMenu',Ev('K')]);
$mw->bind($class,'<Alt-KeyPress>',['TraverseWithinMenu',Ev('K')]);
return$class;}sub UpArrow{my$menu=shift;
if($menu->cget('-type')eq 'menubar'){$menu->NextMenu('left');}else{$menu->NextEntry(-1);}}sub DownArrow{my$menu=shift;
if($menu->cget('-type')eq 'menubar'){$menu->NextMenu('right');}else{$menu->NextEntry(1);}}sub LeftArrow{my$menu=shift;
if($menu->cget('-type')eq 'menubar'){$menu->NextEntry(-1);}else{$menu->NextMenu('left');}}sub RightArrow{my$menu=shift;
if($menu->cget('-type')eq 'menubar'){$menu->NextEntry(1);}else{$menu->NextMenu('right');}}sub Unpost{my$menu=shift;
my$mb=$Tk::postedMb;
eval{local$SIG{__DIE__};$Tk::focus->focus()}if(defined$Tk::focus);
undef$Tk::focus;
eval{local$SIG{__DIE__};
if(defined$mb){$menu=$mb->cget('-menu');
$menu->unpost();
$Tk::postedMb=undef;
$mb->configure('-cursor',$Tk::cursor);
$mb->configure('-relief',$Tk::relief)}elsif(defined$Tk::popup){$Tk::popup->unpost();
my$grab=$Tk::popup->grabCurrent;
$grab->grabRelease if(defined$grab);
undef$Tk::popup;}elsif(defined$menu&&ref$menu&&$menu->cget('-type')ne 'menubar'&&$menu->cget('-type')ne 'tearoff'){while(1){my$parent=$menu->parent;
last if(!$parent->IsMenu||!$parent->ismapped);
$parent->postcascade('none');
$parent->GenerateMenuSelect;
$parent->activate('none');
my$type=$parent->cget('-type');
last if($type eq 'menubar'||$type eq 'tearoff');
$menu=$parent}$menu->unpost()if($menu->cget('-type')ne 'menubar');}};
warn"$@" if($@);
if($Tk::tearoff||$Tk::menubar){if(defined$menu&&ref$menu){my$grab=$menu->grabCurrent;
$grab->grabRelease if(defined$grab);}RestoreOldGrab();
if($Tk::menubar){$Tk::menubar->configure(-cursor=>$Tk::cursor);
undef$Tk::menubar;}if($Tk::platform ne 'unix'){undef$Tk::tearoff;}}}sub RestoreOldGrab{if(defined$Tk::oldGrab){eval{local$SIG{__DIE__};
if($Tk::grabStatus eq 'global'){$Tk::oldGrab->grabGlobal;}else{$Tk::oldGrab->grab;}};
undef$Tk::oldGrab;}}sub typeIS{my$w=shift;
my$type=$w->type(shift);
return defined$type&&$type eq shift;}sub Motion{my$menu=shift;
my$x=shift;
my$y=shift;
my$state=shift;
my$t=$menu->cget('-type');
if($menu->IS($Tk::window)){if($menu->cget('-type')eq 'menubar'){{$menu->activate("\@$x,$y");
$menu->GenerateMenuSelect;}}else{$menu->activate("\@$x,$y");
$menu->GenerateMenuSelect;}}if(($state&0x1f00)!=0){$menu->postcascade('active')}}sub ButtonDown{my$menu=shift;
$menu->postcascade('active');
if(defined$Tk::postedMb){$Tk::postedMb->grabGlobal}else{while($menu->cget('-type')eq 'normal'&&$menu->parent->IsMenu&&$menu->parent->ismapped){$menu=$menu->parent;}if(!defined$Tk::menuBar){$Tk::menuBar=$menu;
$Tk::cursor=$menu->cget('-cursor');
$menu->configure(-cursor=>'arrow');}$menu->SaveGrabInfo unless($menu->IS($menu->grabCurrent));
$menu->grabGlobal if($Tk::platform eq 'unix');}}sub Enter{my$w=shift;
my$ev=$w->XEvent;
$Tk::window=$w;
if($w->cget('-type')eq 'tearoff'){if($ev->m ne 'NotifyUngrab'){$w->SetFocus if($Tk::platform eq 'unix');}}$w->Motion($ev->x,$ev->y,$ev->s);}sub Leave{my$menu=shift;
my$rootx=shift;
my$rooty=shift;
my$state=shift;
undef$Tk::window;
return if($menu->index('active')eq 'none');
if($menu->typeIS('active','cascade')){my$c=$menu->Containing($rootx,$rooty);
return if(defined$c&&$menu->entrycget('active','-menu')->IS($c));}$menu->activate('none');
$menu->GenerateMenuSelect;}sub Invoke{my$w=shift;
my$release=shift;
if($release&&!defined($Tk::window)){$w->postcascade('none');
$w->activate('none');
$w->eventGenerate('<<MenuSelect>>');
$w->Unpost;
return;}my$type=$w->type('active');
if($w->typeIS('active','cascade')){$w->postcascade('active');
my$menu=$w->entrycget('active','-menu');
$menu->FirstEntry()if(defined$menu);}elsif($w->typeIS('active','tearoff')){$w->Unpost();
$w->tearOffMenu();}elsif($w->typeIS('active','menubar')){$w->postcascade('none');
$w->activate('none');
$w->eventGenerate('<<MenuSelect>>');
$w->Unpost;}else{$w->Unpost();
$w->invoke('active')}}sub Escape{my$menu=shift;
my$parent=$menu->parent;
if(!$parent->IsMenu){$menu->Unpost()}elsif($parent->cget('-type')eq 'menubar'){$menu->Unpost;
RestoreOldGrab();}else{$menu->NextMenu(-1)}}sub NextMenu{my$menu=shift;
my$direction=shift;
my$count;
if($direction eq 'right'){$count=1;
if($menu->typeIS('active','cascade')){$menu->postcascade('active');
my$m2=$menu->entrycget('active','-menu');
$m2->FirstEntry if(defined$m2);
return;}else{my$parent=$menu->parent;
while($parent->PathName ne '.'){if($parent->IsMenu&&$parent->cget('-type')eq 'menubar'){$parent->SetFocus;
$parent->NextEntry(1);
return;}$parent=$parent->parent;}}}else{$count=-1;
my$m2=$menu->parent;
if($m2->IsMenu){if($m2->cget('-type')ne 'menubar'){$menu->activate('none');
$menu->GenerateMenuSelect;
$m2->SetFocus;
my$tmp=$m2->index('active');
$m2->activate('none');
$m2->activate($tmp);
return;}}}my$m2=$menu->parent;
if($m2->IsMenu){if($m2->cget('-type')eq 'menubar'){$m2->SetFocus;
$m2->NextEntry(-1);
return;}}my$w=$Tk::postedMb;
return unless defined$w;
my@buttons=$w->parent->children;
my$length=@buttons;
my$i=Tk::lsearch(\@buttons,$w)+$count;
my$mb;
while(1){while($i<0){$i+=$length}while($i>=$length){$i+=-$length}$mb=$buttons[$i];
last if($mb->IsMenubutton&&$mb->cget('-state')ne 'disabled'&&defined($mb->cget('-menu'))&&$mb->cget('-menu')->index('last')ne 'none');
return if($mb==$w);
$i+=$count}$mb->PostFirst();}sub NextEntry{my$menu=shift;
my$count=shift;
if($menu->index('last')eq 'none'){return;}my$length=$menu->index('last')+1;
my$quitAfter=$length;
my$active=$menu->index('active');
my$i=($active eq 'none')?0:$active+$count;
while(1){return if($quitAfter<=0);
while($i<0){$i+=$length}while($i>=$length){$i+=-$length}my$state=eval{local$SIG{__DIE__};$menu->entrycget($i,'-state')};
last if(defined($state)&&$state ne 'disabled');
return if($i==$active);
$i+=$count;
$quitAfter-=1;}$menu->activate($i);
$menu->GenerateMenuSelect;
if($menu->type($i)eq 'cascade'){my$cascade=$menu->entrycget($i,'-menu');
$menu->postcascade($i);
$cascade->FirstEntry if(defined$cascade);}}sub TraverseWithinMenu{my$w=shift;
my$char=shift;
return unless(defined$char);
$char="\L$char";
my$last=$w->index('last');
return if($last eq 'none');
for(my$i=0;$i<=$last;$i+=1){my$label=eval{local$SIG{__DIE__};$w->entrycget($i,'-label')};
next unless defined($label);
my$ul=$w->entrycget($i,'-underline');
if(defined$ul&&$ul>=0){$label=substr("\L$label",$ul,1);
if(defined($label)&&$label eq$char){if($w->type($i)eq 'cascade'){$w->postcascade($i);
$w->activate($i);
my$m2=$w->entrycget($i,'-menu');
$m2->FirstEntry if(defined$m2);}else{$w->Unpost();
$w->invoke($i);}return;}}}}sub FindMenu{my($menu,$char)=@_;
if($menu->cget('-type')eq 'menubar'){if(!defined($char)||$char eq ''){$menu->FirstEntry;}else{$menu->TraverseWithinMenu($char);}return$menu;}return undef;}sub FirstEntry{my$menu=shift;
return if(!defined($menu)||$menu eq ''||!ref($menu));
$menu->SetFocus;
return if($menu->index('active')ne 'none');
my$last=$menu->index('last');
return if($last eq 'none');
for(my$i=0;$i<=$last;$i+=1){my$state=eval{local$SIG{__DIE__};$menu->entrycget($i,'-state')};
if(defined$state&&$state ne 'disabled'&&!$menu->typeIS($i,'tearoff')){$menu->activate($i);
$menu->GenerateMenuSelect;
if($menu->type($i)eq 'cascade'){my$cascade=$menu->entrycget($i,'-menu');
if(defined$cascade){$menu->postcascade($i);
$cascade->FirstEntry;}}return;}}}sub FindName{my$menu=shift;
my$s=shift;
my$i=undef;
if($s!~/^active$|^last$|^none$|^[0-9]|^@/){$i=eval{local$SIG{__DIE__};$menu->index($s)};
return$i;}my$last=$menu->index('last');
return if($last eq 'none');
for($i=0;$i<=$last;$i+=1){my$label=eval{local$SIG{__DIE__};$menu->entrycget($i,'-label')};
return$i if(defined$label&&$label eq$s);}return undef;}sub PostOverPoint{my$menu=shift;
my$x=shift;
my$y=shift;
my$entry=shift;
if(defined$entry){if($entry==$menu->index('last')){$y-=($menu->yposition($entry)+$menu->height)/2;}else{$y-=($menu->yposition($entry)+$menu->yposition($entry+1))/2;}$x-=$menu->reqwidth/2;}$menu->post($x,$y);
if(defined($entry)&&$menu->entrycget($entry,'-state')ne 'disabled'){$menu->activate($entry);
$menu->GenerateMenuSelect;}}sub Post{my$menu=shift;
return unless(defined$menu);
my$x=shift;
my$y=shift;
my$entry=shift;
Unpost(undef)if(defined($Tk::popup)||defined($Tk::postedMb));
$menu->PostOverPoint($x,$y,$entry);
$menu->grabGlobal;
$Tk::popup=$menu;
$Tk::focus=$menu->focusCurrent;
$menu->focus();}sub SetFocus{my$menu=shift;
$Tk::focus=$menu->focusCurrent if(!defined($Tk::focus));
$menu->focus;}sub GenerateMenuSelect{my$menu=shift;
$Tk::activeMenu=$menu;
$Tk::activeItem=$menu->index('active');
$menu->eventGenerate('<<MenuSelect>>');}sub tearOffMenu{my$w=shift;
my$x=(@_)?shift:0;
my$y=(@_)?shift:0;
$x=$w->rootx if$x==0;
$y=$w->rooty if$y==0;
my$parent=$w->parent;
while($parent->toplevel!=$parent||$parent->IsMenu){$parent=$parent->parent;}my$menu=$w->clone($parent,'tearoff');
my$title=$menu->cget('-title');
unless(defined$title&&length($title)){$parent=$w->parent;
if($parent->IsMenubutton){$title=$parent->cget('-text');}elsif($parent->IsMenu){$title=$parent->entrycget('active','-label');}}$menu->title($title)if(defined$title&&length($title));
$menu->post($x,$y);
$menu->bind('<Enter>','EnterFocus');
$menu->Callback('-tearoffcommand');
return$menu;}sub MenuDup{my$src=shift;
my$parent=shift;
my$type=(@_)?shift:'normal';
my%args=(-type=>$type);
foreach my $option($src->configure()){next if(@$option==2);
$args{$$option[0]}=$$option[4]unless exists$args{$$option[0]};}my$dst=ref($src)->new($parent,%args);
if($type eq 'tearoff'){$dst->transient($parent->MainWindow);}my$last=$src->index('last');
if($last ne 'none'){for(my$i=$src->cget('-tearoff');$i<=$last;$i++){my$type=$src->type($i);
if(defined$type){my@args=();
foreach my $option($src->entryconfigure($i)){next if(@$option==2);
push(@args,$$option[0],$$option[4])if(defined$$option[4]);}$dst->add($type,@args);}}}my@bindtags=$src->bindtags;
my$path=$src->PathName;
foreach(@bindtags){$_=$dst if($_ eq$path);}$dst->bindtags([@bindtags]);
foreach my $event($src->bind){my$cb=$src->bind($event);
$dst->bind($event,$cb->Substitute($src,$dst));}return$dst;}sub separator{require Tk::Menu::Item;shift->Separator(@_);}sub cascade{require Tk::Menu::Item;shift->Cascade(@_);}sub checkbutton{require Tk::Menu::Item;shift->Checkbutton(@_);}sub radiobutton{require Tk::Menu::Item;shift->Radiobutton(@_);}sub command{my($menu,%args)=@_;
require Tk::Menu::Item;
if(exists$args{-button}){my$button=delete$args{-button};
$button=['Misc',-underline=>0]unless(defined$button);
my@bargs=();
($button,@bargs)=@$button if(ref($button)&&ref$button eq 'ARRAY');
$menu=$menu->Menubutton(-label=>$button,@bargs);}$menu->Command(%args);}sub Menubutton{my($menu,%args)=@_;
my$name=delete($args{'-text'})||$args{'-label'};;
$args{'-label'}=$name if(defined$name);
my$items=delete$args{'-menuitems'};
foreach my $opt(qw(-pack -after -before -side -padx -ipadx -pady -ipady -fill)){delete$args{$opt};}if(defined($name)&&!defined($args{-underline})){my$underline=($name=~s/^(.*)~/$1/)?length($1):undef;
if(defined($underline)&&($underline>=0)){$args{-underline}=$underline;
$args{-label}=$name;}}my$hash=$menu->TkHash('MenuButtons');
my$mb=$hash->{$name};
if(defined$mb){delete$args{'-tearoff'};
$mb->configure(%args)if%args;}else{$mb=$menu->cascade(%args);
$hash->{$name}=$mb;}$mb->menu->AddItems(@$items)if defined($items)&&@$items;
return$mb;}sub BalloonInfo{my($menu,$balloon,$X,$Y,@opt)=@_;
my$i=$menu->index('active');
if($i eq 'none'){my$y=$Y-$menu->rooty;
$i=$menu->index("\@$y");}foreach my $opt(@opt){my$info=$balloon->GetOption($opt,$menu);
if($opt=~/^-(statusmsg|balloonmsg)$/&&UNIVERSAL::isa($info,'ARRAY')){$balloon->Subclient($i);
return '' if$i eq 'none';
return${$info}[$i]||'';}return$info;}}1;
__END__


