t/t69rubthru.t

   1 #!perl -w
   2
   3 BEGIN { $| = 1; print "1..23\n"; }
   4 END {print "not ok 1\n" unless $loaded;}
   5 use Imager qw(:all :handy);
   6 $loaded = 1;
   7 print "ok 1\n";
   8 init_log("testout/t69rubthru.log", 1);
   9
  10 my $src_height = 80;
  11 my $src_width = 80;
  12
  13 # raw interface
  14 my $targ = Imager::ImgRaw::new(100, 100, 3);
  15 my $src = Imager::ImgRaw::new($src_height, $src_width, 4);
  16 my $halfred = NC(255, 0, 0, 128);
  17 i_box_filled($src, 20, 20, 60, 60, $halfred);
  18 i_rubthru($targ, $src, 10, 10, 0, 0, $src_width, $src_height) or print "not ";
  19 print "ok 2\n";
  20 my $c = Imager::i_get_pixel($targ, 10, 10) or print "not ";
  21 print "ok 3\n";
  22 color_cmp($c, NC(0, 0, 0)) == 0 or print "not ";
  23 print "ok 4\n";
  24 $c = Imager::i_get_pixel($targ, 30, 30) or print "not ";
  25 print "ok 5\n";
  26 color_cmp($c, NC(128, 0, 0)) == 0 or print "not ";
  27 print "ok 6\n";
  28
  29 my $black = NC(0, 0, 0);
  30 # reset the target and try a grey+alpha source
  31 i_box_filled($targ, 0, 0, 100, 100, $black);
  32 my $gsrc = Imager::ImgRaw::new($src_width, $src_height, 2);
  33 my $halfwhite = NC(255, 128, 0);
  34 i_box_filled($gsrc, 20, 20, 60, 60, $halfwhite);
  35 i_rubthru($targ, $gsrc, 10, 10, 0, 0, $src_width, $src_height) or print "not ";
  36 print "ok 7\n";
  37 $c = Imager::i_get_pixel($targ, 15, 15) or print "not ";
  38 print "ok 8\n";
  39 color_cmp($c, NC(0, 0, 0)) == 0 or print "not ";
  40 print "ok 9\n";
  41 $c = Imager::i_get_pixel($targ, 30, 30) or print "not ";
  42 print "ok 10\n";
  43 color_cmp($c, NC(128, 128, 128)) == 0 or print "not ";
  44 print "ok 11\n";
  45
  46 # try grey target and grey alpha source
  47 my $gtarg = Imager::ImgRaw::new(100, 100, 1);
  48 i_rubthru($gtarg, $gsrc, 10, 10, 0, 0, $src_width, $src_height) or print "not ";
  49 print "ok 12\n";
  50 $c = Imager::i_get_pixel($gtarg, 10, 10) or print "not ";
  51 print "ok 13\n";
  52 ($c->rgba)[0] == 0 or print "not ";
  53 print "ok 14\n";
  54 (Imager::i_get_pixel($gtarg, 30, 30)->rgba)[0] == 128 or print "not ";
  55 print "ok 15\n";
  56
  57 # an attempt rub a 4 channel image over 1 channel should fail
  58 i_rubthru($gtarg, $src, 10, 10, 0, 0, $src_width, $src_height) and print "not ";
  59 print "ok 16\n";
  60
  61 # simple test for 16-bit/sample images
  62 my $targ16 = Imager::i_img_16_new(100, 100, 3);
  63 i_rubthru($targ16, $src, 10, 10, 0, 0, $src_width, $src_height) or print "not ";
  64 print "ok 17\n";
  65 $c = Imager::i_get_pixel($targ16, 30, 30) or print "not ";
  66 print "ok 18\n";
  67 color_cmp($c, NC(128, 0, 0)) == 0 or print "not ";
  68 print "ok 19\n";
  69
  70 # check the OO interface
  71 my $ootarg = Imager->new(xsize=>100, ysize=>100);
  72 my $oosrc = Imager->new(xsize=>80, ysize=>80, channels=>4);
  73 $oosrc->box(color=>$halfred, xmin=>20, ymin=>20, xmax=>60, ymax=>60,
  74             filled=>1);
  75 $ootarg->rubthrough(src=>$oosrc, tx=>10, ty=>10) or print "not ";
  76 print "ok 20\n";
  77 color_cmp(Imager::i_get_pixel($ootarg->{IMG}, 10, 10), NC(0, 0, 0)) == 0
  78   or print "not ";
  79 print "ok 21\n";
  80 color_cmp(Imager::i_get_pixel($ootarg->{IMG}, 30, 30), NC(128, 0, 0)) == 0
  81   or print "not ";
  82 print "ok 22\n";
  83
  84 # make sure we fail as expected
  85 my $oogtarg = Imager->new(xsize=>100, ysize=>100, channels=>1);
  86 $oogtarg->rubthrough(src=>$oosrc) and print "not ";
  87 print "ok 23\n";
  88
  89
  90 sub color_cmp {
  91   my ($l, $r) = @_;
  92   my @l = $l->rgba;
  93   my @r = $r->rgba;
  94   print "# (",join(",", @l[0..2]),") <=> (",join(",", @r[0..2]),")\n";
  95   return $l[0] <=> $r[0]
  96     || $l[1] <=> $r[1]
  97       || $l[2] <=> $r[2];
  98 }
  99
 100