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 # Change 1..1 below to 1..last_test_to_print .
   6 # (It may become useful if the test is moved to ./t subdirectory.)
   7
   8 use strict;
   9
  10 my $loaded;
  11 BEGIN { $| = 1; print "1..93\n"; }
  12 END {print "not ok 1\n" unless $loaded;}
  13 use Imager qw(:handy :all);
  14 $loaded = 1;
  15 print "ok 1\n";
  16
  17 require "t/testtools.pl";
  18
  19 init_log("testout/t01introvert.log",1);
  20
  21 my $im_g = Imager::ImgRaw::new(100, 101, 1);
  22
  23 print Imager::i_img_getchannels($im_g) == 1
  24   ? "ok 2\n" : "not ok 2 # 1 channel image channel count mismatch\n";
  25 print Imager::i_img_getmask($im_g) & 1
  26   ? "ok 3\n" : "not ok 3 # 1 channel image bad mask\n";
  27 print Imager::i_img_virtual($im_g)
  28   ? "not ok 4 # 1 channel image thinks it is virtual\n" : "ok 4\n";
  29 print Imager::i_img_bits($im_g) == 8
  30   ? "ok 5\n" : "not ok 5 # 1 channel image has bits != 8\n";
  31 print Imager::i_img_type($im_g) == 0 # direct
  32   ? "ok 6\n" : "not ok 6 # 1 channel image isn't direct\n";
  33
  34 my @ginfo = Imager::i_img_info($im_g);
  35 print $ginfo[0] == 100
  36   ? "ok 7\n" : "not ok 7 # 1 channel image width incorrect\n";
  37 print $ginfo[1] == 101
  38   ? "ok 8\n" : "not ok 8 # 1 channel image height incorrect\n";
  39
  40 undef $im_g; # can we check for release after this somehow?
  41
  42 my $im_rgb = Imager::ImgRaw::new(100, 101, 3);
  43
  44 print Imager::i_img_getchannels($im_rgb) == 3
  45   ? "ok 9\n" : "not ok 9 # 3 channel image channel count mismatch\n";
  46 print +(Imager::i_img_getmask($im_rgb) & 7) == 7
  47   ? "ok 10\n" : "not ok 10 # 3 channel image bad mask\n";
  48 print Imager::i_img_bits($im_rgb) == 8
  49   ? "ok 11\n" : "not ok 11 # 3 channel image has bits != 8\n";
  50 print Imager::i_img_type($im_rgb) == 0 # direct
  51   ? "ok 12\n" : "not ok 12 # 3 channel image isn't direct\n";
  52
  53 undef $im_rgb;
  54
  55 my $im_pal = Imager::i_img_pal_new(100, 101, 3, 256);
  56
  57 print $im_pal ? "ok 13\n" : "not ok 13 # couldn't make paletted image\n";
  58 print Imager::i_img_getchannels($im_pal) == 3
  59   ? "ok 14\n" : "not ok 14 # pal img channel count mismatch\n";
  60 print Imager::i_img_bits($im_pal) == 8
  61   ? "ok 15\n" : "not ok 15 # pal img bits != 8\n";
  62 print Imager::i_img_type($im_pal) == 1
  63   ? "ok 16\n" : "not ok 16 # pal img isn't paletted\n";
  64
  65 my $red = NC(255, 0, 0);
  66 my $green = NC(0, 255, 0);
  67 my $blue = NC(0, 0, 255);
  68
  69 my $red_idx = check_add(17, $im_pal, $red, 0);
  70 my $green_idx = check_add(21, $im_pal, $green, 1);
  71 my $blue_idx = check_add(25, $im_pal, $blue, 2);
  72
  73 # basic writing of palette indicies
  74 # fill with red
  75 Imager::i_ppal($im_pal, 0, 0, ($red_idx) x 100) == 100
  76   or print "not ";
  77 print "ok 29\n";
  78 # and blue
  79 Imager::i_ppal($im_pal, 50, 0, ($blue_idx) x 50) == 50
  80   or print "not ";
  81 print "ok 30\n";
  82
  83 # make sure we get it back
  84 my @pals = Imager::i_gpal($im_pal, 0, 100, 0);
  85 grep($_ != $red_idx, @pals[0..49]) and print "not ";
  86 print "ok 31\n";
  87 grep($_ != $blue_idx, @pals[50..99]) and print "not ";
  88 print "ok 32\n";
  89 Imager::i_gpal($im_pal, 0, 100, 0) eq "\0" x 50 . "\2" x 50 or print "not ";
  90 print "ok 33\n";
  91 my @samp = Imager::i_gsamp($im_pal, 0, 100, 0, 0, 1, 2);
  92 @samp == 300 or print "not ";
  93 print "ok 34\n";
  94 my @samp_exp = ((255, 0, 0) x 50, (0, 0, 255) x 50);
  95 my $diff = array_ncmp(\@samp, \@samp_exp);
  96 $diff == 0 or print "not ";
  97 print "ok 35\n";
  98 my $samp = Imager::i_gsamp($im_pal, 0, 100, 0, 0, 1, 2);
  99 length($samp) == 300 or print "not ";
 100 print "ok 36\n";
 101 $samp eq "\xFF\0\0" x 50 . "\0\0\xFF" x 50
 102   or print "not ";
 103 print "ok 37\n";
 104
 105 # reading indicies as colors
 106 my $c_red = Imager::i_get_pixel($im_pal, 0, 0)
 107   or print "not ";
 108 print "ok 38\n";
 109 color_cmp($red, $c_red) == 0
 110   or print "not ";
 111 print "ok 39\n";
 112 my $c_blue = Imager::i_get_pixel($im_pal, 50, 0)
 113   or print "not ";
 114 print "ok 40\n";
 115 color_cmp($blue, $c_blue) == 0
 116   or print "not ";
 117 print "ok 41\n";
 118
 119 # drawing with colors
 120 Imager::i_ppix($im_pal, 0, 0, $green) and print "not ";
 121 print "ok 42\n";
 122 # that was in the palette, should still be paletted
 123 print Imager::i_img_type($im_pal) == 1
 124   ? "ok 43\n" : "not ok 43 # pal img isn't paletted (but still should be)\n";
 125
 126 my $c_green = Imager::i_get_pixel($im_pal, 0, 0)
 127   or print "not ";
 128 print "ok 44\n";
 129 color_cmp($green, $c_green) == 0
 130   or print "not ";
 131 print "ok 45\n";
 132
 133 Imager::i_colorcount($im_pal) == 3 or print "not ";
 134 print "ok 46\n";
 135 Imager::i_findcolor($im_pal, $green) == 1 or print "not ";
 136 print "ok 47\n";
 137
 138 my $black = NC(0, 0, 0);
 139 # this should convert the image to RGB
 140 Imager::i_ppix($im_pal, 1, 0, $black) and print "not ";
 141 print "ok 48\n";
 142 print Imager::i_img_type($im_pal) == 0
 143   ? "ok 49\n" : "not ok 49 # pal img shouldn't be paletted now\n";
 144
 145 my %quant =
 146   (
 147    colors => [$red, $green, $blue, $black],
 148    makemap => 'none',
 149   );
 150 my $im_pal2 = Imager::i_img_to_pal($im_pal, \%quant);
 151 $im_pal2 or print "not ";
 152 print "ok 50\n";
 153 @{$quant{colors}} == 4 or print "not ";
 154 print "ok 51\n";
 155 Imager::i_gsamp($im_pal2, 0, 100, 0, 0, 1, 2)
 156   eq "\0\xFF\0\0\0\0"."\xFF\0\0" x 48 . "\0\0\xFF" x 50
 157   or print "not ";
 158 print "ok 52\n";
 159
 160 # test the OO interfaces
 161 my $impal2 = Imager->new(type=>'pseudo', xsize=>200, ysize=>201)
 162   or print "not ";
 163 print "ok 53\n";
 164 $impal2->getchannels == 3 or print "not ";
 165 print "ok 54\n";
 166 $impal2->bits == 8 or print "not ";
 167 print "ok 55\n";
 168 $impal2->type eq 'paletted' or print "not ";
 169 print "ok 56\n";
 170
 171 {
 172   my $red_idx = $impal2->addcolors(colors=>[$red])
 173     or print "not ";
 174   print "ok 57\n";
 175   $red_idx == 0 or print "not ";
 176   print "ok 58\n";
 177   my $blue_idx = $impal2->addcolors(colors=>[$blue, $green])
 178     or print "not ";
 179   print "ok 59\n";
 180   $blue_idx == 1 or print "not ";
 181   print "ok 60\n";
 182   my $green_idx = $blue_idx + 1;
 183   my $c = $impal2->getcolors(start=>$green_idx);
 184   color_cmp($green, $c) == 0 or print "not ";
 185   print "ok 61\n";
 186   my @cols = $impal2->getcolors;
 187   @cols == 3 or print "not ";
 188   print "ok 62\n";
 189   my @exp = ( $red, $blue, $green );
 190   for my $i (0..2) {
 191     if (color_cmp($cols[$i], $exp[$i])) {
 192       print "not ";
 193       last;
 194     }
 195   }
 196   print "ok 63\n";
 197   $impal2->colorcount == 3 or print "not ";
 198   print "ok 64\n";
 199   $impal2->maxcolors == 256 or print "not ";
 200   print "ok 65\n";
 201   $impal2->findcolor(color=>$blue) == 1 or print "not ";
 202   print "ok 66\n";
 203   $impal2->setcolors(start=>0, colors=>[ $blue, $red ]) or print "not ";
 204   print "ok 67\n";
 205
 206   # make an rgb version
 207   my $imrgb2 = $impal2->to_rgb8();
 208   $imrgb2->type eq 'direct' or print "not ";
 209   print "ok 68\n";
 210
 211   # and back again, specifying the palette
 212   my @colors = ( $red, $blue, $green );
 213   my $impal3 = $imrgb2->to_paletted(colors=>\@colors,
 214                                     make_colors=>'none',
 215                                     translate=>'closest')
 216     or print "not ";
 217   print "ok 69\n";
 218   dump_colors(@colors);
 219   print "# in image\n";
 220   dump_colors($impal3->getcolors);
 221   $impal3->colorcount == 3 or print "not ";
 222   print "ok 70\n";
 223   $impal3->type eq 'paletted' or print "not ";
 224   print "ok 71\n";
 225 }
 226
 227 my $num = 72;
 228 okn($num++, !Imager->new(xsize=>0, ysize=>1), "fail to create 0 height image");
 229 matchn($num++, Imager->errstr, qr/Image sizes must be positive/,
 230        "0 height error message check");
 231 okn($num++, !Imager->new(xsize=>1, ysize=>0), "fail to create 0 width image");
 232 matchn($num++, Imager->errstr, qr/Image sizes must be positive/,
 233        "0 width error message check");
 234 okn($num++, !Imager->new(xsize=>-1, ysize=>1), "fail to create -ve height image");
 235 matchn($num++, Imager->errstr, qr/Image sizes must be positive/,
 236        "-ve width error message check");
 237 okn($num++, !Imager->new(xsize=>1, ysize=>-1), "fail to create -ve width image");
 238 matchn($num++, Imager->errstr, qr/Image sizes must be positive/,
 239        "-ve height error message check");
 240 okn($num++, !Imager->new(xsize=>-1, ysize=>-1), "fail to create -ve width/height image");
 241 matchn($num++, Imager->errstr, qr/Image sizes must be positive/,
 242        "-ve width/height error message check");
 243
 244 okn($num++, !Imager->new(xsize=>1, ysize=>1, channels=>0),
 245     "fail to create a zero channel image");
 246 matchn($num++, Imager->errstr, qr/channels must be between 1 and 4/,
 247        "out of range channel message check");
 248 okn($num++, !Imager->new(xsize=>1, ysize=>1, channels=>5),
 249     "fail to create a five channel image");
 250 matchn($num++, Imager->errstr, qr/channels must be between 1 and 4/,
 251        "out of range channel message check");
 252
 253 {
 254   # https://rt.cpan.org/Ticket/Display.html?id=8213
 255   # check for handling of memory allocation of very large images
 256   # only test this on 32-bit machines - on a 64-bit machine it may
 257   # result in trying to allocate 4Gb of memory, which is unfriendly at
 258   # least and may result in running out of memory, causing a different
 259   # type of exit
 260   use Config;
 261   if ($Config{intsize} == 4) {
 262     my $uint_range = 256 ** $Config{intsize};
 263     print "# range $uint_range\n";
 264     my $dim1 = int(sqrt($uint_range))+1;
 265
 266     my $im_b = Imager->new(xsize=>$dim1, ysize=>$dim1, channels=>1);
 267     isn($num++, $im_b, undef, "integer overflow check - 1 channel");
 268
 269     $im_b = Imager->new(xisze=>$dim1, ysize=>1, channels=>1);
 270     okn($num++, $im_b, "but same width ok");
 271     $im_b = Imager->new(xisze=>1, ysize=>$dim1, channels=>1);
 272     okn($num++, $im_b, "but same height ok");
 273     matchn($num++, Imager->errstr, qr/integer overflow/,
 274            "check the error message");
 275
 276     # do a similar test with a 3 channel image, so we're sure we catch
 277     # the same case where the third dimension causes the overflow
 278     my $dim3 = int(sqrt($uint_range / 3))+1;
 279
 280     $im_b = Imager->new(xsize=>$dim3, ysize=>$dim3, channels=>3);
 281     isn($num++, $im_b, undef, "integer overflow check - 3 channel");
 282
 283     $im_b = Imager->new(xisze=>$dim3, ysize=>1, channels=>3);
 284     okn($num++, $im_b, "but same width ok");
 285     $im_b = Imager->new(xisze=>1, ysize=>$dim3, channels=>3);
 286     okn($num++, $im_b, "but same height ok");
 287
 288     matchn($num++, Imager->errstr, qr/integer overflow/,
 289            "check the error message");
 290   }
 291   else {
 292     skipn($num, 8, "don't want to allocate 4Gb");
 293     $num += 8;
 294   }
 295 }
 296
 297 sub check_add {
 298   my ($base, $im, $color, $expected) = @_;
 299   my $index = Imager::i_addcolors($im, $color)
 300     or print "not ";
 301   print "ok ",$base++,"\n";
 302   print "# $index\n";
 303   $index == $expected
 304     or print "not ";
 305   print "ok ",$base++,"\n";
 306   my ($new) = Imager::i_getcolors($im, $index)
 307     or print "not ";
 308   print "ok ",$base++,"\n";
 309   color_cmp($new, $color) == 0
 310     or print "not ";
 311   print "ok ",$base++,"\n";
 312
 313   $index;
 314 }
 315
 316 sub color_cmp {
 317   my ($l, $r) = @_;
 318   my @l = $l->rgba;
 319   my @r = $r->rgba;
 320   return $l[0] <=> $r[0]
 321     || $l[1] <=> $r[1]
 322       || $l[2] <=> $r[2];
 323 }
 324
 325 sub array_ncmp {
 326   my ($a1, $a2) = @_;
 327   my $len = @$a1 < @$a2 ? @$a1 : @$a2;
 328   for my $i (0..$len-1) {
 329     my $diff = $a1->[$i] <=> $a2->[$i]
 330       and return $diff;
 331   }
 332   return @$a1 <=> @$a2;
 333 }
 334
 335 sub dump_colors {
 336   for my $col (@_) {
 337     print "# ", map(sprintf("%02X", $_), ($col->rgba)[0..2]),"\n";
 338   }
 339 }