t/t105gif.t

   1 $|=1;
   2 print "1..23\n";
   3 use Imager qw(:all);
   4
   5 init_log("testout/t105gif.log",1);
   6
   7 $green=i_color_new(0,255,0,255);
   8 $blue=i_color_new(0,0,255,255);
   9 $red=i_color_new(255,0,0,255);
  10
  11 $img=Imager::ImgRaw::new(150,150,3);
  12
  13 i_box_filled($img,70,25,130,125,$green);
  14 i_box_filled($img,20,25,80,125,$blue);
  15 i_arc($img,75,75,30,0,361,$red);
  16 i_conv($img,[0.1, 0.2, 0.4, 0.2, 0.1]);
  17
  18 my $timg = Imager::ImgRaw::new(20, 20, 4);
  19 my $trans = i_color_new(255, 0, 0, 127);
  20 i_box_filled($timg, 0, 0, 20, 20, $green);
  21 i_box_filled($timg, 2, 2, 18, 18, $trans);
  22
  23 if (!i_has_format("gif")) {
  24         for (1..23) { print "ok $_ # skip no gif support\n"; }
  25 } else {
  26     open(FH,">testout/t105.gif") || die "Cannot open testout/t105.gif\n";
  27     binmode(FH);
  28     i_writegifmc($img,fileno(FH),7) || die "Cannot write testout/t105.gif\n";
  29     close(FH);
  30
  31     print "ok 1\n";
  32
  33     open(FH,"testout/t105.gif") || die "Cannot open testout/t105.gif\n";
  34     binmode(FH);
  35     $img=i_readgif(fileno(FH)) || die "Cannot read testout/t105.gif\n";
  36     close(FH);
  37
  38     print "ok 2\n";
  39
  40     open(FH,"testout/t105.gif") || die "Cannot open testout/t105.gif\n";
  41     binmode(FH);
  42     ($img, $palette)=i_readgif(fileno(FH));
  43     $img || die "Cannot read testout/t105.gif\n";
  44     close(FH);
  45
  46     $palette=''; # just to skip a warning.
  47
  48     print "ok 3\n";
  49
  50     # check that reading interlaced/non-interlaced versions of
  51     # the same GIF produce the same image
  52     # I could replace this with code that used Imager's built-in
  53     # image comparison code, but I know this code revealed the error
  54     open(FH, "<testimg/scalei.gif") || die "Cannot open testimg/scalei.gif";
  55     binmode FH;
  56     ($imgi) = i_readgif(fileno(FH));
  57     $imgi || die "Cannot read testimg/scalei.gif";
  58     close FH;
  59     print "ok 4\n";
  60     open FH, "<testimg/scale.gif" or die "Cannot open testimg/scale.gif";
  61     binmode FH;
  62     ($imgni) = i_readgif(fileno(FH));
  63     $imgni or die "Cannot read testimg/scale.gif";
  64     close FH;
  65     print "ok 5\n";
  66
  67     open FH, ">testout/t105i.ppm" or die "Cannot create testout/t105i.ppm";
  68     binmode FH;
  69     i_writeppm($imgi, fileno(FH)) or die "Cannot write testout/t105i.ppm";
  70     close FH;
  71
  72     open FH, ">testout/t105ni.ppm" or die "Cannot create testout/t105ni.ppm";
  73     binmode FH;
  74     i_writeppm($imgni, fileno(FH)) or die "Cannot write testout/t105ni.ppm";
  75     close FH;
  76
  77     # compare them
  78     open FH, "<testout/t105i.ppm" or die "Cannot open testout/t105i.ppm";
  79     $datai = do { local $/; <FH> };
  80     close FH;
  81     open FH, "<testout/t105ni.ppm" or die "Cannot open testout/t105ni.ppm";
  82     $datani = do { local $/; <FH> };
  83     close FH;
  84     if ($datai eq $datani) {
  85       print "ok 6\n";
  86     }
  87     else {
  88       print "not ok 6\n";
  89     }
  90
  91     my $gifver = Imager::i_giflib_version();
  92     if ($gifver >= 4.0) {
  93       # reading with a callback
  94       # various sizes to make sure the buffering works
  95       # requested size
  96       open FH, "<testimg/scale.gif" or die "Cannot open testimg/scale.gif";
  97       binmode FH;
  98       # no callback version in giflib3, so don't overwrite a good image
  99       my $img2 = i_readgif_callback(sub { my $tmp; read(FH, $tmp, $_[0]) and $tmp });
 100       close FH;
 101       print $img ? "ok 7\n" : "not ok 7\n";
 102
 103       print test_readgif_cb(1) ? "ok 8\n" : "not ok 8\n";
 104       print test_readgif_cb(512) ? "ok 9\n" : "not ok 9\n";
 105       print test_readgif_cb(1024) ? "ok 10\n" : "not ok 10\n";
 106     }
 107     else {
 108       print "ok $_ # skip giflib3 doesn't support callbacks\n" for (7..10);
 109     }
 110     open FH, ">testout/t105_mc.gif" or die "Cannot open testout/t105_mc.gif";
 111     binmode FH;
 112     i_writegifmc($img, fileno(FH), 7) or print "not ";
 113     close(FH);
 114     print "ok 11\n";
 115
 116     # new writegif_gen
 117     # test webmap, custom errdiff map
 118     # (looks fairly awful)
 119     open FH, ">testout/t105_gen.gif" or die $!;
 120     binmode FH;
 121     i_writegif_gen(fileno(FH), { make_colors=>'webmap',
 122                                  translate=>'errdiff',
 123                                  errdiff=>'custom',
 124                                  errdiff_width=>2,
 125                                  errdiff_height=>2,
 126                                  errdiff_map=>[0, 1, 1, 0]}, $img)
 127       or print "not ";
 128     close FH;
 129     print "ok 12\n";
 130
 131     print "# the following tests are fairly slow\n";
 132
 133     # test animation, mc_addi, error diffusion, ordered transparency
 134     my @imgs;
 135     my $sortagreen = i_color_new(0, 255, 0, 63);
 136     for my $i (0..4) {
 137       my $im = Imager::ImgRaw::new(200, 200, 4);
 138       for my $j (0..$i-1) {
 139         my $fill = i_color_new(0, 128, 0, 255 * ($i-$j)/$i);
 140         i_box_filled($im, 0, $j*40, 199, $j*40+40, $fill);
 141       }
 142       i_box_filled($im, 0, $i*40, 199, 199, $blue);
 143       push(@imgs, $im);
 144     }
 145     my @gif_delays = (50) x 5;
 146     my @gif_disposal = (2) x 5;
 147     open FH, ">testout/t105_anim.gif" or die $!;
 148     binmode FH;
 149     i_writegif_gen(fileno(FH), { make_colors=>'addi',
 150                                  translate=>'closest',
 151                                  gif_delays=>\@gif_delays,
 152                                  gif_disposal=>\@gif_disposal,
 153                                  transp=>'ordered',
 154                                  tr_orddith=>'dot8'}, @imgs)
 155       or die "Cannot write anim gif";
 156     close FH;
 157     print "ok 13\n";
 158
 159     if ($gifver >= 4.0) {
 160       unless (fork) {
 161         # this can SIGSEGV with some versions of giflib
 162         open FH, ">testout/t105_anim_cb.gif" or die $!;
 163         i_writegif_callback(sub {
 164                               print FH $_[0]
 165                             },
 166                             -1, # max buffering
 167                             { make_colors=>'webmap',
 168                               translate=>'closest',
 169                               gif_delays=>\@gif_delays,
 170                               gif_disposal=>\@gif_disposal,
 171                               #transp=>'ordered',
 172                               tr_orddith=>'dot8'}, @imgs)
 173           or die "Cannot write anim gif";
 174         close FH;
 175         print "ok 14\n";
 176         exit;
 177       }
 178       if (wait > 0 && $?) {
 179         print "not ok 14 # you probably need to patch giflib\n";
 180         print <<EOS;
 181 #--- egif_lib.c 2000/12/11 07:33:12     1.1
 182 #+++ egif_lib.c 2000/12/11 07:33:48
 183 #@@ -167,6 +167,12 @@
 184 #         _GifError = E_GIF_ERR_NOT_ENOUGH_MEM;
 185 #         return NULL;
 186 #     }
 187 #+    if ((Private->HashTable = _InitHashTable()) == NULL) {
 188 #+        free(GifFile);
 189 #+        free(Private);
 190 #+        _GifError = E_GIF_ERR_NOT_ENOUGH_MEM;
 191 #+        return NULL;
 192 #+    }
 193 #
 194 #     GifFile->Private = (VoidPtr) Private;
 195 #     Private->FileHandle = 0;
 196 EOS
 197       }
 198     }
 199     else {
 200       print "ok 14 # skip giflib3 doesn't support callbacks\n";
 201     }
 202     @imgs = ();
 203     for $g (0..3) {
 204       my $im = Imager::ImgRaw::new(200, 200, 3);
 205       for my $x (0 .. 39) {
 206         for my $y (0 .. 39) {
 207           my $c = i_color_new($x * 6, $y * 6, 32*$g+$x+$y, 255);
 208           i_box_filled($im, $x*5, $y*5, $x*5+4, $y*5+4, $c);
 209         }
 210       }
 211       push(@imgs, $im);
 212     }
 213     # test giflib with multiple palettes
 214     # (it was meant to test the NS loop extension too, but that's broken)
 215     # this looks better with make_colors=>'addi', translate=>'errdiff'
 216     # this test aims to overload the palette for each image, so the
 217     # output looks moderately horrible
 218     open FH, ">testout/t105_mult_pall.gif" or die "Cannot create file: $!";
 219     binmode FH;
 220     i_writegif_gen(fileno(FH), { make_colors=>'webmap',
 221                                  translate=>'giflib',
 222                                  gif_delays=>[ 50, 50, 50, 50 ],
 223                                  #gif_loop_count => 50,
 224                                  gif_each_palette => 1,
 225                                }, @imgs) or print "not ";
 226     close FH;
 227     print "ok 15\n";
 228
 229     # regression test: giflib doesn't like 1 colour images
 230     my $img1 = Imager::ImgRaw::new(100, 100, 3);
 231     i_box_filled($img1, 0, 0, 100, 100, $red);
 232     open FH, ">testout/t105_onecol.gif" or die $!;
 233     binmode FH;
 234     if (i_writegif_gen(fileno(FH), { translate=>'giflib'}, $img1)) {
 235       print "ok 16 # single colour write regression\n";
 236     } else {
 237       print "not ok 16 # single colour write regression\n";
 238     }
 239     close FH;
 240
 241     # transparency test
 242     # previously it was harder do write transparent images
 243     # tests the improvements
 244     my $timg = Imager::ImgRaw::new(20, 20, 4);
 245     my $trans = i_color_new(255, 0, 0, 127);
 246     i_box_filled($timg, 0, 0, 20, 20, $green);
 247     i_box_filled($timg, 2, 2, 18, 18, $trans);
 248     open FH, ">testout/t105_trans.gif" or die $!;
 249     binmode FH;
 250     i_writegif_gen(fileno(FH), { make_colors=>'addi',
 251                                  translate=>'closest',
 252                                  transp=>'ordered',
 253                                }, $timg) or print "not ";
 254     print "ok 17\n";
 255     close FH;
 256
 257     # some error handling tests
 258     # open a file handle for read and try to save to it
 259     # is this idea portable?
 260     # whether or not it is, giflib segfaults on this <sigh>
 261     #open FH, "<testout/t105_trans.gif" or die $!;
 262     #binmode FH; # habit, I suppose
 263     #if (i_writegif_gen(fileno(FH), {}, $timg)) {
 264     #  # this is meant to _fail_
 265     #  print "not ok 18 # writing to read-only should fail";
 266     #}
 267     #else {
 268     #  print "ok 18 # ",Imager::_error_as_msg(),"\n";
 269     #}
 270     #close FH;
 271
 272     # try to read a file of the wrong format - the script will do
 273     open FH, "<t/t105gif.t"
 274       or die "Cannot open this script!: $!";
 275     binmode FH;
 276     my $im2 = i_readgif(fileno(FH));
 277     if ($im2) {
 278       # this should have failed
 279       print "not ok 18 # giflib think script if a GIF file\n";
 280     }
 281     else {
 282       print "ok 18 # ",Imager::_error_as_msg(),"\n";
 283     }
 284     close FH;
 285
 286     # try to save no images :)
 287     open FH, ">testout/t105_none.gif"
 288       or die "Cannot open testout/t105_none.gif: $!";
 289     binmode FH;
 290     if (i_writegif_gen(fileno(FH), {}, "hello")) {
 291       print "not ok 19 # shouldn't be able to save strings\n";
 292     }
 293     else {
 294       print "ok 19 # ",Imager::_error_as_msg(),"\n";
 295     }
 296
 297     # try to read a truncated gif (no image descriptors)
 298     read_failure('testimg/trimgdesc.gif', 20);
 299     # file truncated just after the image descriptor tag
 300     read_failure('testimg/trmiddesc.gif', 21);
 301     # image has no colour map
 302     read_failure('testimg/nocmap.gif', 22);
 303
 304     # image has a local colour map
 305     open FH, "< testimg/loccmap.gif"
 306       or die "Cannot open testimg/loccmap.gif: $!";
 307     binmode FH;
 308     if (i_readgif(fileno(FH))) {
 309       print "ok 23\n";
 310     }
 311     else {
 312       print "not ok 23 # failed to read image with only a local colour map";
 313     }
 314     close FH;
 315 }
 316
 317 sub test_readgif_cb {
 318   my ($size) = @_;
 319
 320   open FH, "<testimg/scale.gif" or die "Cannot open testimg/scale.gif";
 321   binmode FH;
 322   my $img = i_readgif_callback(sub { my $tmp; read(FH, $tmp, $size) and $tmp });
 323   close FH;
 324   return $img;
 325 }
 326
 327 # tests for reading bad gif files
 328 sub read_failure {
 329   my ($filename, $testnum) = @_;
 330
 331   open FH, "< $filename"
 332     or die "Cannot open $filename: $!";
 333   binmode FH;
 334   my ($result, $map) = i_readgif(fileno(FH));
 335   if ($result) {
 336     print "not ok $testnum # this is an invalid file, we succeeded\n";
 337   }
 338   else {
 339     print "ok $testnum # ",Imager::_error_as_msg(),"\n";
 340   }
 341   close FH;
 342 }
 343