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 Test::More tests=>196;
   7
   8 BEGIN { use_ok(Imager => qw(:handy :all)) }
   9
  10 require "t/testtools.pl";
  11
  12 init_log("testout/t01introvert.log",1);
  13
  14 my $im_g = Imager::ImgRaw::new(100, 101, 1);
  15
  16 my $red = NC(255, 0, 0);
  17 my $green = NC(0, 255, 0);
  18 my $blue = NC(0, 0, 255);
  19
  20 use Imager::Color::Float;
  21 my $f_black = Imager::Color::Float->new(0, 0, 0);
  22 my $f_red = Imager::Color::Float->new(1.0, 0, 0);
  23 my $f_green = Imager::Color::Float->new(0, 1.0, 0);
  24 my $f_blue = Imager::Color::Float->new(0, 0, 1.0);
  25
  26 is(Imager::i_img_getchannels($im_g), 1, "1 channel image channel count");
  27 ok(Imager::i_img_getmask($im_g) & 1, "1 channel image mask");
  28 ok(!Imager::i_img_virtual($im_g), "1 channel image not virtual");
  29 is(Imager::i_img_bits($im_g), 8, "1 channel image has 8 bits/sample");
  30 is(Imager::i_img_type($im_g), 0, "1 channel image is direct");
  31
  32 my @ginfo = Imager::i_img_info($im_g);
  33 is($ginfo[0], 100, "1 channel image width");
  34 is($ginfo[1], 101, "1 channel image height");
  35
  36 undef $im_g; # can we check for release after this somehow?
  37
  38 my $im_rgb = Imager::ImgRaw::new(100, 101, 3);
  39
  40 is(Imager::i_img_getchannels($im_rgb), 3, "3 channel image channel count");
  41 is((Imager::i_img_getmask($im_rgb) & 7), 7, "3 channel image mask");
  42 is(Imager::i_img_bits($im_rgb), 8, "3 channel image has 8 bits/sample");
  43 is(Imager::i_img_type($im_rgb), 0, "3 channel image is direct");
  44
  45 undef $im_rgb;
  46
  47 my $im_pal = Imager::i_img_pal_new(100, 101, 3, 256);
  48
  49 ok($im_pal, "make paletted image");
  50 is(Imager::i_img_getchannels($im_pal), 3, "pal img channel count");
  51 is(Imager::i_img_bits($im_pal), 8, "pal img bits");
  52 is(Imager::i_img_type($im_pal), 1, "pal img is paletted");
  53
  54 my $red_idx = check_add($im_pal, $red, 0);
  55 my $green_idx = check_add($im_pal, $green, 1);
  56 my $blue_idx = check_add($im_pal, $blue, 2);
  57
  58 # basic writing of palette indicies
  59 # fill with red
  60 is(Imager::i_ppal($im_pal, 0, 0, ($red_idx) x 100), 100,
  61    "write red 100 times");
  62 # and blue
  63 is(Imager::i_ppal($im_pal, 50, 0, ($blue_idx) x 50), 50,
  64    "write blue 50 times");
  65
  66 # make sure we get it back
  67 my @pals = Imager::i_gpal($im_pal, 0, 100, 0);
  68 ok(!grep($_ != $red_idx, @pals[0..49]), "check for red");
  69 ok(!grep($_ != $blue_idx, @pals[50..99]), "check for blue");
  70 is(Imager::i_gpal($im_pal, 0, 100, 0), "\0" x 50 . "\2" x 50,
  71    "gpal in scalar context");
  72 my @samp = Imager::i_gsamp($im_pal, 0, 100, 0, 0, 1, 2);
  73 is(@samp, 300, "gsamp count in list context");
  74 my @samp_exp = ((255, 0, 0) x 50, (0, 0, 255) x 50);
  75 is_deeply(\@samp, \@samp_exp, "gsamp list deep compare");
  76 my $samp = Imager::i_gsamp($im_pal, 0, 100, 0, 0, 1, 2);
  77 is(length($samp), 300, "gsamp scalar length");
  78 is($samp, "\xFF\0\0" x 50 . "\0\0\xFF" x 50, "gsamp scalar bytes");
  79
  80 # reading indicies as colors
  81 my $c_red = Imager::i_get_pixel($im_pal, 0, 0);
  82 ok($c_red, "got the red pixel");
  83 ok(color_cmp($red, $c_red) == 0, "and it's red");
  84 my $c_blue = Imager::i_get_pixel($im_pal, 50, 0);
  85 ok($c_blue, "got the blue pixel");
  86 ok(color_cmp($blue, $c_blue) == 0, "and it's blue");
  87
  88 # drawing with colors
  89 ok(Imager::i_ppix($im_pal, 0, 0, $green) == 0, "draw with color in palette");
  90 # that was in the palette, should still be paletted
  91 is(Imager::i_img_type($im_pal), 1, "image still paletted");
  92
  93 my $c_green = Imager::i_get_pixel($im_pal, 0, 0);
  94 ok($c_green, "got green pixel");
  95 ok(color_cmp($green, $c_green) == 0, "and it's green");
  96
  97 is(Imager::i_colorcount($im_pal), 3, "still 3 colors in palette");
  98 is(Imager::i_findcolor($im_pal, $green), 1, "and green is the second");
  99
 100 my $black = NC(0, 0, 0);
 101 # this should convert the image to RGB
 102 ok(Imager::i_ppix($im_pal, 1, 0, $black) == 0, "draw with black (not in palette)");
 103 is(Imager::i_img_type($im_pal), 0, "pal img shouldn't be paletted now");
 104
 105 my %quant =
 106   (
 107    colors => [$red, $green, $blue, $black],
 108    makemap => 'none',
 109   );
 110 my $im_pal2 = Imager::i_img_to_pal($im_pal, \%quant);
 111 ok($im_pal2, "got an image from quantizing");
 112 is(@{$quant{colors}}, 4, "has the right number of colours");
 113 is(Imager::i_gsamp($im_pal2, 0, 100, 0, 0, 1, 2),
 114   "\0\xFF\0\0\0\0"."\xFF\0\0" x 48 . "\0\0\xFF" x 50,
 115    "colors are still correct");
 116
 117 # test the OO interfaces
 118 my $impal2 = Imager->new(type=>'pseudo', xsize=>200, ysize=>201);
 119 ok($impal2, "make paletted via OO");
 120 is($impal2->getchannels, 3, "check channels");
 121 is($impal2->bits, 8, "check bits");
 122 is($impal2->type, 'paletted', "check type");
 123
 124 {
 125   my $red_idx = $impal2->addcolors(colors=>[$red]);
 126   ok($red_idx, "add red to OO");
 127   is(0+$red_idx, 0, "and it's expected index for red");
 128   my $blue_idx = $impal2->addcolors(colors=>[$blue, $green]);
 129   ok($blue_idx, "add blue/green via OO");
 130   is($blue_idx, 1, "and it's expected index for blue");
 131   my $green_idx = $blue_idx + 1;
 132   my $c = $impal2->getcolors(start=>$green_idx);
 133   ok(color_cmp($green, $c) == 0, "found green where expected");
 134   my @cols = $impal2->getcolors;
 135   is(@cols, 3, "got 3 colors");
 136   my @exp = ( $red, $blue, $green );
 137   my $good = 1;
 138   for my $i (0..2) {
 139     if (color_cmp($cols[$i], $exp[$i])) {
 140       $good = 0;
 141       last;
 142     }
 143   }
 144   ok($good, "all colors in palette as expected");
 145   is($impal2->colorcount, 3, "and colorcount returns 3");
 146   is($impal2->maxcolors, 256, "maxcolors as expected");
 147   is($impal2->findcolor(color=>$blue), 1, "findcolors found blue");
 148   ok($impal2->setcolors(start=>0, colors=>[ $blue, $red ]),
 149      "we can setcolors");
 150
 151   # make an rgb version
 152   my $imrgb2 = $impal2->to_rgb8();
 153   is($imrgb2->type, 'direct', "converted is direct");
 154
 155   # and back again, specifying the palette
 156   my @colors = ( $red, $blue, $green );
 157   my $impal3 = $imrgb2->to_paletted(colors=>\@colors,
 158                                     make_colors=>'none',
 159                                     translate=>'closest');
 160   ok($impal3, "got a paletted image from conversion");
 161   dump_colors(@colors);
 162   print "# in image\n";
 163   dump_colors($impal3->getcolors);
 164   is($impal3->colorcount, 3, "new image has expected color table size");
 165   is($impal3->type, 'paletted', "and is paletted");
 166 }
 167
 168 ok(!Imager->new(xsize=>0, ysize=>1), "fail to create 0 height image");
 169 cmp_ok(Imager->errstr, '=~', qr/Image sizes must be positive/,
 170        "0 height error message check");
 171 ok(!Imager->new(xsize=>1, ysize=>0), "fail to create 0 width image");
 172 cmp_ok(Imager->errstr, '=~', qr/Image sizes must be positive/,
 173        "0 width error message check");
 174 ok(!Imager->new(xsize=>-1, ysize=>1), "fail to create -ve height image");
 175 cmp_ok(Imager->errstr, '=~', qr/Image sizes must be positive/,
 176        "-ve width error message check");
 177 ok(!Imager->new(xsize=>1, ysize=>-1), "fail to create -ve width image");
 178 cmp_ok(Imager->errstr, '=~', qr/Image sizes must be positive/,
 179        "-ve height error message check");
 180 ok(!Imager->new(xsize=>-1, ysize=>-1), "fail to create -ve width/height image");
 181 cmp_ok(Imager->errstr, '=~', qr/Image sizes must be positive/,
 182        "-ve width/height error message check");
 183
 184 ok(!Imager->new(xsize=>1, ysize=>1, channels=>0),
 185    "fail to create a zero channel image");
 186 cmp_ok(Imager->errstr, '=~', qr/channels must be between 1 and 4/,
 187        "out of range channel message check");
 188 ok(!Imager->new(xsize=>1, ysize=>1, channels=>5),
 189    "fail to create a five channel image");
 190 cmp_ok(Imager->errstr, '=~', qr/channels must be between 1 and 4/,
 191        "out of range channel message check");
 192
 193 {
 194   # https://rt.cpan.org/Ticket/Display.html?id=8213
 195   # check for handling of memory allocation of very large images
 196   # only test this on 32-bit machines - on a 64-bit machine it may
 197   # result in trying to allocate 4Gb of memory, which is unfriendly at
 198   # least and may result in running out of memory, causing a different
 199   # type of exit
 200  SKIP:
 201   {
 202     use Config;
 203     skip("don't want to allocate 4Gb", 8) unless $Config{intsize} == 4;
 204
 205     my $uint_range = 256 ** $Config{intsize};
 206     print "# range $uint_range\n";
 207     my $dim1 = int(sqrt($uint_range))+1;
 208
 209     my $im_b = Imager->new(xsize=>$dim1, ysize=>$dim1, channels=>1);
 210     is($im_b, undef, "integer overflow check - 1 channel");
 211
 212     $im_b = Imager->new(xisze=>$dim1, ysize=>1, channels=>1);
 213     ok($im_b, "but same width ok");
 214     $im_b = Imager->new(xisze=>1, ysize=>$dim1, channels=>1);
 215     ok($im_b, "but same height ok");
 216     cmp_ok(Imager->errstr, '=~', qr/integer overflow/,
 217            "check the error message");
 218
 219     # do a similar test with a 3 channel image, so we're sure we catch
 220     # the same case where the third dimension causes the overflow
 221     my $dim3 = int(sqrt($uint_range / 3))+1;
 222
 223     $im_b = Imager->new(xsize=>$dim3, ysize=>$dim3, channels=>3);
 224     is($im_b, undef, "integer overflow check - 3 channel");
 225
 226     $im_b = Imager->new(xisze=>$dim3, ysize=>1, channels=>3);
 227     ok($im_b, "but same width ok");
 228     $im_b = Imager->new(xisze=>1, ysize=>$dim3, channels=>3);
 229     ok($im_b, "but same height ok");
 230
 231     cmp_ok(Imager->errstr, '=~', qr/integer overflow/,
 232            "check the error message");
 233   }
 234 }
 235
 236 { # http://rt.cpan.org/NoAuth/Bug.html?id=9672
 237   my $warning;
 238   local $SIG{__WARN__} =
 239     sub {
 240       $warning = "@_";
 241       my $printed = $warning;
 242       $printed =~ s/\n$//;
 243       $printed =~ s/\n/\n\#/g;
 244       print "# ",$printed, "\n";
 245     };
 246   my $img = Imager->new(xsize=>10, ysize=>10);
 247   $img->to_rgb8(); # doesn't really matter what the source is
 248   cmp_ok($warning, '=~', 'void', "correct warning");
 249   cmp_ok($warning, '=~', 't01introvert\\.t', "correct file");
 250 }
 251
 252 { # http://rt.cpan.org/NoAuth/Bug.html?id=11860
 253   my $im = Imager->new(xsize=>2, ysize=>2);
 254   $im->setpixel(x=>0, 'y'=>0, color=>$red);
 255   $im->setpixel(x=>1, 'y'=>0, color=>$blue);
 256
 257   my @row = Imager::i_glin($im->{IMG}, 0, 2, 0);
 258   is(@row, 2, "got 2 pixels from i_glin");
 259   ok(color_cmp($row[0], $red) == 0, "red first");
 260   ok(color_cmp($row[1], $blue) == 0, "then blue");
 261 }
 262
 263 { # general tag tests
 264
 265   # we don't care much about the image itself
 266   my $im = Imager::ImgRaw::new(10, 10, 1);
 267
 268   ok(Imager::i_tags_addn($im, 'alpha', 0, 101), "i_tags_addn(...alpha, 0, 101)");
 269   ok(Imager::i_tags_addn($im, undef, 99, 102), "i_tags_addn(...undef, 99, 102)");
 270   is(Imager::i_tags_count($im), 2, "should have 2 tags");
 271   ok(Imager::i_tags_addn($im, undef, 99, 103), "i_tags_addn(...undef, 99, 103)");
 272   is(Imager::i_tags_count($im), 3, "should have 3 tags, despite the dupe");
 273   is(Imager::i_tags_find($im, 'alpha', 0), '0 but true', "find alpha");
 274   is(Imager::i_tags_findn($im, 99, 0), 1, "find 99");
 275   is(Imager::i_tags_findn($im, 99, 2), 2, "find 99 again");
 276   is(Imager::i_tags_get($im, 0), 101, "check first");
 277   is(Imager::i_tags_get($im, 1), 102, "check second");
 278   is(Imager::i_tags_get($im, 2), 103, "check third");
 279
 280   ok(Imager::i_tags_add($im, 'beta', 0, "hello", 0),
 281      "add string with string key");
 282   ok(Imager::i_tags_add($im, 'gamma', 0, "goodbye", 0),
 283      "add another one");
 284   ok(Imager::i_tags_add($im, undef, 199, "aloha", 0),
 285      "add one keyed by number");
 286   is(Imager::i_tags_find($im, 'beta', 0), 3, "find beta");
 287   is(Imager::i_tags_find($im, 'gamma', 0), 4, "find gamma");
 288   is(Imager::i_tags_findn($im, 199, 0), 5, "find 199");
 289   ok(Imager::i_tags_delete($im, 2), "delete");
 290   is(Imager::i_tags_find($im, 'beta', 0), 2, 'find beta after deletion');
 291   ok(Imager::i_tags_delbyname($im, 'beta'), 'delete beta by name');
 292   is(Imager::i_tags_find($im, 'beta', 0), undef, 'beta not there now');
 293   is(Imager::i_tags_get_string($im, "gamma"), "goodbye",
 294      'i_tags_get_string() on a string');
 295   is(Imager::i_tags_get_string($im, 99), 102,
 296      'i_tags_get_string() on a number entry');
 297   ok(Imager::i_tags_delbycode($im, 99), 'delete by code');
 298   is(Imager::i_tags_findn($im, 99, 0), undef, '99 not there now');
 299   is(Imager::i_tags_count($im), 3, 'final count of 3');
 300 }
 301
 302 {
 303   print "# low-level scan line function tests\n";
 304   my $im = Imager::ImgRaw::new(10, 10, 4);
 305   Imager::i_ppix($im, 5, 0, $red);
 306
 307   # i_glin/i_glinf
 308   my @colors = Imager::i_glin($im, 0, 10, 0);
 309   is_deeply([ (0) x 20, (255, 0, 0, 255), (0) x 16 ],
 310             [ map $_->rgba, @colors ],
 311             "i_glin - list context");
 312   my $colors = Imager::i_glin($im, 0, 10, 0);
 313   is("00" x 20 . "FF0000FF" . "00" x 16,
 314      uc unpack("H*", $colors), "i_glin - scalar context");
 315   my @fcolors = Imager::i_glinf($im, 0, 10, 0);
 316   is_deeply([ (0.0) x 20, (1.0, 0, 0, 1.0) , (0) x 16 ],
 317             [ map $_->rgba, @fcolors ],
 318             "i_glinf - list context");
 319   my $fcolors = Imager::i_glinf($im, 0, 10, 0);
 320   is_deeply([ (0.0) x 20, (1.0, 0, 0, 1.0) , (0) x 16 ],
 321             [ unpack "d*", $fcolors ],
 322             "i_glinf - scalar context");
 323
 324   # i_plin/i_plinf
 325   my @plin_colors = (($black) x 4, $red, $blue, ($black) x 4);
 326   is(Imager::i_plin($im, 0, 1, @plin_colors),
 327      10, "i_plin - pass in a list");
 328   # make sure we get it back
 329   is_deeply([ map [ $_->rgba ], @plin_colors ],
 330             [ map [ $_->rgba ], Imager::i_glin($im, 0, 10, 1) ],
 331             "check i_plin wrote to the image");
 332   my @scalar_plin =
 333     (
 334      (0,0,0,0) x 4,
 335      (0, 255, 0, 255),
 336      (0, 0, 255, 255),
 337      (0, 0, 0, 0) x 4,
 338     );
 339   is(Imager::i_plin($im, 0, 2, pack("C*", @scalar_plin)),
 340      10, "i_plin - pass in a scalar");
 341   is_deeply(\@scalar_plin,
 342             [ map $_->rgba , Imager::i_glin($im, 0, 10, 2) ],
 343             "check i_plin scalar wrote to the image");
 344
 345   my @plinf_colors = # Note: only 9 pixels
 346     (
 347      ($f_blue) x 4,
 348      $f_red,
 349      ($f_black) x 3,
 350      $f_black
 351     );
 352   is(Imager::i_plinf($im, 0, 3, @plinf_colors), 9,
 353      "i_plinf - list");
 354   is_deeply([ map $_->rgba, Imager::i_glinf($im, 0, 9, 3) ],
 355             [ map $_->rgba, @plinf_colors ],
 356             "check colors were written");
 357   my @scalar_plinf =
 358     (
 359      ( 1.0, 1.0,   0, 1.0 ) x 3,
 360      (   0, 1.0, 1.0, 1.0 ) x 2,
 361      (   0,   0,   0,   0 ),
 362      ( 1.0,   0, 1.0, 1.0 ),
 363     );
 364   is(Imager::i_plinf($im, 2, 4, pack("d*", @scalar_plinf)),
 365      7, "i_plinf - scalar");
 366   is_deeply(\@scalar_plinf,
 367             [ map $_->rgba, Imager::i_glinf($im, 2, 9, 4) ],
 368             "check colors were written");
 369
 370   is_deeply([ Imager::i_gsamp($im, 0, 10, 0, (0, 3)) ],
 371             [ (0, 0) x 5, (255, 255), (0, 0) x 4 ],
 372             "i_gsamp list context");
 373   is("0000" x 5 . "FFFF" . "0000" x 4,
 374      uc unpack("H*", Imager::i_gsamp($im, 0, 10, 0, (0, 3))),
 375      "i_gsamp scalar context");
 376   is_deeply([ Imager::i_gsampf($im, 2, 9, 4, 0, 2, 3) ],
 377             [ (1.0, 0, 1.0) x 3, (0, 1.0, 1.0) x 2, (0, 0, 0),
 378               (1.0, 1.0, 1.0) ], "i_gsampf - list context");
 379   is_deeply([ unpack("d*", Imager::i_gsampf($im, 2, 9, 4, 0, 2, 3)) ],
 380             [ (1.0, 0, 1.0) x 3, (0, 1.0, 1.0) x 2, (0, 0, 0),
 381               (1.0, 1.0, 1.0) ], "i_gsampf - scalar context");
 382   print "# end low-level scan-line function tests\n";
 383 }
 384
 385 {
 386   print "# OO level scanline function tests\n";
 387   my $im = Imager->new(xsize=>10, ysize=>10, channels=>4);
 388   $im->setpixel(color=>$red, 'x'=>5, 'y'=>0);
 389   ok(!$im->getscanline(), "getscanline() - supply nothing, get nothing");
 390   is($im->errstr, "missing y parameter", "check message");
 391   is_deeply([ map [ $_->rgba ], $im->getscanline('y'=>0) ],
 392             [ ([ 0,0,0,0]) x 5, [ 255, 0, 0, 255 ], ([ 0,0,0,0]) x 4 ],
 393             "getscanline, list context, default x, width");
 394   is_deeply([ map [ $_->rgba ], $im->getscanline('y'=>0, 'x'=>3) ],
 395             [ ([0,0,0,0]) x 2, [ 255, 0, 0, 255 ], ([0,0,0,0]) x 4 ],
 396             "getscanline, list context, default width");
 397   is_deeply([ map [ $_->rgba ], $im->getscanline('y'=>0, 'x'=>4, width=>4) ],
 398             [ [0,0,0,0], [ 255, 0, 0, 255 ], ([0,0,0,0]) x 2 ],
 399             "getscanline, list context, no defaults");
 400   is(uc unpack("H*",  $im->getscanline('y'=>0)),
 401      "00000000" x 5 .  "FF0000FF" . "00000000" x 4,
 402      "getscanline, scalar context, default x, width");
 403   is_deeply([ map [ $_->rgba ],
 404               $im->getscanline('y'=>0, 'x'=>4, width=>4, type=>'float') ],
 405             [ [0,0,0,0], [ 1.0, 0, 0, 1.0 ], ([0,0,0,0]) x 2 ],
 406             "getscanline float, list context, no defaults");
 407   is_deeply([ unpack "d*",
 408               $im->getscanline('y'=>0, 'x'=>4, width=>4, type=>'float') ],
 409             [ (0,0,0,0), ( 1.0, 0, 0, 1.0 ), (0,0,0,0) x 2 ],
 410             "getscanline float, scalar context, no defaults");
 411
 412   ok(!$im->getscanline('y'=>0, type=>'invalid'),
 413      "check invalid type checking");
 414   like($im->errstr, qr/invalid type parameter/,
 415        "check message for invalid type");
 416
 417   my @plin_colors = (($black) x 4, $red, $blue, ($green) x 4);
 418   is($im->setscanline('y'=>1, pixels=>\@plin_colors), 10,
 419      "setscanline - arrayref, default x");
 420   is_deeply([ map [ $_->rgba ], @plin_colors ],
 421             [ map [ $_->rgba ], $im->getscanline('y'=>1) ],
 422             "check colors were written");
 423
 424   my @plin_colors2 = ( $green, $red, $blue, $red );
 425   is($im->setscanline('y'=>2, 'x'=>3, pixels=>\@plin_colors2), 4,
 426      "setscanline - arrayref");
 427
 428   # using map instead of x here due to a bug in some versions of Test::More
 429   # fixed in the latest Test::More
 430   is_deeply([ ( map [ 0,0,0,0 ], 1..3), (map [ $_->rgba ], @plin_colors2),
 431               ( map [ 0,0,0,0 ], 1..3) ],
 432             [ map [ $_->rgba ], $im->getscanline('y'=>2) ],
 433             "check write to middle of line");
 434
 435   my $raw_colors = pack "H*", "FF00FFFF"."FF0000FF"."FFFFFFFF";
 436   is($im->setscanline('y'=>3, 'x'=>2, pixels=>$raw_colors), 3,
 437      "setscanline - scalar, default raw type")
 438     or print "# ",$im->errstr,"\n";
 439   is(uc unpack("H*", $im->getscanline('y'=>3, 'x'=>1, 'width'=>5)),
 440      "00000000".uc(unpack "H*", $raw_colors)."00000000",
 441      "check write");
 442
 443   # float colors
 444   my @fcolors = ( $f_red, $f_blue, $f_black, $f_green );
 445   is($im->setscanline('y'=>4, 'x'=>3, pixels=>\@fcolors), 4,
 446      "setscanline - float arrayref");
 447   is_deeply([ map [ $_->rgba ], @fcolors ],
 448             [ map [ $_->rgba ], $im->getscanline('y'=>4, 'x'=>3, width=>4, type=>'float') ],
 449             "check write");
 450   # packed
 451   my $packed_fcolors = pack "d*", map $_->rgba, @fcolors;
 452   is($im->setscanline('y'=>5, 'x'=>4, pixels=>$packed_fcolors, type=>'float'), 4,
 453      "setscanline - float scalar");
 454   is_deeply([ map [ $_->rgba ], @fcolors ],
 455             [ map [ $_->rgba ], $im->getscanline('y'=>5, 'x'=>4, width=>4, type=>'float') ],
 456             "check write");
 457
 458   # get samples
 459   is_deeply([ $im->getsamples('y'=>1, channels=>[ 0 ]) ],
 460             [ map +($_->rgba)[0], @plin_colors ],
 461             "get channel 0, list context, default x, width");
 462   is_deeply([ unpack "C*", $im->getsamples('y'=>1, channels=>[0, 2]) ],
 463             [ map { ($_->rgba)[0, 2] } @plin_colors ],
 464             "get channel 0, 1, scalar context");
 465   is_deeply([ $im->getsamples('y'=>4, 'x'=>3, width=>4, type=>'float',
 466                               channels=>[1,3]) ],
 467             [ map { ($_->rgba)[1,3] } @fcolors ],
 468             "get channels 1,3, list context, float samples");
 469   is_deeply([ unpack "d*",
 470               $im->getsamples('y'=>4, 'x'=>3, width=>4,
 471                               type=>'float', channels=>[3,2,1,0]) ],
 472             [ map { ($_->rgba)[3,2,1,0] } @fcolors ],
 473             "get channels 3..0 as scalar, float samples");
 474
 475   print "# end OO level scanline function tests\n";
 476 }
 477
 478 { # check the channel mask function
 479
 480   my $im = Imager->new(xsize => 10, ysize=>10, bits=>8);
 481
 482   mask_tests($im, 0.005);
 483 }
 484
 485 sub check_add {
 486   my ($im, $color, $expected) = @_;
 487   my $index = Imager::i_addcolors($im, $color);
 488   ok($index, "got index");
 489   print "# $index\n";
 490   is(0+$index, $expected, "index matched expected");
 491   my ($new) = Imager::i_getcolors($im, $index);
 492   ok($new, "got the color");
 493   ok(color_cmp($new, $color) == 0, "color matched what was added");
 494
 495   $index;
 496 }
 497
 498 # sub array_ncmp {
 499 #   my ($a1, $a2) = @_;
 500 #   my $len = @$a1 < @$a2 ? @$a1 : @$a2;
 501 #   for my $i (0..$len-1) {
 502 #     my $diff = $a1->[$i] <=> $a2->[$i]
 503 #       and return $diff;
 504 #   }
 505 #   return @$a1 <=> @$a2;
 506 # }
 507
 508 sub dump_colors {
 509   for my $col (@_) {
 510     print "# ", map(sprintf("%02X", $_), ($col->rgba)[0..2]),"\n";
 511   }
 512 }