t/t107bmp.t

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