#!perl -w
# some of this is tested in t01introvert.t too
use strict;
-my $loaded;
-BEGIN {
- require "t/testtools.pl";
- $| = 1; print "1..57\n";
-}
-END { okx(0, "loading") unless $loaded; }
-use Imager;
-$loaded = 1;
+use Test::More tests => 126;
+BEGIN { use_ok("Imager"); }
+
+use Imager::Test qw(image_bounds_checks test_image is_color3);
-okx(1, "Loaded");
+sub isbin($$$);
my $img = Imager->new(xsize=>50, ysize=>50, type=>'paletted');
-okx($img, "paletted image created");
+ok($img, "paletted image created");
-okx($img->type eq 'paletted', "got a paletted image");
+is($img->type, 'paletted', "got a paletted image");
my $black = Imager::Color->new(0,0,0);
my $red = Imager::Color->new(255,0,0);
my $blacki = $img->addcolors(colors=>[ $black, $red, $green, $blue ]);
print "# blacki $blacki\n";
-okx(defined $blacki && $blacki == 0, "we got the first color");
+ok(defined $blacki && $blacki == 0, "we got the first color");
-okx($img->colorcount() == 4, "should have 4 colors");
+ok($img->colorcount() == 4, "should have 4 colors");
my ($redi, $greeni, $bluei) = 1..3;
my @all = $img->getcolors;
-okx(@all == 4, "all colors is 4");
+ok(@all == 4, "all colors is 4");
coloreq($all[0], $black, "first black");
coloreq($all[1], $red, "then red");
coloreq($all[2], $green, "then green");
# get all up to the last (count defaulting to size-index) we'd get a
# false positive
my $one_color = $img->getcolors(start=>$redi);
-okx($one_color->isa('Imager::Color'), "check scalar context");
+ok($one_color->isa('Imager::Color'), "check scalar context");
coloreq($one_color, $red, "and that it's what we want");
# make sure we can find colors
-okx(!defined($img->findcolor(color=>$white)),
+ok(!defined($img->findcolor(color=>$white)),
"shouldn't be able to find white");
-okx($img->findcolor(color=>$black) == $blacki, "find black");
-okx($img->findcolor(color=>$red) == $redi, "find red");
-okx($img->findcolor(color=>$green) == $greeni, "find green");
-okx($img->findcolor(color=>$blue) == $bluei, "find blue");
+ok($img->findcolor(color=>$black) == $blacki, "find black");
+ok($img->findcolor(color=>$red) == $redi, "find red");
+ok($img->findcolor(color=>$green) == $greeni, "find green");
+ok($img->findcolor(color=>$blue) == $bluei, "find blue");
# various failure tests for setcolors
-okx(!defined($img->setcolors(start=>-1, colors=>[$white])),
+ok(!defined($img->setcolors(start=>-1, colors=>[$white])),
"expect failure: low index");
-okx(!defined($img->setcolors(start=>1, colors=>[])),
+ok(!defined($img->setcolors(start=>1, colors=>[])),
"expect failure: no colors");
-okx(!defined($img->setcolors(start=>5, colors=>[$white])),
+ok(!defined($img->setcolors(start=>5, colors=>[$white])),
"expect failure: high index");
# set the green index to white
-okx($img->setcolors(start => $greeni, colors => [$white]),
+ok($img->setcolors(start => $greeni, colors => [$white]),
"set a color");
# and check it
coloreq(scalar($img->getcolors(start=>$greeni)), $white,
"make sure it was set");
-okx($img->findcolor(color=>$white) == $greeni, "and that we can find it");
-okx(!defined($img->findcolor(color=>$green)), "and can't find the old color");
+ok($img->findcolor(color=>$white) == $greeni, "and that we can find it");
+ok(!defined($img->findcolor(color=>$green)), "and can't find the old color");
# write a few colors
-okx(scalar($img->setcolors(start=>$redi, colors=>[ $green, $red])),
+ok(scalar($img->setcolors(start=>$redi, colors=>[ $green, $red])),
"save multiple");
coloreq(scalar($img->getcolors(start=>$redi)), $green, "first of multiple");
coloreq(scalar($img->getcolors(start=>$greeni)), $red, "second of multiple");
$img->setcolors(start=>$red, colors=>[$red, $green]);
# draw on the image, make sure it stays paletted when it should
-okx($img->box(color=>$red, filled=>1), "fill with red");
-okx($img->type eq 'paletted', "paletted after fill");
-okx($img->box(color=>$green, filled=>1, xmin=>10, ymin=>10,
+ok($img->box(color=>$red, filled=>1), "fill with red");
+is($img->type, 'paletted', "paletted after fill");
+ok($img->box(color=>$green, filled=>1, xmin=>10, ymin=>10,
xmax=>40, ymax=>40), "green box");
-okx($img->type eq 'paletted', 'still paletted after box');
+is($img->type, 'paletted', 'still paletted after box');
# an AA line will almost certainly convert the image to RGB, don't use
# an AA line here
-okx($img->line(color=>$blue, x1=>10, y1=>10, x2=>40, y2=>40),
+ok($img->line(color=>$blue, x1=>10, y1=>10, x2=>40, y2=>40),
"draw a line");
-okx($img->type eq 'paletted', 'still paletted after line');
+is($img->type, 'paletted', 'still paletted after line');
# draw with white - should convert to direct
-okx($img->box(color=>$white, filled=>1, xmin=>20, ymin=>20,
+ok($img->box(color=>$white, filled=>1, xmin=>20, ymin=>20,
xmax=>30, ymax=>30), "white box");
-okx($img->type eq 'direct', "now it should be direct");
+is($img->type, 'direct', "now it should be direct");
# various attempted to make a paletted image from our now direct image
my $palimg = $img->to_paletted;
-okx($palimg, "we got an image");
+ok($palimg, "we got an image");
# they should be the same pixel for pixel
-okx(Imager::i_img_diff($img->{IMG}, $palimg->{IMG}) == 0, "same pixels");
+ok(Imager::i_img_diff($img->{IMG}, $palimg->{IMG}) == 0, "same pixels");
# strange case: no color picking, and no colors
# this was causing a segmentation fault
$palimg = $img->to_paletted(colors=>[ ], make_colors=>'none');
-okx(!defined $palimg, "to paletted with an empty palette is an error");
+ok(!defined $palimg, "to paletted with an empty palette is an error");
print "# ",$img->errstr,"\n";
-okx(scalar($img->errstr =~ /no colors available for translation/),
+ok(scalar($img->errstr =~ /no colors available for translation/),
"and got the correct msg");
-okx(!Imager->new(xsize=>1, ysize=>-1, type=>'paletted'),
+ok(!Imager->new(xsize=>1, ysize=>-1, type=>'paletted'),
"fail on -ve height");
-matchx(Imager->errstr, qr/Image sizes must be positive/,
+cmp_ok(Imager->errstr, '=~', qr/Image sizes must be positive/,
"and correct error message");
-okx(!Imager->new(xsize=>-1, ysize=>1, type=>'paletted'),
+ok(!Imager->new(xsize=>-1, ysize=>1, type=>'paletted'),
"fail on -ve width");
-matchx(Imager->errstr, qr/Image sizes must be positive/,
+cmp_ok(Imager->errstr, '=~', qr/Image sizes must be positive/,
"and correct error message");
-okx(!Imager->new(xsize=>-1, ysize=>-1, type=>'paletted'),
+ok(!Imager->new(xsize=>-1, ysize=>-1, type=>'paletted'),
"fail on -ve width/height");
-matchx(Imager->errstr, qr/Image sizes must be positive/,
+cmp_ok(Imager->errstr, '=~', qr/Image sizes must be positive/,
"and correct error message");
-okx(!Imager->new(xsize=>1, ysize=>1, type=>'paletted', channels=>0),
+ok(!Imager->new(xsize=>1, ysize=>1, type=>'paletted', channels=>0),
"fail on 0 channels");
-matchx(Imager->errstr, qr/Channels must be positive and <= 4/,
+cmp_ok(Imager->errstr, '=~', qr/Channels must be positive and <= 4/,
"and correct error message");
-okx(!Imager->new(xsize=>1, ysize=>1, type=>'paletted', channels=>5),
+ok(!Imager->new(xsize=>1, ysize=>1, type=>'paletted', channels=>5),
"fail on 5 channels");
-matchx(Imager->errstr, qr/Channels must be positive and <= 4/,
+cmp_ok(Imager->errstr, '=~', qr/Channels must be positive and <= 4/,
"and correct error message");
{
# least and may result in running out of memory, causing a different
# type of exit
use Config;
- if ($Config{ivsize} == 4) {
- my $uint_range = 256 ** $Config{ivsize};
+ SKIP:
+ {
+ skip("don't want to allocate 4Gb", 10)
+ unless $Config{intsize} == 4;
+
+ my $uint_range = 256 ** $Config{intsize};
my $dim1 = int(sqrt($uint_range))+1;
my $im_b = Imager->new(xsize=>$dim1, ysize=>$dim1, channels=>1, type=>'paletted');
- isx($im_b, undef, "integer overflow check - 1 channel");
+ is($im_b, undef, "integer overflow check - 1 channel");
$im_b = Imager->new(xisze=>$dim1, ysize=>1, channels=>1, type=>'paletted');
- okx($im_b, "but same width ok");
+ ok($im_b, "but same width ok");
$im_b = Imager->new(xisze=>1, ysize=>$dim1, channels=>1, type=>'paletted');
- okx($im_b, "but same height ok");
- matchx(Imager->errstr, qr/integer overflow/,
+ ok($im_b, "but same height ok");
+ cmp_ok(Imager->errstr, '=~', qr/integer overflow/,
"check the error message");
# do a similar test with a 3 channel image, so we're sure we catch
my $dim3 = $dim1;
$im_b = Imager->new(xsize=>$dim3, ysize=>$dim3, channels=>3, type=>'paletted');
- isx($im_b, undef, "integer overflow check - 3 channel");
+ is($im_b, undef, "integer overflow check - 3 channel");
- $im_b = Imager->new(xisze=>$dim3, ysize=>1, channels=>3, type=>'paletted');
- okx($im_b, "but same width ok");
- $im_b = Imager->new(xisze=>1, ysize=>$dim3, channels=>3, type=>'paletted');
- okx($im_b, "but same height ok");
+ $im_b = Imager->new(xsize=>$dim3, ysize=>1, channels=>3, type=>'paletted');
+ ok($im_b, "but same width ok");
+ $im_b = Imager->new(xsize=>1, ysize=>$dim3, channels=>3, type=>'paletted');
+ ok($im_b, "but same height ok");
- matchx(Imager->errstr, qr/integer overflow/,
+ cmp_ok(Imager->errstr, '=~', qr/integer overflow/,
"check the error message");
+
+ # test the scanline allocation check
+ # divide by 2 to get int range, by 3 so that the image (one byte/pixel)
+ # doesn't integer overflow, but the scanline of i_color (4/pixel) does
+ my $dim4 = $uint_range / 2 / 3;
+ my $im_o = Imager->new(xsize=>$dim4, ysize=>1, channels=>3, type=>'paletted');
+ is($im_o, undef, "integer overflow check - scanline size");
+ cmp_ok(Imager->errstr, '=~',
+ qr/integer overflow calculating scanline allocation/,
+ "check error message");
}
- else {
- skipx(8, "don't want to allocate 4Gb");
+}
+
+{ # http://rt.cpan.org/NoAuth/Bug.html?id=9672
+ my $warning;
+ local $SIG{__WARN__} =
+ sub {
+ $warning = "@_";
+ my $printed = $warning;
+ $printed =~ s/\n$//;
+ $printed =~ s/\n/\n\#/g;
+ print "# ",$printed, "\n";
+ };
+ my $img = Imager->new(xsize=>10, ysize=>10);
+ $img->to_paletted();
+ cmp_ok($warning, '=~', 'void', "correct warning");
+ cmp_ok($warning, '=~', 't023palette\\.t', "correct file");
+}
+
+{ # http://rt.cpan.org/NoAuth/Bug.html?id=12676
+ # setcolors() has a fencepost error
+ my $img = Imager->new(xsize=>10, ysize=>10, type=>'paletted');
+
+ is($img->addcolors(colors=>[ $black, $red ]), "0 but true",
+ "add test colors");
+ ok($img->setcolors(start=>1, colors=>[ $green ]), "set the last color");
+ ok(!$img->setcolors(start=>2, colors=>[ $black ]),
+ "set after the last color");
+}
+
+{ # https://rt.cpan.org/Ticket/Display.html?id=20056
+ # added named color support to addcolor/setcolor
+ my $img = Imager->new(xsize => 10, ysize => 10, type => 'paletted');
+ is($img->addcolors(colors => [ qw/000000 FF0000/ ]), "0 but true",
+ "add colors as strings instead of objects");
+ my @colors = $img->getcolors;
+ iscolor($colors[0], $black, "check first color");
+ iscolor($colors[1], $red, "check second color");
+ ok($img->setcolors(colors => [ qw/00FF00 0000FF/ ]),
+ "setcolors as strings instead of objects");
+ @colors = $img->getcolors;
+ iscolor($colors[0], $green, "check first color");
+ iscolor($colors[1], $blue, "check second color");
+
+ # make sure we handle bad colors correctly
+ is($img->colorcount, 2, "start from a known state");
+ is($img->addcolors(colors => [ 'XXFGXFXGXFX' ]), undef,
+ "fail to add unknown color");
+ is($img->errstr, 'No color named XXFGXFXGXFX found', 'check error message');
+ is($img->setcolors(colors => [ 'XXFGXFXGXFXZ' ]), undef,
+ "fail to set to unknown color");
+ is($img->errstr, 'No color named XXFGXFXGXFXZ found', 'check error message');
+}
+
+{ # https://rt.cpan.org/Ticket/Display.html?id=20338
+ # OO interface to i_glin/i_plin
+ my $im = Imager->new(xsize => 10, ysize => 10, type => 'paletted');
+ is($im->addcolors(colors => [ "#000", "#F00", "#0F0", "#00F" ]), "0 but true",
+ "add some test colors")
+ or print "# ", $im->errstr, "\n";
+ # set a pixel to check
+ $im->setpixel(x => 1, 'y' => 0, color => "#0F0");
+ is_deeply([ $im->getscanline('y' => 0, type=>'index') ],
+ [ 0, 2, (0) x 8 ], "getscanline index in list context");
+ isbin($im->getscanline('y' => 0, type=>'index'),
+ "\x00\x02" . "\x00" x 8,
+ "getscanline index in scalar context");
+ is($im->setscanline('y' => 0, pixels => [ 1, 2, 0, 3 ], type => 'index'),
+ 4, "setscanline with list");
+ is($im->setscanline('y' => 0, x => 4, pixels => pack("C*", 3, 2, 1, 0, 3),
+ type => 'index'),
+ 5, "setscanline with pv");
+ is_deeply([ $im->getscanline(type => 'index', 'y' => 0) ],
+ [ 1, 2, 0, 3, 3, 2, 1, 0, 3, 0 ],
+ "check values set");
+ eval { # should croak on OOR index
+ $im->setscanline('y' => 1, pixels => [ 255 ], type=>'index');
+ };
+ ok($@, "croak on setscanline() to invalid index");
+ eval { # same again with pv
+ $im->setscanline('y' => 1, pixels => "\xFF", type => 'index');
+ };
+ ok($@, "croak on setscanline() with pv to invalid index");
+}
+
+{
+ print "# make_colors => mono\n";
+ # test mono make_colors
+ my $imrgb = Imager->new(xsize => 10, ysize => 10);
+ $imrgb->setpixel(x => 0, 'y' => 0, color => '#FFF');
+ $imrgb->setpixel(x => 1, 'y' => 0, color => '#FF0');
+ $imrgb->setpixel(x => 2, 'y' => 0, color => '#000');
+ my $mono = $imrgb->to_paletted(make_colors => 'mono',
+ translate => 'closest');
+ is($mono->type, 'paletted', "check we get right image type");
+ is($mono->colorcount, 2, "only 2 colors");
+ my ($is_mono, $ziw) = $mono->is_bilevel;
+ ok($is_mono, "check monochrome check true");
+ is($ziw, 0, "check ziw false");
+ my @colors = $mono->getcolors;
+ iscolor($colors[0], $black, "check first entry");
+ iscolor($colors[1], $white, "check second entry");
+ my @pixels = $mono->getscanline(x => 0, 'y' => 0, width => 3, type=>'index');
+ is($pixels[0], 1, "check white pixel");
+ is($pixels[1], 1, "check yellow pixel");
+ is($pixels[2], 0, "check black pixel");
+}
+
+{ # check for the various mono images we accept
+ my $mono_8_bw_3 = Imager->new(xsize => 2, ysize => 2, channels => 3,
+ type => 'paletted');
+ ok($mono_8_bw_3->addcolors(colors => [ qw/000000 FFFFFF/ ]),
+ "mono8bw3 - add colors");
+ ok($mono_8_bw_3->is_bilevel, "it's mono");
+ is(($mono_8_bw_3->is_bilevel)[1], 0, 'zero not white');
+
+ my $mono_8_wb_3 = Imager->new(xsize => 2, ysize => 2, channels => 3,
+ type => 'paletted');
+ ok($mono_8_wb_3->addcolors(colors => [ qw/FFFFFF 000000/ ]),
+ "mono8wb3 - add colors");
+ ok($mono_8_wb_3->is_bilevel, "it's mono");
+ is(($mono_8_wb_3->is_bilevel)[1], 1, 'zero is white');
+
+ my $mono_8_bw_1 = Imager->new(xsize => 2, ysize => 2, channels => 1,
+ type => 'paletted');
+ ok($mono_8_bw_1->addcolors(colors => [ qw/000000 FFFFFF/ ]),
+ "mono8bw - add colors");
+ ok($mono_8_bw_1->is_bilevel, "it's mono");
+ is(($mono_8_bw_1->is_bilevel)[1], 0, 'zero not white');
+
+ my $mono_8_wb_1 = Imager->new(xsize => 2, ysize => 2, channels => 1,
+ type => 'paletted');
+ ok($mono_8_wb_1->addcolors(colors => [ qw/FFFFFF 000000/ ]),
+ "mono8wb - add colors");
+ ok($mono_8_wb_1->is_bilevel, "it's mono");
+ is(($mono_8_wb_1->is_bilevel)[1], 1, 'zero is white');
+}
+
+{ # check bounds checking
+ my $im = Imager->new(xsize => 10, ysize => 10, type=>'paletted');
+ ok($im->addcolors(colors => [ $black ]), "add color of pixel bounds check writes");
+
+ image_bounds_checks($im);
+}
+
+{ # test colors array returns colors
+ my $data;
+ my $im = test_image();
+ my @colors;
+ my $imp = $im->to_paletted(colors => \@colors,
+ make_colors => 'webmap',
+ translate => 'closest');
+ ok($imp, "made paletted");
+ is(@colors, 216, "should be 216 colors in the webmap");
+ is_color3($colors[0], 0, 0, 0, "first should be 000000");
+ is_color3($colors[1], 0, 0, 0x33, "second should be 000033");
+ is_color3($colors[8], 0, 0x33, 0x66, "9th should be 003366");
+}
+
+sub iscolor {
+ my ($c1, $c2, $msg) = @_;
+
+ my $builder = Test::Builder->new;
+ my @c1 = $c1->rgba;
+ my @c2 = $c2->rgba;
+ if (!$builder->ok($c1[0] == $c2[0] && $c1[1] == $c2[1] && $c1[2] == $c2[2],
+ $msg)) {
+ $builder->diag(<<DIAG);
+ got color: [ @c1 ]
+ expected color: [ @c2 ]
+DIAG
+ }
+}
+
+sub isbin ($$$) {
+ my ($got, $expected, $msg) = @_;
+
+ my $builder = Test::Builder->new;
+ if (!$builder->ok($got eq $expected, $msg)) {
+ (my $got_dec = $got) =~ s/([^ -~])/sprintf("\\x%02x", ord $1)/ge;
+ (my $exp_dec = $expected) =~ s/([^ -~])/sprintf("\\x%02x", ord $1)/ge;
+ $builder->diag(<<DIAG);
+ got: "$got_dec"
+ expected: "$exp_dec"
+DIAG
}
}
my ($rr, $gr, $br, $ar) = $right->rgba;
print "# comparing color($rl,$gl,$bl,$al) with ($rr,$gr,$br,$ar)\n";
- okx($rl == $rr && $gl == $gr && $bl == $br && $al == $ar,
+ ok($rl == $rr && $gl == $gr && $bl == $br && $al == $ar,
$comment);
}
projects / imager.git / blobdiff