t/t69rubthru.t

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