# The help widget that provides both "balloon" and "status bar"
# types of help messages.
$VERSION = '3.037'; # $Id: //depot/Tk8/Tixish/Balloon.pm#37 $
Tk
::Widget
->Construct('Balloon');
use base
qw(Tk::Toplevel);
$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');
$w->SUPER::Populate
($args);
# Only the container frame's background should be black... makes it
$w->configure(-background
=> 'black');
my $al = $a->Label(-bd
=> 0,
-bitmap
=> '@' . Tk
->findINC('balArrow.xbm'));
$al->pack(-side
=> 'left', -padx
=> 1, -pady
=> 1, -anchor
=> 'nw');
my $ml = $m->Label(-bd
=> 0,
-text
=> $args->{-message
});
$w->Advertise('message' => $ml);
$ml->pack(-side
=> 'left',
$a->pack(-fill
=> 'both', -side
=> 'left');
$m->pack(-fill
=> 'both', -side
=> 'left');
# append to global list of balloons
$w->{'menu_index'} = 'none';
$w->{'menu_index_over'} = 'none';
$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]
# attach a client to the balloon
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]);
# detach a client from the balloon.
$w->Deactivate if ($client->IS($w->{'client'}));
delete $w->{'clients'}{$client};
my ($w,$opt,$client) = @_;
$client = $w->{'client'} unless defined $client;
my $info = $w->{'clients'}{$client};
return $info->{$opt} if exists $info->{$opt};
my ($ewin, $x, $y, $s) = @_;
# Don't do anything if a button is down or a grab is active
# 0x1f00 is (Button1Mask | .. | Button5Mask)
return if not defined $ewin or ((($s & 0x1f00) or $ewin->grabCurrent()) and not $ewin->isa('Tk::Menu'));
# Find which window we are over
my $over = $ewin->Containing($x, $y);
foreach my $w (@balloons) {
# if cursor has moved over the balloon -- ignore
next if defined $over and $over->toplevel eq $w;
# find the client window that matches
while (defined $client) {
last if (exists $w->{'clients'}{$client});
$client = $client->Parent;
# popping up disabled -- ignore
my $state = $w->GetOption(-state => $client);
next if $state eq 'none';
# Check if a button was recently released:
# Deactivate it if the motioncommand says to:
my $command = $w->GetOption(-motioncommand
=> $client);
$deactivate = $command->Call($client, $x, $y) if defined $command;
# warn "deact: $client $w->{'client'}";
$w->Deactivate unless $client->IS($w->{'client'});
my $msg = $client->BalloonInfo($w,$x,$y,'-statusmsg','-balloonmsg');
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;
# cursor is at a position covered by a non client
# pop down the balloon if it is up or scheduled.
foreach my $w (@balloons) {
# switch the balloon to a new 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);
# Execute the user's command and return if it returns false:
my $pos = $command->Call($client);
if ($pos =~ /^(\d+),(\d+)$/) {
# Save the returned position so the Popup method can use it:
$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->{'delay'} = $w->repeat(200, ['Verify', $w, $client]);
if (defined($w->{'subclient'}) && (!defined($data) || $w->{'subclient'} ne $data))
$w->{'subclient'} = $data;
my ($X,$Y) = (@_) ?
@_ : ($w->pointerxy);
my $over = $w->Containing($X,$Y);
return if not defined $over or ($over->toplevel eq $w);
my $deactivate = # DELETE? or move it to the isa-Menu section?:
not $client->IS($w->{'client'})
or (!$client->isa('Tk::Menu') && $w->grabCurrent);
$client->BalloonInfo($w,$X,$Y,'-statusmsg','-balloonmsg');
my $delay = delete $w->{'delay'};
$delay->cancel if defined $delay;
my $client = $w->{'client'};
my $command = $w->GetOption(-cancelcommand
=> $client);
# Execute the user's command and return if it returns false:
return if not $command->Call($client);
$w->{'menu_index'} = 'none';
$w->{'subclient'} = undef;
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');
# Dereference it if it looks like a scalar reference:
$msg = $$msg if UNIVERSAL
::isa
($msg, 'SCALAR');
$w->Subwidget('message')->configure(-text
=> $msg);
return unless Exists
($w);
return unless Exists
($client);
return if $msg eq ''; # Don't popup empty balloons.
my $pos = $w->GetOption(-balloonposition
=> $client);
my $postpos = delete $w->{'clients'}{$client}{'postposition'};
# The postcommand must have returned a position for the balloon - I will use that:
} 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));
croak
"'$pos' is not a valid position for the balloon - it must be one of: 'widget', 'mouse'.";
my($width, $height) = ($w->reqwidth, $w->reqheight);
my $xx = ($x + $width > $w->screenwidth
?
$w->screenwidth - $width
my $yy = ($y + $height > $w->screenheight
?
$w->screenheight - $height
$w->geometry("+$xx+$yy");
#$w->MoveToplevelWindow($x,$y);
#$w->update; # This can cause confusion by processing more Motion events before this one has finished.
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');
# Dereference it if it looks like a scalar reference:
$msg = $$msg if UNIVERSAL
::isa
($msg, 'SCALAR');
eval { $s->configure(-text
=> $msg); };
my $client = $w->{'client'};
my $s = $w->GetOption(-statusbar
=> $client);
if (defined $s and $s->winfo('exists')) {
my $vref = $s->cget(-textvariable
);
eval { $s->configure(-text
=> ''); }
@balloons = grep($w != $_, @balloons);
# Above doesn't seem to work but at least I have removed it from the
# list of balloons and maybe undef'ing the object will get rid of it.