t/t023palette.t

   1 #!perl -w
   2 # some of this is tested in t01introvert.t too
   3 use strict;
   4 use lib 't';
   5 use Test::More tests => 75;
   6 BEGIN { use_ok("Imager"); }
   7
   8 my $img = Imager->new(xsize=>50, ysize=>50, type=>'paletted');
   9
  10 ok($img, "paletted image created");
  11
  12 ok($img->type eq 'paletted', "got a paletted image");
  13
  14 my $black = Imager::Color->new(0,0,0);
  15 my $red = Imager::Color->new(255,0,0);
  16 my $green = Imager::Color->new(0,255,0);
  17 my $blue = Imager::Color->new(0,0,255);
  18
  19 my $white = Imager::Color->new(255,255,255);
  20
  21 # add some color
  22 my $blacki = $img->addcolors(colors=>[ $black, $red, $green, $blue ]);
  23
  24 print "# blacki $blacki\n";
  25 ok(defined $blacki && $blacki == 0, "we got the first color");
  26
  27 ok($img->colorcount() == 4, "should have 4 colors");
  28 my ($redi, $greeni, $bluei) = 1..3;
  29
  30 my @all = $img->getcolors;
  31 ok(@all == 4, "all colors is 4");
  32 coloreq($all[0], $black, "first black");
  33 coloreq($all[1], $red, "then red");
  34 coloreq($all[2], $green, "then green");
  35 coloreq($all[3], $blue, "and finally blue");
  36
  37 # keep this as an assignment, checking for scalar context
  38 # we don't want the last color, otherwise if the behaviour changes to
  39 # get all up to the last (count defaulting to size-index) we'd get a
  40 # false positive
  41 my $one_color = $img->getcolors(start=>$redi);
  42 ok($one_color->isa('Imager::Color'), "check scalar context");
  43 coloreq($one_color, $red, "and that it's what we want");
  44
  45 # make sure we can find colors
  46 ok(!defined($img->findcolor(color=>$white)),
  47     "shouldn't be able to find white");
  48 ok($img->findcolor(color=>$black) == $blacki, "find black");
  49 ok($img->findcolor(color=>$red) == $redi, "find red");
  50 ok($img->findcolor(color=>$green) == $greeni, "find green");
  51 ok($img->findcolor(color=>$blue) == $bluei, "find blue");
  52
  53 # various failure tests for setcolors
  54 ok(!defined($img->setcolors(start=>-1, colors=>[$white])),
  55     "expect failure: low index");
  56 ok(!defined($img->setcolors(start=>1, colors=>[])),
  57     "expect failure: no colors");
  58 ok(!defined($img->setcolors(start=>5, colors=>[$white])),
  59     "expect failure: high index");
  60
  61 # set the green index to white
  62 ok($img->setcolors(start => $greeni, colors => [$white]),
  63     "set a color");
  64 # and check it
  65 coloreq(scalar($img->getcolors(start=>$greeni)), $white,
  66         "make sure it was set");
  67 ok($img->findcolor(color=>$white) == $greeni, "and that we can find it");
  68 ok(!defined($img->findcolor(color=>$green)), "and can't find the old color");
  69
  70 # write a few colors
  71 ok(scalar($img->setcolors(start=>$redi, colors=>[ $green, $red])),
  72            "save multiple");
  73 coloreq(scalar($img->getcolors(start=>$redi)), $green, "first of multiple");
  74 coloreq(scalar($img->getcolors(start=>$greeni)), $red, "second of multiple");
  75
  76 # put it back
  77 $img->setcolors(start=>$red, colors=>[$red, $green]);
  78
  79 # draw on the image, make sure it stays paletted when it should
  80 ok($img->box(color=>$red, filled=>1), "fill with red");
  81 ok($img->type eq 'paletted', "paletted after fill");
  82 ok($img->box(color=>$green, filled=>1, xmin=>10, ymin=>10,
  83               xmax=>40, ymax=>40), "green box");
  84 ok($img->type eq 'paletted', 'still paletted after box');
  85 # an AA line will almost certainly convert the image to RGB, don't use
  86 # an AA line here
  87 ok($img->line(color=>$blue, x1=>10, y1=>10, x2=>40, y2=>40),
  88     "draw a line");
  89 ok($img->type eq 'paletted', 'still paletted after line');
  90
  91 # draw with white - should convert to direct
  92 ok($img->box(color=>$white, filled=>1, xmin=>20, ymin=>20,
  93               xmax=>30, ymax=>30), "white box");
  94 ok($img->type eq 'direct', "now it should be direct");
  95
  96 # various attempted to make a paletted image from our now direct image
  97 my $palimg = $img->to_paletted;
  98 ok($palimg, "we got an image");
  99 # they should be the same pixel for pixel
 100 ok(Imager::i_img_diff($img->{IMG}, $palimg->{IMG}) == 0, "same pixels");
 101
 102 # strange case: no color picking, and no colors
 103 # this was causing a segmentation fault
 104 $palimg = $img->to_paletted(colors=>[ ], make_colors=>'none');
 105 ok(!defined $palimg, "to paletted with an empty palette is an error");
 106 print "# ",$img->errstr,"\n";
 107 ok(scalar($img->errstr =~ /no colors available for translation/),
 108     "and got the correct msg");
 109
 110 ok(!Imager->new(xsize=>1, ysize=>-1, type=>'paletted'),
 111     "fail on -ve height");
 112 cmp_ok(Imager->errstr, '=~', qr/Image sizes must be positive/,
 113        "and correct error message");
 114 ok(!Imager->new(xsize=>-1, ysize=>1, type=>'paletted'),
 115     "fail on -ve width");
 116 cmp_ok(Imager->errstr, '=~', qr/Image sizes must be positive/,
 117        "and correct error message");
 118 ok(!Imager->new(xsize=>-1, ysize=>-1, type=>'paletted'),
 119     "fail on -ve width/height");
 120 cmp_ok(Imager->errstr, '=~', qr/Image sizes must be positive/,
 121        "and correct error message");
 122
 123 ok(!Imager->new(xsize=>1, ysize=>1, type=>'paletted', channels=>0),
 124     "fail on 0 channels");
 125 cmp_ok(Imager->errstr, '=~', qr/Channels must be positive and <= 4/,
 126        "and correct error message");
 127 ok(!Imager->new(xsize=>1, ysize=>1, type=>'paletted', channels=>5),
 128     "fail on 5 channels");
 129 cmp_ok(Imager->errstr, '=~', qr/Channels must be positive and <= 4/,
 130        "and correct error message");
 131
 132 {
 133   # https://rt.cpan.org/Ticket/Display.html?id=8213
 134   # check for handling of memory allocation of very large images
 135   # only test this on 32-bit machines - on a 64-bit machine it may
 136   # result in trying to allocate 4Gb of memory, which is unfriendly at
 137   # least and may result in running out of memory, causing a different
 138   # type of exit
 139   use Config;
 140  SKIP:
 141   {
 142     skip("don't want to allocate 4Gb", 10)
 143       unless $Config{intsize} == 4;
 144
 145     my $uint_range = 256 ** $Config{intsize};
 146     my $dim1 = int(sqrt($uint_range))+1;
 147
 148     my $im_b = Imager->new(xsize=>$dim1, ysize=>$dim1, channels=>1, type=>'paletted');
 149     is($im_b, undef, "integer overflow check - 1 channel");
 150
 151     $im_b = Imager->new(xisze=>$dim1, ysize=>1, channels=>1, type=>'paletted');
 152     ok($im_b, "but same width ok");
 153     $im_b = Imager->new(xisze=>1, ysize=>$dim1, channels=>1, type=>'paletted');
 154     ok($im_b, "but same height ok");
 155     cmp_ok(Imager->errstr, '=~', qr/integer overflow/,
 156            "check the error message");
 157
 158     # do a similar test with a 3 channel image, so we're sure we catch
 159     # the same case where the third dimension causes the overflow
 160     # for paletted images the third dimension can't cause an overflow
 161     # but make sure we didn't anything too dumb in the checks
 162     my $dim3 = $dim1;
 163
 164     $im_b = Imager->new(xsize=>$dim3, ysize=>$dim3, channels=>3, type=>'paletted');
 165     is($im_b, undef, "integer overflow check - 3 channel");
 166
 167     $im_b = Imager->new(xsize=>$dim3, ysize=>1, channels=>3, type=>'paletted');
 168     ok($im_b, "but same width ok");
 169     $im_b = Imager->new(xsize=>1, ysize=>$dim3, channels=>3, type=>'paletted');
 170     ok($im_b, "but same height ok");
 171
 172     cmp_ok(Imager->errstr, '=~', qr/integer overflow/,
 173            "check the error message");
 174
 175     # test the scanline allocation check
 176     # divide by 2 to get int range, by 3 so that the image (one byte/pixel)
 177     # doesn't integer overflow, but the scanline of i_color (4/pixel) does
 178     my $dim4 = $uint_range / 2 / 3;
 179     my $im_o = Imager->new(xsize=>$dim4, ysize=>1, channels=>3, type=>'paletted');
 180     is($im_o, undef, "integer overflow check - scanline size");
 181     cmp_ok(Imager->errstr, '=~',
 182            qr/integer overflow calculating scanline allocation/,
 183            "check error message");
 184   }
 185 }
 186
 187 { # http://rt.cpan.org/NoAuth/Bug.html?id=9672
 188   my $warning;
 189   local $SIG{__WARN__} =
 190     sub {
 191       $warning = "@_";
 192       my $printed = $warning;
 193       $printed =~ s/\n$//;
 194       $printed =~ s/\n/\n\#/g;
 195       print "# ",$printed, "\n";
 196     };
 197   my $img = Imager->new(xsize=>10, ysize=>10);
 198   $img->to_paletted();
 199   cmp_ok($warning, '=~', 'void', "correct warning");
 200   cmp_ok($warning, '=~', 't023palette\\.t', "correct file");
 201 }
 202
 203 { # http://rt.cpan.org/NoAuth/Bug.html?id=12676
 204   # setcolors() has a fencepost error
 205   my $img = Imager->new(xsize=>10, ysize=>10, type=>'paletted');
 206
 207   is($img->addcolors(colors=>[ $black, $red ]), "0 but true",
 208      "add test colors");
 209   ok($img->setcolors(start=>1, colors=>[ $green ]), "set the last color");
 210   ok(!$img->setcolors(start=>2, colors=>[ $black ]),
 211      "set after the last color");
 212 }
 213
 214 { # https://rt.cpan.org/Ticket/Display.html?id=20056
 215   # added named color support to addcolor/setcolor
 216   my $img = Imager->new(xsize => 10, ysize => 10, type => 'paletted');
 217   is($img->addcolors(colors => [ qw/000000 FF0000/ ]), "0 but true",
 218      "add colors as strings instead of objects");
 219   my @colors = $img->getcolors;
 220   iscolor($colors[0], $black, "check first color");
 221   iscolor($colors[1], $red, "check second color");
 222   ok($img->setcolors(colors => [ qw/00FF00 0000FF/ ]),
 223      "setcolors as strings instead of objects");
 224   @colors = $img->getcolors;
 225   iscolor($colors[0], $green, "check first color");
 226   iscolor($colors[1], $blue, "check second color");
 227
 228   # make sure we handle bad colors correctly
 229   is($img->colorcount, 2, "start from a known state");
 230   is($img->addcolors(colors => [ 'XXFGXFXGXFX' ]), undef,
 231      "fail to add unknown color");
 232   is($img->errstr, 'No color named XXFGXFXGXFX found', 'check error message');
 233   is($img->setcolors(colors => [ 'XXFGXFXGXFXZ' ]), undef,
 234      "fail to set to unknown color");
 235   is($img->errstr, 'No color named XXFGXFXGXFXZ found', 'check error message');
 236 }
 237
 238 sub iscolor {
 239   my ($c1, $c2, $msg) = @_;
 240
 241   my $builder = Test::Builder->new;
 242   my @c1 = $c1->rgba;
 243   my @c2 = $c2->rgba;
 244   if (!$builder->ok($c1[0] == $c2[0] && $c1[1] == $c2[1] && $c1[2] == $c2[2],
 245                     $msg)) {
 246     $builder->diag(<<DIAG);
 247       got color: [ @c1 ]
 248  expected color: [ @c2 ]
 249 DIAG
 250   }
 251 }
 252
 253 sub coloreq {
 254   my ($left, $right, $comment) = @_;
 255
 256   my ($rl, $gl, $bl, $al) = $left->rgba;
 257   my ($rr, $gr, $br, $ar) = $right->rgba;
 258
 259   print "# comparing color($rl,$gl,$bl,$al) with ($rr,$gr,$br,$ar)\n";
 260   ok($rl == $rr && $gl == $gr && $bl == $br && $al == $ar,
 261       $comment);
 262 }
 263