t/t023palette.t

   1 #!perl -w
   2 # some of this is tested in t01introvert.t too
   3 use strict;
   4 use Test::More tests => 211;
   5 BEGIN { use_ok("Imager", ':handy'); }
   6
   7 use Imager::Test qw(image_bounds_checks test_image is_color3 isnt_image is_color4 is_fcolor3);
   8
   9 Imager->open_log(log => "testout/t023palette.log");
  10
  11 sub isbin($$$);
  12
  13 my $img = Imager->new(xsize=>50, ysize=>50, type=>'paletted');
  14
  15 ok($img, "paletted image created");
  16
  17 is($img->type, 'paletted', "got a paletted image");
  18
  19 my $black = Imager::Color->new(0,0,0);
  20 my $red = Imager::Color->new(255,0,0);
  21 my $green = Imager::Color->new(0,255,0);
  22 my $blue = Imager::Color->new(0,0,255);
  23
  24 my $white = Imager::Color->new(255,255,255);
  25
  26 # add some color
  27 my $blacki = $img->addcolors(colors=>[ $black, $red, $green, $blue ]);
  28
  29 print "# blacki $blacki\n";
  30 ok(defined $blacki && $blacki == 0, "we got the first color");
  31
  32 ok($img->colorcount() == 4, "should have 4 colors");
  33 my ($redi, $greeni, $bluei) = 1..3;
  34
  35 my @all = $img->getcolors;
  36 ok(@all == 4, "all colors is 4");
  37 coloreq($all[0], $black, "first black");
  38 coloreq($all[1], $red, "then red");
  39 coloreq($all[2], $green, "then green");
  40 coloreq($all[3], $blue, "and finally blue");
  41
  42 # keep this as an assignment, checking for scalar context
  43 # we don't want the last color, otherwise if the behaviour changes to
  44 # get all up to the last (count defaulting to size-index) we'd get a
  45 # false positive
  46 my $one_color = $img->getcolors(start=>$redi);
  47 ok($one_color->isa('Imager::Color'), "check scalar context");
  48 coloreq($one_color, $red, "and that it's what we want");
  49
  50 # make sure we can find colors
  51 ok(!defined($img->findcolor(color=>$white)),
  52     "shouldn't be able to find white");
  53 ok($img->findcolor(color=>$black) == $blacki, "find black");
  54 ok($img->findcolor(color=>$red) == $redi, "find red");
  55 ok($img->findcolor(color=>$green) == $greeni, "find green");
  56 ok($img->findcolor(color=>$blue) == $bluei, "find blue");
  57
  58 # various failure tests for setcolors
  59 ok(!defined($img->setcolors(start=>-1, colors=>[$white])),
  60     "expect failure: low index");
  61 ok(!defined($img->setcolors(start=>1, colors=>[])),
  62     "expect failure: no colors");
  63 ok(!defined($img->setcolors(start=>5, colors=>[$white])),
  64     "expect failure: high index");
  65
  66 # set the green index to white
  67 ok($img->setcolors(start => $greeni, colors => [$white]),
  68     "set a color");
  69 # and check it
  70 coloreq(scalar($img->getcolors(start=>$greeni)), $white,
  71         "make sure it was set");
  72 ok($img->findcolor(color=>$white) == $greeni, "and that we can find it");
  73 ok(!defined($img->findcolor(color=>$green)), "and can't find the old color");
  74
  75 # write a few colors
  76 ok(scalar($img->setcolors(start=>$redi, colors=>[ $green, $red])),
  77            "save multiple");
  78 coloreq(scalar($img->getcolors(start=>$redi)), $green, "first of multiple");
  79 coloreq(scalar($img->getcolors(start=>$greeni)), $red, "second of multiple");
  80
  81 # put it back
  82 $img->setcolors(start=>$red, colors=>[$red, $green]);
  83
  84 # draw on the image, make sure it stays paletted when it should
  85 ok($img->box(color=>$red, filled=>1), "fill with red");
  86 is($img->type, 'paletted', "paletted after fill");
  87 ok($img->box(color=>$green, filled=>1, xmin=>10, ymin=>10,
  88               xmax=>40, ymax=>40), "green box");
  89 is($img->type, 'paletted', 'still paletted after box');
  90 # an AA line will almost certainly convert the image to RGB, don't use
  91 # an AA line here
  92 ok($img->line(color=>$blue, x1=>10, y1=>10, x2=>40, y2=>40),
  93     "draw a line");
  94 is($img->type, 'paletted', 'still paletted after line');
  95
  96 # draw with white - should convert to direct
  97 ok($img->box(color=>$white, filled=>1, xmin=>20, ymin=>20,
  98               xmax=>30, ymax=>30), "white box");
  99 is($img->type, 'direct', "now it should be direct");
 100
 101 # various attempted to make a paletted image from our now direct image
 102 my $palimg = $img->to_paletted;
 103 ok($palimg, "we got an image");
 104 # they should be the same pixel for pixel
 105 ok(Imager::i_img_diff($img->{IMG}, $palimg->{IMG}) == 0, "same pixels");
 106
 107 # strange case: no color picking, and no colors
 108 # this was causing a segmentation fault
 109 $palimg = $img->to_paletted(colors=>[ ], make_colors=>'none');
 110 ok(!defined $palimg, "to paletted with an empty palette is an error");
 111 print "# ",$img->errstr,"\n";
 112 ok(scalar($img->errstr =~ /no colors available for translation/),
 113     "and got the correct msg");
 114
 115 ok(!Imager->new(xsize=>1, ysize=>-1, type=>'paletted'),
 116     "fail on -ve height");
 117 cmp_ok(Imager->errstr, '=~', qr/Image sizes must be positive/,
 118        "and correct error message");
 119 ok(!Imager->new(xsize=>-1, ysize=>1, type=>'paletted'),
 120     "fail on -ve width");
 121 cmp_ok(Imager->errstr, '=~', qr/Image sizes must be positive/,
 122        "and correct error message");
 123 ok(!Imager->new(xsize=>-1, ysize=>-1, type=>'paletted'),
 124     "fail on -ve width/height");
 125 cmp_ok(Imager->errstr, '=~', qr/Image sizes must be positive/,
 126        "and correct error message");
 127
 128 ok(!Imager->new(xsize=>1, ysize=>1, type=>'paletted', channels=>0),
 129     "fail on 0 channels");
 130 cmp_ok(Imager->errstr, '=~', qr/Channels must be positive and <= 4/,
 131        "and correct error message");
 132 ok(!Imager->new(xsize=>1, ysize=>1, type=>'paletted', channels=>5),
 133     "fail on 5 channels");
 134 cmp_ok(Imager->errstr, '=~', qr/Channels must be positive and <= 4/,
 135        "and correct error message");
 136
 137 {
 138   # https://rt.cpan.org/Ticket/Display.html?id=8213
 139   # check for handling of memory allocation of very large images
 140   # only test this on 32-bit machines - on a 64-bit machine it may
 141   # result in trying to allocate 4Gb of memory, which is unfriendly at
 142   # least and may result in running out of memory, causing a different
 143   # type of exit
 144   use Config;
 145  SKIP:
 146   {
 147     skip("don't want to allocate 4Gb", 10)
 148       unless $Config{ptrsize} == 4;
 149
 150     my $uint_range = 256 ** $Config{intsize};
 151     my $dim1 = int(sqrt($uint_range))+1;
 152
 153     my $im_b = Imager->new(xsize=>$dim1, ysize=>$dim1, channels=>1, type=>'paletted');
 154     is($im_b, undef, "integer overflow check - 1 channel");
 155
 156     $im_b = Imager->new(xisze=>$dim1, ysize=>1, channels=>1, type=>'paletted');
 157     ok($im_b, "but same width ok");
 158     $im_b = Imager->new(xisze=>1, ysize=>$dim1, channels=>1, type=>'paletted');
 159     ok($im_b, "but same height ok");
 160     cmp_ok(Imager->errstr, '=~', qr/integer overflow/,
 161            "check the error message");
 162
 163     # do a similar test with a 3 channel image, so we're sure we catch
 164     # the same case where the third dimension causes the overflow
 165     # for paletted images the third dimension can't cause an overflow
 166     # but make sure we didn't anything too dumb in the checks
 167     my $dim3 = $dim1;
 168
 169     $im_b = Imager->new(xsize=>$dim3, ysize=>$dim3, channels=>3, type=>'paletted');
 170     is($im_b, undef, "integer overflow check - 3 channel");
 171
 172     $im_b = Imager->new(xsize=>$dim3, ysize=>1, channels=>3, type=>'paletted');
 173     ok($im_b, "but same width ok");
 174     $im_b = Imager->new(xsize=>1, ysize=>$dim3, channels=>3, type=>'paletted');
 175     ok($im_b, "but same height ok");
 176
 177     cmp_ok(Imager->errstr, '=~', qr/integer overflow/,
 178            "check the error message");
 179
 180     # test the scanline allocation check
 181     # divide by 2 to get int range, by 3 so that the image (one byte/pixel)
 182     # doesn't integer overflow, but the scanline of i_color (4/pixel) does
 183     my $dim4 = $uint_range / 3;
 184     my $im_o = Imager->new(xsize=>$dim4, ysize=>1, channels=>3, type=>'paletted');
 185     is($im_o, undef, "integer overflow check - scanline size");
 186     cmp_ok(Imager->errstr, '=~',
 187            qr/integer overflow calculating scanline allocation/,
 188            "check error message");
 189   }
 190 }
 191
 192 { # http://rt.cpan.org/NoAuth/Bug.html?id=9672
 193   my $warning;
 194   local $SIG{__WARN__} =
 195     sub {
 196       $warning = "@_";
 197       my $printed = $warning;
 198       $printed =~ s/\n$//;
 199       $printed =~ s/\n/\n\#/g;
 200       print "# ",$printed, "\n";
 201     };
 202   my $img = Imager->new(xsize=>10, ysize=>10);
 203   $img->to_paletted();
 204   cmp_ok($warning, '=~', 'void', "correct warning");
 205   cmp_ok($warning, '=~', 't023palette\\.t', "correct file");
 206 }
 207
 208 { # http://rt.cpan.org/NoAuth/Bug.html?id=12676
 209   # setcolors() has a fencepost error
 210   my $img = Imager->new(xsize=>10, ysize=>10, type=>'paletted');
 211
 212   is($img->addcolors(colors=>[ $black, $red ]), "0 but true",
 213      "add test colors");
 214   ok($img->setcolors(start=>1, colors=>[ $green ]), "set the last color");
 215   ok(!$img->setcolors(start=>2, colors=>[ $black ]),
 216      "set after the last color");
 217 }
 218
 219 { # https://rt.cpan.org/Ticket/Display.html?id=20056
 220   # added named color support to addcolor/setcolor
 221   my $img = Imager->new(xsize => 10, ysize => 10, type => 'paletted');
 222   is($img->addcolors(colors => [ qw/000000 FF0000/ ]), "0 but true",
 223      "add colors as strings instead of objects");
 224   my @colors = $img->getcolors;
 225   iscolor($colors[0], $black, "check first color");
 226   iscolor($colors[1], $red, "check second color");
 227   ok($img->setcolors(colors => [ qw/00FF00 0000FF/ ]),
 228      "setcolors as strings instead of objects");
 229   @colors = $img->getcolors;
 230   iscolor($colors[0], $green, "check first color");
 231   iscolor($colors[1], $blue, "check second color");
 232
 233   # make sure we handle bad colors correctly
 234   is($img->colorcount, 2, "start from a known state");
 235   is($img->addcolors(colors => [ 'XXFGXFXGXFX' ]), undef,
 236      "fail to add unknown color");
 237   is($img->errstr, 'No color named XXFGXFXGXFX found', 'check error message');
 238   is($img->setcolors(colors => [ 'XXFGXFXGXFXZ' ]), undef,
 239      "fail to set to unknown color");
 240   is($img->errstr, 'No color named XXFGXFXGXFXZ found', 'check error message');
 241 }
 242
 243 { # https://rt.cpan.org/Ticket/Display.html?id=20338
 244   # OO interface to i_glin/i_plin
 245   my $im = Imager->new(xsize => 10, ysize => 10, type => 'paletted');
 246   is($im->addcolors(colors => [ "#000", "#F00", "#0F0", "#00F" ]), "0 but true",
 247      "add some test colors")
 248     or print "# ", $im->errstr, "\n";
 249   # set a pixel to check
 250   $im->setpixel(x => 1, 'y' => 0, color => "#0F0");
 251   is_deeply([ $im->getscanline('y' => 0, type=>'index') ],
 252             [ 0, 2, (0) x 8 ], "getscanline index in list context");
 253   isbin($im->getscanline('y' => 0, type=>'index'),
 254         "\x00\x02" . "\x00" x 8,
 255         "getscanline index in scalar context");
 256   is($im->setscanline('y' => 0, pixels => [ 1, 2, 0, 3 ], type => 'index'),
 257      4, "setscanline with list");
 258   is($im->setscanline('y' => 0, x => 4, pixels => pack("C*", 3, 2, 1, 0, 3),
 259                       type => 'index'),
 260      5, "setscanline with pv");
 261   is_deeply([ $im->getscanline(type => 'index', 'y' => 0) ],
 262             [ 1, 2, 0, 3, 3, 2, 1, 0, 3, 0 ],
 263             "check values set");
 264   eval { # should croak on OOR index
 265     $im->setscanline('y' => 1, pixels => [ 255 ], type=>'index');
 266   };
 267   ok($@, "croak on setscanline() to invalid index");
 268   eval { # same again with pv
 269     $im->setscanline('y' => 1, pixels => "\xFF", type => 'index');
 270   };
 271   ok($@, "croak on setscanline() with pv to invalid index");
 272 }
 273
 274 {
 275   print "# make_colors => mono\n";
 276   # test mono make_colors
 277   my $imrgb = Imager->new(xsize => 10, ysize => 10);
 278   $imrgb->setpixel(x => 0, 'y' => 0, color => '#FFF');
 279   $imrgb->setpixel(x => 1, 'y' => 0, color => '#FF0');
 280   $imrgb->setpixel(x => 2, 'y' => 0, color => '#000');
 281   my $mono = $imrgb->to_paletted(make_colors => 'mono',
 282                                    translate => 'closest');
 283   is($mono->type, 'paletted', "check we get right image type");
 284   is($mono->colorcount, 2, "only 2 colors");
 285   my ($is_mono, $ziw) = $mono->is_bilevel;
 286   ok($is_mono, "check monochrome check true");
 287   is($ziw, 0, "check ziw false");
 288   my @colors = $mono->getcolors;
 289   iscolor($colors[0], $black, "check first entry");
 290   iscolor($colors[1], $white, "check second entry");
 291   my @pixels = $mono->getscanline(x => 0, 'y' => 0, width => 3, type=>'index');
 292   is($pixels[0], 1, "check white pixel");
 293   is($pixels[1], 1, "check yellow pixel");
 294   is($pixels[2], 0, "check black pixel");
 295 }
 296
 297 { # check for the various mono images we accept
 298   my $mono_8_bw_3 = Imager->new(xsize => 2, ysize => 2, channels => 3,
 299                               type => 'paletted');
 300   ok($mono_8_bw_3->addcolors(colors => [ qw/000000 FFFFFF/ ]),
 301      "mono8bw3 - add colors");
 302   ok($mono_8_bw_3->is_bilevel, "it's mono");
 303   is(($mono_8_bw_3->is_bilevel)[1], 0, 'zero not white');
 304
 305   my $mono_8_wb_3 = Imager->new(xsize => 2, ysize => 2, channels => 3,
 306                               type => 'paletted');
 307   ok($mono_8_wb_3->addcolors(colors => [ qw/FFFFFF 000000/ ]),
 308      "mono8wb3 - add colors");
 309   ok($mono_8_wb_3->is_bilevel, "it's mono");
 310   is(($mono_8_wb_3->is_bilevel)[1], 1, 'zero is white');
 311
 312   my $mono_8_bw_1 = Imager->new(xsize => 2, ysize => 2, channels => 1,
 313                               type => 'paletted');
 314   ok($mono_8_bw_1->addcolors(colors => [ qw/000000 FFFFFF/ ]),
 315      "mono8bw - add colors");
 316   ok($mono_8_bw_1->is_bilevel, "it's mono");
 317   is(($mono_8_bw_1->is_bilevel)[1], 0, 'zero not white');
 318
 319   my $mono_8_wb_1 = Imager->new(xsize => 2, ysize => 2, channels => 1,
 320                               type => 'paletted');
 321   ok($mono_8_wb_1->addcolors(colors => [ qw/FFFFFF 000000/ ]),
 322      "mono8wb - add colors");
 323   ok($mono_8_wb_1->is_bilevel, "it's mono");
 324   is(($mono_8_wb_1->is_bilevel)[1], 1, 'zero is white');
 325 }
 326
 327 { # check bounds checking
 328   my $im = Imager->new(xsize => 10, ysize => 10, type=>'paletted');
 329   ok($im->addcolors(colors => [ $black ]), "add color of pixel bounds check writes");
 330
 331   image_bounds_checks($im);
 332 }
 333
 334 { # test colors array returns colors
 335   my $data;
 336   my $im = test_image();
 337   my @colors;
 338   my $imp = $im->to_paletted(colors => \@colors,
 339                              make_colors => 'webmap',
 340                              translate => 'closest');
 341   ok($imp, "made paletted");
 342   is(@colors, 216, "should be 216 colors in the webmap");
 343   is_color3($colors[0], 0, 0, 0, "first should be 000000");
 344   is_color3($colors[1], 0, 0, 0x33, "second should be 000033");
 345   is_color3($colors[8], 0, 0x33, 0x66, "9th should be 003366");
 346 }
 347
 348 { # RT 68508
 349   my $im = Imager->new(xsize => 10, ysize => 10);
 350   $im->box(filled => 1, color => Imager::Color->new(255, 0, 0));
 351   my $palim = $im->to_paletted(make_colors => "mono", translate => "errdiff");
 352   ok($palim, "convert to mono with error diffusion");
 353   my $blank = Imager->new(xsize => 10, ysize => 10);
 354   isnt_image($palim, $blank, "make sure paletted isn't all black");
 355 }
 356
 357 { # check validation of palette entries
 358   my $im = Imager->new(xsize => 10, ysize => 10, type => 'paletted');
 359   $im->addcolors(colors => [ $black, $red ]);
 360   {
 361     my $no_croak = eval {
 362       $im->setscanline(y => 0, type => 'index', pixels => [ 0, 1 ]);
 363       1;
 364     };
 365     ok($no_croak, "valid values don't croak");
 366   }
 367   {
 368     my $no_croak = eval {
 369       $im->setscanline(y => 0, type => 'index', pixels => pack("C*", 0, 1));
 370       1;
 371     };
 372     ok($no_croak, "valid values don't croak (packed)");
 373   }
 374   {
 375     my $no_croak = eval {
 376       $im->setscanline(y => 0, type => 'index', pixels => [ 2, 255 ]);
 377       1;
 378     };
 379     ok(!$no_croak, "invalid values do croak");
 380   }
 381   {
 382     my $no_croak = eval {
 383       $im->setscanline(y => 0, type => 'index', pixels => pack("C*", 2, 255));
 384       1;
 385     };
 386     ok(!$no_croak, "invalid values do croak (packed)");
 387   }
 388 }
 389
 390 {
 391   my $im = Imager->new(xsize => 1, ysize => 1);
 392   my $im_bad = Imager->new;
 393   {
 394     my @map = Imager->make_palette({});
 395     ok(!@map, "make_palette should fail with no images");
 396     is(Imager->errstr, "make_palette: supply at least one image",
 397        "check error message");
 398   }
 399   {
 400     my @map = Imager->make_palette({}, $im, $im_bad, $im);
 401     ok(!@map, "make_palette should fail with an empty image");
 402     is(Imager->errstr, "make_palette: image 2 is empty",
 403        "check error message");
 404   }
 405   {
 406     my @map = Imager->make_palette({ make_colors => "mono" }, $im);
 407     is(@map, 2, "mono should make 2 color palette")
 408       or skip("unexpected color count", 2);
 409     is_color4($map[0], 0, 0, 0, 255, "check map[0]");
 410     is_color4($map[1], 255, 255, 255, 255, "check map[1]");
 411   }
 412   {
 413     my @map = Imager->make_palette({ make_colors => "gray4" }, $im);
 414     is(@map, 4, "gray4 should make 4 color palette")
 415       or skip("unexpected color count", 4);
 416     is_color4($map[0], 0, 0, 0, 255, "check map[0]");
 417     is_color4($map[1], 85, 85, 85, 255, "check map[1]");
 418     is_color4($map[2], 170, 170, 170, 255, "check map[2]");
 419     is_color4($map[3], 255, 255, 255, 255, "check map[3]");
 420   }
 421   {
 422     my @map = Imager->make_palette({ make_colors => "gray16" }, $im);
 423     is(@map, 16, "gray16 should make 16 color palette")
 424       or skip("unexpected color count", 4);
 425     is_color4($map[0], 0, 0, 0, 255, "check map[0]");
 426     is_color4($map[1], 17, 17, 17, 255, "check map[1]");
 427     is_color4($map[2], 34, 34, 34, 255, "check map[2]");
 428     is_color4($map[15], 255, 255, 255, 255, "check map[15]");
 429   }
 430   {
 431     my @map = Imager->make_palette({ make_colors => "gray" }, $im);
 432     is(@map, 256, "gray16 should make 256 color palette")
 433       or skip("unexpected color count", 4);
 434     is_color4($map[0], 0, 0, 0, 255, "check map[0]");
 435     is_color4($map[1], 1, 1, 1, 255, "check map[1]");
 436     is_color4($map[33], 33, 33, 33, 255, "check map[2]");
 437     is_color4($map[255], 255, 255, 255, 255, "check map[15]");
 438   }
 439 }
 440
 441 my $psamp_outside_error = "Image position outside of image";
 442 { # psamp
 443   print "# psamp\n";
 444   my $imraw = Imager::i_img_pal_new(10, 10, 3, 255);
 445   my @colors =
 446     (
 447      NC(0, 0, 0), NC(255, 128, 64), NC(64, 128, 192),
 448      NC(64, 0, 192), NC(255, 128, 0), NC(64, 32, 0),
 449      NC(128, 63, 32), NC(255, 128, 32), NC(64, 32, 16),
 450     );
 451   is(Imager::i_addcolors($imraw, @colors), "0 but true",
 452      "add colors needed for testing");
 453   {
 454     is(Imager::i_psamp($imraw, 0, 2, undef, [ 255, 128, 64 ]), 3,
 455        "i_psamp def channels, 3 samples");
 456     is_color3(Imager::i_get_pixel($imraw, 0, 2), 255, 128, 64,
 457               "check color written");
 458     Imager::i_img_setmask($imraw, 5);
 459     is(Imager::i_psamp($imraw, 1, 3, undef, [ 64, 128, 192 ]), 3,
 460        "i_psamp def channels, 3 samples, masked");
 461     is_color3(Imager::i_get_pixel($imraw, 1, 3), 64, 0, 192,
 462               "check color written");
 463     is(Imager::i_psamp($imraw, 1, 7, [ 0, 1, 2 ], [ 64, 128, 192 ]), 3,
 464        "i_psamp channels listed, 3 samples, masked");
 465     is_color3(Imager::i_get_pixel($imraw, 1, 7), 64, 0, 192,
 466               "check color written");
 467     Imager::i_img_setmask($imraw, ~0);
 468     is(Imager::i_psamp($imraw, 2, 4, [ 0, 1 ], [ 255, 128, 64, 32 ]), 4,
 469        "i_psamp channels [0, 1], 4 samples");
 470     is_color3(Imager::i_get_pixel($imraw, 2, 4), 255, 128, 0,
 471               "check first color written");
 472     is_color3(Imager::i_get_pixel($imraw, 3, 4), 64, 32, 0,
 473               "check second color written");
 474     is(Imager::i_psamp($imraw, 0, 5, [ 0, 1, 2 ], [ (128, 63, 32) x 10 ]), 30,
 475        "write a full row");
 476     is_deeply([ Imager::i_gsamp($imraw, 0, 10, 5, [ 0, 1, 2 ]) ],
 477               [ (128, 63, 32) x 10 ],
 478               "check full row");
 479     is(Imager::i_psamp($imraw, 8, 8, [ 0, 1, 2 ],
 480                        [ 255, 128, 32, 64, 32, 16, 32, 16, 8 ]),
 481        6, "i_psamp channels [0, 1, 2], 9 samples, but room for 6");
 482   }
 483   { # errors we catch
 484     is(Imager::i_psamp($imraw, 6, 8, [ 0, 1, 3 ], [ 255, 128, 32 ]),
 485        undef, "i_psamp channels [0, 1, 3], 3 samples (invalid channel number)");
 486     is(_get_error(), "No channel 3 in this image",
 487        "check error message");
 488     is(Imager::i_psamp($imraw, 6, 8, [ 0, 1, -1 ], [ 255, 128, 32 ]),
 489        undef, "i_psamp channels [0, 1, -1], 3 samples (invalid channel number)");
 490     is(_get_error(), "No channel -1 in this image",
 491        "check error message");
 492     is(Imager::i_psamp($imraw, 0, -1, undef, [ 0, 0, 0 ]), undef,
 493        "negative y");
 494     is(_get_error(), $psamp_outside_error, "check message");
 495     is(Imager::i_psamp($imraw, 0, 10, undef, [ 0, 0, 0 ]), undef,
 496        "y overflow");
 497     is(_get_error(), $psamp_outside_error, "check message");
 498     is(Imager::i_psamp($imraw, -1, 0, undef, [ 0, 0, 0 ]), undef,
 499        "negative x");
 500     is(_get_error(), $psamp_outside_error, "check message");
 501     is(Imager::i_psamp($imraw, 10, 0, undef, [ 0, 0, 0 ]), undef,
 502        "x overflow");
 503     is(_get_error(), $psamp_outside_error, "check message");
 504   }
 505   ok(Imager::i_img_type($imraw), "still paletted");
 506   print "# end psamp tests\n";
 507 }
 508
 509 { # psampf
 510   print "# psampf\n";
 511   my $imraw = Imager::i_img_pal_new(10, 10, 3, 255);
 512   my @colors =
 513     (
 514      NC(0, 0, 0), NC(255, 128, 64), NC(64, 128, 192),
 515      NC(64, 0, 191), NC(255, 128, 0), NC(64, 32, 0),
 516      NC(128, 64, 32), NC(255, 128, 32), NC(64, 32, 16),
 517     );
 518   is(Imager::i_addcolors($imraw, @colors), "0 but true",
 519      "add colors needed for testing");
 520   {
 521     is(Imager::i_psampf($imraw, 0, 2, undef, [ 1, 0.5, 0.25 ]), 3,
 522        "i_psampf def channels, 3 samples");
 523     is_color3(Imager::i_get_pixel($imraw, 0, 2), 255, 128, 64,
 524               "check color written");
 525     Imager::i_img_setmask($imraw, 5);
 526     is(Imager::i_psampf($imraw, 1, 3, undef, [ 0.25, 0.5, 0.75 ]), 3,
 527        "i_psampf def channels, 3 samples, masked");
 528     is_color3(Imager::i_get_pixel($imraw, 1, 3), 64, 0, 191,
 529               "check color written");
 530     is(Imager::i_psampf($imraw, 1, 7, [ 0, 1, 2 ], [ 0.25, 0.5, 0.75 ]), 3,
 531        "i_psampf channels listed, 3 samples, masked");
 532     is_color3(Imager::i_get_pixel($imraw, 1, 7), 64, 0, 191,
 533               "check color written");
 534     Imager::i_img_setmask($imraw, ~0);
 535     is(Imager::i_psampf($imraw, 2, 4, [ 0, 1 ], [ 1, 0.5, 0.25, 0.125 ]), 4,
 536        "i_psampf channels [0, 1], 4 samples");
 537     is_color3(Imager::i_get_pixel($imraw, 2, 4), 255, 128, 0,
 538               "check first color written");
 539     is_color3(Imager::i_get_pixel($imraw, 3, 4), 64, 32, 0,
 540               "check second color written");
 541     is(Imager::i_psampf($imraw, 0, 5, [ 0, 1, 2 ], [ (0.5, 0.25, 0.125) x 10 ]), 30,
 542        "write a full row");
 543     is_deeply([ Imager::i_gsamp($imraw, 0, 10, 5, [ 0, 1, 2 ]) ],
 544               [ (128, 64, 32) x 10 ],
 545               "check full row");
 546     is(Imager::i_psampf($imraw, 8, 8, [ 0, 1, 2 ],
 547                         [ 1.0, 0.5, 0.125, 0.25, 0.125, 0.0625, 0.125, 0, 1 ]),
 548        6, "i_psampf channels [0, 1, 2], 9 samples, but room for 6");
 549   }
 550   { # errors we catch
 551     is(Imager::i_psampf($imraw, 6, 8, [ 0, 1, 3 ], [ 1, 0.5, 0.125 ]),
 552        undef, "i_psampf channels [0, 1, 3], 3 samples (invalid channel number)");
 553     is(_get_error(), "No channel 3 in this image",
 554        "check error message");
 555     is(Imager::i_psampf($imraw, 6, 8, [ 0, 1, -1 ], [ 1, 0.5, 0.125 ]),
 556        undef, "i_psampf channels [0, 1, -1], 3 samples (invalid channel number)");
 557     is(_get_error(), "No channel -1 in this image",
 558        "check error message");
 559     is(Imager::i_psampf($imraw, 0, -1, undef, [ 0, 0, 0 ]), undef,
 560        "negative y");
 561     is(_get_error(), $psamp_outside_error, "check message");
 562     is(Imager::i_psampf($imraw, 0, 10, undef, [ 0, 0, 0 ]), undef,
 563        "y overflow");
 564     is(_get_error(), $psamp_outside_error, "check message");
 565     is(Imager::i_psampf($imraw, -1, 0, undef, [ 0, 0, 0 ]), undef,
 566        "negative x");
 567     is(_get_error(), $psamp_outside_error, "check message");
 568     is(Imager::i_psampf($imraw, 10, 0, undef, [ 0, 0, 0 ]), undef,
 569        "x overflow");
 570     is(_get_error(), $psamp_outside_error, "check message");
 571   }
 572   ok(Imager::i_img_type($imraw), "still paletted");
 573   print "# end psampf tests\n";
 574 }
 575
 576 { # 75258 - gpixf() broken for paletted images
 577   my $im = Imager->new(xsize => 10, ysize => 10, type => "paletted");
 578   ok($im, "make a test image");
 579   my @colors = ( $black, $red, $green, $blue );
 580   is($im->addcolors(colors => \@colors), "0 but true",
 581      "add some colors");
 582   $im->setpixel(x => 0, y => 0, color => $red);
 583   $im->setpixel(x => 1, y => 0, color => $green);
 584   $im->setpixel(x => 2, y => 0, color => $blue);
 585   is_fcolor3($im->getpixel(x => 0, y => 0, type => "float"),
 586              1.0, 0, 0, "get a pixel in float form, make sure it's red");
 587   is_fcolor3($im->getpixel(x => 1, y => 0, type => "float"),
 588              0, 1.0, 0, "get a pixel in float form, make sure it's green");
 589   is_fcolor3($im->getpixel(x => 2, y => 0, type => "float"),
 590              0, 0, 1.0, "get a pixel in float form, make sure it's blue");
 591 }
 592
 593 Imager->close_log;
 594
 595 unless ($ENV{IMAGER_KEEP_FILES}) {
 596   unlink "testout/t023palette.log"
 597 }
 598
 599 sub iscolor {
 600   my ($c1, $c2, $msg) = @_;
 601
 602   my $builder = Test::Builder->new;
 603   my @c1 = $c1->rgba;
 604   my @c2 = $c2->rgba;
 605   if (!$builder->ok($c1[0] == $c2[0] && $c1[1] == $c2[1] && $c1[2] == $c2[2],
 606                     $msg)) {
 607     $builder->diag(<<DIAG);
 608       got color: [ @c1 ]
 609  expected color: [ @c2 ]
 610 DIAG
 611   }
 612 }
 613
 614 sub isbin ($$$) {
 615   my ($got, $expected, $msg) = @_;
 616
 617   my $builder = Test::Builder->new;
 618   if (!$builder->ok($got eq $expected, $msg)) {
 619     (my $got_dec = $got) =~ s/([^ -~])/sprintf("\\x%02x", ord $1)/ge;
 620     (my $exp_dec = $expected)  =~ s/([^ -~])/sprintf("\\x%02x", ord $1)/ge;
 621     $builder->diag(<<DIAG);
 622       got: "$got_dec"
 623  expected: "$exp_dec"
 624 DIAG
 625   }
 626 }
 627
 628 sub coloreq {
 629   my ($left, $right, $comment) = @_;
 630
 631   my ($rl, $gl, $bl, $al) = $left->rgba;
 632   my ($rr, $gr, $br, $ar) = $right->rgba;
 633
 634   print "# comparing color($rl,$gl,$bl,$al) with ($rr,$gr,$br,$ar)\n";
 635   ok($rl == $rr && $gl == $gr && $bl == $br && $al == $ar,
 636       $comment);
 637 }
 638
 639 sub _get_error {
 640   my @errors = Imager::i_errors();
 641   return join(": ", map $_->[0], @errors);
 642 }