1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127
|
# -*- perl -*-
use strict;
use Tk;
BEGIN {
if (!eval q{
use Test::More;
1;
}) {
print "1..0 # skip: no Test::More module\n";
exit;
}
}
plan tests => 14;
# Run
# env BATCH=0 perl -Mblib t/balloon.t
# for interactive balloon test
if (!defined $ENV{BATCH}) { $ENV{BATCH} = 1 }
my $mw = Tk::MainWindow->new;
eval { $mw->geometry('+10+10'); }; # This works for mwm and interactivePlacement
my $statusbar = $mw->Label->pack;
my $balloon;
eval { require Tk::Balloon; };
is($@, "", 'Loading Tk::Balloon');
eval { $balloon = $mw->Balloon; };
is($@, "", 'Creating Balloon widget');
ok( Tk::Exists($balloon), "Existance of ballon" );
my $l = $mw->Label->pack;
eval { $balloon->attach($l, -msg => "test"); };
is($@, "", 'Attaching message to Label widget');
eval { $balloon->attach($l, -statusmsg => "test1", -balloonmsg => "test2"); };
is($@, "", 'Attaching statusmsg/baloonmsg to Label widget');
{
my $c = $mw->Canvas(-width => 100, -height => 50)->pack;
my $ci = $c->createLine(0,0,10,10);
eval { $balloon->attach($c, -msg => {$ci => "test"}); };
is($@, "", 'Attaching message to Canvas item');
}
{
my $c = $mw->Scrolled("Canvas", -width => 100, -height => 50)->pack;
my $ci = $c->createLine(0,0,10,10);
eval { $balloon->attach($c, -msg => {$ci => "test"}); };
is($@, "", 'Attaching message to scrolled Canvas item');
}
my $menubar = $mw->Menu;
$mw->configure(-menu => $menubar);
my $filemenu = $menubar->cascade(-label => "~File", -tearoff => 0);
$filemenu->command(-label => "Test1");
$filemenu->command(-label => "Test2");
$filemenu->command(-label => "Test3");
my $filemenu_menu = $filemenu->cget(-menu);
eval { $balloon->attach($filemenu_menu,
-msg => ["Test1 msg", "Test2 msg", "Test3 msg"]); };
is($@, "", 'Attaching message to Menu');
eval { $balloon->configure(-motioncommand => \&motioncmd); };
is($@, "", "Set motioncommand option");
eval { $balloon->configure(-motioncommand => undef); };
is($@, "", "Reset motioncommand option");
{
my $lb = $mw->Listbox(-height => 6)->pack;
$lb->insert("end",1,2,3,4);
eval { $balloon->attach($lb, -msg => ['one','two','three','four']); };
is($@, "", 'Attaching message to Listbox items');
}
{
my $slb = $mw->Scrolled('Listbox', -height => 2)->pack;
$slb->insert("end",1,2,3,4);
eval { $balloon->attach($slb,
-msg => ['one','two','three','four']); };
is($@, "", 'Attaching message to scrolled Listbox items');
}
{
require Tk::NoteBook;
my $nb = $mw->NoteBook->pack;
for (1..4) {
my $p = $nb->add("page$_", -label => "Page$_");
$p->Label(-text => "Page $_")->pack;
}
$balloon->attach($nb,
-balloonposition => 'mouse',
-msg => { page1 => "This is page1",
page2 => "This is page2",
page3 => "This is page3",
page4 => "This is page4",
});
pass("Attached hash ballooninfo to NoteBook");
}
{
my $nb = $mw->NoteBook->pack;
for (1..4) {
my $p = $nb->add("page$_", -label => "Page$_");
$p->Label(-text => "Page $_")->pack;
}
$balloon->attach($nb,
-balloonposition => 'mouse',
-msg => "Balloon applies to whole notebook",
);
pass("Attached scalar ballooninfo to NoteBook");
}
## not yet:
# $l->eventGenerate("<Motion>");
# sub motioncmd {
# my(@args) = @_;
# warn "<<<@args";
# }
MainLoop if !$ENV{BATCH};
sub motioncmd { warn "dummy motioncommand\n" }
__END__
|