t/t023palette.t

   1 #!perl -w
   2 # some of this is tested in t01introvert.t too
   3 use strict;
   4 use Test::More tests => 128;
   5 BEGIN { use_ok("Imager"); }
   6
   7 use Imager::Test qw(image_bounds_checks test_image is_color3 isnt_image);
   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 Imager->close_log;
 358
 359 unless ($ENV{IMAGER_KEEP_FILES}) {
 360   unlink "testout/t023palette.log"
 361 }
 362
 363 sub iscolor {
 364   my ($c1, $c2, $msg) = @_;
 365
 366   my $builder = Test::Builder->new;
 367   my @c1 = $c1->rgba;
 368   my @c2 = $c2->rgba;
 369   if (!$builder->ok($c1[0] == $c2[0] && $c1[1] == $c2[1] && $c1[2] == $c2[2],
 370                     $msg)) {
 371     $builder->diag(<<DIAG);
 372       got color: [ @c1 ]
 373  expected color: [ @c2 ]
 374 DIAG
 375   }
 376 }
 377
 378 sub isbin ($$$) {
 379   my ($got, $expected, $msg) = @_;
 380
 381   my $builder = Test::Builder->new;
 382   if (!$builder->ok($got eq $expected, $msg)) {
 383     (my $got_dec = $got) =~ s/([^ -~])/sprintf("\\x%02x", ord $1)/ge;
 384     (my $exp_dec = $expected)  =~ s/([^ -~])/sprintf("\\x%02x", ord $1)/ge;
 385     $builder->diag(<<DIAG);
 386       got: "$got_dec"
 387  expected: "$exp_dec"
 388 DIAG
 389   }
 390 }
 391
 392 sub coloreq {
 393   my ($left, $right, $comment) = @_;
 394
 395   my ($rl, $gl, $bl, $al) = $left->rgba;
 396   my ($rr, $gr, $br, $ar) = $right->rgba;
 397
 398   print "# comparing color($rl,$gl,$bl,$al) with ($rr,$gr,$br,$ar)\n";
 399   ok($rl == $rr && $gl == $gr && $bl == $br && $al == $ar,
 400       $comment);
 401 }
 402