t/t01introvert.t

   1 #!perl -w
   2 # t/t01introvert.t - tests internals of image formats
   3 # to make sure we get expected values
   4
   5 use strict;
   6 use lib 't';
   7 use Test::More tests=>95;
   8
   9 BEGIN { use_ok(Imager => qw(:handy :all)) }
  10
  11 require "t/testtools.pl";
  12
  13 init_log("testout/t01introvert.log",1);
  14
  15 my $im_g = Imager::ImgRaw::new(100, 101, 1);
  16
  17 is(Imager::i_img_getchannels($im_g), 1, "1 channel image channel count");
  18 ok(Imager::i_img_getmask($im_g) & 1, "1 channel image mask");
  19 ok(!Imager::i_img_virtual($im_g), "1 channel image not virtual");
  20 is(Imager::i_img_bits($im_g), 8, "1 channel image has 8 bits/sample");
  21 is(Imager::i_img_type($im_g), 0, "1 channel image is direct");
  22
  23 my @ginfo = Imager::i_img_info($im_g);
  24 is($ginfo[0], 100, "1 channel image width");
  25 is($ginfo[1], 101, "1 channel image height");
  26
  27 undef $im_g; # can we check for release after this somehow?
  28
  29 my $im_rgb = Imager::ImgRaw::new(100, 101, 3);
  30
  31 is(Imager::i_img_getchannels($im_rgb), 3, "3 channel image channel count");
  32 is((Imager::i_img_getmask($im_rgb) & 7), 7, "3 channel image mask");
  33 is(Imager::i_img_bits($im_rgb), 8, "3 channel image has 8 bits/sample");
  34 is(Imager::i_img_type($im_rgb), 0, "3 channel image is direct");
  35
  36 undef $im_rgb;
  37
  38 my $im_pal = Imager::i_img_pal_new(100, 101, 3, 256);
  39
  40 ok($im_pal, "make paletted image");
  41 is(Imager::i_img_getchannels($im_pal), 3, "pal img channel count");
  42 is(Imager::i_img_bits($im_pal), 8, "pal img bits");
  43 is(Imager::i_img_type($im_pal), 1, "pal img is paletted");
  44
  45 my $red = NC(255, 0, 0);
  46 my $green = NC(0, 255, 0);
  47 my $blue = NC(0, 0, 255);
  48
  49 my $red_idx = check_add($im_pal, $red, 0);
  50 my $green_idx = check_add($im_pal, $green, 1);
  51 my $blue_idx = check_add($im_pal, $blue, 2);
  52
  53 # basic writing of palette indicies
  54 # fill with red
  55 is(Imager::i_ppal($im_pal, 0, 0, ($red_idx) x 100), 100,
  56    "write red 100 times");
  57 # and blue
  58 is(Imager::i_ppal($im_pal, 50, 0, ($blue_idx) x 50), 50,
  59    "write blue 50 times");
  60
  61 # make sure we get it back
  62 my @pals = Imager::i_gpal($im_pal, 0, 100, 0);
  63 ok(!grep($_ != $red_idx, @pals[0..49]), "check for red");
  64 ok(!grep($_ != $blue_idx, @pals[50..99]), "check for blue");
  65 is(Imager::i_gpal($im_pal, 0, 100, 0), "\0" x 50 . "\2" x 50,
  66    "gpal in scalar context");
  67 my @samp = Imager::i_gsamp($im_pal, 0, 100, 0, 0, 1, 2);
  68 is(@samp, 300, "gsamp count in list context");
  69 my @samp_exp = ((255, 0, 0) x 50, (0, 0, 255) x 50);
  70 is_deeply(\@samp, \@samp_exp, "gsamp list deep compare");
  71 my $samp = Imager::i_gsamp($im_pal, 0, 100, 0, 0, 1, 2);
  72 is(length($samp), 300, "gsamp scalar length");
  73 is($samp, "\xFF\0\0" x 50 . "\0\0\xFF" x 50, "gsamp scalar bytes");
  74
  75 # reading indicies as colors
  76 my $c_red = Imager::i_get_pixel($im_pal, 0, 0);
  77 ok($c_red, "got the red pixel");
  78 ok(color_cmp($red, $c_red) == 0, "and it's red");
  79 my $c_blue = Imager::i_get_pixel($im_pal, 50, 0);
  80 ok($c_blue, "got the blue pixel");
  81 ok(color_cmp($blue, $c_blue) == 0, "and it's blue");
  82
  83 # drawing with colors
  84 ok(Imager::i_ppix($im_pal, 0, 0, $green) == 0, "draw with color in palette");
  85 # that was in the palette, should still be paletted
  86 is(Imager::i_img_type($im_pal), 1, "image still paletted");
  87
  88 my $c_green = Imager::i_get_pixel($im_pal, 0, 0);
  89 ok($c_green, "got green pixel");
  90 ok(color_cmp($green, $c_green) == 0, "and it's green");
  91
  92 is(Imager::i_colorcount($im_pal), 3, "still 3 colors in palette");
  93 is(Imager::i_findcolor($im_pal, $green), 1, "and green is the second");
  94
  95 my $black = NC(0, 0, 0);
  96 # this should convert the image to RGB
  97 ok(Imager::i_ppix($im_pal, 1, 0, $black) == 0, "draw with black (not in palette)");
  98 is(Imager::i_img_type($im_pal), 0, "pal img shouldn't be paletted now");
  99
 100 my %quant =
 101   (
 102    colors => [$red, $green, $blue, $black],
 103    makemap => 'none',
 104   );
 105 my $im_pal2 = Imager::i_img_to_pal($im_pal, \%quant);
 106 ok($im_pal2, "got an image from quantizing");
 107 is(@{$quant{colors}}, 4, "has the right number of colours");
 108 is(Imager::i_gsamp($im_pal2, 0, 100, 0, 0, 1, 2),
 109   "\0\xFF\0\0\0\0"."\xFF\0\0" x 48 . "\0\0\xFF" x 50,
 110    "colors are still correct");
 111
 112 # test the OO interfaces
 113 my $impal2 = Imager->new(type=>'pseudo', xsize=>200, ysize=>201);
 114 ok($impal2, "make paletted via OO");
 115 is($impal2->getchannels, 3, "check channels");
 116 is($impal2->bits, 8, "check bits");
 117 is($impal2->type, 'paletted', "check type");
 118
 119 {
 120   my $red_idx = $impal2->addcolors(colors=>[$red]);
 121   ok($red_idx, "add red to OO");
 122   is(0+$red_idx, 0, "and it's expected index for red");
 123   my $blue_idx = $impal2->addcolors(colors=>[$blue, $green]);
 124   ok($blue_idx, "add blue/green via OO");
 125   is($blue_idx, 1, "and it's expected index for blue");
 126   my $green_idx = $blue_idx + 1;
 127   my $c = $impal2->getcolors(start=>$green_idx);
 128   ok(color_cmp($green, $c) == 0, "found green where expected");
 129   my @cols = $impal2->getcolors;
 130   is(@cols, 3, "got 3 colors");
 131   my @exp = ( $red, $blue, $green );
 132   my $good = 1;
 133   for my $i (0..2) {
 134     if (color_cmp($cols[$i], $exp[$i])) {
 135       $good = 0;
 136       last;
 137     }
 138   }
 139   ok($good, "all colors in palette as expected");
 140   is($impal2->colorcount, 3, "and colorcount returns 3");
 141   is($impal2->maxcolors, 256, "maxcolors as expected");
 142   is($impal2->findcolor(color=>$blue), 1, "findcolors found blue");
 143   ok($impal2->setcolors(start=>0, colors=>[ $blue, $red ]),
 144      "we can setcolors");
 145
 146   # make an rgb version
 147   my $imrgb2 = $impal2->to_rgb8();
 148   is($imrgb2->type, 'direct', "converted is direct");
 149
 150   # and back again, specifying the palette
 151   my @colors = ( $red, $blue, $green );
 152   my $impal3 = $imrgb2->to_paletted(colors=>\@colors,
 153                                     make_colors=>'none',
 154                                     translate=>'closest');
 155   ok($impal3, "got a paletted image from conversion");
 156   dump_colors(@colors);
 157   print "# in image\n";
 158   dump_colors($impal3->getcolors);
 159   is($impal3->colorcount, 3, "new image has expected color table size");
 160   is($impal3->type, 'paletted', "and is paletted");
 161 }
 162
 163 ok(!Imager->new(xsize=>0, ysize=>1), "fail to create 0 height image");
 164 cmp_ok(Imager->errstr, '=~', qr/Image sizes must be positive/,
 165        "0 height error message check");
 166 ok(!Imager->new(xsize=>1, ysize=>0), "fail to create 0 width image");
 167 cmp_ok(Imager->errstr, '=~', qr/Image sizes must be positive/,
 168        "0 width error message check");
 169 ok(!Imager->new(xsize=>-1, ysize=>1), "fail to create -ve height image");
 170 cmp_ok(Imager->errstr, '=~', qr/Image sizes must be positive/,
 171        "-ve width error message check");
 172 ok(!Imager->new(xsize=>1, ysize=>-1), "fail to create -ve width image");
 173 cmp_ok(Imager->errstr, '=~', qr/Image sizes must be positive/,
 174        "-ve height error message check");
 175 ok(!Imager->new(xsize=>-1, ysize=>-1), "fail to create -ve width/height image");
 176 cmp_ok(Imager->errstr, '=~', qr/Image sizes must be positive/,
 177        "-ve width/height error message check");
 178
 179 ok(!Imager->new(xsize=>1, ysize=>1, channels=>0),
 180    "fail to create a zero channel image");
 181 cmp_ok(Imager->errstr, '=~', qr/channels must be between 1 and 4/,
 182        "out of range channel message check");
 183 ok(!Imager->new(xsize=>1, ysize=>1, channels=>5),
 184    "fail to create a five channel image");
 185 cmp_ok(Imager->errstr, '=~', qr/channels must be between 1 and 4/,
 186        "out of range channel message check");
 187
 188 {
 189   # https://rt.cpan.org/Ticket/Display.html?id=8213
 190   # check for handling of memory allocation of very large images
 191   # only test this on 32-bit machines - on a 64-bit machine it may
 192   # result in trying to allocate 4Gb of memory, which is unfriendly at
 193   # least and may result in running out of memory, causing a different
 194   # type of exit
 195  SKIP:
 196   {
 197     use Config;
 198     skip("don't want to allocate 4Gb", 8) unless $Config{intsize} == 4;
 199
 200     my $uint_range = 256 ** $Config{intsize};
 201     print "# range $uint_range\n";
 202     my $dim1 = int(sqrt($uint_range))+1;
 203
 204     my $im_b = Imager->new(xsize=>$dim1, ysize=>$dim1, channels=>1);
 205     is($im_b, undef, "integer overflow check - 1 channel");
 206
 207     $im_b = Imager->new(xisze=>$dim1, ysize=>1, channels=>1);
 208     ok($im_b, "but same width ok");
 209     $im_b = Imager->new(xisze=>1, ysize=>$dim1, channels=>1);
 210     ok($im_b, "but same height ok");
 211     cmp_ok(Imager->errstr, '=~', qr/integer overflow/,
 212            "check the error message");
 213
 214     # do a similar test with a 3 channel image, so we're sure we catch
 215     # the same case where the third dimension causes the overflow
 216     my $dim3 = int(sqrt($uint_range / 3))+1;
 217
 218     $im_b = Imager->new(xsize=>$dim3, ysize=>$dim3, channels=>3);
 219     is($im_b, undef, "integer overflow check - 3 channel");
 220
 221     $im_b = Imager->new(xisze=>$dim3, ysize=>1, channels=>3);
 222     ok($im_b, "but same width ok");
 223     $im_b = Imager->new(xisze=>1, ysize=>$dim3, channels=>3);
 224     ok($im_b, "but same height ok");
 225
 226     cmp_ok(Imager->errstr, '=~', qr/integer overflow/,
 227            "check the error message");
 228   }
 229 }
 230
 231 { # http://rt.cpan.org/NoAuth/Bug.html?id=9672
 232   my $warning;
 233   local $SIG{__WARN__} =
 234     sub {
 235       $warning = "@_";
 236       my $printed = $warning;
 237       $printed =~ s/\n$//;
 238       $printed =~ s/\n/\n\#/g;
 239       print "# ",$printed, "\n";
 240     };
 241   my $img = Imager->new(xsize=>10, ysize=>10);
 242   $img->to_rgb8(); # doesn't really matter what the source is
 243   cmp_ok($warning, '=~', 'void', "correct warning");
 244   cmp_ok($warning, '=~', 't01introvert\\.t', "correct file");
 245 }
 246
 247 sub check_add {
 248   my ($im, $color, $expected) = @_;
 249   my $index = Imager::i_addcolors($im, $color);
 250   ok($index, "got index");
 251   print "# $index\n";
 252   is(0+$index, $expected, "index matched expected");
 253   my ($new) = Imager::i_getcolors($im, $index);
 254   ok($new, "got the color");
 255   ok(color_cmp($new, $color) == 0, "color matched what was added");
 256
 257   $index;
 258 }
 259
 260 sub color_cmp {
 261   my ($l, $r) = @_;
 262   my @l = $l->rgba;
 263   my @r = $r->rgba;
 264   return $l[0] <=> $r[0]
 265     || $l[1] <=> $r[1]
 266       || $l[2] <=> $r[2];
 267 }
 268
 269 # sub array_ncmp {
 270 #   my ($a1, $a2) = @_;
 271 #   my $len = @$a1 < @$a2 ? @$a1 : @$a2;
 272 #   for my $i (0..$len-1) {
 273 #     my $diff = $a1->[$i] <=> $a2->[$i]
 274 #       and return $diff;
 275 #   }
 276 #   return @$a1 <=> @$a2;
 277 # }
 278
 279 sub dump_colors {
 280   for my $col (@_) {
 281     print "# ", map(sprintf("%02X", $_), ($col->rgba)[0..2]),"\n";
 282   }
 283 }