#!/usr/bin/perl
use warnings;
use strict;
use Tk;
use Tk::CanvasBalloon;

# the -stipple=>'transparent' option will still 
# allow the bindings to work, but you can see the overlap 
# See Chapter 17 of Mastering Perl/Tk 

my $mw = MainWindow->new();

# first create a canvas widget 
my $canvas = $mw->Canvas(width => 300, height => 200)->pack();

#create a balloon 
my $msg = '';
my $balloon = $mw->CanvasBalloon(
            -initwait        => 0,
    );

my $one = $canvas->createOval(55, 20, 200, 190,
                      -fill => 'blue',
                      -outline=>'blue',
                      -tags => ['blue'],
                      -stipple => 'transparent',
                      );

my $two = $canvas->createOval(105, 20, 250, 190,
                      -fill => 'red',
                      -outline=>'red',
                      -tags => ['red'],
                      -stipple => 'transparent',
                      );

$balloon->attach($canvas, ['blue','red'],
           -balloonmsg => $msg,
        );

my $ebutton = $mw->Button(-text => 'Exit',
                  -command => 'Tk::exit')->pack();

$canvas->Tk::bind("<Motion>", [ \&print_xy, Ev('x'), Ev('y') ]);

MainLoop();

sub print_xy {
  my ($canv, $x, $y) = @_;
  my @tags =();
#trick to find overlapping objects, just use x1 = x and y1 = y 
#to get a rectangular region of 1 point 
my (@current) = $canvas->find('overlapping', $x, $y, $x, $y);

foreach my $id(@current){
    push @tags, $canvas->gettags($id);
}

$msg = join ' ', @tags;
$balloon->Popup($msg);

}
__END__