t/t108tga.t

   1 #!perl -w
   2 print "1..18\n";
   3 use Imager qw(:all);
   4 use strict;
   5 init_log("testout/t108tga.log",1);
   6
   7
   8 my $img = create_test_image();
   9 my $base_diff = 0;
  10
  11 write_test(1, $img, "testout/t108_24bit.tga", 0, 0, "");
  12 write_test(2, $img, "testout/t108_24bit_rle.tga", 0, 1, "");
  13 write_test(3, $img, "testout/t108_15bit.tga", 1, 1, "");
  14 write_test(4, $img, "testout/t108_15bit_rle.tga", 1, 1, "");
  15
  16 # 'webmap' is noticably faster than the default
  17 my $im8 = Imager::i_img_to_pal($img, { make_colors=>'webmap',
  18                                        translate=>'errdiff'});
  19
  20 write_test(5, $im8, "testout/t108_8bit.tga", 0, 0, "");
  21 write_test(6, $im8, "testout/t108_8bit_rle.tga", 0, 1, "");
  22 write_test(7, $im8, "testout/t108_8_15bit.tga", 1, 0, "");
  23 write_test(8, $im8, "testout/t108_8_15bit_rle.tga", 1, 1, "");
  24
  25
  26 # use a fixed palette so we get reproducible results for the compressed
  27 # version
  28
  29 my @bit4 = map { NC($_) }
  30   qw(605844 966600 0148b2 00f800 bf0a33 5e009e
  31      2ead1b 0000f8 004b01 fd0000 0e1695 000002);
  32
  33 my @bit1 = (NC(0, 0, 0), NC(176, 160, 144));
  34
  35 my $im4 = Imager::i_img_to_pal($img, { colors=>\@bit4,
  36                                        make_colors=>'none' });
  37
  38 my $im1 = Imager::i_img_to_pal($img, { colors=>\@bit1,
  39                                        make_colors=>'none',
  40                                        translate=>'errdiff' });
  41
  42 write_test(9, $im4, "testout/t108_4bit.tga", 0, 1, "");
  43 write_test(10, $im1, "testout/t108_1bit.tga", 0, 1, "This is a comment!");
  44
  45 read_test(11, "testout/t108_24bit.tga", $img);
  46 read_test(12, "testout/t108_8bit.tga",  $im8);
  47 read_test(13, "testout/t108_4bit.tga",  $im4);
  48 read_test(14, "testout/t108_1bit.tga",  $im1);
  49
  50 # the following might have slight differences
  51
  52 $base_diff = i_img_diff($img, $im8) * 2;
  53
  54 print "# base difference $base_diff\n";
  55
  56 my $imoo = Imager->new;
  57 if ($imoo->read(file=>'testout/t108_24bit.tga')) {
  58   print "ok 15\n";
  59 } else {
  60   print "not ok 15 # ",$imoo->errstr,"\n";
  61 }
  62
  63 if ($imoo->write(file=>'testout/t108_oo.tga')) {
  64   print "ok 16\n";
  65 } else {
  66   print "not 16 # ",$imoo->errstr,"\n";
  67 }
  68
  69
  70
  71
  72 sub write_test {
  73   my ($test_num, $im, $filename, $wierdpack, $compress, $idstring) = @_;
  74   local *FH;
  75
  76   if (open FH, "> $filename") {
  77     binmode FH;
  78     my $IO = Imager::io_new_fd(fileno(FH));
  79     if (Imager::i_writetga_wiol($im, $IO, $wierdpack, $compress, $idstring)) {
  80       print "ok $test_num\n";
  81     } else {
  82       print "not ok $test_num # ",Imager->_error_as_msg(),"\n";
  83     }
  84     undef $IO;
  85     close FH;
  86   } else {
  87     print "not ok $test_num # $!\n";
  88   }
  89 }
  90
  91
  92 sub read_test {
  93   my ($test_num, $filename, $im, %tags) = @_;
  94   local *FH;
  95
  96   if (open FH, "< $filename") {
  97     binmode FH;
  98     my $IO = Imager::io_new_fd(fileno(FH));
  99     my $im_read = Imager::i_readtga_wiol($IO,-1);
 100     if ($im_read) {
 101       my $diff = i_img_diff($im, $im_read);
 102       if ($diff > $base_diff) {
 103         print "not ok $test_num # image mismatch $diff\n";
 104       }
 105       print "ok $test_num\n";
 106     } else {
 107       print "not ok $test_num # ",Imager->_error_as_msg(),"\n";
 108     }
 109     undef $IO;
 110     close FH;
 111   } else {
 112     print "not ok $test_num # $!\n";
 113   }
 114 }
 115
 116
 117
 118 sub create_test_image {
 119
 120   my $green  = i_color_new(0,255,0,255);
 121   my $blue   = i_color_new(0,0,255,255);
 122   my $red    = i_color_new(255,0,0,255);
 123
 124   my $img    = Imager::ImgRaw::new(150,150,3);
 125
 126   i_box_filled($img, 70, 25, 130, 125, $green);
 127   i_box_filled($img, 20, 25,  80, 125, $blue);
 128   i_arc($img, 75, 75, 30, 0, 361, $red);
 129   i_conv($img, [0.1, 0.2, 0.4, 0.2, 0.1]);
 130
 131   return $img;
 132 }