t/100-base/010-introvert.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 => 492;
   7
   8 BEGIN { use_ok(Imager => qw(:handy :all)) }
   9
  10 use Imager::Test qw(image_bounds_checks is_color3 is_color4 is_fcolor4 color_cmp mask_tests is_fcolor3);
  11
  12 -d "testout" or mkdir "testout";
  13
  14 Imager->open_log(log => "testout/t01introvert.log");
  15
  16 my $im_g = Imager::ImgRaw::new(100, 101, 1);
  17
  18 my $red = NC(255, 0, 0);
  19 my $green = NC(0, 255, 0);
  20 my $blue = NC(0, 0, 255);
  21
  22 use Imager::Color::Float;
  23 my $f_black = Imager::Color::Float->new(0, 0, 0);
  24 my $f_red = Imager::Color::Float->new(1.0, 0, 0);
  25 my $f_green = Imager::Color::Float->new(0, 1.0, 0);
  26 my $f_blue = Imager::Color::Float->new(0, 0, 1.0);
  27
  28 is(Imager::i_img_getchannels($im_g), 1, "1 channel image channel count");
  29 ok(Imager::i_img_getmask($im_g) & 1, "1 channel image mask");
  30 ok(!Imager::i_img_virtual($im_g), "1 channel image not virtual");
  31 is(Imager::i_img_bits($im_g), 8, "1 channel image has 8 bits/sample");
  32 is(Imager::i_img_type($im_g), 0, "1 channel image is direct");
  33 is(Imager::i_img_get_width($im_g), 100, "100 pixels wide");
  34 is(Imager::i_img_get_height($im_g), 101, "101 pixels high");
  35
  36 my @ginfo = Imager::i_img_info($im_g);
  37 is($ginfo[0], 100, "1 channel image width");
  38 is($ginfo[1], 101, "1 channel image height");
  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 is(Imager::i_img_getchannels($im_rgb), 3, "3 channel image channel count");
  45 is((Imager::i_img_getmask($im_rgb) & 7), 7, "3 channel image mask");
  46 is(Imager::i_img_bits($im_rgb), 8, "3 channel image has 8 bits/sample");
  47 is(Imager::i_img_type($im_rgb), 0, "3 channel image is direct");
  48
  49 undef $im_rgb;
  50
  51 my $im_pal = Imager::i_img_pal_new(100, 101, 3, 256);
  52
  53 ok($im_pal, "make paletted image");
  54 is(Imager::i_img_getchannels($im_pal), 3, "pal img channel count");
  55 is(Imager::i_img_bits($im_pal), 8, "pal img bits");
  56 is(Imager::i_img_type($im_pal), 1, "pal img is paletted");
  57
  58 my $red_idx = check_add($im_pal, $red, 0);
  59 my $green_idx = check_add($im_pal, $green, 1);
  60 my $blue_idx = check_add($im_pal, $blue, 2);
  61
  62 # basic writing of palette indicies
  63 # fill with red
  64 is(Imager::i_ppal($im_pal, 0, 0, ($red_idx) x 100), 100,
  65    "write red 100 times");
  66 # and blue
  67 is(Imager::i_ppal($im_pal, 50, 0, ($blue_idx) x 50), 50,
  68    "write blue 50 times");
  69
  70 # make sure we get it back
  71 my @pals = Imager::i_gpal($im_pal, 0, 100, 0);
  72 ok(!grep($_ != $red_idx, @pals[0..49]), "check for red");
  73 ok(!grep($_ != $blue_idx, @pals[50..99]), "check for blue");
  74 is(Imager::i_gpal($im_pal, 0, 100, 0), "\0" x 50 . "\2" x 50,
  75    "gpal in scalar context");
  76 my @samp = Imager::i_gsamp($im_pal, 0, 100, 0, [ 0, 1, 2 ]);
  77 is(@samp, 300, "gsamp count in list context");
  78 my @samp_exp = ((255, 0, 0) x 50, (0, 0, 255) x 50);
  79 is_deeply(\@samp, \@samp_exp, "gsamp list deep compare");
  80 my $samp = Imager::i_gsamp($im_pal, 0, 100, 0, [ 0, 1, 2 ]);
  81 is(length($samp), 300, "gsamp scalar length");
  82 is($samp, "\xFF\0\0" x 50 . "\0\0\xFF" x 50, "gsamp scalar bytes");
  83
  84 # reading indicies as colors
  85 my $c_red = Imager::i_get_pixel($im_pal, 0, 0);
  86 ok($c_red, "got the red pixel");
  87 is_color3($c_red, 255, 0, 0, "and it's red");
  88 my $c_blue = Imager::i_get_pixel($im_pal, 50, 0);
  89 ok($c_blue, "got the blue pixel");
  90 is_color3($c_blue, 0, 0, 255, "and it's blue");
  91
  92 # drawing with colors
  93 ok(Imager::i_ppix($im_pal, 0, 0, $green) == 0, "draw with color in palette");
  94 # that was in the palette, should still be paletted
  95 is(Imager::i_img_type($im_pal), 1, "image still paletted");
  96
  97 my $c_green = Imager::i_get_pixel($im_pal, 0, 0);
  98 ok($c_green, "got green pixel");
  99 is_color3($c_green, 0, 255, 0, "and it's green");
 100
 101 is(Imager::i_colorcount($im_pal), 3, "still 3 colors in palette");
 102 is(Imager::i_findcolor($im_pal, $green), 1, "and green is the second");
 103
 104 my $black = NC(0, 0, 0);
 105 # this should convert the image to RGB
 106 ok(Imager::i_ppix($im_pal, 1, 0, $black) == 0, "draw with black (not in palette)");
 107 is(Imager::i_img_type($im_pal), 0, "pal img shouldn't be paletted now");
 108
 109 {
 110   my %quant =
 111     (
 112      colors => [$red, $green, $blue, $black],
 113      make_colors => 'none',
 114     );
 115   my $im_pal2 = Imager::i_img_to_pal($im_pal, \%quant);
 116   ok($im_pal2, "got an image from quantizing")
 117     or diag _get_error();
 118   is(@{$quant{colors}}, 4, "quant has the right number of colours");
 119   is(Imager::i_colorcount($im_pal2), 4, "and so does the image");
 120   my @colors = Imager::i_getcolors($im_pal2, 0, 4);
 121   my ($first) = Imager::i_getcolors($im_pal2, 0);
 122   my @first = $colors[0]->rgba;
 123   is_color3($first, $first[0], $first[1], $first[2],
 124            "check first color is first for multiple or single fetch");
 125   is_color3($colors[0], 255, 0, 0, "still red");
 126   is_color3($colors[1], 0, 255, 0, "still green");
 127   is_color3($colors[2], 0, 0, 255, "still blue");
 128   is_color3($colors[3], 0, 0, 0, "still black");
 129   my @samples = Imager::i_gsamp($im_pal2, 0, 100, 0, [ 0, 1, 2 ]);
 130   my @expect = unpack("C*", "\0\xFF\0\0\0\0"."\xFF\0\0" x 48 . "\0\0\xFF" x 50);
 131   my $match_list = is_deeply(\@samples, \@expect, "colors are still correct");
 132   my $samples = Imager::i_gsamp($im_pal2, 0, 100, 0, [ 0, 1, 2 ]);
 133   my $match_scalar = is_deeply([ unpack("C*", $samples) ],
 134                                \@expect, "colors are still correct (scalar)");
 135   unless ($match_list && $match_scalar) {
 136     # this has been failing on a particular smoker, provide more
 137     # diagnostic information
 138     print STDERR "Pallete:\n";
 139     print STDERR "  $_: ", join(",", $colors[$_]->rgba), "\n" for 0..$#colors;
 140     print STDERR "Samples (list): ", join(",", @samples), "\n";
 141     print STDERR "Samples (scalar): ", join(",", unpack("C*", $samples)), "\n";
 142     print STDERR "Indexes: ", join(",", Imager::i_gpal($im_pal2, 0, 100, 0)), "\n";
 143   }
 144 }
 145
 146 # test the OO interfaces
 147 my $impal2 = Imager->new(type=>'pseudo', xsize=>200, ysize=>201);
 148 ok($impal2, "make paletted via OO")
 149   or diag(Imager->errstr);
 150 is($impal2->getchannels, 3, "check channels");
 151 is($impal2->bits, 8, "check bits");
 152 is($impal2->type, 'paletted', "check type");
 153 is($impal2->getwidth, 200, "check width");
 154 is($impal2->getheight, 201, "check height");
 155 is($impal2->colormodel, "rgb", "check color model (string)");
 156 is($impal2->colormodel(numeric => 1), 3, "check color model (numeric)");
 157 is($impal2->alphachannel, undef, "check alpha channel (has none)");
 158 is($impal2->colorchannels, 3, "check colorchannels");
 159
 160 {
 161   my $red_idx = $impal2->addcolors(colors=>[$red]);
 162   ok($red_idx, "add red to OO");
 163   is(0+$red_idx, 0, "and it's expected index for red");
 164   my $blue_idx = $impal2->addcolors(colors=>[$blue, $green]);
 165   ok($blue_idx, "add blue/green via OO");
 166   is($blue_idx, 1, "and it's expected index for blue");
 167   my $green_idx = $blue_idx + 1;
 168   my $c = $impal2->getcolors(start=>$green_idx);
 169   is_color3($c, 0, 255, 0, "found green where expected");
 170   my @cols = $impal2->getcolors;
 171   is(@cols, 3, "got 3 colors");
 172   my @exp = ( $red, $blue, $green );
 173   my $good = 1;
 174   for my $i (0..2) {
 175     if (color_cmp($cols[$i], $exp[$i])) {
 176       $good = 0;
 177       last;
 178     }
 179   }
 180   ok($good, "all colors in palette as expected");
 181   is($impal2->colorcount, 3, "and colorcount returns 3");
 182   is($impal2->maxcolors, 256, "maxcolors as expected");
 183   is($impal2->findcolor(color=>$blue), 1, "findcolors found blue");
 184   ok($impal2->setcolors(start=>0, colors=>[ $blue, $red ]),
 185      "we can setcolors");
 186
 187   # make an rgb version
 188   my $imrgb2 = $impal2->to_rgb8()
 189     or diag($impal2->errstr);
 190   is($imrgb2->type, 'direct', "converted is direct");
 191
 192   # and back again, specifying the palette
 193   my @colors = ( $red, $blue, $green );
 194   my $impal3 = $imrgb2->to_paletted(colors=>\@colors,
 195                                     make_colors=>'none',
 196                                     translate=>'closest');
 197   ok($impal3, "got a paletted image from conversion");
 198   dump_colors(@colors);
 199   print "# in image\n";
 200   dump_colors($impal3->getcolors);
 201   is($impal3->colorcount, 3, "new image has expected color table size");
 202   is($impal3->type, 'paletted', "and is paletted");
 203 }
 204
 205 {
 206   my $im = Imager->new;
 207   ok($im, "make empty image");
 208   ok(!$im->to_rgb8, "convert to rgb8");
 209   is($im->errstr, "to_rgb8: empty input image", "check message");
 210   is($im->bits, undef, "can't call bits on an empty image");
 211   is($im->errstr, "bits: empty input image", "check message");
 212   is($im->type, undef, "can't call type on an empty image");
 213   is($im->errstr, "type: empty input image", "check message");
 214   is($im->virtual, undef, "can't call virtual on an empty image");
 215   is($im->errstr, "virtual: empty input image", "check message");
 216   is($im->is_bilevel, undef, "can't call virtual on an empty image");
 217   is($im->errstr, "is_bilevel: empty input image", "check message");
 218   ok(!$im->getscanline(y => 0), "can't call getscanline on an empty image");
 219   is($im->errstr, "getscanline: empty input image", "check message");
 220   ok(!$im->setscanline(y => 0, pixels => [ $red, $blue ]),
 221      "can't call setscanline on an empty image");
 222   is($im->errstr, "setscanline: empty input image", "check message");
 223   ok(!$im->getsamples(y => 0), "can't call getsamples on an empty image");
 224   is($im->errstr, "getsamples: empty input image", "check message");
 225   is($im->getwidth, undef, "can't get width of empty image");
 226   is($im->errstr, "getwidth: empty input image", "check message");
 227   is($im->getheight, undef, "can't get height of empty image");
 228   is($im->errstr, "getheight: empty input image", "check message");
 229   is($im->getchannels, undef, "can't get channels of empty image");
 230   is($im->errstr, "getchannels: empty input image", "check message");
 231   is($im->getmask, undef, "can't get mask of empty image");
 232   is($im->errstr, "getmask: empty input image", "check message");
 233   is($im->setmask, undef, "can't set mask of empty image");
 234   is($im->errstr, "setmask: empty input image", "check message");
 235   is($im->colorchannels, undef, "can't get colorchannels of empty image");
 236   is($im->errstr, "colorchannels: empty input image", "check message");
 237   is($im->alphachannel, undef, "can't get alphachannel of empty image");
 238   is($im->errstr, "alphachannel: empty input image", "check message");
 239   is($im->colormodel, undef, "can't get colormodel of empty image");
 240   is($im->errstr, "colormodel: empty input image", "check message");
 241 }
 242
 243 { # basic checks, 8-bit direct images
 244   my $im = Imager->new(xsize => 2, ysize => 3);
 245   ok($im, 'create 8-bit direct image');
 246   is($im->bits, 8, '8 bits');
 247   ok(!$im->virtual, 'not virtual');
 248   is($im->type, 'direct', 'direct image');
 249   ok(!$im->is_bilevel, 'not mono');
 250 }
 251
 252 ok(!Imager->new(xsize=>0, ysize=>1), "fail to create 0 height image");
 253 cmp_ok(Imager->errstr, '=~', qr/Image sizes must be positive/,
 254        "0 height error message check");
 255 ok(!Imager->new(xsize=>1, ysize=>0), "fail to create 0 width image");
 256 cmp_ok(Imager->errstr, '=~', qr/Image sizes must be positive/,
 257        "0 width error message check");
 258 ok(!Imager->new(xsize=>-1, ysize=>1), "fail to create -ve height image");
 259 cmp_ok(Imager->errstr, '=~', qr/Image sizes must be positive/,
 260        "-ve width error message check");
 261 ok(!Imager->new(xsize=>1, ysize=>-1), "fail to create -ve width image");
 262 cmp_ok(Imager->errstr, '=~', qr/Image sizes must be positive/,
 263        "-ve height error message check");
 264 ok(!Imager->new(xsize=>-1, ysize=>-1), "fail to create -ve width/height image");
 265 cmp_ok(Imager->errstr, '=~', qr/Image sizes must be positive/,
 266        "-ve width/height error message check");
 267
 268 ok(!Imager->new(xsize=>1, ysize=>1, channels=>0),
 269    "fail to create a zero channel image");
 270 cmp_ok(Imager->errstr, '=~', qr/channels must be between 1 and 4/,
 271        "out of range channel message check");
 272 ok(!Imager->new(xsize=>1, ysize=>1, channels=>5),
 273    "fail to create a five channel image");
 274 cmp_ok(Imager->errstr, '=~', qr/channels must be between 1 and 4/,
 275        "out of range channel message check");
 276
 277 {
 278   # https://rt.cpan.org/Ticket/Display.html?id=8213
 279   # check for handling of memory allocation of very large images
 280   # only test this on 32-bit machines - on a 64-bit machine it may
 281   # result in trying to allocate 4Gb of memory, which is unfriendly at
 282   # least and may result in running out of memory, causing a different
 283   # type of exit
 284  SKIP:
 285   {
 286     use Config;
 287     skip("don't want to allocate 4Gb", 8) unless $Config{ptrsize} == 4;
 288
 289     my $uint_range = 256 ** $Config{intsize};
 290     print "# range $uint_range\n";
 291     my $dim1 = int(sqrt($uint_range))+1;
 292
 293     my $im_b = Imager->new(xsize=>$dim1, ysize=>$dim1, channels=>1);
 294     is($im_b, undef, "integer overflow check - 1 channel");
 295
 296     $im_b = Imager->new(xisze=>$dim1, ysize=>1, channels=>1);
 297     ok($im_b, "but same width ok");
 298     $im_b = Imager->new(xisze=>1, ysize=>$dim1, channels=>1);
 299     ok($im_b, "but same height ok");
 300     cmp_ok(Imager->errstr, '=~', qr/integer overflow/,
 301            "check the error message");
 302
 303     # do a similar test with a 3 channel image, so we're sure we catch
 304     # the same case where the third dimension causes the overflow
 305     my $dim3 = int(sqrt($uint_range / 3))+1;
 306
 307     $im_b = Imager->new(xsize=>$dim3, ysize=>$dim3, channels=>3);
 308     is($im_b, undef, "integer overflow check - 3 channel");
 309
 310     $im_b = Imager->new(xisze=>$dim3, ysize=>1, channels=>3);
 311     ok($im_b, "but same width ok");
 312     $im_b = Imager->new(xisze=>1, ysize=>$dim3, channels=>3);
 313     ok($im_b, "but same height ok");
 314
 315     cmp_ok(Imager->errstr, '=~', qr/integer overflow/,
 316            "check the error message");
 317   }
 318 }
 319
 320 { # http://rt.cpan.org/NoAuth/Bug.html?id=9672
 321   my $warning;
 322   local $SIG{__WARN__} =
 323     sub {
 324       $warning = "@_";
 325       my $printed = $warning;
 326       $printed =~ s/\n$//;
 327       $printed =~ s/\n/\n\#/g;
 328       print "# ",$printed, "\n";
 329     };
 330   my $img = Imager->new(xsize=>10, ysize=>10);
 331   $img->to_rgb8(); # doesn't really matter what the source is
 332   cmp_ok($warning, '=~', 'void', "correct warning");
 333   cmp_ok($warning, '=~', 'introvert\\.t', "correct file");
 334 }
 335
 336 { # http://rt.cpan.org/NoAuth/Bug.html?id=11860
 337   my $im = Imager->new(xsize=>2, ysize=>2);
 338   $im->setpixel(x=>0, 'y'=>0, color=>$red);
 339   $im->setpixel(x=>1, 'y'=>0, color=>$blue);
 340
 341   my @row = Imager::i_glin($im->{IMG}, 0, 2, 0);
 342   is(@row, 2, "got 2 pixels from i_glin");
 343   is_color3($row[0], 255, 0, 0, "red first");
 344   is_color3($row[1], 0, 0, 255, "then blue");
 345 }
 346
 347 { # general tag tests
 348
 349   # we don't care much about the image itself
 350   my $im = Imager::ImgRaw::new(10, 10, 1);
 351
 352   ok(Imager::i_tags_addn($im, 'alpha', 0, 101), "i_tags_addn(...alpha, 0, 101)");
 353   ok(Imager::i_tags_addn($im, undef, 99, 102), "i_tags_addn(...undef, 99, 102)");
 354   is(Imager::i_tags_count($im), 2, "should have 2 tags");
 355   ok(Imager::i_tags_addn($im, undef, 99, 103), "i_tags_addn(...undef, 99, 103)");
 356   is(Imager::i_tags_count($im), 3, "should have 3 tags, despite the dupe");
 357   is(Imager::i_tags_find($im, 'alpha', 0), '0 but true', "find alpha");
 358   is(Imager::i_tags_findn($im, 99, 0), 1, "find 99");
 359   is(Imager::i_tags_findn($im, 99, 2), 2, "find 99 again");
 360   is(Imager::i_tags_get($im, 0), 101, "check first");
 361   is(Imager::i_tags_get($im, 1), 102, "check second");
 362   is(Imager::i_tags_get($im, 2), 103, "check third");
 363
 364   ok(Imager::i_tags_add($im, 'beta', 0, "hello", 0),
 365      "add string with string key");
 366   ok(Imager::i_tags_add($im, 'gamma', 0, "goodbye", 0),
 367      "add another one");
 368   ok(Imager::i_tags_add($im, undef, 199, "aloha", 0),
 369      "add one keyed by number");
 370   is(Imager::i_tags_find($im, 'beta', 0), 3, "find beta");
 371   is(Imager::i_tags_find($im, 'gamma', 0), 4, "find gamma");
 372   is(Imager::i_tags_findn($im, 199, 0), 5, "find 199");
 373   ok(Imager::i_tags_delete($im, 2), "delete");
 374   is(Imager::i_tags_find($im, 'beta', 0), 2, 'find beta after deletion');
 375   ok(Imager::i_tags_delbyname($im, 'beta'), 'delete beta by name');
 376   is(Imager::i_tags_find($im, 'beta', 0), undef, 'beta not there now');
 377   is(Imager::i_tags_get_string($im, "gamma"), "goodbye",
 378      'i_tags_get_string() on a string');
 379   is(Imager::i_tags_get_string($im, 99), 102,
 380      'i_tags_get_string() on a number entry');
 381   ok(Imager::i_tags_delbycode($im, 99), 'delete by code');
 382   is(Imager::i_tags_findn($im, 99, 0), undef, '99 not there now');
 383   is(Imager::i_tags_count($im), 3, 'final count of 3');
 384 }
 385
 386 {
 387   print "# low-level scan line function tests\n";
 388   my $im = Imager::ImgRaw::new(10, 10, 4);
 389   Imager::i_ppix($im, 5, 0, $red);
 390
 391   # i_glin/i_glinf
 392   my @colors = Imager::i_glin($im, 0, 10, 0);
 393   is_deeply([ (0) x 20, (255, 0, 0, 255), (0) x 16 ],
 394             [ map $_->rgba, @colors ],
 395             "i_glin - list context");
 396   my $colors = Imager::i_glin($im, 0, 10, 0);
 397   is("00" x 20 . "FF0000FF" . "00" x 16,
 398      uc unpack("H*", $colors), "i_glin - scalar context");
 399   my @fcolors = Imager::i_glinf($im, 0, 10, 0);
 400   is_deeply([ (0.0) x 20, (1.0, 0, 0, 1.0) , (0) x 16 ],
 401             [ map $_->rgba, @fcolors ],
 402             "i_glinf - list context");
 403   my $fcolors = Imager::i_glinf($im, 0, 10, 0);
 404   is_deeply([ (0.0) x 20, (1.0, 0, 0, 1.0) , (0) x 16 ],
 405             [ unpack "d*", $fcolors ],
 406             "i_glinf - scalar context");
 407
 408   # i_plin/i_plinf
 409   my @plin_colors = (($black) x 4, $red, $blue, ($black) x 4);
 410   is(Imager::i_plin($im, 0, 1, @plin_colors),
 411      10, "i_plin - pass in a list");
 412   # make sure we get it back
 413   is_deeply([ map [ $_->rgba ], @plin_colors ],
 414             [ map [ $_->rgba ], Imager::i_glin($im, 0, 10, 1) ],
 415             "check i_plin wrote to the image");
 416   my @scalar_plin =
 417     (
 418      (0,0,0,0) x 4,
 419      (0, 255, 0, 255),
 420      (0, 0, 255, 255),
 421      (0, 0, 0, 0) x 4,
 422     );
 423   is(Imager::i_plin($im, 0, 2, pack("C*", @scalar_plin)),
 424      10, "i_plin - pass in a scalar");
 425   is_deeply(\@scalar_plin,
 426             [ map $_->rgba , Imager::i_glin($im, 0, 10, 2) ],
 427             "check i_plin scalar wrote to the image");
 428
 429   my @plinf_colors = # Note: only 9 pixels
 430     (
 431      ($f_blue) x 4,
 432      $f_red,
 433      ($f_black) x 3,
 434      $f_black
 435     );
 436   is(Imager::i_plinf($im, 0, 3, @plinf_colors), 9,
 437      "i_plinf - list");
 438   is_deeply([ map $_->rgba, Imager::i_glinf($im, 0, 9, 3) ],
 439             [ map $_->rgba, @plinf_colors ],
 440             "check colors were written");
 441   my @scalar_plinf =
 442     (
 443      ( 1.0, 1.0,   0, 1.0 ) x 3,
 444      (   0, 1.0, 1.0, 1.0 ) x 2,
 445      (   0,   0,   0,   0 ),
 446      ( 1.0,   0, 1.0, 1.0 ),
 447     );
 448   is(Imager::i_plinf($im, 2, 4, pack("d*", @scalar_plinf)),
 449      7, "i_plinf - scalar");
 450   is_deeply(\@scalar_plinf,
 451             [ map $_->rgba, Imager::i_glinf($im, 2, 9, 4) ],
 452             "check colors were written");
 453
 454   is_deeply([ Imager::i_gsamp($im, 0, 10, 0, [ 0, 3 ]) ],
 455             [ (0, 0) x 5, (255, 255), (0, 0) x 4 ],
 456             "i_gsamp list context");
 457   is("0000" x 5 . "FFFF" . "0000" x 4,
 458      uc unpack("H*", Imager::i_gsamp($im, 0, 10, 0, [ 0, 3 ])),
 459      "i_gsamp scalar context");
 460   is_deeply([ Imager::i_gsampf($im, 2, 9, 4, [ 0, 2, 3 ]) ],
 461             [ (1.0, 0, 1.0) x 3, (0, 1.0, 1.0) x 2, (0, 0, 0),
 462               (1.0, 1.0, 1.0) ], "i_gsampf - list context");
 463   is_deeply([ unpack("d*", Imager::i_gsampf($im, 2, 9, 4, [ 0, 2, 3 ])) ],
 464             [ (1.0, 0, 1.0) x 3, (0, 1.0, 1.0) x 2, (0, 0, 0),
 465               (1.0, 1.0, 1.0) ], "i_gsampf - scalar context");
 466   print "# end low-level scan-line function tests\n";
 467 }
 468
 469 my $psamp_outside_error = "Image position outside of image";
 470 { # psamp
 471   print "# psamp\n";
 472   my $imraw = Imager::ImgRaw::new(10, 20, 3);
 473   {
 474     is(Imager::i_psamp($imraw, 0, 2, undef, [ 255, 128, 64 ]), 3,
 475        "i_psamp def channels, 3 samples");
 476     is_color3(Imager::i_get_pixel($imraw, 0, 2), 255, 128, 64,
 477               "check color written");
 478     Imager::i_img_setmask($imraw, 5);
 479     is(Imager::i_psamp($imraw, 1, 3, undef, [ 64, 128, 192 ]), 3,
 480        "i_psamp def channels, 3 samples, masked");
 481     is_color3(Imager::i_get_pixel($imraw, 1, 3), 64, 0, 192,
 482               "check color written");
 483     is(Imager::i_psamp($imraw, 1, 7, [ 0, 1, 2 ], [ 64, 128, 192 ]), 3,
 484        "i_psamp channels listed, 3 samples, masked");
 485     is_color3(Imager::i_get_pixel($imraw, 1, 7), 64, 0, 192,
 486               "check color written");
 487     Imager::i_img_setmask($imraw, ~0);
 488     is(Imager::i_psamp($imraw, 2, 4, [ 0, 1 ], [ 255, 128, 64, 32 ]), 4,
 489        "i_psamp channels [0, 1], 4 samples");
 490     is_color3(Imager::i_get_pixel($imraw, 2, 4), 255, 128, 0,
 491               "check first color written");
 492     is_color3(Imager::i_get_pixel($imraw, 3, 4), 64, 32, 0,
 493               "check second color written");
 494     is(Imager::i_psamp($imraw, 0, 5, [ 0, 1, 2 ], [ (128, 63, 32) x 10 ]), 30,
 495        "write a full row");
 496     is_deeply([ Imager::i_gsamp($imraw, 0, 10, 5, [ 0, 1, 2 ]) ],
 497               [ (128, 63, 32) x 10 ],
 498               "check full row");
 499     is(Imager::i_psamp($imraw, 8, 8, [ 0, 1, 2 ],
 500                        [ 255, 128, 32, 64, 32, 16, 32, 16, 8 ]),
 501        6, "i_psamp channels [0, 1, 2], 9 samples, but room for 6");
 502     is(Imager::i_psamp($imraw, 4, 6, undef, [ 0 .. 18 ], 1), 18,
 503        "psamp with offset");
 504     is_deeply([ Imager::i_gsamp($imraw, 0, 10, 6, undef) ],
 505               [ (0) x 12, 1 .. 18 ],
 506               "check result");
 507     is(Imager::i_psamp($imraw, 4, 11, undef, [ 0 .. 18 ], 1, 3), 9,
 508        "psamp with offset and width");
 509     is_deeply([ Imager::i_gsamp($imraw, 0, 10, 11, undef) ],
 510               [ (0) x 12, 1 .. 9, (0) x 9 ],
 511               "check result");
 512   }
 513   { # errors we catch
 514     is(Imager::i_psamp($imraw, 6, 8, [ 0, 1, 3 ], [ 255, 128, 32 ]),
 515        undef, "i_psamp channels [0, 1, 3], 3 samples (invalid channel number)");
 516     is(_get_error(), "No channel 3 in this image",
 517        "check error message");
 518     is(Imager::i_psamp($imraw, 6, 8, [ 0, 1, -1 ], [ 255, 128, 32 ]),
 519        undef, "i_psamp channels [0, 1, -1], 3 samples (invalid channel number)");
 520     is(_get_error(), "No channel -1 in this image",
 521        "check error message");
 522     is(Imager::i_psamp($imraw, 0, -1, undef, [ 0, 0, 0 ]), undef,
 523        "negative y");
 524     is(_get_error(), $psamp_outside_error,
 525        "check error message");
 526     is(Imager::i_psamp($imraw, 0, 20, undef, [ 0, 0, 0 ]), undef,
 527        "y overflow");
 528     is(_get_error(), $psamp_outside_error,
 529        "check error message");
 530     is(Imager::i_psamp($imraw, -1, 0, undef, [ 0, 0, 0 ]), undef,
 531        "negative x");
 532     is(_get_error(), $psamp_outside_error,
 533        "check error message");
 534     is(Imager::i_psamp($imraw, 10, 0, undef, [ 0, 0, 0 ]), undef,
 535        "x overflow");
 536     is(_get_error(), $psamp_outside_error,
 537        "check error message");
 538   }
 539   { # test the im_sample_list typemap
 540     ok(!eval { Imager::i_psamp($imraw, 9, 9, [ 0 ], undef); 1 },
 541        "pass undef as the sample list");
 542     like($@, qr/data must be a scalar or an arrayref/,
 543          "check message");
 544     ok(!eval { Imager::i_psamp($imraw, 9, 9, [ 0 ], { a => 1 }); 1 },
 545        "hashref as the sample list");
 546     like($@, qr/data must be a scalar or an arrayref/,
 547          "check message");
 548     ok(!eval { Imager::i_psamp($imraw, 9, 9, [ 0 ], []); 1 },
 549        "empty sample list");
 550     like($@, qr/i_psamp: no samples provided in data/,
 551          "check message");
 552     ok(!eval { Imager::i_psamp($imraw, 9, 9, [ 0 ], ""); 1 },
 553        "empty scalar sample list");
 554     like($@, qr/i_psamp: no samples provided in data/,
 555          "check message");
 556
 557     # not the typemap
 558     is(Imager::i_psamp($imraw, 0, 8, undef, [ (0) x 3 ], -1), undef,
 559        "negative offset");
 560     is(_get_error(), "offset must be non-negative",
 561        "check message");
 562
 563     is(Imager::i_psamp($imraw, 0, 8, undef, [ (0) x 3 ], 4), undef,
 564        "too high offset");
 565     is(_get_error(), "offset greater than number of samples supplied",
 566        "check message");
 567   }
 568   print "# end psamp tests\n";
 569 }
 570
 571 { # psampf
 572   print "# psampf\n";
 573   my $imraw = Imager::ImgRaw::new(10, 20, 3);
 574   {
 575     is(Imager::i_psampf($imraw, 0, 2, undef, [ 1, 0.5, 0.25 ]), 3,
 576        "i_psampf def channels, 3 samples");
 577     is_color3(Imager::i_get_pixel($imraw, 0, 2), 255, 128, 64,
 578               "check color written");
 579     Imager::i_img_setmask($imraw, 5);
 580     is(Imager::i_psampf($imraw, 1, 3, undef, [ 0.25, 0.5, 0.75 ]), 3,
 581        "i_psampf def channels, 3 samples, masked");
 582     is_color3(Imager::i_get_pixel($imraw, 1, 3), 64, 0, 191,
 583               "check color written");
 584     is(Imager::i_psampf($imraw, 1, 7, [ 0, 1, 2 ], [ 0.25, 0.5, 0.75 ]), 3,
 585        "i_psampf channels listed, 3 samples, masked");
 586     is_color3(Imager::i_get_pixel($imraw, 1, 7), 64, 0, 191,
 587               "check color written");
 588     Imager::i_img_setmask($imraw, ~0);
 589     is(Imager::i_psampf($imraw, 2, 4, [ 0, 1 ], [ 1, 0.5, 0.25, 0.125 ]), 4,
 590        "i_psampf channels [0, 1], 4 samples");
 591     is_color3(Imager::i_get_pixel($imraw, 2, 4), 255, 128, 0,
 592               "check first color written");
 593     is_color3(Imager::i_get_pixel($imraw, 3, 4), 64, 32, 0,
 594               "check second color written");
 595     is(Imager::i_psampf($imraw, 0, 5, [ 0, 1, 2 ], [ (0.5, 0.25, 0.125) x 10 ]), 30,
 596        "write a full row");
 597     is_deeply([ Imager::i_gsamp($imraw, 0, 10, 5, [ 0, 1, 2 ]) ],
 598               [ (128, 64, 32) x 10 ],
 599               "check full row");
 600     is(Imager::i_psampf($imraw, 8, 8, [ 0, 1, 2 ],
 601                         [ 1.0, 0.5, 0.125, 0.25, 0.125, 0.0625, 0.125, 0, 1 ]),
 602        6, "i_psampf channels [0, 1, 2], 9 samples, but room for 6");
 603     is(Imager::i_psampf($imraw, 4, 6, undef, [ map $_/254.9, 0 .. 18 ], 1), 18,
 604        "psampf with offset");
 605     is_deeply([ Imager::i_gsamp($imraw, 0, 10, 6, undef) ],
 606               [ (0) x 12, 1 .. 18 ],
 607               "check result");
 608     is(Imager::i_psampf($imraw, 4, 11, undef, [ map $_/254.9, 0 .. 18 ], 1, 3), 9,
 609        "psampf with offset and width");
 610     is_deeply([ Imager::i_gsamp($imraw, 0, 10, 11, undef) ],
 611               [ (0) x 12, 1 .. 9, (0) x 9 ],
 612               "check result");
 613   }
 614   { # errors we catch
 615     is(Imager::i_psampf($imraw, 6, 8, [ 0, 1, 3 ], [ 1, 0.5, 0.125 ]),
 616        undef, "i_psampf channels [0, 1, 3], 3 samples (invalid channel number)");
 617     is(_get_error(), "No channel 3 in this image",
 618        "check error message");
 619     is(Imager::i_psampf($imraw, 6, 8, [ 0, 1, -1 ], [ 1, 0.5, 0.125 ]),
 620        undef, "i_psampf channels [0, 1, -1], 3 samples (invalid channel number)");
 621     is(_get_error(), "No channel -1 in this image",
 622        "check error message");
 623     is(Imager::i_psampf($imraw, 0, -1, undef, [ 0, 0, 0 ]), undef,
 624        "negative y");
 625     is(_get_error(), $psamp_outside_error,
 626        "check error message");
 627     is(Imager::i_psampf($imraw, 0, 20, undef, [ 0, 0, 0 ]), undef,
 628        "y overflow");
 629     is(_get_error(), $psamp_outside_error,
 630        "check error message");
 631     is(Imager::i_psampf($imraw, -1, 0, undef, [ 0, 0, 0 ]), undef,
 632        "negative x");
 633     is(_get_error(), $psamp_outside_error,
 634        "check error message");
 635     is(Imager::i_psampf($imraw, 10, 0, undef, [ 0, 0, 0 ]), undef,
 636        "x overflow");
 637     is(_get_error(), $psamp_outside_error,
 638        "check error message");
 639   }
 640   { # test the im_fsample_list typemap
 641     ok(!eval { Imager::i_psampf($imraw, 9, 9, [ 0 ], undef); 1 },
 642        "pass undef as the sample list");
 643     like($@, qr/data must be a scalar or an arrayref/,
 644          "check message");
 645     ok(!eval { Imager::i_psampf($imraw, 9, 9, [ 0 ], { a => 1 }); 1 },
 646        "hashref as the sample list");
 647     like($@, qr/data must be a scalar or an arrayref/,
 648          "check message");
 649     ok(!eval { Imager::i_psampf($imraw, 9, 9, [ 0 ], []); 1 },
 650        "empty sample list");
 651     like($@, qr/i_psampf: no samples provided in data/,
 652          "check message");
 653     ok(!eval { Imager::i_psampf($imraw, 9, 9, [ 0 ], ""); 1 },
 654        "empty scalar sample list");
 655     like($@, qr/i_psampf: no samples provided in data/,
 656          "check message");
 657
 658     # not the typemap
 659     is(Imager::i_psampf($imraw, 0, 8, undef, [ (0) x 3 ], -1), undef,
 660        "negative offset");
 661     is(_get_error(), "offset must be non-negative",
 662        "check message");
 663
 664     is(Imager::i_psampf($imraw, 0, 8, undef, [ (0) x 3 ], 4), undef,
 665        "too high offset");
 666     is(_get_error(), "offset greater than number of samples supplied",
 667        "check message");
 668   }
 669   print "# end psampf tests\n";
 670 }
 671
 672 {
 673   print "# OO level scanline function tests\n";
 674   my $im = Imager->new(xsize=>10, ysize=>10, channels=>4);
 675   $im->setpixel(color=>$red, 'x'=>5, 'y'=>0);
 676   ok(!$im->getscanline(), "getscanline() - supply nothing, get nothing");
 677   is($im->errstr, "missing y parameter", "check message");
 678   is_deeply([ map [ $_->rgba ], $im->getscanline('y'=>0) ],
 679             [ ([ 0,0,0,0]) x 5, [ 255, 0, 0, 255 ], ([ 0,0,0,0]) x 4 ],
 680             "getscanline, list context, default x, width");
 681   is_deeply([ map [ $_->rgba ], $im->getscanline('y'=>0, 'x'=>3) ],
 682             [ ([0,0,0,0]) x 2, [ 255, 0, 0, 255 ], ([0,0,0,0]) x 4 ],
 683             "getscanline, list context, default width");
 684   is_deeply([ map [ $_->rgba ], $im->getscanline('y'=>0, 'x'=>4, width=>4) ],
 685             [ [0,0,0,0], [ 255, 0, 0, 255 ], ([0,0,0,0]) x 2 ],
 686             "getscanline, list context, no defaults");
 687   is(uc unpack("H*",  $im->getscanline('y'=>0)),
 688      "00000000" x 5 .  "FF0000FF" . "00000000" x 4,
 689      "getscanline, scalar context, default x, width");
 690   is_deeply([ map [ $_->rgba ],
 691               $im->getscanline('y'=>0, 'x'=>4, width=>4, type=>'float') ],
 692             [ [0,0,0,0], [ 1.0, 0, 0, 1.0 ], ([0,0,0,0]) x 2 ],
 693             "getscanline float, list context, no defaults");
 694   is_deeply([ unpack "d*",
 695               $im->getscanline('y'=>0, 'x'=>4, width=>4, type=>'float') ],
 696             [ (0,0,0,0), ( 1.0, 0, 0, 1.0 ), (0,0,0,0) x 2 ],
 697             "getscanline float, scalar context, no defaults");
 698
 699   ok(!$im->getscanline('y'=>0, type=>'invalid'),
 700      "check invalid type checking");
 701   like($im->errstr, qr/invalid type parameter/,
 702        "check message for invalid type");
 703
 704   my @plin_colors = (($black) x 4, $red, $blue, ($green) x 4);
 705   is($im->setscanline('y'=>1, pixels=>\@plin_colors), 10,
 706      "setscanline - arrayref, default x");
 707   is_deeply([ map [ $_->rgba ], @plin_colors ],
 708             [ map [ $_->rgba ], $im->getscanline('y'=>1) ],
 709             "check colors were written");
 710
 711   my @plin_colors2 = ( $green, $red, $blue, $red );
 712   is($im->setscanline('y'=>2, 'x'=>3, pixels=>\@plin_colors2), 4,
 713      "setscanline - arrayref");
 714
 715   # using map instead of x here due to a bug in some versions of Test::More
 716   # fixed in the latest Test::More
 717   is_deeply([ ( map [ 0,0,0,0 ], 1..3), (map [ $_->rgba ], @plin_colors2),
 718               ( map [ 0,0,0,0 ], 1..3) ],
 719             [ map [ $_->rgba ], $im->getscanline('y'=>2) ],
 720             "check write to middle of line");
 721
 722   my $raw_colors = pack "H*", "FF00FFFF"."FF0000FF"."FFFFFFFF";
 723   is($im->setscanline('y'=>3, 'x'=>2, pixels=>$raw_colors), 3,
 724      "setscanline - scalar, default raw type")
 725     or print "# ",$im->errstr,"\n";
 726   is(uc unpack("H*", $im->getscanline('y'=>3, 'x'=>1, 'width'=>5)),
 727      "00000000".uc(unpack "H*", $raw_colors)."00000000",
 728      "check write");
 729
 730   # float colors
 731   my @fcolors = ( $f_red, $f_blue, $f_black, $f_green );
 732   is($im->setscanline('y'=>4, 'x'=>3, pixels=>\@fcolors), 4,
 733      "setscanline - float arrayref");
 734   is_deeply([ map [ $_->rgba ], @fcolors ],
 735             [ map [ $_->rgba ], $im->getscanline('y'=>4, 'x'=>3, width=>4, type=>'float') ],
 736             "check write");
 737   # packed
 738   my $packed_fcolors = pack "d*", map $_->rgba, @fcolors;
 739   is($im->setscanline('y'=>5, 'x'=>4, pixels=>$packed_fcolors, type=>'float'), 4,
 740      "setscanline - float scalar");
 741   is_deeply([ map [ $_->rgba ], @fcolors ],
 742             [ map [ $_->rgba ], $im->getscanline('y'=>5, 'x'=>4, width=>4, type=>'float') ],
 743             "check write");
 744
 745   # get samples
 746   is_deeply([ $im->getsamples('y'=>1, channels=>[ 0 ]) ],
 747             [ map +($_->rgba)[0], @plin_colors ],
 748             "get channel 0, list context, default x, width");
 749   is_deeply([ unpack "C*", $im->getsamples('y'=>1, channels=>[0, 2]) ],
 750             [ map { ($_->rgba)[0, 2] } @plin_colors ],
 751             "get channel 0, 1, scalar context");
 752   is_deeply([ $im->getsamples('y'=>4, 'x'=>3, width=>4, type=>'float',
 753                               channels=>[1,3]) ],
 754             [ map { ($_->rgba)[1,3] } @fcolors ],
 755             "get channels 1,3, list context, float samples");
 756   is_deeply([ unpack "d*",
 757               $im->getsamples('y'=>4, 'x'=>3, width=>4,
 758                               type=>'float', channels=>[3,2,1,0]) ],
 759             [ map { ($_->rgba)[3,2,1,0] } @fcolors ],
 760             "get channels 3..0 as scalar, float samples");
 761
 762   print "# end OO level scanline function tests\n";
 763 }
 764
 765 { # RT 74882
 766   # for the non-gsamp_bits case with a target parameter it was
 767   # treating the target parameter as a hashref
 768   {
 769     my $im = Imager->new(xsize => 10, ysize => 10);
 770     my $c1 = NC(0, 63, 255);
 771     my $c2 = NC(255, 128, 255);
 772     is($im->setscanline(y => 1, pixels => [ ( $c1, $c2 ) x 5 ]),
 773        10, "set some test data")
 774       or diag "setscanline: ", $im->errstr;
 775     my @target;
 776     is($im->getsamples(y => 1, x => 1, target => \@target, width => 3),
 777        9, "getsamples to target");
 778     is_deeply(\@target, [ 255, 128, 255, 0, 63, 255, 255, 128, 255 ],
 779               "check result");
 780   }
 781   {
 782     my $im = Imager->new(xsize => 10, ysize => 10, bits => "double");
 783     my $c1 = NCF(0, 0.25, 1.0);
 784     my $c2 = NCF(1.0, 0.5, 1.0);
 785     is($im->setscanline(y => 1, pixels => [ ( $c1, $c2 ) x 5 ]),
 786        10, "set some test data")
 787       or diag "setscanline: ", $im->errstr;
 788     my @target;
 789     is($im->getsamples(y => 1, x => 1, target => \@target, width => 3, type => "float"),
 790        9, "getsamples to target");
 791     is_deeply(\@target, [ 1.0, 0.5, 1.0, 0, 0.25, 1.0, 1.0, 0.5, 1.0 ],
 792               "check result");
 793   }
 794 }
 795
 796 { # to avoid confusion, i_glin/i_glinf modified to return 0 in unused
 797   # channels at the perl level
 798   my $im = Imager->new(xsize => 4, ysize => 4, channels => 2);
 799   my $fill = Imager::Color->new(128, 255, 0, 0);
 800   ok($im->box(filled => 1, color => $fill), 'fill it up');
 801   my $data = $im->getscanline('y' => 0);
 802   is(unpack("H*", $data), "80ff000080ff000080ff000080ff0000",
 803      "check we get zeros");
 804   my @colors = $im->getscanline('y' => 0);
 805   is_color4($colors[0], 128, 255, 0, 0, "check object interface[0]");
 806   is_color4($colors[1], 128, 255, 0, 0, "check object interface[1]");
 807   is_color4($colors[2], 128, 255, 0, 0, "check object interface[2]");
 808   is_color4($colors[3], 128, 255, 0, 0, "check object interface[3]");
 809
 810   my $dataf = $im->getscanline('y' => 0, type => 'float');
 811   # the extra pack/unpack is to force double precision rather than long
 812   # double, otherwise the test fails
 813   is_deeply([ unpack("d*", $dataf) ],
 814             [ unpack("d*", pack("d*", ( 128.0 / 255.0, 1.0, 0, 0, ) x 4)) ],
 815             "check we get zeroes (double)");
 816   my @fcolors = $im->getscanline('y' => 0, type => 'float');
 817   is_fcolor4($fcolors[0], 128.0/255.0, 1.0, 0, 0, "check object interface[0]");
 818   is_fcolor4($fcolors[1], 128.0/255.0, 1.0, 0, 0, "check object interface[1]");
 819   is_fcolor4($fcolors[2], 128.0/255.0, 1.0, 0, 0, "check object interface[2]");
 820   is_fcolor4($fcolors[3], 128.0/255.0, 1.0, 0, 0, "check object interface[3]");
 821 }
 822
 823 { # check the channel mask function
 824
 825   my $im = Imager->new(xsize => 10, ysize=>10, bits=>8);
 826
 827   mask_tests($im, 0.005);
 828 }
 829
 830 { # check bounds checking
 831   my $im = Imager->new(xsize => 10, ysize => 10);
 832
 833   image_bounds_checks($im);
 834 }
 835
 836 { # setsamples() interface to psamp()
 837   my $im = Imager->new(xsize => 10, ysize => 10);
 838   is($im->setsamples(y => 1, x => 2, data => [ 1 .. 6 ]), 6,
 839      "simple put (array), default channels");
 840   is_deeply([ $im->getsamples(y => 1, x => 0) ],
 841             [ (0) x 6, 1 .. 6, (0) x 18 ], "check they were stored");
 842   is($im->setsamples(y => 3, x => 3, data => pack("C*", 2 .. 10 )), 9,
 843      "simple put (scalar), default channels")
 844     or diag $im->errstr;
 845   is_deeply([ $im->getsamples(y => 3, x => 0) ],
 846             [ (0) x 9, 2 .. 10, (0) x 12 ], "check they were stored");
 847   is($im->setsamples(y => 4, x => 4, data => [ map $_ / 254.5, 1 .. 6 ], type => 'float'),
 848      6, "simple put (float array), default channels");
 849   is_deeply([ $im->getsamples(y => 4, x => 0) ],
 850             [ (0) x 12, 1 .. 6, (0) x 12 ], "check they were stored");
 851
 852   is($im->setsamples(y => 5, x => 3, data => pack("d*", map $_ / 254.5, 1 .. 6), type => 'float'),
 853      6, "simple put (float scalar), default channels");
 854   is_deeply([ $im->getsamples(y => 5, x => 0) ],
 855             [ (0) x 9, 1 .. 6, (0) x 15 ], "check they were stored");
 856
 857   is($im->setsamples(y => 7, x => 3, data => [ 0 .. 18 ], offset => 1), 18,
 858      "setsamples offset");
 859   is_deeply([ $im->getsamples(y => 7) ],
 860             [ (0) x 9, 1 .. 18, (0) x 3 ],
 861             "check result");
 862
 863   is($im->setsamples(y => 8, x => 3, data => [ map $_ / 254.9, 0 .. 18 ],
 864                      offset => 1, type => 'float'),
 865      18, "setsamples offset (float)");
 866   is_deeply([ $im->getsamples(y => 8) ],
 867             [ (0) x 9, 1 .. 18, (0) x 3 ],
 868             "check result");
 869
 870   is_deeply([ $im->setsamples(y => 6, x => 10, data => [ (0) x 3 ]) ],
 871             [], "check out of range result (8bit)");
 872   is($im->errstr, $psamp_outside_error, "check error message");
 873
 874   is_deeply([ $im->setsamples(y => 6, x => 10, data => [ (0) x 3 ], type => "float") ],
 875             [], "check out of range result (float)");
 876   is($im->errstr, $psamp_outside_error, "check error message");
 877
 878   is_deeply([ $im->setsamples(y => 6, x => 2, channels => [0, 1, 3 ],
 879                               data => [ (0) x 3 ]) ],
 880             [], "check bad channels (8bit)");
 881   is($im->errstr, "No channel 3 in this image",
 882      "check error message");
 883
 884   is_deeply([ $im->setsamples(y => 6, x => 2, channels => [0, 1, 3 ],
 885                               data => [ (0) x 3 ], type => "float") ],
 886             [], "check bad channels (float)");
 887   is($im->errstr, "No channel 3 in this image",
 888      "check error message");
 889
 890   is($im->setsamples(y => 5, data => [ (0) x 3 ], type => "bad"),
 891      undef, "setsamples with bad type");
 892   is($im->errstr, "setsamples: type parameter invalid",
 893      "check error message");
 894   is($im->setsamples(y => 5),
 895      undef, "setsamples with no data");
 896   is($im->errstr, "setsamples: data parameter missing",
 897      "check error message");
 898
 899   is($im->setsamples(y => 5, data => undef),
 900      undef, "setsamples with undef data");
 901   is($im->errstr, "setsamples: data parameter not defined",
 902      "check error message");
 903
 904   my $imempty = Imager->new;
 905   is($imempty->setsamples(y => 0, data => [ (0) x 3 ]), undef,
 906      "setsamples to empty image");
 907   is($imempty->errstr, "setsamples: empty input image",
 908      "check error message");
 909 }
 910
 911 { # getpixel parameters
 912   my $im = Imager->new(xsize => 10, ysize => 10);
 913   $im->box(filled => 1, xmax => 4, color => NC(255, 0, 0));
 914   $im->box(filled => 1, xmin => 5, ymax => 4, color => NC(0, 255, 255));
 915   $im->box(filled => 1, xmin => 5, ymin => 5, color => NC(255, 0, 255));
 916   { # error handling
 917     my $empty = Imager->new;
 918     ok(!$empty->getpixel(x => 0, y => 0), "getpixel empty image");
 919     is($empty->errstr, "getpixel: empty input image", "check message");
 920
 921     ok(!$im->getpixel(y => 0), "missing x");
 922     is($im->errstr, "getpixel: missing x or y parameter", "check message");
 923
 924     $im->_set_error("something different");
 925     ok(!$im->getpixel(x => 0), "missing y");
 926     is($im->errstr, "getpixel: missing x or y parameter", "check message");
 927
 928     ok(!$im->getpixel(x => [], y => 0), "empty x array ref");
 929     is($im->errstr, "getpixel: x is a reference to an empty array",
 930        "check message");
 931
 932     ok(!$im->getpixel(x => 0, y => []), "empty y array ref");
 933     is($im->errstr, "getpixel: y is a reference to an empty array",
 934        "check message");
 935
 936     ok(!$im->getpixel(x => 0, y => 0, type => "bad"), "bad type (scalar path)");
 937     is($im->errstr, "getpixel: type must be '8bit' or 'float'",
 938       "check message");
 939
 940     $im->_set_error("something different");
 941     ok(!$im->getpixel(x => [ 0 ], y => [ 0 ], type => "bad"),
 942        "bad type (array path)");
 943     is($im->errstr, "getpixel: type must be '8bit' or 'float'",
 944       "check message");
 945   }
 946
 947   # simple calls
 948   is_color4($im->getpixel(x => 1, y => 0), 255, 0, 0, 0,
 949             "getpixel(1, 0)");
 950   is_color4($im->getpixel(x => 8, y => 1), 0, 255, 255, 0,
 951             "getpixel(8, 1)");
 952   is_color4($im->getpixel(x => 8, y => 7), 255, 0, 255, 0,
 953             "getpixel(8, 7)");
 954
 955   {
 956     # simple arrayrefs
 957     my @colors = $im->getpixel(x => [ 0, 8, 7 ], y => [ 0, 7, 3 ]);
 958     is(@colors, 3, "getpixel 2 3 element array refs");
 959     is_color3($colors[0], 255, 0, 0, "check first color");
 960     is_color3($colors[1], 255, 0, 255, "check second color");
 961     is_color3($colors[2], 0, 255, 255, "check third color");
 962   }
 963
 964   # array and scalar
 965   {
 966     my @colors = $im->getpixel(x => 5, y => [ 4, 5, 9 ]);
 967     is(@colors, 3, "getpixel x scalar, y arrayref of 3");
 968     is_color3($colors[0], 0, 255, 255, "check first color");
 969     is_color3($colors[1], 255, 0, 255, "check second color");
 970     is_color3($colors[2], 255, 0, 255, "check third color");
 971   }
 972
 973   {
 974     my @colors = $im->getpixel(x => [ 0, 4, 5 ], y => 2);
 975     is(@colors, 3, "getpixel y scalar, x arrayref of 3");
 976     is_color3($colors[0], 255, 0, 0, "check first color");
 977     is_color3($colors[1], 255, 0, 0, "check second color");
 978     is_color3($colors[2], 0, 255, 255, "check third color");
 979   }
 980
 981   { # float
 982     is_fcolor3($im->getpixel(x => 1, y => 0, type => 'float'),
 983                1.0, 0, 0, "getpixel(1,0) float");
 984     is_fcolor4($im->getpixel(x => 8, y => 1, type => 'float'),
 985                0, 1.0, 1.0, 0, "getpixel(8,1) float");
 986     is_fcolor4($im->getpixel(x => 8, y => 7, type => 'float'),
 987                1.0, 0, 1.0, 0, "getpixel(8,7) float");
 988
 989     my @colors = $im->getpixel(x => [ 0, 8, 7 ], y => [ 0, 7, 3 ], type => 'float');
 990     is(@colors, 3, "getpixel 2 3 element array refs (float)");
 991     is_fcolor3($colors[0], 1, 0, 0, "check first color");
 992     is_fcolor3($colors[1], 1, 0, 1, "check second color");
 993     is_fcolor3($colors[2], 0, 1, 1, "check third color");
 994   }
 995
 996   { # out of bounds
 997     my @colors = $im->getpixel(x => [ 0, -1, 5, 10 ], y => 0);
 998     is(@colors, 4, "should be 4 entries")
 999       or diag $im->errstr;
1000     is_color3($colors[0], 255, 0, 0, "first red");
1001     is($colors[1], undef, "second undef");
1002     is_color3($colors[2], 0, 255, 255, "third cyan");
1003     is($colors[3], undef, "fourth undef");
1004   }
1005
1006   { # out of bounds
1007     my @colors = $im->getpixel(x => [ 0, -1, 5, 10 ], y => 0, type => "float");
1008     is(@colors, 4, "should be 4 entries")
1009       or diag $im->errstr;
1010     is_fcolor3($colors[0], 1.0, 0, 0, "first red");
1011     is($colors[1], undef, "second undef");
1012     is_fcolor3($colors[2], 0, 1.0, 1.0, "third cyan");
1013     is($colors[3], undef, "fourth undef");
1014   }
1015 }
1016
1017 { # setpixel
1018   my $im = Imager->new(xsize => 10, ysize => 10);
1019   { # errors
1020     my $empty = Imager->new;
1021     is_deeply([ $empty->setpixel(x => 0, y => 0, color => $red) ], [],
1022        "setpixel on empty image");
1023     is($empty->errstr, "setpixel: empty input image", "check message");
1024
1025     is_deeply([ $im->setpixel(y => 0, color => $red) ], [], "missing x");
1026     is($im->errstr, "setpixel: missing x or y parameter", "check message");
1027
1028     $im->_set_error("something different");
1029     is_deeply([$im->setpixel(x => 0, color => $red)], [], "missing y");
1030     is($im->errstr, "setpixel: missing x or y parameter", "check message");
1031
1032     is_deeply([ $im->setpixel(x => [], y => 0, color => $red) ], [],
1033               "empty x array ref");
1034     is($im->errstr, "setpixel: x is a reference to an empty array",
1035        "check message");
1036
1037     is_deeply([$im->setpixel(x => 0, y => [], color => $red)], [],
1038               "empty y array ref");
1039     is($im->errstr, "setpixel: y is a reference to an empty array",
1040        "check message");
1041
1042     is_deeply([ $im->setpixel(x => 0, y => 0, color => "not really a color") ], [],
1043        "color not a color");
1044     is($im->errstr, "setpixel: No color named not really a color found",
1045        "check message");
1046   }
1047
1048   # simple set
1049   is($im->setpixel(x => 0, y => 0, color => $red), 1,
1050      "simple setpixel")
1051     or diag "simple set float: ", $im->errstr;
1052   is_color3($im->getpixel(x => 0, y => 0), 255, 0, 0, "check stored pixel");
1053
1054   is($im->setpixel(x => 1, y => 2, color => $f_red), 1,
1055      "simple setpixel (float)")
1056     or diag "simple set float: ", $im->errstr;
1057   is_color3($im->getpixel(x => 1, y => 2), 255, 0, 0, "check stored pixel");
1058
1059   is($im->setpixel(x => -1, y => 0, color => $red), "0 but true",
1060      "simple setpixel outside of image");
1061   is($im->setpixel(x => 0, y => -1, color => $f_red), "0 but true",
1062      "simple setpixel (float) outside of image");
1063
1064   # simple arrayrefs
1065   is($im->setpixel( x => [ 0, 8, 7 ], y => [ 0, 7, 3 ], color => $blue),
1066      3, "setpixel with 3 element array refs");
1067   my @colors = $im->getpixel(x => [ 8, 7, 0 ], y => [ 7, 3, 0 ]);
1068   is_color3($colors[0], 0, 0, 255, "check first color");
1069   is_color3($colors[1], 0, 0, 255, "check second color");
1070   is_color3($colors[2], 0, 0, 255, "check third color");
1071
1072   # array and scalar
1073   {
1074     is($im->setpixel(x => 5, y => [ 4, 5, 9 ], color => $green), 3,
1075        "setpixel with x scalar, y arrayref of 3");
1076     my @colors = $im->getpixel(x => [ 5, 5, 5 ], y => [ 4, 5, 9 ]);
1077     is_color3($colors[0], 0, 255, 0, "check first color");
1078     is_color3($colors[1], 0, 255, 0, "check second color");
1079     is_color3($colors[2], 0, 255, 0, "check third color");
1080   }
1081
1082   {
1083     is($im->setpixel(x => [ 0, 4, 5 ], y => 2, color => $blue), 3,
1084        "setpixel with y scalar, x arrayref of 3");
1085     my @colors = $im->getpixel(x => [ 0, 4, 5 ], y => [ 2, 2, 2 ]);
1086     is_color3($colors[0], 0, 0, 255, "check first color");
1087     is_color3($colors[1], 0, 0, 255, "check second color");
1088     is_color3($colors[2], 0, 0, 255, "check third color");
1089   }
1090
1091   {
1092     is($im->setpixel(x => [ 0, -1, 10, 5, 0 ], y => [ 0, 1, 2, 3, 1 ], color => $blue), 3,
1093        "set array with two bad locations")
1094       or diag "set array bad locations: ", $im->errstr;
1095     my @colors = $im->getpixel(x => [ 0, 5, 0 ], y => [ 0, 3, 1 ]);
1096     is_color3($colors[0], 0, 0, 255, "check first color");
1097     is_color3($colors[1], 0, 0, 255, "check second color");
1098     is_color3($colors[2], 0, 0, 255, "check third color");
1099   }
1100   {
1101     is($im->setpixel(x => [ 0, -1, 10, 5, 0 ], y => [ 0, 1, 2, 3, 1 ], color => $f_green), 3,
1102        "set array with two bad locations (float)")
1103       or diag "set array bad locations (float): ", $im->errstr;
1104     my @colors = $im->getpixel(x => [ 0, 5, 0 ], y => [ 0, 3, 1 ]);
1105     is_color3($colors[0], 0, 255, 0, "check first color");
1106     is_color3($colors[1], 0, 255, 0, "check second color");
1107     is_color3($colors[2], 0, 255, 0, "check third color");
1108   }
1109   { # default color
1110     is($im->setpixel(x => 0, y => 9), 1, "setpixel() default color")
1111       or diag "setpixel default color: ", $im->errstr;
1112     is_color3($im->getpixel(x => 0, y => 9), 255, 255, 255,
1113               "check color set");
1114   }
1115 }
1116
1117 {
1118   my $empty = Imager->new;
1119   ok(!$empty->addtag(name => "foo", value => 1),
1120      "can't addtag on an empty image");
1121   is($empty->errstr, "addtag: empty input image",
1122     "check error message");
1123   ok(!$empty->settag(name => "foo", value => 1),
1124      "can't settag on an empty image");
1125   is($empty->errstr, "settag: empty input image",
1126     "check error message");
1127   ok(!$empty->deltag(name => "foo"), "can't deltag on an empty image");
1128   is($empty->errstr, "deltag: empty input image",
1129      "check error message");
1130   ok(!$empty->tags(name => "foo"), "can't tags on an empty image");
1131   is($empty->errstr, "tags: empty input image",
1132      "check error message");
1133 }
1134
1135 {
1136   my @tests =
1137     (
1138      [ "gray",  1, undef ],
1139      [ "graya", 1, 1     ],
1140      [ "rgb",   3, undef ],
1141      [ "rgba",  3, 3     ],
1142     );
1143   for my $test (@tests) {
1144     my ($model, $color_channels, $alpha) = @$test;
1145     my $im = Imager->new(model => $model, xsize => 10, ysize => 10)
1146       or die "Cannot create $model image:", Imager->errstr;
1147     ok($im, "make a $model image via model");
1148     is($im->colormodel, $model, "check colormodel is $model");
1149     is($im->alphachannel, $alpha, "check alphachannel");
1150     is($im->colorchannels, $color_channels, "check colorchannels");
1151   }
1152 }
1153
1154 Imager->close_log();
1155
1156 unless ($ENV{IMAGER_KEEP_FILES}) {
1157   unlink "testout/t01introvert.log";
1158 }
1159
1160 sub check_add {
1161   my ($im, $color, $expected) = @_;
1162   my $index = Imager::i_addcolors($im, $color);
1163   ok($index, "got index");
1164   print "# $index\n";
1165   is(0+$index, $expected, "index matched expected");
1166   my ($new) = Imager::i_getcolors($im, $index);
1167   ok($new, "got the color");
1168   ok(color_cmp($new, $color) == 0, "color matched what was added");
1169
1170   $index;
1171 }
1172
1173 # sub array_ncmp {
1174 #   my ($a1, $a2) = @_;
1175 #   my $len = @$a1 < @$a2 ? @$a1 : @$a2;
1176 #   for my $i (0..$len-1) {
1177 #     my $diff = $a1->[$i] <=> $a2->[$i]
1178 #       and return $diff;
1179 #   }
1180 #   return @$a1 <=> @$a2;
1181 # }
1182
1183 sub dump_colors {
1184   for my $col (@_) {
1185     print "# ", map(sprintf("%02X", $_), ($col->rgba)[0..2]),"\n";
1186   }
1187 }
1188
1189 sub _get_error {
1190   my @errors = Imager::i_errors();
1191   return join(": ", map $_->[0], @errors);
1192 }