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
|
BEGIN
{
$| = 1;
$^W = 1;
eval { require Test; };
if ($@)
{
$^W=0;
print "1..0\n";
print STDERR "\n\tTest.pm module not installed.\n\tGrab it from CPAN to run this test.\n\t";
exit;
}
Test->import;
}
use strict;
##
## Test all widget classes: load module, create, pack, and
## destory an instance. Check in configure does not return
## an error so (some) ConfigSpecs errors are uncovered
##
use vars '@class';
BEGIN
{
@class =
qw(
Cloth
FireButton
NumEntryPlain
NumEntry
TFrame
);
};
my $mw;
BEGIN {
if (!eval {
require Tk;
$mw = Tk::MainWindow->new();
Tk::Exists($mw);
}) {
print "1..0 # skip cannot open DISPLAY\n";
CORE::exit;
}
}
plan test => 10*@class;
my $w;
foreach my $class (@class)
{
print "Testing $class\n";
undef($w);
eval "require Tk::$class;";
ok($@, "", "Error loading Tk::$class");
eval { $w = $mw->$class(); };
ok($@, "", "can't create $class widget");
skip($@, Tk::Exists($w), 1, "$class instance does not exist");
if (Tk::Exists($w))
{
if ($w->isa('Tk::Wm'))
{
# KDE-beta4 wm with policies:
# 'interactive placement'
# okay with geometry and positionfrom
# 'manual placement'
# geometry and positionfrom do not help
eval { $w->positionfrom('user'); };
#eval { $w->geometry('+10+10'); };
ok ($@, "", 'Problem set postitionform to user');
eval { $w->Popup; };
ok ($@, "", "Can't Popup a $class widget")
}
else
{
ok(1); # dummy for above positionfrom test
eval { $w->pack; };
ok ($@, "", "Can't pack a $class widget")
}
eval { $mw->update; };
ok ($@, "", "Error during 'update' for $class widget");
eval { my @dummy = $w->configure; };
ok ($@, "", "Error: configure list for $class");
eval { $mw->update; };
ok ($@, "", "Error: 'update' after configure for $class widget");
eval { $w->destroy; };
ok($@, "", "can't destroy $class widget");
ok(!Tk::Exists($w), 1, "$class: widget not really destroyed");
}
else
{
# Widget $class couldn't be created:
# Popup/pack, update, destroy skipped
for (1..5) { skip (1,1,1, "skipped because widget could not be created"); }
}
}
1;
__END__
|
