File: balloon.t

package info (click to toggle)
perl-tk 1%3A804.036%2Bdfsg1-5
  • links: PTS, VCS
  • area: main
  • in suites: forky, sid, trixie
  • size: 35,284 kB
  • sloc: ansic: 349,560; perl: 52,292; sh: 12,678; makefile: 5,700; asm: 3,565; ada: 1,681; pascal: 1,082; cpp: 1,006; yacc: 883; cs: 879
file content (127 lines) | stat: -rwxr-xr-x 3,436 bytes parent folder | download | duplicates (8)
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__