#!/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__