t/150-type/040-palette.t

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