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 tests => 226;
   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
 443 my $psamp_outside_error = "Image position outside of image";
 444 { # psamp
 445   print "# psamp\n";
 446   my $imraw = Imager::i_img_pal_new(10, 10, 3, 255);
 447   my @colors =
 448     (
 449      NC(0, 0, 0), NC(255, 128, 64), NC(64, 128, 192),
 450      NC(64, 0, 192), NC(255, 128, 0), NC(64, 32, 0),
 451      NC(128, 63, 32), NC(255, 128, 32), NC(64, 32, 16),
 452     );
 453   is(Imager::i_addcolors($imraw, @colors), "0 but true",
 454      "add colors needed for testing");
 455   {
 456     is(Imager::i_psamp($imraw, 0, 2, undef, [ 255, 128, 64 ]), 3,
 457        "i_psamp def channels, 3 samples");
 458     is_color3(Imager::i_get_pixel($imraw, 0, 2), 255, 128, 64,
 459               "check color written");
 460     Imager::i_img_setmask($imraw, 5);
 461     is(Imager::i_psamp($imraw, 1, 3, undef, [ 64, 128, 192 ]), 3,
 462        "i_psamp def channels, 3 samples, masked");
 463     is_color3(Imager::i_get_pixel($imraw, 1, 3), 64, 0, 192,
 464               "check color written");
 465     is(Imager::i_psamp($imraw, 1, 7, [ 0, 1, 2 ], [ 64, 128, 192 ]), 3,
 466        "i_psamp channels listed, 3 samples, masked");
 467     is_color3(Imager::i_get_pixel($imraw, 1, 7), 64, 0, 192,
 468               "check color written");
 469     Imager::i_img_setmask($imraw, ~0);
 470     is(Imager::i_psamp($imraw, 2, 4, [ 0, 1 ], [ 255, 128, 64, 32 ]), 4,
 471        "i_psamp channels [0, 1], 4 samples");
 472     is_color3(Imager::i_get_pixel($imraw, 2, 4), 255, 128, 0,
 473               "check first color written");
 474     is_color3(Imager::i_get_pixel($imraw, 3, 4), 64, 32, 0,
 475               "check second color written");
 476     is(Imager::i_psamp($imraw, 0, 5, [ 0, 1, 2 ], [ (128, 63, 32) x 10 ]), 30,
 477        "write a full row");
 478     is_deeply([ Imager::i_gsamp($imraw, 0, 10, 5, [ 0, 1, 2 ]) ],
 479               [ (128, 63, 32) x 10 ],
 480               "check full row");
 481     is(Imager::i_psamp($imraw, 8, 8, [ 0, 1, 2 ],
 482                        [ 255, 128, 32, 64, 32, 16, 32, 16, 8 ]),
 483        6, "i_psamp channels [0, 1, 2], 9 samples, but room for 6");
 484   }
 485   { # errors we catch
 486     is(Imager::i_psamp($imraw, 6, 8, [ 0, 1, 3 ], [ 255, 128, 32 ]),
 487        undef, "i_psamp channels [0, 1, 3], 3 samples (invalid channel number)");
 488     is(_get_error(), "No channel 3 in this image",
 489        "check error message");
 490     is(Imager::i_psamp($imraw, 6, 8, [ 0, 1, -1 ], [ 255, 128, 32 ]),
 491        undef, "i_psamp channels [0, 1, -1], 3 samples (invalid channel number)");
 492     is(_get_error(), "No channel -1 in this image",
 493        "check error message");
 494     is(Imager::i_psamp($imraw, 0, -1, undef, [ 0, 0, 0 ]), undef,
 495        "negative y");
 496     is(_get_error(), $psamp_outside_error, "check message");
 497     is(Imager::i_psamp($imraw, 0, 10, undef, [ 0, 0, 0 ]), undef,
 498        "y overflow");
 499     is(_get_error(), $psamp_outside_error, "check message");
 500     is(Imager::i_psamp($imraw, -1, 0, undef, [ 0, 0, 0 ]), undef,
 501        "negative x");
 502     is(_get_error(), $psamp_outside_error, "check message");
 503     is(Imager::i_psamp($imraw, 10, 0, undef, [ 0, 0, 0 ]), undef,
 504        "x overflow");
 505     is(_get_error(), $psamp_outside_error, "check message");
 506   }
 507   ok(Imager::i_img_type($imraw), "still paletted");
 508   print "# end psamp tests\n";
 509 }
 510
 511 { # psampf
 512   print "# psampf\n";
 513   my $imraw = Imager::i_img_pal_new(10, 10, 3, 255);
 514   my @colors =
 515     (
 516      NC(0, 0, 0), NC(255, 128, 64), NC(64, 128, 192),
 517      NC(64, 0, 191), NC(255, 128, 0), NC(64, 32, 0),
 518      NC(128, 64, 32), NC(255, 128, 32), NC(64, 32, 16),
 519     );
 520   is(Imager::i_addcolors($imraw, @colors), "0 but true",
 521      "add colors needed for testing");
 522   {
 523     is(Imager::i_psampf($imraw, 0, 2, undef, [ 1, 0.5, 0.25 ]), 3,
 524        "i_psampf def channels, 3 samples");
 525     is_color3(Imager::i_get_pixel($imraw, 0, 2), 255, 128, 64,
 526               "check color written");
 527     Imager::i_img_setmask($imraw, 5);
 528     is(Imager::i_psampf($imraw, 1, 3, undef, [ 0.25, 0.5, 0.75 ]), 3,
 529        "i_psampf def channels, 3 samples, masked");
 530     is_color3(Imager::i_get_pixel($imraw, 1, 3), 64, 0, 191,
 531               "check color written");
 532     is(Imager::i_psampf($imraw, 1, 7, [ 0, 1, 2 ], [ 0.25, 0.5, 0.75 ]), 3,
 533        "i_psampf channels listed, 3 samples, masked");
 534     is_color3(Imager::i_get_pixel($imraw, 1, 7), 64, 0, 191,
 535               "check color written");
 536     Imager::i_img_setmask($imraw, ~0);
 537     is(Imager::i_psampf($imraw, 2, 4, [ 0, 1 ], [ 1, 0.5, 0.25, 0.125 ]), 4,
 538        "i_psampf channels [0, 1], 4 samples");
 539     is_color3(Imager::i_get_pixel($imraw, 2, 4), 255, 128, 0,
 540               "check first color written");
 541     is_color3(Imager::i_get_pixel($imraw, 3, 4), 64, 32, 0,
 542               "check second color written");
 543     is(Imager::i_psampf($imraw, 0, 5, [ 0, 1, 2 ], [ (0.5, 0.25, 0.125) x 10 ]), 30,
 544        "write a full row");
 545     is_deeply([ Imager::i_gsamp($imraw, 0, 10, 5, [ 0, 1, 2 ]) ],
 546               [ (128, 64, 32) x 10 ],
 547               "check full row");
 548     is(Imager::i_psampf($imraw, 8, 8, [ 0, 1, 2 ],
 549                         [ 1.0, 0.5, 0.125, 0.25, 0.125, 0.0625, 0.125, 0, 1 ]),
 550        6, "i_psampf channels [0, 1, 2], 9 samples, but room for 6");
 551   }
 552   { # errors we catch
 553     is(Imager::i_psampf($imraw, 6, 8, [ 0, 1, 3 ], [ 1, 0.5, 0.125 ]),
 554        undef, "i_psampf channels [0, 1, 3], 3 samples (invalid channel number)");
 555     is(_get_error(), "No channel 3 in this image",
 556        "check error message");
 557     is(Imager::i_psampf($imraw, 6, 8, [ 0, 1, -1 ], [ 1, 0.5, 0.125 ]),
 558        undef, "i_psampf channels [0, 1, -1], 3 samples (invalid channel number)");
 559     is(_get_error(), "No channel -1 in this image",
 560        "check error message");
 561     is(Imager::i_psampf($imraw, 0, -1, undef, [ 0, 0, 0 ]), undef,
 562        "negative y");
 563     is(_get_error(), $psamp_outside_error, "check message");
 564     is(Imager::i_psampf($imraw, 0, 10, undef, [ 0, 0, 0 ]), undef,
 565        "y overflow");
 566     is(_get_error(), $psamp_outside_error, "check message");
 567     is(Imager::i_psampf($imraw, -1, 0, undef, [ 0, 0, 0 ]), undef,
 568        "negative x");
 569     is(_get_error(), $psamp_outside_error, "check message");
 570     is(Imager::i_psampf($imraw, 10, 0, undef, [ 0, 0, 0 ]), undef,
 571        "x overflow");
 572     is(_get_error(), $psamp_outside_error, "check message");
 573   }
 574   ok(Imager::i_img_type($imraw), "still paletted");
 575   print "# end psampf tests\n";
 576 }
 577
 578 { # 75258 - gpixf() broken for paletted images
 579   my $im = Imager->new(xsize => 10, ysize => 10, type => "paletted");
 580   ok($im, "make a test image");
 581   my @colors = ( $black, $red, $green, $blue );
 582   is($im->addcolors(colors => \@colors), "0 but true",
 583      "add some colors");
 584   $im->setpixel(x => 0, y => 0, color => $red);
 585   $im->setpixel(x => 1, y => 0, color => $green);
 586   $im->setpixel(x => 2, y => 0, color => $blue);
 587   is_fcolor3($im->getpixel(x => 0, y => 0, type => "float"),
 588              1.0, 0, 0, "get a pixel in float form, make sure it's red");
 589   is_fcolor3($im->getpixel(x => 1, y => 0, type => "float"),
 590              0, 1.0, 0, "get a pixel in float form, make sure it's green");
 591   is_fcolor3($im->getpixel(x => 2, y => 0, type => "float"),
 592              0, 0, 1.0, "get a pixel in float form, make sure it's blue");
 593 }
 594
 595 {
 596   my $empty = Imager->new;
 597   ok(!$empty->to_paletted, "can't convert an empty image");
 598   is($empty->errstr, "to_paletted: empty input image",
 599     "check error message");
 600
 601   is($empty->addcolors(colors => [ $black ]), -1,
 602      "can't addcolors() to an empty image");
 603   is($empty->errstr, "addcolors: empty input image",
 604      "check error message");
 605
 606   ok(!$empty->setcolors(colors => [ $black ]),
 607      "can't setcolors() to an empty image");
 608   is($empty->errstr, "setcolors: empty input image",
 609      "check error message");
 610
 611   ok(!$empty->getcolors(),
 612      "can't getcolors() from an empty image");
 613   is($empty->errstr, "getcolors: empty input image",
 614      "check error message");
 615
 616   is($empty->colorcount, -1, "can't colorcount() an empty image");
 617   is($empty->errstr, "colorcount: empty input image",
 618      "check error message");
 619
 620   is($empty->maxcolors, -1, "can't maxcolors() an empty image");
 621   is($empty->errstr, "maxcolors: empty input image",
 622      "check error message");
 623
 624   is($empty->findcolor(color => $blue), undef,
 625      "can't findcolor an empty image");
 626   is($empty->errstr, "findcolor: empty input image",
 627      "check error message");
 628 }
 629
 630 Imager->close_log;
 631
 632 unless ($ENV{IMAGER_KEEP_FILES}) {
 633   unlink "testout/t023palette.log"
 634 }
 635
 636 sub iscolor {
 637   my ($c1, $c2, $msg) = @_;
 638
 639   my $builder = Test::Builder->new;
 640   my @c1 = $c1->rgba;
 641   my @c2 = $c2->rgba;
 642   if (!$builder->ok($c1[0] == $c2[0] && $c1[1] == $c2[1] && $c1[2] == $c2[2],
 643                     $msg)) {
 644     $builder->diag(<<DIAG);
 645       got color: [ @c1 ]
 646  expected color: [ @c2 ]
 647 DIAG
 648   }
 649 }
 650
 651 sub isbin ($$$) {
 652   my ($got, $expected, $msg) = @_;
 653
 654   my $builder = Test::Builder->new;
 655   if (!$builder->ok($got eq $expected, $msg)) {
 656     (my $got_dec = $got) =~ s/([^ -~])/sprintf("\\x%02x", ord $1)/ge;
 657     (my $exp_dec = $expected)  =~ s/([^ -~])/sprintf("\\x%02x", ord $1)/ge;
 658     $builder->diag(<<DIAG);
 659       got: "$got_dec"
 660  expected: "$exp_dec"
 661 DIAG
 662   }
 663 }
 664
 665 sub coloreq {
 666   my ($left, $right, $comment) = @_;
 667
 668   my ($rl, $gl, $bl, $al) = $left->rgba;
 669   my ($rr, $gr, $br, $ar) = $right->rgba;
 670
 671   print "# comparing color($rl,$gl,$bl,$al) with ($rr,$gr,$br,$ar)\n";
 672   ok($rl == $rr && $gl == $gr && $bl == $br && $al == $ar,
 673       $comment);
 674 }
 675
 676 sub _get_error {
 677   my @errors = Imager::i_errors();
 678   return join(": ", map $_->[0], @errors);
 679 }