t/t108tga.t

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