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
|
BEGIN { $|=1; $^W=1; }
use strict;
BEGIN {
if (!eval q{
use Test::More;
1;
}) {
print "1..0 # skip: no Test::More module\n";
exit;
}
}
use Tk;
BEGIN { plan tests => 19 };
my $mw = Tk::MainWindow->new;
$mw->geometry('+0+0');
my $w = $mw->Label(-text=>'a widget but not a Wm')->grid;
##
## appname (missing until Tk800 until .004)
##
{
my $name;
eval { $name = $w->appname; };
is($@, "", "\$w->appname works");
my ($leaf) = $name =~ /^(\w+)/;
is( $leaf, 'widget', "Appname matches filename" );
is( $mw->name, $name, "\$mw->name is equal to appname");
}
##
## scaling (missing until Tk800 until .004)
##
{
my $scale;
eval { $scale = $w->scaling; };
is($@, "", "\$w->scaling works");
like($scale, qr/^[0-9.]+$/, "Scaling factor is a number: '$scale'" );
}
##
## pathname did not work until Tk800.004
##
{
my $path;
my $c = $w->PathName;
eval { $path = $mw->pathname($w->id); };
is($@, "", "\$mw->pathname works");
is( $path, $c, "Pathname and pathname agree" );
}
##
## Busy/Unbusy
##
{
my $oldcursor = $mw->cget(-cursor);
$mw->update; # make main window viewable, necessary for Busy
$mw->Busy;
is($mw->cget(-cursor), "watch", "The busy cursor");
$mw->after(10);
$mw->Unbusy;
is($mw->cget(-cursor), $oldcursor, "Old cursor restored");
}
##
## Busy/Unbusy with recursion
##
{
my $oldcursor = $mw->cget(-cursor);
my $w2 = $mw->Label(-cursor => "cross")->grid;
$mw->Busy(-recurse => 1, -cursor => "watch");
is($mw->cget(-cursor), "watch", "The busy cursor");
is($w2->cget(-cursor), "watch", "Subwidget has also the busy cursor");
$mw->after(10);
$mw->Unbusy;
is($mw->cget(-cursor), $oldcursor, "Old cursor restored");
is($w2->cget(-cursor), "cross", "Oldsubwidget cursor also restored");
$w2->destroy;
}
## [rt.cpan.org #32858]
{
my $top = $mw->Toplevel;
$top->geometry('+0+0');
$mw->update;
$mw->Busy(-recurse => 1);
for my $w ($mw, $top) {
is(($w->bindtags)[0], 'Busy', "tag 'Busy' set for $w");
is($w->cget('-cursor'), 'watch', "cursor 'watch'set for $w");
}
$mw->Unbusy;
$top->destroy;
}
##
## PathName vs. Widget
##
{
my $path = $w->PathName;
is($mw->Widget($path), $w, "PathName() and Widget()");
}
## [rt.cpan.org #49515]
SKIP: {
skip 'Probably does not work on monochrome displays', 1
if $w->depth == 1;
my $w2 = $mw->Label;
$w2->RecolorTree({background => 'green'});
is($w2->cget('-background'), 'green', 'RecolorTree was effective');
}
1;
__END__
|
