GIF/t/t30fixed.t

   1 #!perl -w
   2 use strict;
   3 use Test::More tests => 9;
   4 use Imager;
   5 use Imager::Test qw(test_image);
   6
   7 -d "testout" or mkdir "testout";
   8
   9 Imager->open_log(log => "testout/t30fixed.log");
  10
  11 {
  12   # RT 67912
  13   # previously, if you tried to write a paletted image to GIF:
  14   #  - specified a fixed palette with make_colors => "mono", "web" or "none"
  15   #  - there was room for the colors in the image in the rest of the
  16   #  palette (or they were found in the generated palette)
  17   # the GIF would be written with essentially it's original palette
  18   # instead of the specified palette
  19   #
  20   # This was confusing, especially if you specified a restricted
  21   # palette such as mono or a small greyscale ramp
  22
  23   my $src = test_image();
  24   ok($src, "make source image");
  25   my $pal = $src->to_paletted(max_colors => 250);
  26   ok($pal, "make paletted version");
  27   cmp_ok($pal->colorcount, "<=", 250, "make sure not too many colors");
  28
  29   my $mono = $src->to_paletted(make_colors => "mono", translate => "errdiff");
  30   ok($mono, "make mono image directly");
  31   ok($mono->write(file => "testout/t30monodirect.gif", type => "gif"),
  32      "save mono direct image");
  33
  34   Imager->log("Save manually paletted version\n");
  35   ok($pal->write(file => "testout/t30color.gif"),
  36      "save generated palette version");
  37   Imager->log("Save mono version\n");
  38   ok($pal->write(file => "testout/t30monoind.gif", type => "gif",
  39                  make_colors => "mono", translate => "errdiff"),
  40      "write paletted with mono colormap");
  41
  42   my $rd = Imager->new(file => "testout/t30monoind.gif", type => "gif");
  43   ok($rd, "read it back in");
  44   is($rd->colorcount, 2, "should only have 2 colors");
  45 }
  46
  47 Imager->close_log;