t/t020masked.t

   1 #!perl -w
   2
   3 BEGIN { $| = 1; print "1..35\n"; }
   4 END {print "not ok 1\n" unless $loaded;}
   5 use Imager qw(:all :handy);
   6 #use Data::Dumper;
   7 $loaded = 1;
   8 print "ok 1\n";
   9 init_log("testout/t020masked.log", 1);
  10
  11 my $base_rgb = Imager::ImgRaw::new(100, 100, 3);
  12 # put something in there
  13 my $red = NC(255, 0, 0);
  14 my $green = NC(0, 255, 0);
  15 my $blue = NC(0, 0, 255);
  16 my $white = NC(255, 255, 255);
  17 my @cols = ($red, $green, $blue);
  18 for my $y (0..99) {
  19   Imager::i_plin($base_rgb, 0, $y, ($cols[$y % 3] ) x 100);
  20 }
  21
  22 # first a simple subset image
  23 my $s_rgb = Imager::i_img_masked_new($base_rgb, undef, 25, 25, 50, 50);
  24
  25 print Imager::i_img_getchannels($s_rgb) == 3
  26   ? "ok 2\n" : "not ok 2 # 1 channel image channel count mismatch\n";
  27 print Imager::i_img_getmask($s_rgb) & 1
  28   ? "ok 3\n" : "not ok 3 # 1 channel image bad mask\n";
  29 print Imager::i_img_virtual($s_rgb) == 0
  30   ? "not ok 4 # 1 channel image thinks it isn't virtual\n" : "ok 4\n";
  31 print Imager::i_img_bits($s_rgb) == 8
  32   ? "ok 5\n" : "not ok 5 # 1 channel image has bits != 8\n";
  33 print Imager::i_img_type($s_rgb) == 0 # direct
  34   ? "ok 6\n" : "not ok 6 # 1 channel image isn't direct\n";
  35
  36 my @ginfo = i_img_info($s_rgb);
  37 print $ginfo[0] == 50
  38   ? "ok 7\n" : "not ok 7 # image width incorrect\n";
  39 print $ginfo[1] == 50
  40   ? "ok 8\n" : "not ok 8 # image height incorrect\n";
  41
  42 # sample some pixels through the subset
  43 my $c = Imager::i_get_pixel($s_rgb, 0, 0);
  44 color_cmp($c, $green) == 0 or print "not ";
  45 print "ok 9\n";
  46 $c = Imager::i_get_pixel($s_rgb, 49, 49);
  47 # (25+49)%3 = 2
  48 color_cmp($c, $blue) == 0 or print "not ";
  49 print "ok 10\n";
  50
  51 # try writing to it
  52 for my $y (0..49) {
  53   Imager::i_plin($s_rgb, 0, $y, ($cols[$y % 3]) x 50);
  54 }
  55 print "ok 11\n";
  56 # and checking the target image
  57 $c = Imager::i_get_pixel($base_rgb, 25, 25);
  58 color_cmp($c, $red) == 0 or print "not ";
  59 print "ok 12\n";
  60 $c = Imager::i_get_pixel($base_rgb, 29, 29);
  61 color_cmp($c, $green) == 0 or print "not ";
  62 print "ok 13\n";
  63
  64 undef $s_rgb;
  65
  66 # a basic background
  67 for my $y (0..99) {
  68   Imager::i_plin($base_rgb, 0, $y, ($red ) x 100);
  69 }
  70 my $mask = Imager::ImgRaw::new(50, 50, 1);
  71 # some venetian blinds
  72 for my $y (4..20) {
  73   Imager::i_plin($mask, 5, $y*2, ($white) x 40);
  74 }
  75 # with a strip down the middle
  76 for my $y (0..49) {
  77   Imager::i_plin($mask, 20, $y, ($white) x 8);
  78 }
  79 my $m_rgb = Imager::i_img_masked_new($base_rgb, $mask, 25, 25, 50, 50);
  80 $m_rgb or print "not ";
  81 print "ok 14\n";
  82 for my $y (0..49) {
  83   Imager::i_plin($m_rgb, 0, $y, ($green) x 50);
  84 }
  85 my @color_tests =
  86   (
  87    [ 25+0,  25+0,  $red ],
  88    [ 25+19, 25+0,  $red ],
  89    [ 25+20, 25+0,  $green ],
  90    [ 25+27, 25+0,  $green ],
  91    [ 25+28, 25+0,  $red ],
  92    [ 25+49, 25+0,  $red ],
  93    [ 25+19, 25+7,  $red ],
  94    [ 25+19, 25+8,  $green ],
  95    [ 25+19, 25+9,  $red ],
  96    [ 25+0,  25+8,  $red ],
  97    [ 25+4,  25+8,  $red ],
  98    [ 25+5,  25+8,  $green ],
  99    [ 25+44, 25+8,  $green ],
 100    [ 25+45, 25+8,  $red ],
 101    [ 25+49, 25+49, $red ],
 102   );
 103 my $test_num = 15;
 104 for my $test (@color_tests) {
 105   color_test($test_num++, $base_rgb, @$test);
 106 }
 107
 108 {
 109   # tests for the OO versions, fairly simple, since the basic functionality
 110   # is covered by the low-level interface tests
 111
 112   my $base = Imager->new(xsize=>100, ysize=>100)
 113     or print "not ";
 114   print "ok 30\n";
 115   $base->box(color=>$blue, filled=>1); # fill it all
 116   my $mask = Imager->new(xsize=>80, ysize=>80, channels=>1);
 117   $mask->box(color=>$white, filled=>1, xmin=>5, xmax=>75, ymin=>5, ymax=>75);
 118   my $m_img = $base->masked(mask=>$mask, left=>5, top=>5)
 119     or print "not ";
 120   print "ok 31\n";
 121   $m_img->getwidth == 80 or print "not ";
 122   print "ok 32\n";
 123   $m_img->box(color=>$green, filled=>1);
 124   color_cmp(Imager::i_get_pixel($m_img->{IMG}, 0, 0), $blue) == 0
 125     or print "not ";
 126   print "ok 33\n";
 127   color_cmp(Imager::i_get_pixel($m_img->{IMG}, 5, 5), $green) == 0
 128     or print "not ";
 129   print "ok 34\n";
 130
 131   # older versions destroyed the Imager::ImgRaw object manually in
 132   # Imager::DESTROY rather than letting Imager::ImgRaw::DESTROY
 133   # destroy the object
 134   # so we test here by destroying the base and mask objects and trying
 135   # to draw to the masked wrapper
 136   # you may need to test with ElectricFence to trigger the problem
 137   undef $mask;
 138   undef $base;
 139   $m_img->box(color=>$blue, filled=>1);
 140   print "ok 35\n";
 141 }
 142
 143 sub color_test {
 144   my ($num, $im, $x, $y, $expected) = @_;
 145   my $c = Imager::i_get_pixel($im, $x, $y);
 146   color_cmp($c, $expected) == 0 or print "not ";
 147   print "ok $num # $x, $y\n";
 148 }
 149
 150 sub color_cmp {
 151   my ($l, $r) = @_;
 152   my @l = $l->rgba;
 153   my @r = $r->rgba;
 154   # print "# (",join(",", @l[0..2]),") <=> (",join(",", @r[0..2]),")\n";
 155   return $l[0] <=> $r[0]
 156     || $l[1] <=> $r[1]
 157       || $l[2] <=> $r[2];
 158 }
 159