#
# The help widget that provides both "balloon" and "status bar"
# types of help messages.
#
# This is a patched version of Balloon 3.037 - it adds support
# for different orientations of the balloon widget, depending
# on wether there's enough space for it. The little arrow now
# should always point directly to the client.
# Added by Gerhard Petrowitsch (gerhard.petrowitsch@philips.com)
#
# Nov 1, 2003 - Jack Dunnigan
# Added support for more than one screen in single logical
# screen mode (i.e. xinerama, dual monitors)
package Tk::Balloon;
use vars qw($VERSION);
$VERSION = '4.012'; # was: sprintf '4.%03d', q$Revision: #10 $ =~ /\D(\d+)\s*$/;
use Tk qw(Ev Exists);
use Carp;
require Tk::Toplevel;
Tk::Widget->Construct('Balloon');
use base qw(Tk::Toplevel);
# use UNIVERSAL; avoid the UNIVERSAL.pm file subs are XS in perl core
use strict;
my @balloons;
my $button_up = 0;
my %arrows = ( TL => 'R0lGODlhBgAGAJEAANnZ2QAAAP///////yH5BAEAAAAALAAAAAAGAAYAAAINjA0HAEdwLCwMKIQfBQA7',
TR => 'R0lGODlhBgAGAJEAANnZ2QAAAP///////yH5BAEAAAAALAAAAAAGAAYAAAIRBGMDwAEQkgAIAAoCABEEuwAAOw==',
BR => 'R0lGODlhBgAGAJEAANnZ2QAAAP///////yH5BAEAAAAALAAAAAAGAAYAAAIPDOHHhYVRAIgIAEISQLELADs=',
BL => 'R0lGODlhBgAGAJEAANnZ2QAAAP///////yH5BAEAAAAALAAAAAAGAAYAAAIPhB1xAUFALCIMKAaAWQAVADs=',
NO => 'R0lGODlhAQABAJEAANnZ2f///////////yH5BAEAAAAALAAAAAABAAEAAAICRAEAOw=='
);
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;
# Only the container frame's background should be black... makes it
# look better.
$w->configure(-background => 'black');
# the balloon arrows
$w->{img_tl} = $w->Photo(-data => $arrows{TL}, -format => 'gif');
$w->{img_tr} = $w->Photo(-data => $arrows{TR}, -format => 'gif');
$w->{img_bl} = $w->Photo(-data => $arrows{BL}, -format => 'gif');
$w->{img_br} = $w->Photo(-data => $arrows{BR}, -format => 'gif');
$w->{img_no} = $w->Photo(-data => $arrows{NO}, -format => 'gif');
$w->OnDestroy([$w, '_destroyed']);
$w->{'pointer'} = $w->Label(-bd=>0, -relief=>'flat',-image=>$w->{img_no});
# the balloon message
# We give the Label a big borderwidth
# ..enough to slide a 6x6 gif image along the border including some space
my $ml = $w->Label(-bd => 0,
-padx => 10,
-pady => 3,
-justify => 'left',
-relief=>'flat');
$w->Advertise('message' => $ml);
$ml->pack(
-side => 'top',
-anchor => 'nw',
-expand => 1,
-fill => 'both',
-padx => 0,
-pady => 0);
# append to global list of balloons
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->{'current_screen'} = 0;
$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'],
-foreground => ['DESCENDANTS', 'foreground', 'Foreground', undef],
-font => [$ml, 'font', 'Font', '-*-helvetica-medium-r-normal--*-120-*-*-*-*-*-*'],
-borderwidth => ['SELF', 'borderWidth', 'BorderWidth', 1],
-numscreens=>['PASSIVE', 'numScreens','NumScreens',1],
);
}
sub _get_client {
my ($w, $client) = @_;
if ($client->can("Subwidget") and my $scrolled = $client->Subwidget("scrolled")) {
$scrolled;
} else {
$client;
}
}
# attach a client to the balloon
sub attach {
my ($w, $client, %args) = @_;
$client = $w->_get_client($client);
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.
sub detach {
my ($w, $client) = @_;
$client = $w->_get_client($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;
# Find which window we are over
my $over = $ewin->Containing($x, $y);
return if &grabBad($ewin, $over);
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
my $client = $over;
while (defined $client) {
last if (exists $w->{'clients'}{$client});
if ($client->can("MasterMenu")) {
my $master = $client->MasterMenu;
if ($master && exists $w->{'clients'}{$master}) {
$w->{'clients'}{$client} = $w->{'clients'}{$master};
last;
}
}
$client = $client->Parent;
}
if (defined $client) {
# popping up disabled -- ignore
my $state = $w->GetOption(-state => $client);
next if $state eq 'none';
# Check if a button was recently released:
my $deactivate = 0;
if ($button_up) {
$deactivate = 1;
$button_up = 0;
}
# Deactivate it if the motioncommand says to:
my $command = $w->GetOption(-motioncommand => $client);
$deactivate = $command->Call($client, $x, $y) if defined $command;
if ($deactivate)
{
$w->Deactivate;
}
else
{
# warn "deact: $client $w->{'client'}";
$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 {
# cursor is at a position covered by a non client
# pop down the balloon if it is up or scheduled.
$w->Deactivate;
}
}
}
sub ButtonDown {
my ($ewin) = @_;
foreach my $w (@balloons) {
$w->Deactivate;
}
}
sub ButtonUp {
$button_up = 1;
}
# switch the balloon to a new client
sub SwitchToClient {
my ($w, $client) = @_;
return unless Exists($w);
return unless Exists($client);
return unless $client->IS($w->{'client'});
return if &grabBad($w, $client);
my $command = $w->GetOption(-postcommand => $client);
if (defined $command) {
# Execute the user's command and return if it returns false:
my $pos = $command->Call($client);
return if not $pos;
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->{'popped'} = 1;
$w->{'delay'} = $w->repeat(200, ['Verify', $w, $client]);
}
sub grabBad {
my ($w, $client) = @_;
return 0 unless Exists($client);
my $g = $w->grabCurrent;
return 0 unless defined $g;
return 0 if $g->isa('Tk::Menu');
return 0 if $g eq $client;
# Ignore grab check if $w is the balloon itself.
# XXX Why is this necessary? Is it possible to remove the grabBad
# condition in SwitchToClient altogether?
return 0 if $w->isa(__PACKAGE__);
# The grab is OK if $client is a decendant of $g. Use the internal Tcl/Tk
# pathname (yes, it's cheating, but it's legal).
return 0 if $g == $w->MainWindow;
my $wp = $w->PathName;
my $gp = $g->PathName;
return 0 if $wp =~ /^$gp/;
return 1; # bad grab
} # end grabBad
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 = # DELETE? or move it to the isa-Menu section?:
# ($over ne $client) or
not $client->IS($w->{'client'})
# or (!$client->isa('Tk::Menu') && $w->grabCurrent);
# or $w->grabbad($client);
or &grabBad($w, $client);
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) {
# Execute the user's command and return if it returns false:
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;
$w->{'location'} = 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');
# Dereference it if it looks like a scalar reference:
$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 ''; # Don't popup empty balloons.
my ($x, $y);
my $pos = $w->GetOption(-balloonposition => $client);
my $postpos = delete $w->{'clients'}{$client}{'postposition'};
if (defined $postpos) {
# The postcommand must have returned a position for the balloon - I will use that:
($x,$y) = @{$postpos};
} elsif ($pos eq 'mouse') {
($x,$y)=$client->pointerxy; # We adjust the position later
} 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;
# Explanation of following code. [JD]
# PREMISE: We want to ensure that the balloon is always "on screen".
# To do this we use calculate the size of the
# toplevel before it is mapped. Then we adjust it's position with respect to the
# mouse cursor or widget. Balloons are usually shown below and to the right of the target.
# From extensive KDE experience using Xinerama, and from using dual monitors on WinXP..
# the balloon will extend across two monitors in single logical screen mode (SLS).
# This is an undesirable characteristic indeed. Trying to read a disjointed balloon
# across monitors is not fun.
#
# The intent of the following code is to fix this problem. We do this by avoiding
# placement of any part of the balloon over,say, the "half screenwidth" mark (for two
# monitors in SLS mode) or "thirds of screenwidth" mark (for 3 monitors) and so on...
# i.e. In SLS mode these *WILL BE* separate screens and as such, should be considered hard
# boundaries to be avoided.
#
# The only drawback of this code, is I know of no way to actually determine this on a
# user by user basis. This means that the developer or administrator will have to know
# the hardware (monitor) setup for which the application is designed.
#
# This code uses Gerhard's GIF images but changes *how* the image gets shown. Instead
# of creating four separate labels, we configure only ONE label with the proper image.
# Then using the place geometry manager, this image/label can be "slid" along the
# appropriate side of the toplevel so that it always points directly at the target widget.
#
# Here we go..
my ($width, $height) = ($w->reqwidth, $w->reqheight);
my ($sw, $sh) = ($w->screenwidth, $w->screenheight);
my $numscreen = $w->cget(-numscreens);
my $deltax = $sw/$numscreen;
my $leftedge;
my $rightedge;
my $count = 0;
for (my $i=0; $i<$sw; $i+=$deltax){
$leftedge = $i;
$rightedge = $i + $deltax;
if ($x >= $leftedge && $x < $rightedge ){
last;
}
$count++;
}
# Force another look at balloon location because mouse has switched
# virtual screens.
$w->{'location'} = undef unless ( $count == $w->{'current_screen'} );
$w->{'current_screen'} = $count;
my $xx=undef;
my $yy=undef; # to hold final toplevel placement
my $slideOffsetX = 0;
my $slideOffsetY = 0;
my $cornerOffset = 5; #default - keep corner away from pointer
my $testtop = $y - $height - $cornerOffset;
my $testbottom = $y + $height + (2*$cornerOffset);
my $testright = $x + $width + (2*$cornerOffset);
my $testleft = $x - $width - $cornerOffset;
my $vert='bottom'; #default
my $horiz='right'; #default
if ( defined $w->{'location'} ){
# Once balloon is activated, **don't** change the location of the balloon.
# It is annoying to have it jump from one location to another.
( $w->{'location'}=~/top/ ) ? ( $vert = 'top' ) : ( $vert = 'bottom' );
( $w->{'location'}=~/left/ ) ? ( $horiz = 'left' ) : ( $horiz = 'right' );
if ($vert eq 'top' && $testtop < 0) {
$yy = 0;
$slideOffsetY = $testtop;
}
elsif ($vert eq 'bottom' && $testbottom > $sh) {
$slideOffsetY = $testbottom - $sh;
}
if ($horiz eq 'left' && $testleft < $leftedge) {
$xx = $leftedge;
}
elsif ($horiz eq 'right' && $testright > $rightedge) {
$slideOffsetX = $testright - $rightedge;
}
}
else {
#Test balloon positions in the vertical
if ($testbottom > $sh) {
#Then offscreen to bottom, check top
if ($testtop >= 0) {
$vert = 'top';
}
elsif ($y > $sh/2) {
#still offscreen to top but there is more room above then below
$vert = 'top';
$yy=0;
$slideOffsetY = $testtop;
}
if ($vert eq 'bottom'){
#Calculate Yoffset to fit entire balloon onto screen
$slideOffsetY = $testbottom - $sh;
}
}
#Test balloon positions in the horizontal
if ($testright > $rightedge) {
#The offscreen, check left
if ($testleft >= $leftedge) {
$horiz = 'left';
}
elsif ($x > ($leftedge+$deltax) ) {
#still offscreen to left but there is more room to left than right
$horiz = 'left';
$xx=0;
$slideOffsetX = $testleft;
}
if ($horiz eq 'right'){
#Calculate Xoffset to fit entire balloon onto screen
$slideOffsetX = $testright - $rightedge;
}
}
}
$w->{'location'} = $vert.$horiz unless (defined $w->{'location'});
if ($w->{'location'} eq 'bottomright') {
if ( $slideOffsetX or $slideOffsetY ) {
$w->{'pointer'}->configure(-image => $w->{img_no});
}
else {
$w->{'pointer'}->configure(-image => $w->{img_tl});
}
$w->{'pointer'}->place(
-in=>$w,
# -relx=>0, -x=>$slideOffsetX + 2,
# -rely=>0, -y=>$slideOffsetY + 2,
-relx=>0, -x=>2,
-rely=>0, -y=>2,
-bordermode=>'outside',
-anchor=>'nw');
$xx=$x-$slideOffsetX+(2*$cornerOffset) unless (defined $xx);
$yy=$y-$slideOffsetY+(2*$cornerOffset) unless (defined $yy);
}
elsif ($w->{'location'} eq 'bottomleft') {
if ( $slideOffsetX or $slideOffsetY ) {
$w->{'pointer'}->configure(-image => $w->{img_no});
}
else {
$w->{'pointer'}->configure(-image => $w->{img_tr});
}
$w->{'pointer'}->place(-in=>$w,
# -relx=>1, -x=>$slideOffsetX - 2,
# -rely=>0, -y=>$slideOffsetY + 2,
-relx=>1, -x=>-2,
-rely=>0, -y=>2,
-bordermode=>'outside',
-anchor=>'ne');
$xx=$x-$width-$slideOffsetX-$cornerOffset unless (defined $xx);
$yy=$y-$slideOffsetY+(2*$cornerOffset) unless (defined $yy);
}
elsif ($w->{'location'} eq 'topright') {
if ( $slideOffsetX or $slideOffsetY ) {
$w->{'pointer'}->configure(-image => $w->{img_no});
}
else {
$w->{'pointer'}->configure(-image => $w->{img_bl});
}
$w->{'pointer'}->place(-in=>$w,
# -relx=>0, -x=>$slideOffsetX + 2,
# -rely=>1, -y=>$slideOffsetY - 2,
-relx=>0, -x=>2,
-rely=>1, -y=>-2,
-bordermode=>'outside',
-anchor=>'sw');
$xx=$x-$slideOffsetX+$cornerOffset unless (defined $xx);
$yy=$y-$height-$slideOffsetY-$cornerOffset unless (defined $yy);
}
elsif ($w->{'location'} eq 'topleft') {
if ( $slideOffsetX or $slideOffsetY ) {
$w->{'pointer'}->configure(-image => $w->{img_no});
}
else {
$w->{'pointer'}->configure(-image => $w->{img_br});
}
$w->{'pointer'}->place(-in=>$w,
# -relx=>1, -x=>$slideOffsetX - 2,
# -rely=>1, -y=>$slideOffsetY - 2,
-relx=>1, -x=>-2,
-rely=>1, -y=>-2,
-bordermode=>'outside',
-anchor=>'se');
$xx=$x-$width-$slideOffsetX-$cornerOffset unless (defined $xx);
$yy=$y-$height-$slideOffsetY-$cornerOffset unless (defined $yy);
}
$w->{'pointer'}->raise;
$xx = int($xx);
$yy = int($yy);
$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');
# Dereference it if it looks like a scalar reference:
$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 _destroyed {
my ($w) = @_;
# This is called when widget is destroyed (no matter how!)
# via the ->OnDestroy hook set in Populate.
# remove ourselves from the list of baloons.
@balloons = grep($w != $_, @balloons);
# FIXME: If @balloons is now empty perhaps remove the 'all' bindings
# to reduce overhead until another balloon is created?
# Delete the images
for (qw(no tl tr bl br)) {
my $img = delete $w->{"img_$_"};
$img->delete if defined $img;
}
}
1;