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..71\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 init_log("testout/t01introvert.log",1);
  18
  19 my $im_g = Imager::ImgRaw::new(100, 101, 1);
  20
  21 print Imager::i_img_getchannels($im_g) == 1
  22   ? "ok 2\n" : "not ok 2 # 1 channel image channel count mismatch\n";
  23 print Imager::i_img_getmask($im_g) & 1
  24   ? "ok 3\n" : "not ok 3 # 1 channel image bad mask\n";
  25 print Imager::i_img_virtual($im_g)
  26   ? "not ok 4 # 1 channel image thinks it is virtual\n" : "ok 4\n";
  27 print Imager::i_img_bits($im_g) == 8
  28   ? "ok 5\n" : "not ok 5 # 1 channel image has bits != 8\n";
  29 print Imager::i_img_type($im_g) == 0 # direct
  30   ? "ok 6\n" : "not ok 6 # 1 channel image isn't direct\n";
  31
  32 my @ginfo = Imager::i_img_info($im_g);
  33 print $ginfo[0] == 100
  34   ? "ok 7\n" : "not ok 7 # 1 channel image width incorrect\n";
  35 print $ginfo[1] == 101
  36   ? "ok 8\n" : "not ok 8 # 1 channel image height incorrect\n";
  37
  38 undef $im_g; # can we check for release after this somehow?
  39
  40 my $im_rgb = Imager::ImgRaw::new(100, 101, 3);
  41
  42 print Imager::i_img_getchannels($im_rgb) == 3
  43   ? "ok 9\n" : "not ok 9 # 3 channel image channel count mismatch\n";
  44 print +(Imager::i_img_getmask($im_rgb) & 7) == 7
  45   ? "ok 10\n" : "not ok 10 # 3 channel image bad mask\n";
  46 print Imager::i_img_bits($im_rgb) == 8
  47   ? "ok 11\n" : "not ok 11 # 3 channel image has bits != 8\n";
  48 print Imager::i_img_type($im_rgb) == 0 # direct
  49   ? "ok 12\n" : "not ok 12 # 3 channel image isn't direct\n";
  50
  51 undef $im_rgb;
  52
  53 my $im_pal = Imager::i_img_pal_new(100, 101, 3, 256);
  54
  55 print $im_pal ? "ok 13\n" : "not ok 13 # couldn't make paletted image\n";
  56 print Imager::i_img_getchannels($im_pal) == 3
  57   ? "ok 14\n" : "not ok 14 # pal img channel count mismatch\n";
  58 print Imager::i_img_bits($im_pal) == 8
  59   ? "ok 15\n" : "not ok 15 # pal img bits != 8\n";
  60 print Imager::i_img_type($im_pal) == 1
  61   ? "ok 16\n" : "not ok 16 # pal img isn't paletted\n";
  62
  63 my $red = NC(255, 0, 0);
  64 my $green = NC(0, 255, 0);
  65 my $blue = NC(0, 0, 255);
  66
  67 my $red_idx = check_add(17, $im_pal, $red, 0);
  68 my $green_idx = check_add(21, $im_pal, $green, 1);
  69 my $blue_idx = check_add(25, $im_pal, $blue, 2);
  70
  71 # basic writing of palette indicies
  72 # fill with red
  73 Imager::i_ppal($im_pal, 0, 0, ($red_idx) x 100) == 100
  74   or print "not ";
  75 print "ok 29\n";
  76 # and blue
  77 Imager::i_ppal($im_pal, 50, 0, ($blue_idx) x 50) == 50
  78   or print "not ";
  79 print "ok 30\n";
  80
  81 # make sure we get it back
  82 my @pals = Imager::i_gpal($im_pal, 0, 100, 0);
  83 grep($_ != $red_idx, @pals[0..49]) and print "not ";
  84 print "ok 31\n";
  85 grep($_ != $blue_idx, @pals[50..99]) and print "not ";
  86 print "ok 32\n";
  87 Imager::i_gpal($im_pal, 0, 100, 0) eq "\0" x 50 . "\2" x 50 or print "not ";
  88 print "ok 33\n";
  89 my @samp = Imager::i_gsamp($im_pal, 0, 100, 0, 0, 1, 2);
  90 @samp == 300 or print "not ";
  91 print "ok 34\n";
  92 my @samp_exp = ((255, 0, 0) x 50, (0, 0, 255) x 50);
  93 my $diff = array_ncmp(\@samp, \@samp_exp);
  94 $diff == 0 or print "not ";
  95 print "ok 35\n";
  96 my $samp = Imager::i_gsamp($im_pal, 0, 100, 0, 0, 1, 2);
  97 length($samp) == 300 or print "not ";
  98 print "ok 36\n";
  99 $samp eq "\xFF\0\0" x 50 . "\0\0\xFF" x 50
 100   or print "not ";
 101 print "ok 37\n";
 102
 103 # reading indicies as colors
 104 my $c_red = Imager::i_get_pixel($im_pal, 0, 0)
 105   or print "not ";
 106 print "ok 38\n";
 107 color_cmp($red, $c_red) == 0
 108   or print "not ";
 109 print "ok 39\n";
 110 my $c_blue = Imager::i_get_pixel($im_pal, 50, 0)
 111   or print "not ";
 112 print "ok 40\n";
 113 color_cmp($blue, $c_blue) == 0
 114   or print "not ";
 115 print "ok 41\n";
 116
 117 # drawing with colors
 118 Imager::i_ppix($im_pal, 0, 0, $green) and print "not ";
 119 print "ok 42\n";
 120 # that was in the palette, should still be paletted
 121 print Imager::i_img_type($im_pal) == 1
 122   ? "ok 43\n" : "not ok 43 # pal img isn't paletted (but still should be)\n";
 123
 124 my $c_green = Imager::i_get_pixel($im_pal, 0, 0)
 125   or print "not ";
 126 print "ok 44\n";
 127 color_cmp($green, $c_green) == 0
 128   or print "not ";
 129 print "ok 45\n";
 130
 131 Imager::i_colorcount($im_pal) == 3 or print "not ";
 132 print "ok 46\n";
 133 Imager::i_findcolor($im_pal, $green) == 1 or print "not ";
 134 print "ok 47\n";
 135
 136 my $black = NC(0, 0, 0);
 137 # this should convert the image to RGB
 138 Imager::i_ppix($im_pal, 1, 0, $black) and print "not ";
 139 print "ok 48\n";
 140 print Imager::i_img_type($im_pal) == 0
 141   ? "ok 49\n" : "not ok 49 # pal img shouldn't be paletted now\n";
 142
 143 my %quant =
 144   (
 145    colors => [$red, $green, $blue, $black],
 146    makemap => 'none',
 147   );
 148 my $im_pal2 = Imager::i_img_to_pal($im_pal, \%quant);
 149 $im_pal2 or print "not ";
 150 print "ok 50\n";
 151 @{$quant{colors}} == 4 or print "not ";
 152 print "ok 51\n";
 153 Imager::i_gsamp($im_pal2, 0, 100, 0, 0, 1, 2)
 154   eq "\0\xFF\0\0\0\0"."\xFF\0\0" x 48 . "\0\0\xFF" x 50
 155   or print "not ";
 156 print "ok 52\n";
 157
 158 # test the OO interfaces
 159 my $impal2 = Imager->new(type=>'pseudo', xsize=>200, ysize=>201)
 160   or print "not ";
 161 print "ok 53\n";
 162 $impal2->getchannels == 3 or print "not ";
 163 print "ok 54\n";
 164 $impal2->bits == 8 or print "not ";
 165 print "ok 55\n";
 166 $impal2->type eq 'paletted' or print "not ";
 167 print "ok 56\n";
 168
 169 {
 170   my $red_idx = $impal2->addcolors(colors=>[$red])
 171     or print "not ";
 172   print "ok 57\n";
 173   $red_idx == 0 or print "not ";
 174   print "ok 58\n";
 175   my $blue_idx = $impal2->addcolors(colors=>[$blue, $green])
 176     or print "not ";
 177   print "ok 59\n";
 178   $blue_idx == 1 or print "not ";
 179   print "ok 60\n";
 180   my $green_idx = $blue_idx + 1;
 181   my $c = $impal2->getcolors(start=>$green_idx);
 182   color_cmp($green, $c) == 0 or print "not ";
 183   print "ok 61\n";
 184   my @cols = $impal2->getcolors;
 185   @cols == 3 or print "not ";
 186   print "ok 62\n";
 187   my @exp = ( $red, $blue, $green );
 188   for my $i (0..2) {
 189     if (color_cmp($cols[$i], $exp[$i])) {
 190       print "not ";
 191       last;
 192     }
 193   }
 194   print "ok 63\n";
 195   $impal2->colorcount == 3 or print "not ";
 196   print "ok 64\n";
 197   $impal2->maxcolors == 256 or print "not ";
 198   print "ok 65\n";
 199   $impal2->findcolor(color=>$blue) == 1 or print "not ";
 200   print "ok 66\n";
 201   $impal2->setcolors(start=>0, colors=>[ $blue, $red ]) or print "not ";
 202   print "ok 67\n";
 203
 204   # make an rgb version
 205   my $imrgb2 = $impal2->to_rgb8();
 206   $imrgb2->type eq 'direct' or print "not ";
 207   print "ok 68\n";
 208
 209   # and back again, specifying the palette
 210   my @colors = ( $red, $blue, $green );
 211   my $impal3 = $imrgb2->to_paletted(colors=>\@colors,
 212                                     make_colors=>'none',
 213                                     translate=>'closest')
 214     or print "not ";
 215   print "ok 69\n";
 216   dump_colors(@colors);
 217   print "# in image\n";
 218   dump_colors($impal3->getcolors);
 219   $impal3->colorcount == 3 or print "not ";
 220   print "ok 70\n";
 221   $impal3->type eq 'paletted' or print "not ";
 222   print "ok 71\n";
 223 }
 224
 225 sub check_add {
 226   my ($base, $im, $color, $expected) = @_;
 227   my $index = Imager::i_addcolors($im, $color)
 228     or print "not ";
 229   print "ok ",$base++,"\n";
 230   print "# $index\n";
 231   $index == $expected
 232     or print "not ";
 233   print "ok ",$base++,"\n";
 234   my ($new) = Imager::i_getcolors($im, $index)
 235     or print "not ";
 236   print "ok ",$base++,"\n";
 237   color_cmp($new, $color) == 0
 238     or print "not ";
 239   print "ok ",$base++,"\n";
 240
 241   $index;
 242 }
 243
 244 sub color_cmp {
 245   my ($l, $r) = @_;
 246   my @l = $l->rgba;
 247   my @r = $r->rgba;
 248   return $l[0] <=> $r[0]
 249     || $l[1] <=> $r[1]
 250       || $l[2] <=> $r[2];
 251 }
 252
 253 sub array_ncmp {
 254   my ($a1, $a2) = @_;
 255   my $len = @$a1 < @$a2 ? @$a1 : @$a2;
 256   for my $i (0..$len-1) {
 257     my $diff = $a1->[$i] <=> $a2->[$i]
 258       and return $diff;
 259   }
 260   return @$a1 <=> @$a2;
 261 }
 262
 263 sub dump_colors {
 264   for my $col (@_) {
 265     print "# ", map(sprintf("%02X", $_), ($col->rgba)[0..2]),"\n";
 266   }
 267 }