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
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
|
#!/usr/bin/perl -w
# -*- perl -*-
#
# $Id: $
#
use strict;
use Data::Dumper;
use Getopt::Long;
use Tk;
use Tk::Balloon;
use Tk::Canvas;
BEGIN {
if (!eval q{
use Test::More;
1;
}) {
print "1..0 # skip: no Test::More module\n";
exit;
}
}
my @dashes1 = ([4,4],
[2,2],
[1,1],
[8,8],
[16,16],
[1,2,3,4,5,6],
'.',
'. ',
',',
', ',
'-',
'- ',
'_',
'_ ',
'.,-_',
#'.,-_.,-_.,-_.,-_', # dumps core!
);
my @dashes2 = (
# now equivalent pairs
'.', [2,4],
'-', [6,4],
'-.', [6,4,2,4],
'-..', [6,4,2,4,2,4],
'. ', [2,8],
',', [4,4],
);
my @dashes;
push @dashes, map { +{dash => $_, width => 1} } @dashes1;
push @dashes, map { +{dash => $_, width => 2} } @dashes2;
plan tests => 6 + 3 * @dashes;
my $show;
GetOptions("show!" => \$show)
or die "usage: $0 [-show]";
my $mw = MainWindow->new;
$mw->geometry("+10+10");
my $b = $mw->Balloon(-initwait => 50, -balloonposition => 'mouse');
$b->Subwidget("message")->configure(-font => "monospace");
{
local $TODO;
$TODO = "Dash errors not yet corrected" if $Tk::VERSION < 804.027502;
my $c = $mw->Canvas;
eval { $c->createLine(0,0,1,1,-dash => [4]) };
like($@, qr{\Qbad dash list "4": must be a list of integers or a format like "-.."}, "error with one number in list");
eval { $c->createLine(0,0,1,1,-dash => 4) };
like($@, qr{\Qbad dash list "4": must be a list of integers or a format like "-.."}, "error with one number in list");
eval { $c->createLine(0,0,1,1,-dash => ',;') };
like($@, qr{\Qbad dash list ",;": must be a list of integers or a format like "-.."}, "error with bad dash list");
eval { $c->createLine(0,0,1,1,-dash => ['x',4]) };
like($@, qr{\Qexpected integer in the range 1..255 but got "x"}, "non-integer in dash list");
}
{
use constant DIR_HORIZ => 0;
use constant DIR_DIAG => 1;
use constant DIR_VERT => 2;
my @c;
my @itemlabel;
for (0 .. 2) {
$c[$_] = $mw->Canvas(-height => 20 + 6 * @dashes)->pack;
$itemlabel[$_] = {};
$b->attach($c[$_], -msg => $itemlabel[$_]);
}
$mw->update; # to refresh Width/Height
my $c_x2 = $c[0]->Width - 10;
my $c_y2 = $c[0]->Height - 10;
for my $dir (DIR_HORIZ, DIR_DIAG, DIR_VERT) {
my $x = 10;
my $y = 10;
my $x2 = $dir == DIR_VERT ? $x : $c_x2;
my $y2 = $dir == DIR_HORIZ ? $y : $dir == DIR_DIAG ? $y + 20 : $c_y2;
my $xd = $dir == DIR_VERT ? 6 : 0;
my $yd = $dir == DIR_VERT ? 0 : 6;
for my $def (@dashes) {
my($dash, $width) = @{$def}{qw(dash width)};
my $dash_printable = Data::Dumper->new([$dash],['dash'])->Indent(0)->Dump;
my $item = $c[$dir]->createLine($x, $y, $x2, $y2, -width => $width, -dash => $dash);
pass("Created dash $dash_printable (direction=$dir)");
$itemlabel[$dir]->{$item} = $dash_printable;
$x +=$xd;
$x2+=$xd;
$y +=$yd;
$y2+=$yd;
}
}
}
{
eval { $mw->Canvas(-scrollregion => "1 2") };
like $@, qr{bad scrollRegion "1 2"}, "Expected error message for bad scrollregion";
}
{
my $c = $mw->Canvas;
my $item = $c->createText(0,0,-text=>"foo");
eval { $c->select('clear',$item,"bla","foo") };
# This used to segfault for Tk <= 804.029_501
like $@, qr{\Qwrong # args: should be ".canvas\E\d+\Q select clear tagOrId index"}, 'select clear error message';
$c->destroy;
}
if (!$show) {
$mw->after(1000, sub { $mw->destroy });
}
MainLoop;
__END__
|
