package Tk::Balloon;
use vars qw($VERSION);
$VERSION = '3.037'; # $Id: //depot/Tk8/Tixish/Balloon.pm#37 $
use Tk qw(Ev Exists);
use Carp;
require Tk::Toplevel;
Tk::Widget->Construct('Balloon');
use base qw(Tk::Toplevel);
use UNIVERSAL;
use strict;
my@balloons;
my$button_up=0;
sub ClassInit{my($class,$mw)=@_;
$mw->bind('all','<Motion>',['Tk::Balloon::Motion',Ev('X'),Ev('Y'),Ev('s')]);
$mw->bind('all','<Leave>',['Tk::Balloon::Motion',Ev('X'),Ev('Y'),Ev('s')]);
$mw->bind('all','<Button>','Tk::Balloon::ButtonDown');
$mw->bind('all','<ButtonRelease>','Tk::Balloon::ButtonUp');
return$class;}sub Populate{my($w,$args)=@_;
$w->SUPER::Populate($args);
$w->overrideredirect(1);
$w->withdraw;
$w->configure(-background=>'black');
my$a=$w->Frame;
my$m=$w->Frame;
$a->configure(-bd=>0);
my$al=$a->Label(-bd=>0,-relief=>'flat',-bitmap=>'@'.Tk->findINC('balArrow.xbm'));
$al->pack(-side=>'left',-padx=>1,-pady=>1,-anchor=>'nw');
$m->configure(-bd=>0);
my$ml=$m->Label(-bd=>0,-padx=>0,-pady=>0,-text=>$args->{-message});
$w->Advertise('message'=>$ml);
$ml->pack(-side=>'left',-anchor=>'w',-expand=>1,-fill=>'both',-padx=>10,-pady=>3);
$a->pack(-fill=>'both',-side=>'left');
$m->pack(-fill=>'both',-side=>'left');
push(@balloons,$w);
$w->{'popped'}=0;
$w->{'buttonDown'}=0;
$w->{'menu_index'}='none';
$w->{'menu_index_over'}='none';
$w->{'canvas_tag'}='';
$w->{'canvas_tag_over'}='';
$w->ConfigSpecs(-installcolormap=>['PASSIVE','installColormap','InstallColormap',0],-initwait=>['PASSIVE','initWait','InitWait',350],-state=>['PASSIVE','state','State','both'],-statusbar=>['PASSIVE','statusBar','StatusBar',undef],-statusmsg=>['PASSIVE','statusMsg','StatusMsg',''],-balloonmsg=>['PASSIVE','balloonMsg','BalloonMsg',''],-balloonposition=>['PASSIVE','balloonPosition','BalloonPosition','widget'],-postcommand=>['CALLBACK','postCommand','PostCommand',undef],-cancelcommand=>['CALLBACK','cancelCommand','CancelCommand',undef],-motioncommand=>['CALLBACK','motionCommand','MotionCommand',undef],-background=>['DESCENDANTS','background','Background','#C0C080'],-font=>[$ml,'font','Font','-*-helvetica-medium-r-normal--*-120-*-*-*-*-*-*'],-borderwidth=>['SELF','borderWidth','BorderWidth',1]);}sub attach{my($w,$client,%args)=@_;
foreach my $key(grep(/command$/,keys%args)){$args{$key}=Tk::Callback->new($args{$key});}my$msg=delete$args{-msg};
$args{-balloonmsg}=$msg unless exists$args{-balloonmsg};
$args{-statusmsg}=$msg unless exists$args{-statusmsg};
$w->{'clients'}{$client}=\%args;
$client->OnDestroy([$w,'detach',$client]);}sub detach{my($w,$client)=@_;
if(Exists($w)){$w->Deactivate if($client->IS($w->{'client'}));}delete$w->{'clients'}{$client};}sub GetOption{my($w,$opt,$client)=@_;
$client=$w->{'client'}unless defined$client;
if(defined$client){my$info=$w->{'clients'}{$client};
return$info->{$opt}if exists$info->{$opt};}return$w->cget($opt);}sub Motion{my($ewin,$x,$y,$s)=@_;
return if not defined$ewin or((($s&0x1f00)or$ewin->grabCurrent())and not$ewin->isa('Tk::Menu'));
my$over=$ewin->Containing($x,$y);
foreach my $w(@balloons){next if defined$over and$over->toplevel eq$w;
my$client=$over;
while(defined$client){last if(exists$w->{'clients'}{$client});
$client=$client->Parent;}if(defined$client){my$state=$w->GetOption(-state=>$client);
next if$state eq 'none';
my$deactivate=0;
if($button_up){$deactivate=1;
$button_up=0;}my$command=$w->GetOption(-motioncommand=>$client);
$deactivate=$command->Call($client,$x,$y)if defined$command;
if($deactivate){$w->Deactivate;}else{$w->Deactivate unless$client->IS($w->{'client'});
my$msg=$client->BalloonInfo($w,$x,$y,'-statusmsg','-balloonmsg');
if(defined($msg)){my$delay=delete$w->{'delay'};
$delay->cancel if defined$delay;
my$initwait=$w->GetOption(-initwait=>$client);
$w->{'delay'}=$client->after($initwait,sub{$w->SwitchToClient($client);});
$w->{'client'}=$client;}}}else{$w->Deactivate;}}}sub ButtonDown{my($ewin)=@_;
foreach my $w(@balloons){$w->Deactivate;}}sub ButtonUp{$button_up=1;}sub SwitchToClient{my($w,$client)=@_;
return unless Exists($w);
return unless Exists($client);
return unless$client->IS($w->{'client'});
return if$w->grabCurrent and not$client->isa('Tk::Menu');
my$command=$w->GetOption(-postcommand=>$client);
if(defined$command){my$pos=$command->Call($client);
return if not$pos;
if($pos=~/^(\d+),(\d+)$/){$w->{'clients'}{$client}{'postposition'}=[$1,$2];}}my$state=$w->GetOption(-state=>$client);
$w->Popup if($state=~/both|balloon/);
$w->SetStatus if($state=~/both|status/);
$w->{'popped'}=1;
$w->{'delay'}=$w->repeat(200,['Verify',$w,$client]);}sub Subclient{my($w,$data)=@_;
if(defined($w->{'subclient'})&&(!defined($data)||$w->{'subclient'}ne$data)){$w->Deactivate;}$w->{'subclient'}=$data;}sub Verify{my$w=shift;
my$client=shift;
my($X,$Y)=(@_)?@_:($w->pointerxy);
my$over=$w->Containing($X,$Y);
return if not defined$over or($over->toplevel eq$w);
my$deactivate=not$client->IS($w->{'client'})or(!$client->isa('Tk::Menu')&&$w->grabCurrent);
if($deactivate){$w->Deactivate;}else{$client->BalloonInfo($w,$X,$Y,'-statusmsg','-balloonmsg');}}sub Deactivate{my($w)=@_;
my$delay=delete$w->{'delay'};
$delay->cancel if defined$delay;
if($w->{'popped'}){my$client=$w->{'client'};
my$command=$w->GetOption(-cancelcommand=>$client);
if(defined$command){return if not$command->Call($client);}$w->withdraw;
$w->ClearStatus;
$w->{'popped'}=0;
$w->{'menu_index'}='none';
$w->{'canvas_tag'}='';}$w->{'client'}=undef;
$w->{'subclient'}=undef;}sub Popup{my($w)=@_;
if($w->cget(-installcolormap)){$w->colormapwindows($w->winfo('toplevel'))}my$client=$w->{'client'};
return if not defined$client or not exists$w->{'clients'}{$client};
my$msg=$client->BalloonInfo($w,$w->pointerxy,'-balloonmsg');
$msg=$$msg if UNIVERSAL::isa($msg,'SCALAR');
$w->Subwidget('message')->configure(-text=>$msg);
$w->idletasks;
return unless Exists($w);
return unless Exists($client);
return if$msg eq '';
my($x,$y);
my$pos=$w->GetOption(-balloonposition=>$client);
my$postpos=delete$w->{'clients'}{$client}{'postposition'};
if(defined$postpos){($x,$y)=@{$postpos};}elsif($pos eq 'mouse'){$x=int($client->pointerx+10);
$y=int($client->pointery+10);}elsif($pos eq 'widget'){$x=int($client->rootx+$client->width/2);
$y=int($client->rooty+int($client->height/1.3));}else{croak"'$pos' is not a valid position for the balloon - it must be one of: 'widget', 'mouse'.";}$w->idletasks;
my($width,$height)=($w->reqwidth,$w->reqheight);
my$xx=($x+$width>$w->screenwidth?$w->screenwidth-$width:$x);
my$yy=($y+$height>$w->screenheight?$w->screenheight-$height:$y);
$w->geometry("+$xx+$yy");
$w->deiconify();
$w->raise;}sub SetStatus{my($w)=@_;
my$client=$w->{'client'};
my$s=$w->GetOption(-statusbar=>$client);
if(defined$s and$s->winfo('exists')){my$vref=$s->cget(-textvariable);
return if not defined$client or not exists$w->{'clients'}{$client};
my$msg=$client->BalloonInfo($w,$w->pointerxy,'-statusmsg');
$msg=$$msg if UNIVERSAL::isa($msg,'SCALAR');
if(not defined$vref){eval{$s->configure(-text=>$msg);};}else{$$vref=$msg;}}}sub ClearStatus{my($w)=@_;
my$client=$w->{'client'};
my$s=$w->GetOption(-statusbar=>$client);
if(defined$s and$s->winfo('exists')){my$vref=$s->cget(-textvariable);
if(defined$vref){$$vref='';}else{eval{$s->configure(-text=>'');}}}}sub destroy{my($w)=@_;
@balloons=grep($w!=$_,@balloons);
undef$w;}1;
