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