GIF/t/t20new.t

   1 #!perl -w
   2 # Before `make install' is performed this script should be runnable with
   3 # `make test'. After `make install' it should work as `perl test.pl'
   4
   5 ######################### We start with some black magic to print on failure.
   6
   7 # Change 1..1 below to 1..last_test_to_print .
   8 # (It may become useful if the test is moved to ./t subdirectory.)
   9
  10
  11 use strict;
  12 use Test::More tests => 21;
  13
  14 use Imager qw(:all :handy);
  15 use Imager::Test qw(test_image is_color3);
  16
  17 -d "testout" or mkdir "testout";
  18
  19 Imager::init('log'=>'testout/t70newgif.log');
  20
  21 my $green=i_color_new(0,255,0,0);
  22 my $blue=i_color_new(0,0,255,0);
  23
  24 {
  25   my $img = test_image();
  26
  27   ok($img->write(file=>'testout/t70newgif.gif',type=>'gif',gifplanes=>1,gifquant=>'lm',lmfixed=>[$green,$blue]))
  28     or print "# failed: ",$img->{ERRSTR}, "\n";
  29 }
  30
  31 SKIP:
  32 {
  33   # make sure the palette is loaded properly (minimal test)
  34   my $im2 = Imager->new();
  35   my $map;
  36   ok($im2->read(file=>'testimg/bandw.gif', colors=>\$map))
  37     or skip("Can't load bandw.gif", 5);
  38   # check the palette
  39   ok($map)
  40     or skip("No palette", 4);
  41   is(@$map, 2)
  42     or skip("Bad map count", 3);
  43   my @sorted = sort { comp_entry($a,$b) } @$map;
  44   # first entry must be #000000 and second #FFFFFF
  45   is_color3($sorted[0], 0,0,0, "check first palette entry");
  46   is_color3($sorted[1], 255,255,255, "check second palette entry");
  47 }
  48
  49 {
  50   # test the read_multi interface
  51   my @imgs = Imager->read_multi();
  52   ok(!@imgs, "read with no sources should fail");
  53   like(Imager->errstr, qr/callback parameter missing/, "check error");
  54   print "# ",Imager->errstr,"\n";
  55
  56   @imgs = Imager->read_multi(type=>'gif');
  57   ok(!@imgs, "read multi no source but type should fail");
  58   like(Imager->errstr, qr/file/, "check error");
  59
  60   # kill warning
  61   *NONESUCH = \20;
  62   @imgs = Imager->read_multi(type=>'gif', fh=>*NONESUCH);
  63   ok(!@imgs, "read from bad fh");
  64   like(Imager->errstr, qr/fh option not open/, "check message");
  65   print "# ",Imager->errstr,"\n";
  66   {
  67     @imgs = Imager->read_multi(type=>'gif', file=>'testimg/screen2.gif');
  68     is(@imgs, 2, "should read 2 images");
  69     isa_ok($imgs[0], "Imager");
  70     isa_ok($imgs[1], "Imager");
  71     is($imgs[0]->type, "paletted");
  72     is($imgs[1]->type, "paletted");
  73     my @left = $imgs[0]->tags(name=>'gif_left');
  74     is(@left, 1);
  75     my $left = $imgs[1]->tags(name=>'gif_left');
  76     is($left, 3);
  77   }
  78   {
  79     open FH, "< testimg/screen2.gif"
  80       or die "Cannot open testimg/screen2.gif: $!";
  81     binmode FH;
  82     my $cb =
  83       sub {
  84         my $tmp;
  85         read(FH, $tmp, $_[0]) and $tmp
  86       };
  87     @imgs = Imager->read_multi(type=>'gif',
  88                                callback => $cb);
  89     close FH;
  90     is(@imgs, 2, "read multi from callback");
  91
  92     open FH, "< testimg/screen2.gif"
  93       or die "Cannot open testimg/screen2.gif: $!";
  94     binmode FH;
  95     my $data = do { local $/; <FH>; };
  96     close FH;
  97     @imgs = Imager->read_multi(type=>'gif',
  98                                data=>$data);
  99     is(@imgs, 2, "read multi from data");
 100   }
 101 }
 102
 103 sub comp_entry {
 104   my ($l, $r) = @_;
 105   my @l = $l->rgba;
 106   my @r = $r->rgba;
 107   return $l[0] <=> $r[0]
 108     || $l[1] <=> $r[1]
 109       || $l[2] <=> $r[2];
 110 }