t/t108tga.t

   1 #!perl -w
   2 use Imager qw(:all);
   3 use strict;
   4 use Test::More tests=>68;
   5 use Imager::Test qw(is_color4 is_image test_image);
   6
   7 -d "testout" or mkdir "testout";
   8
   9 init_log("testout/t108tga.log",1);
  10
  11 my $img = create_test_image();
  12 my $base_diff = 0;
  13
  14 write_test($img, "testout/t108_24bit.tga", 0, 0, "");
  15 write_test($img, "testout/t108_24bit_rle.tga", 0, 1, "");
  16 write_test($img, "testout/t108_15bit.tga", 1, 1, "");
  17 write_test($img, "testout/t108_15bit_rle.tga", 1, 1, "");
  18
  19 # 'webmap' is noticably faster than the default
  20 my $im8 = Imager::i_img_to_pal($img, { make_colors=>'webmap',
  21                                        translate=>'errdiff'});
  22
  23 write_test($im8, "testout/t108_8bit.tga", 0, 0, "");
  24 write_test($im8, "testout/t108_8bit_rle.tga", 0, 1, "");
  25 write_test($im8, "testout/t108_8_15bit.tga", 1, 0, "");
  26 write_test($im8, "testout/t108_8_15bit_rle.tga", 1, 1, "");
  27
  28
  29 # use a fixed palette so we get reproducible results for the compressed
  30 # version
  31
  32 my @bit4 = map { NC($_) }
  33   qw(605844 966600 0148b2 00f800 bf0a33 5e009e
  34      2ead1b 0000f8 004b01 fd0000 0e1695 000002);
  35
  36 my @bit1 = (NC(0, 0, 0), NC(176, 160, 144));
  37
  38 my $im4 = Imager::i_img_to_pal($img, { colors=>\@bit4,
  39                                        make_colors=>'none' });
  40
  41 my $im1 = Imager::i_img_to_pal($img, { colors=>\@bit1,
  42                                        make_colors=>'none',
  43                                        translate=>'errdiff' });
  44
  45 write_test($im4, "testout/t108_4bit.tga", 0, 1, "");
  46 write_test($im1, "testout/t108_1bit.tga", 0, 1, "This is a comment!");
  47
  48 read_test("testout/t108_24bit.tga", $img);
  49 read_test("testout/t108_8bit.tga",  $im8);
  50 read_test("testout/t108_4bit.tga",  $im4);
  51 read_test("testout/t108_1bit.tga",  $im1);
  52
  53 # the following might have slight differences
  54
  55 $base_diff = i_img_diff($img, $im8) * 2;
  56
  57 print "# base difference $base_diff\n";
  58
  59 my $imoo = Imager->new;
  60 ok($imoo->read(file=>'testout/t108_24bit.tga'),
  61    "OO read image")
  62   or print "# ",$imoo->errstr,"\n";
  63
  64 ok($imoo->write(file=>'testout/t108_oo.tga'),
  65    "OO write image")
  66   or print "# ",$imoo->errstr,"\n";
  67
  68 my ($type) = $imoo->tags(name=>'i_format');
  69 is($type, 'tga', "check i_format tag");
  70
  71 # in 0.44 and earlier, reading an image with an idstring of 128 or more
  72 # bytes would result in an allocation error, if the platform char type
  73 # was signed
  74 $imoo = Imager->new;
  75 ok($imoo->read(file=>'testimg/longid.tga'), "read long id image");
  76 my ($id) = $imoo->tags(name=>'tga_idstring');
  77 is($id, "X" x 128, "check tga_idstring tag");
  78 my ($bitspp) = $imoo->tags(name=>'tga_bitspp');
  79 is($bitspp, 24, "check tga_bitspp tag");
  80 my ($compressed) = $imoo->tags(name=>'compressed');
  81 is($compressed, 1, "check compressed tag");
  82
  83 { # check file limits are checked
  84   my $limit_file = "testout/t108_24bit.tga";
  85   ok(Imager->set_file_limits(reset=>1, width=>149), "set width limit 149");
  86   my $im = Imager->new;
  87   ok(!$im->read(file=>$limit_file),
  88      "should fail read due to size limits");
  89   print "# ",$im->errstr,"\n";
  90   like($im->errstr, qr/image width/, "check message");
  91
  92   ok(Imager->set_file_limits(reset=>1, height=>149), "set height limit 149");
  93   ok(!$im->read(file=>$limit_file),
  94      "should fail read due to size limits");
  95   print "# ",$im->errstr,"\n";
  96   like($im->errstr, qr/image height/, "check message");
  97
  98   ok(Imager->set_file_limits(reset=>1, width=>150), "set width limit 150");
  99   ok($im->read(file=>$limit_file),
 100      "should succeed - just inside width limit");
 101   ok(Imager->set_file_limits(reset=>1, height=>150), "set height limit 150");
 102   ok($im->read(file=>$limit_file),
 103      "should succeed - just inside height limit");
 104
 105   # 150 x 150 x 3 channel image uses 67500 bytes
 106   ok(Imager->set_file_limits(reset=>1, bytes=>67499),
 107      "set bytes limit 67499");
 108   ok(!$im->read(file=>$limit_file),
 109      "should fail - too many bytes");
 110   print "# ",$im->errstr,"\n";
 111   like($im->errstr, qr/storage size/, "check error message");
 112   ok(Imager->set_file_limits(reset=>1, bytes=>67500),
 113      "set bytes limit 67500");
 114   ok($im->read(file=>$limit_file),
 115      "should succeed - just inside bytes limit");
 116   Imager->set_file_limits(reset=>1);
 117 }
 118
 119 { # Issue # 18397
 120   # the issue is for 4 channel images to jpeg, but 2 channel images have
 121   # a similar problem on tga
 122   my $im = Imager->new(xsize=>100, ysize=>100, channels => 2);
 123   my $data;
 124   ok(!$im->write(data => \$data, type=>'tga'),
 125      "check failure of writing a 2 channel image");
 126   is($im->errstr, "Cannot store 2 channel image in targa format",
 127      "check the error message");
 128 }
 129
 130 {
 131   ok(grep($_ eq 'tga', Imager->read_types), "check tga in read types");
 132   ok(grep($_ eq 'tga', Imager->write_types), "check tga in write types");
 133 }
 134
 135 { # Issue #32926
 136   # a sample image was read as all transparent
 137   # it had bitsperpixel = 16 and atribute channel set to 1, so it
 138   # should have an alpha channel.
 139   # So we'll do what the gimp does and treat a zero value as opaque.
 140
 141   my $im = Imager->new;
 142   ok($im->read(file => 'testimg/alpha16.tga'),
 143      "read 16-bit/pixel alpha image");
 144   my $c1 = $im->getpixel('x' => 0, 'y' => 0);
 145   is_color4($c1, 0, 0, 0, 0, "check transparent pixel");
 146   my $c2 = $im->getpixel('x' => 19, 'y' => 0);
 147   is_color4($c2, 255, 0, 0, 255, "check opaque pixel");
 148
 149   # since this has an effect on writing too, write,it, read it, check it
 150   my $data;
 151   ok($im->write(data => \$data, type => 'tga', wierdpack => 1),
 152      "write 16-bit/pixel w/alpha");
 153   my $im2 = Imager->new;
 154   ok($im2->read(data => $data), "read it back");
 155   is_image($im, $im2, "check they match");
 156 }
 157
 158 { # prior to the types re-work we treated the tga xsize/ysize as
 159   # signed short, which is wrong
 160  SKIP:
 161   {
 162     my $im = Imager->new(xsize => 40960, ysize => 1);
 163     my $data;
 164     ok($im->write(data => \$data, type => "tga"),
 165        "write a wide (but not too wide) image out");
 166     my $im2 = Imager->new(data => $data);
 167     ok($im2, "read it back in")
 168       or skip("Couldn't read the wide image", 2);
 169     is($im2->getwidth, 40960, "make sure the width survived the trip");
 170     is($im2->getheight, 1, "make sure the height survived the trip");
 171   }
 172
 173  SKIP:
 174   {
 175     my $im = Imager->new(xsize => 1, ysize => 40960);
 176     my $data;
 177     ok($im->write(data => \$data, type => "tga"),
 178        "write a tall (but not too tall) image out");
 179     my $im2 = Imager->new(data => $data);
 180     ok($im2, "read it back in")
 181       or skip("Couldn't read the tall image", 2);
 182     is($im2->getwidth, 1, "make sure the width survived the trip");
 183     is($im2->getheight, 40960, "make sure the height survived the trip");
 184   }
 185 }
 186
 187 {
 188   # TGA files are limited to 0xFFFF x 0xFFFF pixels
 189   my $max_dim = 0xFFFF;
 190   {
 191     my $im = Imager->new(xsize => 1+$max_dim, ysize => 1);
 192     my $data = '';
 193     ok(!$im->write(data => \$data, type => "tga"),
 194        "fail to write too wide an image");
 195     is($im->errstr, "image too large for TGA",
 196        "check error message");
 197   }
 198  SKIP:
 199   {
 200     my $im = Imager->new(xsize => $max_dim, ysize => 1);
 201     $im->box(fill => { hatch => "check4x4" });
 202     my $data = '';
 203     ok($im->write(data => \$data, type => "tga"),
 204        "write image at width limit")
 205       or print "# ", $im->errstr, "\n";
 206     my $im2 = Imager->new(data => $data, ftype => "tga");
 207     ok($im2, "read it ok")
 208       or skip("cannot load the wide image", 1);
 209     is($im->getwidth, $max_dim, "check width");
 210     is($im->getheight, 1, "check height");
 211   }
 212   {
 213     my $im = Imager->new(xsize => 1, ysize => 1+$max_dim);
 214     my $data = '';
 215     ok(!$im->write(data => \$data, type => "tga"),
 216        "fail to write too tall an image");
 217     is($im->errstr, "image too large for TGA",
 218        "check error message");
 219   }
 220  SKIP:
 221   {
 222     my $im = Imager->new(xsize => 1, ysize => $max_dim);
 223     $im->box(fill => { hatch => "check2x2" });
 224     my $data = '';
 225     ok($im->write(data => \$data, type => "tga"),
 226        "write image at width limit");
 227     my $im2 = Imager->new(data => $data, ftype => "tga");
 228     ok($im2, "read it ok")
 229       or skip("cannot load the wide image", 1);
 230     is($im->getwidth, 1, "check width");
 231     is($im->getheight, $max_dim, "check height");
 232   }
 233 }
 234
 235 { # check close failures are handled correctly
 236   my $im = test_image();
 237   my $fail_close = sub {
 238     Imager::i_push_error(0, "synthetic close failure");
 239     return 0;
 240   };
 241   ok(!$im->write(type => "tga", callback => sub { 1 },
 242                  closecb => $fail_close),
 243      "check failing close fails");
 244     like($im->errstr, qr/synthetic close failure/,
 245          "check error message");
 246 }
 247
 248 sub write_test {
 249   my ($im, $filename, $wierdpack, $compress, $idstring) = @_;
 250   local *FH;
 251
 252   if (open FH, "> $filename") {
 253     binmode FH;
 254     my $IO = Imager::io_new_fd(fileno(FH));
 255     ok(Imager::i_writetga_wiol($im, $IO, $wierdpack, $compress, $idstring),
 256        "write $filename")
 257       or print "# ",Imager->_error_as_msg(),"\n";
 258     undef $IO;
 259     close FH;
 260   } else {
 261     fail("write $filename: open failed: $!");
 262   }
 263 }
 264
 265
 266 sub read_test {
 267   my ($filename, $im, %tags) = @_;
 268   local *FH;
 269
 270   if (open FH, "< $filename") {
 271     binmode FH;
 272     my $IO = Imager::io_new_fd(fileno(FH));
 273     my $im_read = Imager::i_readtga_wiol($IO,-1);
 274     if ($im_read) {
 275       my $diff = i_img_diff($im, $im_read);
 276       cmp_ok($diff, '<=', $base_diff,
 277              "check read image vs original");
 278     } else {
 279       fail("read $filename ".Imager->_error_as_msg());
 280     }
 281     undef $IO;
 282     close FH;
 283   } else {
 284     fail("read $filename, open failure: $!");
 285   }
 286 }
 287
 288 sub create_test_image {
 289
 290   my $green  = i_color_new(0,255,0,255);
 291   my $blue   = i_color_new(0,0,255,255);
 292   my $red    = i_color_new(255,0,0,255);
 293
 294   my $img    = Imager::ImgRaw::new(150,150,3);
 295
 296   i_box_filled($img, 70, 25, 130, 125, $green);
 297   i_box_filled($img, 20, 25,  80, 125, $blue);
 298   i_arc($img, 75, 75, 30, 0, 361, $red);
 299   i_conv($img, [0.1, 0.2, 0.4, 0.2, 0.1]);
 300
 301   return $img;
 302 }