# Balloon, pop up help window when mouse lingers over widget.
my $top = MainWindow
->new;
my $status = $top->Label(-width
=> 60, -relief
=> "sunken", -bd
=> 1, -anchor
=> 'w');
$status->pack(-side
=> "bottom", -fill
=> "y", -padx
=> 2, -pady
=> 1);
# create the widgets to be explained
my $mb = $top->Menubutton(-relief
=> 'raised',
$mb->checkbutton(-label
=> 'checkbutton',
$mb->cascade(-label
=> 'cascade entry');
my $menu = $mb->cget(-menu
);
my $cm = $menu->Menu(-tearoff
=> 0);
$mb->entryconfigure('cascade entry', -menu
=> $cm);
$cm->command(-label
=> 'first');
$cm->command(-label
=> 'second');
$mb->command(-label
=> 'Close',
-command
=> sub {$top->destroy;});
my $b1 = $top->Button(-text
=> "Something Unexpected",
-command
=> sub {$top->destroy;});
my $b2 = $top->Button(-text
=> "Something Else Unexpected");
$b2->configure(-command
=> sub {$b2->destroy;});
# Pack the created widgets:
$mb->pack(-side
=> "top", -expand
=> 1);
$b1->pack(-side
=> "top", -expand
=> 1);
$b2->pack(-side
=> "top", -expand
=> 1);
my $t = $top->Text(-height
=> 10, -cursor
=> 'top_left_arrow')->pack;
Move the mouse cursor over the buttons above and let it linger.
A message will be displayed in status box below and a descriptive
balloon will appear. The top button is a menu button which has
different messages set for each menu entry. This text widget has
a balloon attached to it which will change depending on which word
my $c1 = $top->Canvas(-height
=> 100, -width
=> 300, -bg
=> 'white')->pack(-padx
=> 8, -pady
=> 8);
my $c2 = $top->Canvas(-height
=> 100, -width
=> 300, -bg
=> 'white')->pack(-padx
=> 8, -pady
=> 8);
my $id = $c1->create('text', 10, 10,
-text
=> "This is a canvas. You can also attach\nballoons to specific items in a canvas");
$c1->create('rectangle', 40, 60, 80, 80,
$c1->create('oval', 100, 50, 140, 90,
$c2->create('text', 10, 10,
-text
=> "Or you can attach the balloon\nto the canvas as a whole.");
# create the balloon widget
my $b = $top->Balloon(-statusbar
=> $status);
-msg
=> 'Press and hold this button to see the menu.');
-balloonposition
=> 'mouse',
-msg
=> ['Use this to tear off the menu.',
'This is a checkbox entry.',
'cascade', # Cascade entry (ignored by Balloon)
'separator', # Separator: never active so no message will be displayed for this entry.
'This is a command entry - it will close this window.',
-msg
=> 'This balloon is attached to the cascade menu, not it\'s entries',
#-balloonmsg => 'cm msg.',
-balloonmsg
=> "Close Window",
-statusmsg
=> "Press this button to close this window");
-balloonmsg
=> "Self-destruct\nButton",
-statusmsg
=> "Press this button and it will get rid of itself");
my @word = ('', ''); # Indicies surrounding the current word.
my @last = ('', ''); # Same for last word.
$b->attach($t, -msg
=> \
$msg,
-balloonposition
=> 'mouse', # Not really used since the postcommand returns the real position.
-postcommand
=> sub { if ($word[0] eq $word[1]) {
# No word under mouse - don't post the balloon.
# Have a word under mouse - change the message:
my $word = $t->get($word[0], $word[1]);
# Skip it if it contains non-word chars:
return 0 if $word =~ /\W/;
$msg = "The word under the mouse is: $word";
$t->tag('add', 'sel', $word[0] => $word[1]);
# Find a good place to put the balloon (right below the last char in the word):
my $i = $t->index("$word[1] - 1 chars");
my $x = $t->rootx + $p[0] + $p[2] - 4;
my $y = $t->rooty + $p[1] + $p[3] + 2;
-motioncommand
=> sub { my $x = $t->pointerx - $t->rootx;
my $y = $t->pointery - $t->rooty;
@word = ($t->index("\@$x,$y wordstart"), $t->index("\@$x,$y wordend"));
if ($word[0] eq $last[0] and $word[1] eq $last[1]) {
# Same word - don't cancel the balloon.
# New word under mouse - cancel it so a new balloon will be posted.
-balloonposition
=> 'mouse',
-msg
=> {'rectangle' => 'You are over the red rectangle right now.',
$id => 'You are over the text right now.',
'circle' => 'You are over the blue circle right now.',
-msg
=> 'This balloon is attached to the canvas itself.',
# destroy the balloons when I am destroyed:
# - Balloon.pm adds bindings to all widgets which we now want to remove if we can.
$top->OnDestroy(sub { $b->destroy; });