t/t70newgif.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 BEGIN { $| = 1; print "1..24\n"; }
  12 END {print "not ok 1\n" unless $loaded;}
  13
  14 my $buggy_giflib_file = "buggy_giflib.txt";
  15
  16 use Imager qw(:all :handy);
  17 $loaded=1;
  18
  19 print "ok 1\n";
  20
  21 Imager::init('log'=>'testout/t70newgif.log');
  22
  23 $green=i_color_new(0,255,0,0);
  24 $blue=i_color_new(0,0,255,0);
  25
  26 $img=Imager->new();
  27 $img->open(file=>'testimg/scale.ppm',type=>'pnm') || print "failed: ",$img->{ERRSTR},"\n";
  28 print "ok 2\n";
  29
  30
  31 if (i_has_format("gif")) {
  32   $img->write(file=>'testout/t70newgif.gif',type=>'gif',gifplanes=>1,gifquant=>'lm',lmfixed=>[$green,$blue]) || print "failed: ",$img->{ERRSTR},"\nnot ";
  33   print "ok 3\n";
  34
  35   # make sure the palette is loaded properly (minimal test)
  36   my $im2 = Imager->new();
  37   my $map;
  38   if ($im2->read(file=>'testimg/bandw.gif', colors=>\$map)) {
  39     print "ok 4\n";
  40     # check the palette
  41     if ($map) {
  42       print "ok 5\n";
  43       if (@$map == 2) {
  44         print "ok 6\n";
  45         my @sorted = sort { comp_entry($a,$b) } @$map;
  46         # first entry must be #000000 and second #FFFFFF
  47         if (comp_entry($sorted[0], NC(0,0,0)) == 0) {
  48           print "ok 7\n";
  49         }
  50         else {
  51           print "not ok 7 # entry should be black\n";
  52         }
  53         if (comp_entry($sorted[1], NC(255,255,255)) == 0) {
  54           print "ok 8\n";
  55         }
  56         else {
  57           print "not ok 8 # entry should be white\n";
  58         }
  59       }
  60       else {
  61         print "not ok 6 # bad map size\n";
  62         print "ok 7 # skipped bad map size\n";
  63         print "ok 8 # skipped bad map size\n";
  64       }
  65     }
  66     else {
  67       print "not ok 5 # no map returned\n";
  68       for (6..8) {
  69         print "ok $_ # skipped no map returned\n";
  70       }
  71     }
  72   }
  73   else {
  74     print "not ok 4 # ",$im2->errstr,"\n";
  75     print "ok 5 # skipped - couldn't load image\n";
  76   }
  77
  78   # test the read_multi interface
  79   my @imgs = Imager->read_multi();
  80   @imgs and print "not ";
  81   print "ok 9\n";
  82   Imager->errstr =~ /type parameter/ or print "not ";
  83   print "ok 10 # ",Imager->errstr,"\n";
  84
  85   @imgs = Imager->read_multi(type=>'gif');
  86   @imgs and print "not ";
  87   print "ok 11\n";
  88   Imager->errstr =~ /file/ or print "not ";
  89   print "ok 12 # ",Imager->errstr,"\n";
  90   # kill warning
  91   *NONESUCH = \20;
  92   @imgs = Imager->read_multi(type=>'gif', fh=>*NONESUCH);
  93   @imgs and print "not ";
  94   print "ok 13\n";
  95   Imager->errstr =~ /fh option not open/ or print "not ";
  96   print "ok 14 # ",Imager->errstr,"\n";
  97   unless (-e $buggy_giflib_file) {
  98     @imgs = Imager->read_multi(type=>'gif', file=>'testimg/screen2.gif');
  99     @imgs == 2 or print "not ";
 100     print "ok 15\n";
 101     grep(!UNIVERSAL::isa($_, 'Imager'), @imgs) and print "not ";
 102     print "ok 16\n";
 103     grep($_->type eq 'direct', @imgs) and print "not ";
 104     print "ok 17\n";
 105     (my @left = $imgs[0]->tags(name=>'gif_left')) == 1 or print "not ";
 106     print "ok 18\n";
 107     my $left = $imgs[1]->tags(name=>'gif_left') or print "not ";
 108     print "ok 19\n";
 109     $left == 3 or print "not ";
 110     print "ok 20\n";
 111   }
 112   else {
 113     for (15 .. 20) {
 114       print "ok $_ # skip see $buggy_giflib_file\n";
 115     }
 116   }
 117   if (Imager::i_giflib_version() >= 4.0) {
 118     unless (-e $buggy_giflib_file) {
 119       open FH, "< testimg/screen2.gif"
 120         or die "Cannot open testimg/screen2.gif: $!";
 121       binmode FH;
 122       my $cb =
 123         sub {
 124           my $tmp;
 125           read(FH, $tmp, $_[0]) and $tmp
 126         };
 127       @imgs = Imager->read_multi(type=>'gif',
 128                                  callback => $cb) or print "not ";
 129       print "ok 21\n";
 130       close FH;
 131       @imgs == 2 or print "not ";
 132       print "ok 22\n";
 133
 134       open FH, "< testimg/screen2.gif"
 135         or die "Cannot open testimg/screen2.gif: $!";
 136       binmode FH;
 137       my $data = do { local $/; <FH>; };
 138       close FH;
 139       @imgs = Imager->read_multi(type=>'gif',
 140                                  data=>$data) or print "not ";
 141       print "ok 23\n";
 142       @imgs = 2 or print "not ";
 143       print "ok 24\n";
 144     }
 145     else {
 146       for (21..24) {
 147         print "ok $_ # skip see $buggy_giflib_file\n";
 148       }
 149     }
 150   }
 151   else {
 152     for (21..24) {
 153       print "ok $_ # skipped - giflib3 doesn't support callbacks\n";
 154     }
 155   }
 156 }
 157 else {
 158   for (3..24) {
 159     print "ok $_ # skipped: no gif support\n";
 160   }
 161 }
 162
 163 sub comp_entry {
 164   my ($l, $r) = @_;
 165   my @l = $l->rgba;
 166   my @r = $r->rgba;
 167   return $l[0] <=> $r[0]
 168     || $l[1] <=> $r[1]
 169       || $l[2] <=> $r[2];
 170 }