t/t108tga.t

   1 #!perl -w
   2 use Imager qw(:all);
   3 use strict;
   4 use lib 't';
   5 use Test::More tests=>38;
   6 BEGIN { require "t/testtools.pl"; }
   7 init_log("testout/t108tga.log",1);
   8
   9
  10 my $img = create_test_image();
  11 my $base_diff = 0;
  12
  13 write_test($img, "testout/t108_24bit.tga", 0, 0, "");
  14 write_test($img, "testout/t108_24bit_rle.tga", 0, 1, "");
  15 write_test($img, "testout/t108_15bit.tga", 1, 1, "");
  16 write_test($img, "testout/t108_15bit_rle.tga", 1, 1, "");
  17
  18 # 'webmap' is noticably faster than the default
  19 my $im8 = Imager::i_img_to_pal($img, { make_colors=>'webmap',
  20                                        translate=>'errdiff'});
  21
  22 write_test($im8, "testout/t108_8bit.tga", 0, 0, "");
  23 write_test($im8, "testout/t108_8bit_rle.tga", 0, 1, "");
  24 write_test($im8, "testout/t108_8_15bit.tga", 1, 0, "");
  25 write_test($im8, "testout/t108_8_15bit_rle.tga", 1, 1, "");
  26
  27
  28 # use a fixed palette so we get reproducible results for the compressed
  29 # version
  30
  31 my @bit4 = map { NC($_) }
  32   qw(605844 966600 0148b2 00f800 bf0a33 5e009e
  33      2ead1b 0000f8 004b01 fd0000 0e1695 000002);
  34
  35 my @bit1 = (NC(0, 0, 0), NC(176, 160, 144));
  36
  37 my $im4 = Imager::i_img_to_pal($img, { colors=>\@bit4,
  38                                        make_colors=>'none' });
  39
  40 my $im1 = Imager::i_img_to_pal($img, { colors=>\@bit1,
  41                                        make_colors=>'none',
  42                                        translate=>'errdiff' });
  43
  44 write_test($im4, "testout/t108_4bit.tga", 0, 1, "");
  45 write_test($im1, "testout/t108_1bit.tga", 0, 1, "This is a comment!");
  46
  47 read_test("testout/t108_24bit.tga", $img);
  48 read_test("testout/t108_8bit.tga",  $im8);
  49 read_test("testout/t108_4bit.tga",  $im4);
  50 read_test("testout/t108_1bit.tga",  $im1);
  51
  52 # the following might have slight differences
  53
  54 $base_diff = i_img_diff($img, $im8) * 2;
  55
  56 print "# base difference $base_diff\n";
  57
  58 my $imoo = Imager->new;
  59 ok($imoo->read(file=>'testout/t108_24bit.tga'),
  60    "OO read image")
  61   or print "# ",$imoo->errstr,"\n";
  62
  63 ok($imoo->write(file=>'testout/t108_oo.tga'),
  64    "OO write image")
  65   or print "# ",$imoo->errstr,"\n";
  66
  67 my ($type) = $imoo->tags(name=>'i_format');
  68 is($type, 'tga', "check i_format tag");
  69
  70 # in 0.44 and earlier, reading an image with an idstring of 128 or more
  71 # bytes would result in an allocation error, if the platform char type
  72 # was signed
  73 $imoo = Imager->new;
  74 ok($imoo->read(file=>'testimg/longid.tga'), "read long id image");
  75 my ($id) = $imoo->tags(name=>'tga_idstring');
  76 is($id, "X" x 128, "check tga_idstring tag");
  77 my ($bitspp) = $imoo->tags(name=>'tga_bitspp');
  78 is($bitspp, 24, "check tga_bitspp tag");
  79 my ($compressed) = $imoo->tags(name=>'compressed');
  80 is($compressed, 1, "check compressed tag");
  81
  82 { # check file limits are checked
  83   my $limit_file = "testout/t108_24bit.tga";
  84   ok(Imager->set_file_limits(reset=>1, width=>149), "set width limit 149");
  85   my $im = Imager->new;
  86   ok(!$im->read(file=>$limit_file),
  87      "should fail read due to size limits");
  88   print "# ",$im->errstr,"\n";
  89   like($im->errstr, qr/image width/, "check message");
  90
  91   ok(Imager->set_file_limits(reset=>1, height=>149), "set height limit 149");
  92   ok(!$im->read(file=>$limit_file),
  93      "should fail read due to size limits");
  94   print "# ",$im->errstr,"\n";
  95   like($im->errstr, qr/image height/, "check message");
  96
  97   ok(Imager->set_file_limits(reset=>1, width=>150), "set width limit 150");
  98   ok($im->read(file=>$limit_file),
  99      "should succeed - just inside width limit");
 100   ok(Imager->set_file_limits(reset=>1, height=>150), "set height limit 150");
 101   ok($im->read(file=>$limit_file),
 102      "should succeed - just inside height limit");
 103
 104   # 150 x 150 x 3 channel image uses 67500 bytes
 105   ok(Imager->set_file_limits(reset=>1, bytes=>67499),
 106      "set bytes limit 67499");
 107   ok(!$im->read(file=>$limit_file),
 108      "should fail - too many bytes");
 109   print "# ",$im->errstr,"\n";
 110   like($im->errstr, qr/storage size/, "check error message");
 111   ok(Imager->set_file_limits(reset=>1, bytes=>67500),
 112      "set bytes limit 67500");
 113   ok($im->read(file=>$limit_file),
 114      "should succeed - just inside bytes limit");
 115   Imager->set_file_limits(reset=>1);
 116 }
 117
 118 { # Issue # 18397
 119   # the issue is for 4 channel images to jpeg, but 2 channel images have
 120   # a similar problem on tga
 121   my $im = Imager->new(xsize=>100, ysize=>100, channels => 2);
 122   my $data;
 123   ok(!$im->write(data => \$data, type=>'tga'),
 124      "check failure of writing a 2 channel image");
 125   is($im->errstr, "Cannot store 2 channel image in targa format",
 126      "check the error message");
 127 }
 128
 129 sub write_test {
 130   my ($im, $filename, $wierdpack, $compress, $idstring) = @_;
 131   local *FH;
 132
 133   if (open FH, "> $filename") {
 134     binmode FH;
 135     my $IO = Imager::io_new_fd(fileno(FH));
 136     ok(Imager::i_writetga_wiol($im, $IO, $wierdpack, $compress, $idstring),
 137        "write $filename")
 138       or print "# ",Imager->_error_as_msg(),"\n";
 139     undef $IO;
 140     close FH;
 141   } else {
 142     fail("write $filename: open failed: $!");
 143   }
 144 }
 145
 146
 147 sub read_test {
 148   my ($filename, $im, %tags) = @_;
 149   local *FH;
 150
 151   if (open FH, "< $filename") {
 152     binmode FH;
 153     my $IO = Imager::io_new_fd(fileno(FH));
 154     my $im_read = Imager::i_readtga_wiol($IO,-1);
 155     if ($im_read) {
 156       my $diff = i_img_diff($im, $im_read);
 157       cmp_ok($diff, '<=', $base_diff,
 158              "check read image vs original");
 159     } else {
 160       fail("read $filename ".Imager->_error_as_msg());
 161     }
 162     undef $IO;
 163     close FH;
 164   } else {
 165     fail("read $filename, open failure: $!");
 166   }
 167 }
 168
 169
 170
 171 sub create_test_image {
 172
 173   my $green  = i_color_new(0,255,0,255);
 174   my $blue   = i_color_new(0,0,255,255);
 175   my $red    = i_color_new(255,0,0,255);
 176
 177   my $img    = Imager::ImgRaw::new(150,150,3);
 178
 179   i_box_filled($img, 70, 25, 130, 125, $green);
 180   i_box_filled($img, 20, 25,  80, 125, $blue);
 181   i_arc($img, 75, 75, 30, 0, 361, $red);
 182   i_conv($img, [0.1, 0.2, 0.4, 0.2, 0.1]);
 183
 184   return $img;
 185 }