#!perl -w
# t/t01introvert.t - tests internals of image formats
# to make sure we get expected values
-#
-# Change 1..1 below to 1..last_test_to_print .
-# (It may become useful if the test is moved to ./t subdirectory.)
use strict;
+use lib 't';
+use Test::More tests=>93;
-my $loaded;
-BEGIN { $| = 1; print "1..93\n"; }
-END {print "not ok 1\n" unless $loaded;}
-use Imager qw(:handy :all);
-$loaded = 1;
-print "ok 1\n";
+BEGIN { use_ok(Imager => qw(:handy :all)) }
require "t/testtools.pl";
my $im_g = Imager::ImgRaw::new(100, 101, 1);
-print Imager::i_img_getchannels($im_g) == 1
- ? "ok 2\n" : "not ok 2 # 1 channel image channel count mismatch\n";
-print Imager::i_img_getmask($im_g) & 1
- ? "ok 3\n" : "not ok 3 # 1 channel image bad mask\n";
-print Imager::i_img_virtual($im_g)
- ? "not ok 4 # 1 channel image thinks it is virtual\n" : "ok 4\n";
-print Imager::i_img_bits($im_g) == 8
- ? "ok 5\n" : "not ok 5 # 1 channel image has bits != 8\n";
-print Imager::i_img_type($im_g) == 0 # direct
- ? "ok 6\n" : "not ok 6 # 1 channel image isn't direct\n";
+is(Imager::i_img_getchannels($im_g), 1, "1 channel image channel count");
+ok(Imager::i_img_getmask($im_g) & 1, "1 channel image mask");
+ok(!Imager::i_img_virtual($im_g), "1 channel image not virtual");
+is(Imager::i_img_bits($im_g), 8, "1 channel image has 8 bits/sample");
+is(Imager::i_img_type($im_g), 0, "1 channel image is direct");
my @ginfo = Imager::i_img_info($im_g);
-print $ginfo[0] == 100
- ? "ok 7\n" : "not ok 7 # 1 channel image width incorrect\n";
-print $ginfo[1] == 101
- ? "ok 8\n" : "not ok 8 # 1 channel image height incorrect\n";
+is($ginfo[0], 100, "1 channel image width");
+is($ginfo[1], 101, "1 channel image height");
undef $im_g; # can we check for release after this somehow?
my $im_rgb = Imager::ImgRaw::new(100, 101, 3);
-print Imager::i_img_getchannels($im_rgb) == 3
- ? "ok 9\n" : "not ok 9 # 3 channel image channel count mismatch\n";
-print +(Imager::i_img_getmask($im_rgb) & 7) == 7
- ? "ok 10\n" : "not ok 10 # 3 channel image bad mask\n";
-print Imager::i_img_bits($im_rgb) == 8
- ? "ok 11\n" : "not ok 11 # 3 channel image has bits != 8\n";
-print Imager::i_img_type($im_rgb) == 0 # direct
- ? "ok 12\n" : "not ok 12 # 3 channel image isn't direct\n";
+is(Imager::i_img_getchannels($im_rgb), 3, "3 channel image channel count");
+is((Imager::i_img_getmask($im_rgb) & 7), 7, "3 channel image mask");
+is(Imager::i_img_bits($im_rgb), 8, "3 channel image has 8 bits/sample");
+is(Imager::i_img_type($im_rgb), 0, "3 channel image is direct");
undef $im_rgb;
my $im_pal = Imager::i_img_pal_new(100, 101, 3, 256);
-print $im_pal ? "ok 13\n" : "not ok 13 # couldn't make paletted image\n";
-print Imager::i_img_getchannels($im_pal) == 3
- ? "ok 14\n" : "not ok 14 # pal img channel count mismatch\n";
-print Imager::i_img_bits($im_pal) == 8
- ? "ok 15\n" : "not ok 15 # pal img bits != 8\n";
-print Imager::i_img_type($im_pal) == 1
- ? "ok 16\n" : "not ok 16 # pal img isn't paletted\n";
+ok($im_pal, "make paletted image");
+is(Imager::i_img_getchannels($im_pal), 3, "pal img channel count");
+is(Imager::i_img_bits($im_pal), 8, "pal img bits");
+is(Imager::i_img_type($im_pal), 1, "pal img is paletted");
my $red = NC(255, 0, 0);
my $green = NC(0, 255, 0);
my $blue = NC(0, 0, 255);
-my $red_idx = check_add(17, $im_pal, $red, 0);
-my $green_idx = check_add(21, $im_pal, $green, 1);
-my $blue_idx = check_add(25, $im_pal, $blue, 2);
+my $red_idx = check_add($im_pal, $red, 0);
+my $green_idx = check_add($im_pal, $green, 1);
+my $blue_idx = check_add($im_pal, $blue, 2);
# basic writing of palette indicies
# fill with red
-Imager::i_ppal($im_pal, 0, 0, ($red_idx) x 100) == 100
- or print "not ";
-print "ok 29\n";
+is(Imager::i_ppal($im_pal, 0, 0, ($red_idx) x 100), 100,
+ "write red 100 times");
# and blue
-Imager::i_ppal($im_pal, 50, 0, ($blue_idx) x 50) == 50
- or print "not ";
-print "ok 30\n";
+is(Imager::i_ppal($im_pal, 50, 0, ($blue_idx) x 50), 50,
+ "write blue 50 times");
# make sure we get it back
my @pals = Imager::i_gpal($im_pal, 0, 100, 0);
-grep($_ != $red_idx, @pals[0..49]) and print "not ";
-print "ok 31\n";
-grep($_ != $blue_idx, @pals[50..99]) and print "not ";
-print "ok 32\n";
-Imager::i_gpal($im_pal, 0, 100, 0) eq "\0" x 50 . "\2" x 50 or print "not ";
-print "ok 33\n";
+ok(!grep($_ != $red_idx, @pals[0..49]), "check for red");
+ok(!grep($_ != $blue_idx, @pals[50..99]), "check for blue");
+is(Imager::i_gpal($im_pal, 0, 100, 0), "\0" x 50 . "\2" x 50,
+ "gpal in scalar context");
my @samp = Imager::i_gsamp($im_pal, 0, 100, 0, 0, 1, 2);
-@samp == 300 or print "not ";
-print "ok 34\n";
+is(@samp, 300, "gsamp count in list context");
my @samp_exp = ((255, 0, 0) x 50, (0, 0, 255) x 50);
-my $diff = array_ncmp(\@samp, \@samp_exp);
-$diff == 0 or print "not ";
-print "ok 35\n";
+is_deeply(\@samp, \@samp_exp, "gsamp list deep compare");
my $samp = Imager::i_gsamp($im_pal, 0, 100, 0, 0, 1, 2);
-length($samp) == 300 or print "not ";
-print "ok 36\n";
-$samp eq "\xFF\0\0" x 50 . "\0\0\xFF" x 50
- or print "not ";
-print "ok 37\n";
+is(length($samp), 300, "gsamp scalar length");
+is($samp, "\xFF\0\0" x 50 . "\0\0\xFF" x 50, "gsamp scalar bytes");
# reading indicies as colors
-my $c_red = Imager::i_get_pixel($im_pal, 0, 0)
- or print "not ";
-print "ok 38\n";
-color_cmp($red, $c_red) == 0
- or print "not ";
-print "ok 39\n";
-my $c_blue = Imager::i_get_pixel($im_pal, 50, 0)
- or print "not ";
-print "ok 40\n";
-color_cmp($blue, $c_blue) == 0
- or print "not ";
-print "ok 41\n";
+my $c_red = Imager::i_get_pixel($im_pal, 0, 0);
+ok($c_red, "got the red pixel");
+ok(color_cmp($red, $c_red) == 0, "and it's red");
+my $c_blue = Imager::i_get_pixel($im_pal, 50, 0);
+ok($c_blue, "got the blue pixel");
+ok(color_cmp($blue, $c_blue) == 0, "and it's blue");
# drawing with colors
-Imager::i_ppix($im_pal, 0, 0, $green) and print "not ";
-print "ok 42\n";
+ok(Imager::i_ppix($im_pal, 0, 0, $green) == 0, "draw with color in palette");
# that was in the palette, should still be paletted
-print Imager::i_img_type($im_pal) == 1
- ? "ok 43\n" : "not ok 43 # pal img isn't paletted (but still should be)\n";
+is(Imager::i_img_type($im_pal), 1, "image still paletted");
-my $c_green = Imager::i_get_pixel($im_pal, 0, 0)
- or print "not ";
-print "ok 44\n";
-color_cmp($green, $c_green) == 0
- or print "not ";
-print "ok 45\n";
+my $c_green = Imager::i_get_pixel($im_pal, 0, 0);
+ok($c_green, "got green pixel");
+ok(color_cmp($green, $c_green) == 0, "and it's green");
-Imager::i_colorcount($im_pal) == 3 or print "not ";
-print "ok 46\n";
-Imager::i_findcolor($im_pal, $green) == 1 or print "not ";
-print "ok 47\n";
+is(Imager::i_colorcount($im_pal), 3, "still 3 colors in palette");
+is(Imager::i_findcolor($im_pal, $green), 1, "and green is the second");
my $black = NC(0, 0, 0);
# this should convert the image to RGB
-Imager::i_ppix($im_pal, 1, 0, $black) and print "not ";
-print "ok 48\n";
-print Imager::i_img_type($im_pal) == 0
- ? "ok 49\n" : "not ok 49 # pal img shouldn't be paletted now\n";
+ok(Imager::i_ppix($im_pal, 1, 0, $black) == 0, "draw with black (not in palette)");
+is(Imager::i_img_type($im_pal), 0, "pal img shouldn't be paletted now");
my %quant =
(
makemap => 'none',
);
my $im_pal2 = Imager::i_img_to_pal($im_pal, \%quant);
-$im_pal2 or print "not ";
-print "ok 50\n";
-@{$quant{colors}} == 4 or print "not ";
-print "ok 51\n";
-Imager::i_gsamp($im_pal2, 0, 100, 0, 0, 1, 2)
- eq "\0\xFF\0\0\0\0"."\xFF\0\0" x 48 . "\0\0\xFF" x 50
- or print "not ";
-print "ok 52\n";
+ok($im_pal2, "got an image from quantizing");
+is(@{$quant{colors}}, 4, "has the right number of colours");
+is(Imager::i_gsamp($im_pal2, 0, 100, 0, 0, 1, 2),
+ "\0\xFF\0\0\0\0"."\xFF\0\0" x 48 . "\0\0\xFF" x 50,
+ "colors are still correct");
# test the OO interfaces
-my $impal2 = Imager->new(type=>'pseudo', xsize=>200, ysize=>201)
- or print "not ";
-print "ok 53\n";
-$impal2->getchannels == 3 or print "not ";
-print "ok 54\n";
-$impal2->bits == 8 or print "not ";
-print "ok 55\n";
-$impal2->type eq 'paletted' or print "not ";
-print "ok 56\n";
+my $impal2 = Imager->new(type=>'pseudo', xsize=>200, ysize=>201);
+ok($impal2, "make paletted via OO");
+is($impal2->getchannels, 3, "check channels");
+is($impal2->bits, 8, "check bits");
+is($impal2->type, 'paletted', "check type");
{
- my $red_idx = $impal2->addcolors(colors=>[$red])
- or print "not ";
- print "ok 57\n";
- $red_idx == 0 or print "not ";
- print "ok 58\n";
- my $blue_idx = $impal2->addcolors(colors=>[$blue, $green])
- or print "not ";
- print "ok 59\n";
- $blue_idx == 1 or print "not ";
- print "ok 60\n";
+ my $red_idx = $impal2->addcolors(colors=>[$red]);
+ ok($red_idx, "add red to OO");
+ is(0+$red_idx, 0, "and it's expected index for red");
+ my $blue_idx = $impal2->addcolors(colors=>[$blue, $green]);
+ ok($blue_idx, "add blue/green via OO");
+ is($blue_idx, 1, "and it's expected index for blue");
my $green_idx = $blue_idx + 1;
my $c = $impal2->getcolors(start=>$green_idx);
- color_cmp($green, $c) == 0 or print "not ";
- print "ok 61\n";
+ ok(color_cmp($green, $c) == 0, "found green where expected");
my @cols = $impal2->getcolors;
- @cols == 3 or print "not ";
- print "ok 62\n";
+ is(@cols, 3, "got 3 colors");
my @exp = ( $red, $blue, $green );
+ my $good = 1;
for my $i (0..2) {
if (color_cmp($cols[$i], $exp[$i])) {
- print "not ";
+ $good = 0;
last;
}
}
- print "ok 63\n";
- $impal2->colorcount == 3 or print "not ";
- print "ok 64\n";
- $impal2->maxcolors == 256 or print "not ";
- print "ok 65\n";
- $impal2->findcolor(color=>$blue) == 1 or print "not ";
- print "ok 66\n";
- $impal2->setcolors(start=>0, colors=>[ $blue, $red ]) or print "not ";
- print "ok 67\n";
+ ok($good, "all colors in palette as expected");
+ is($impal2->colorcount, 3, "and colorcount returns 3");
+ is($impal2->maxcolors, 256, "maxcolors as expected");
+ is($impal2->findcolor(color=>$blue), 1, "findcolors found blue");
+ ok($impal2->setcolors(start=>0, colors=>[ $blue, $red ]),
+ "we can setcolors");
# make an rgb version
my $imrgb2 = $impal2->to_rgb8();
- $imrgb2->type eq 'direct' or print "not ";
- print "ok 68\n";
+ is($imrgb2->type, 'direct', "converted is direct");
# and back again, specifying the palette
my @colors = ( $red, $blue, $green );
my $impal3 = $imrgb2->to_paletted(colors=>\@colors,
make_colors=>'none',
- translate=>'closest')
- or print "not ";
- print "ok 69\n";
+ translate=>'closest');
+ ok($impal3, "got a paletted image from conversion");
dump_colors(@colors);
print "# in image\n";
dump_colors($impal3->getcolors);
- $impal3->colorcount == 3 or print "not ";
- print "ok 70\n";
- $impal3->type eq 'paletted' or print "not ";
- print "ok 71\n";
+ is($impal3->colorcount, 3, "new image has expected color table size");
+ is($impal3->type, 'paletted', "and is paletted");
}
-my $num = 72;
-okn($num++, !Imager->new(xsize=>0, ysize=>1), "fail to create 0 height image");
-matchn($num++, Imager->errstr, qr/Image sizes must be positive/,
+ok(!Imager->new(xsize=>0, ysize=>1), "fail to create 0 height image");
+cmp_ok(Imager->errstr, '=~', qr/Image sizes must be positive/,
"0 height error message check");
-okn($num++, !Imager->new(xsize=>1, ysize=>0), "fail to create 0 width image");
-matchn($num++, Imager->errstr, qr/Image sizes must be positive/,
+ok(!Imager->new(xsize=>1, ysize=>0), "fail to create 0 width image");
+cmp_ok(Imager->errstr, '=~', qr/Image sizes must be positive/,
"0 width error message check");
-okn($num++, !Imager->new(xsize=>-1, ysize=>1), "fail to create -ve height image");
-matchn($num++, Imager->errstr, qr/Image sizes must be positive/,
+ok(!Imager->new(xsize=>-1, ysize=>1), "fail to create -ve height image");
+cmp_ok(Imager->errstr, '=~', qr/Image sizes must be positive/,
"-ve width error message check");
-okn($num++, !Imager->new(xsize=>1, ysize=>-1), "fail to create -ve width image");
-matchn($num++, Imager->errstr, qr/Image sizes must be positive/,
+ok(!Imager->new(xsize=>1, ysize=>-1), "fail to create -ve width image");
+cmp_ok(Imager->errstr, '=~', qr/Image sizes must be positive/,
"-ve height error message check");
-okn($num++, !Imager->new(xsize=>-1, ysize=>-1), "fail to create -ve width/height image");
-matchn($num++, Imager->errstr, qr/Image sizes must be positive/,
+ok(!Imager->new(xsize=>-1, ysize=>-1), "fail to create -ve width/height image");
+cmp_ok(Imager->errstr, '=~', qr/Image sizes must be positive/,
"-ve width/height error message check");
-okn($num++, !Imager->new(xsize=>1, ysize=>1, channels=>0),
- "fail to create a zero channel image");
-matchn($num++, Imager->errstr, qr/channels must be between 1 and 4/,
+ok(!Imager->new(xsize=>1, ysize=>1, channels=>0),
+ "fail to create a zero channel image");
+cmp_ok(Imager->errstr, '=~', qr/channels must be between 1 and 4/,
"out of range channel message check");
-okn($num++, !Imager->new(xsize=>1, ysize=>1, channels=>5),
- "fail to create a five channel image");
-matchn($num++, Imager->errstr, qr/channels must be between 1 and 4/,
+ok(!Imager->new(xsize=>1, ysize=>1, channels=>5),
+ "fail to create a five channel image");
+cmp_ok(Imager->errstr, '=~', qr/channels must be between 1 and 4/,
"out of range channel message check");
{
# result in trying to allocate 4Gb of memory, which is unfriendly at
# least and may result in running out of memory, causing a different
# type of exit
- use Config;
- if ($Config{intsize} == 4) {
+ SKIP:
+ {
+ use Config;
+ skip("don't want to allocate 4Gb", 8) unless $Config{intsize} == 4;
+
my $uint_range = 256 ** $Config{intsize};
print "# range $uint_range\n";
my $dim1 = int(sqrt($uint_range))+1;
my $im_b = Imager->new(xsize=>$dim1, ysize=>$dim1, channels=>1);
- isn($num++, $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);
- okn($num++, $im_b, "but same width ok");
+ ok($im_b, "but same width ok");
$im_b = Imager->new(xisze=>1, ysize=>$dim1, channels=>1);
- okn($num++, $im_b, "but same height ok");
- matchn($num++, 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 = int(sqrt($uint_range / 3))+1;
$im_b = Imager->new(xsize=>$dim3, ysize=>$dim3, channels=>3);
- isn($num++, $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);
- okn($num++, $im_b, "but same width ok");
+ ok($im_b, "but same width ok");
$im_b = Imager->new(xisze=>1, ysize=>$dim3, channels=>3);
- okn($num++, $im_b, "but same height ok");
+ ok($im_b, "but same height ok");
- matchn($num++, Imager->errstr, qr/integer overflow/,
+ cmp_ok(Imager->errstr, '=~', qr/integer overflow/,
"check the error message");
}
- else {
- skipn($num, 8, "don't want to allocate 4Gb");
- $num += 8;
- }
}
sub check_add {
- my ($base, $im, $color, $expected) = @_;
- my $index = Imager::i_addcolors($im, $color)
- or print "not ";
- print "ok ",$base++,"\n";
+ my ($im, $color, $expected) = @_;
+ my $index = Imager::i_addcolors($im, $color);
+ ok($index, "got index");
print "# $index\n";
- $index == $expected
- or print "not ";
- print "ok ",$base++,"\n";
- my ($new) = Imager::i_getcolors($im, $index)
- or print "not ";
- print "ok ",$base++,"\n";
- color_cmp($new, $color) == 0
- or print "not ";
- print "ok ",$base++,"\n";
+ is(0+$index, $expected, "index matched expected");
+ my ($new) = Imager::i_getcolors($im, $index);
+ ok($new, "got the color");
+ ok(color_cmp($new, $color) == 0, "color matched what was added");
$index;
}
|| $l[2] <=> $r[2];
}
-sub array_ncmp {
- my ($a1, $a2) = @_;
- my $len = @$a1 < @$a2 ? @$a1 : @$a2;
- for my $i (0..$len-1) {
- my $diff = $a1->[$i] <=> $a2->[$i]
- and return $diff;
- }
- return @$a1 <=> @$a2;
-}
+# sub array_ncmp {
+# my ($a1, $a2) = @_;
+# my $len = @$a1 < @$a2 ? @$a1 : @$a2;
+# for my $i (0..$len-1) {
+# my $diff = $a1->[$i] <=> $a2->[$i]
+# and return $diff;
+# }
+# return @$a1 <=> @$a2;
+# }
sub dump_colors {
for my $col (@_) {
#!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;
-
-okx(1, "Loaded");
+use lib 't';
+use Test::More tests => 57;
+BEGIN { use_ok("Imager"); }
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");
+ok($img->type eq '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");
+ok($img->type eq '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');
+ok($img->type eq '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');
+ok($img->type eq '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");
+ok($img->type eq '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{intsize} == 4) {
+ SKIP:
+ {
+ skip("don't want to allocate 4Gb", 8)
+ 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");
+ ok($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");
+ ok($im_b, "but same height ok");
- matchx(Imager->errstr, qr/integer overflow/,
+ cmp_ok(Imager->errstr, '=~', qr/integer overflow/,
"check the error message");
}
- else {
- skipx(8, "don't want to allocate 4Gb");
- }
}
sub coloreq {
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);
}
-Imager::init("log"=>'testout/t67convert.log');
-
+#!perl -w
+use strict;
use Imager qw(:all :handy);
+use lib 't';
+use Test::More tests=>17;
-print "1..17\n";
+Imager::init("log"=>'testout/t67convert.log');
my $imbase = Imager::ImgRaw::new(200,300,3);
# make a 1 channel image from the above (black) image
# but with 1 as the 'extra' value
my $imnew = Imager::i_img_new();
-unless (i_convert($imnew, $imbase, [ [ 0, 0, 0, 1 ] ])) {
- print "not ok 1 # call failed\n";
- print "ok 2 # skipped\n";
- print "ok 3 # skipped\n";
-}
-else {
- print "ok 1\n";
+SKIP:
+{
+ skip("convert to white failed", 3)
+ unless ok(i_convert($imnew, $imbase, [ [ 0, 0, 0, 1 ] ]), "convert to white");
+
my ($w, $h, $ch) = i_img_info($imnew);
# the output image should now have one channel
- if ($ch == 1) {
- print "ok 2\n";
- }
- else {
- print "not ok 2 # $ch channels in output\n";
- }
+ is($ch, 1, "one channel image now");
# should have the same width and height
- if ($w == 200 && $h == 300) {
- print "ok 3\n";
- }
- else {
- print "not ok 3 # output image is the wrong size!\n";
- }
+ ok($w == 200 && $h == 300, "check converted size is the same");
+
# should be a white image now, let's check
my $c = Imager::i_get_pixel($imnew, 20, 20);
my @c = $c->rgba;
print "# @c\n";
- if (($c->rgba())[0] == 255) {
- print "ok 4\n";
- }
- else {
- print "not ok 4 # wrong colour in output image",($c->rgba())[0],"\n";
- }
+ is($c[0], 255, "check image is white");
}
# test the highlevel interface
# currently this requires visual inspection of the output files
my $im = Imager->new;
-if ($im->read(file=>'testimg/scale.ppm')) {
- print "ok 5\n";
- my $out;
- $out = $im->convert(preset=>'gray')
- or print "not ";
- print "ok 6\n";
- if ($out->write(file=>'testout/t67_gray.ppm', type=>'pnm')) {
- print "ok 7\n";
- }
- else {
- print "not ok 7 # Cannot save testout/t67_gray.ppm:", $out->errstr,"\n";
- }
- $out = $im->convert(preset=>'blue')
- or print "not ";
- print "ok 8\n";
+SKIP:
+{
+ skip("could not load scale.ppm", 3)
+ unless $im->read(file=>'testimg/scale.ppm');
+ my $out = $im->convert(preset=>'gray');
+ ok($out, "convert preset gray");
+ ok($out->write(file=>'testout/t67_gray.ppm', type=>'pnm'),
+ "save grey image");
+ $out = $im->convert(preset=>'blue');
+ ok($out, "convert preset blue");
- if ($out->write(file=>'testout/t67_blue.ppm', type=>'pnm')) {
- print "ok 9\n";
- }
- else {
- print "not ok 9 # Cannot save testout/t67_blue.ppm:", $out->errstr, "\n";
- }
-}
-else {
- print "not ok 5 # could not load testout/scale.ppm\n";
- print map "ok $_ # skipped\n", 6..9;
+ ok($out->write(file=>'testout/t67_blue.ppm', type=>'pnm'),
+ "save blue image");
}
# test against 16-bit/sample images
my $im16targ = Imager::i_img_16_new(200, 300, 3);
-unless (i_convert($im16targ, $imbase, [ [ 0, 0, 0, 1 ],
- [ 0, 0, 0, 0 ],
- [ 0, 0, 0, 0 ] ])) {
- print "not ok 10 # call failed\n";
- print map "ok $_ # skipped\n", 11..12;
-}
-else {
- print "ok 10\n";
-
+SKIP:
+{
+ skip("could not convert 16-bit image", 2)
+ unless ok(i_convert($im16targ, $imbase, [ [ 0, 0, 0, 1 ],
+ [ 0, 0, 0, 0 ],
+ [ 0, 0, 0, 0 ] ]),
+ "convert 16/bit sample image");
# image should still be 16-bit
- Imager::i_img_bits($im16targ) == 16
- or print "not ";
- print "ok 11\n";
+ is(Imager::i_img_bits($im16targ), 16, "Image still 16-bit/sample");
# make sure that it's roughly red
my $c = Imager::i_gpixf($im16targ, 0, 0);
my @ch = $c->rgba;
- abs($ch[0] - 1) <= 0.0001 && abs($ch[1]) <= 0.0001 && abs($ch[2]) <= 0.0001
- or print "not ";
- print "ok 12\n";
+ ok(abs($ch[0] - 1) <= 0.0001 && abs($ch[1]) <= 0.0001 && abs($ch[2]) <= 0.0001,
+ "image roughly red");
}
# test against palette based images
my $impal = Imager::i_img_pal_new(200, 300, 3, 256);
my $black = NC(0, 0, 0);
-my $blackindex = Imager::i_addcolors($impal, $black)
- or print "not ";
-print "ok 13\n";
+my $blackindex = Imager::i_addcolors($impal, $black);
+ok($blackindex, "add black to paletted");
for my $y (0..299) {
Imager::i_ppal($impal, 0, $y, ($black) x 200);
}
my $impalout = Imager::i_img_pal_new(200, 300, 3, 256);
-if (i_convert($impalout, $impal, [ [ 0, 0, 0, 0 ],
+SKIP:
+{
+ skip("could not convert paletted", 3)
+ unless ok(i_convert($impalout, $impal, [ [ 0, 0, 0, 0 ],
[ 0, 0, 0, 1 ],
- [ 0, 0, 0, 0 ] ])) {
- Imager::i_img_type($impalout) == 1 or print "not ";
- print "ok 14\n";
- Imager::i_colorcount($impalout) == 1 or print "not ";
- print "ok 15\n";
- my $c = Imager::i_getcolors($impalout, $blackindex) or print "not ";
- print "ok 16\n";
+ [ 0, 0, 0, 0 ] ]),
+ "convert paletted");
+ is(Imager::i_img_type($impalout), 1, "image still paletted");
+ is(Imager::i_colorcount($impalout), 1, "still only one colour");
+ my $c = Imager::i_getcolors($impalout, $blackindex);
+ ok($c, "get color from palette");
my @ch = $c->rgba;
print "# @ch\n";
- $ch[0] == 0 && $ch[1] == 255 && $ch[2] == 0
- or print "not ";
- print "ok 17\n";
-}
-else {
- print "not ok 14 # could not convert paletted image\n";
- print map "ok $_ # skipped\n", 15..17;
+ ok($ch[0] == 0 && $ch[1] == 255 && $ch[2] == 0,
+ "colour is as expected");
}
+
projects / imager.git / commitdiff