t/testtools.pl

   1 # this doesn't need a new namespace - I hope
   2 use strict;
   3 use Imager qw(:all);
   4 use vars qw($TESTNUM);
   5 use Carp 'confess';
   6
   7 $TESTNUM = 1;
   8
   9 sub test_img {
  10   my $green=i_color_new(0,255,0,255);
  11   my $blue=i_color_new(0,0,255,255);
  12   my $red=i_color_new(255,0,0,255);
  13
  14   my $img=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   $img;
  22 }
  23
  24 sub test_oo_img {
  25   my $raw = test_img();
  26   my $img = Imager->new;
  27   $img->{IMG} = $raw;
  28
  29   $img;
  30 }
  31
  32
  33 sub _sv_str {
  34   my ($value) = @_;
  35
  36   if (defined $value) {
  37     if (!length $value || ($value & ~$value)) {
  38       $value =~ s/\\/\\\\/g;
  39       $value =~ s/\r/\\r/g;
  40       $value =~ s/\n/\\n/g;
  41       $value =~ s/\t/\\t/g;
  42       $value =~ s/\"/\\"/g;
  43       $value =~ s/([^ -\x7E])/"\\x".sprintf("%02x", ord($1))/ge;
  44
  45       return qq!"$value"!;
  46     }
  47     else {
  48       return $value; # a number
  49     }
  50   }
  51   else {
  52     return "undef";
  53   }
  54 }
  55
  56
  57 1;
  58
  59 sub test_colorf_gpix {
  60   my ($im, $x, $y, $expected, $epsilon) = @_;
  61   my $c = Imager::i_gpixf($im, $x, $y);
  62   ok($c, "got gpix ($x, $y)");
  63   unless (ok(colorf_cmp($c, $expected, $epsilon) == 0,
  64              "got right color ($x, $y)")) {
  65     print "# got: (", join(",", ($c->rgba)[0,1,2]), ")\n";
  66     print "# expected: (", join(",", ($expected->rgba)[0,1,2]), ")\n";
  67   }
  68 }
  69
  70 sub test_color_gpix {
  71   my ($im, $x, $y, $expected) = @_;
  72   my $c = Imager::i_get_pixel($im, $x, $y);
  73   ok($c, "got gpix ($x, $y)");
  74   unless (ok(color_cmp($c, $expected) == 0,
  75      "got right color ($x, $y)")) {
  76     print "# got: (", join(",", ($c->rgba)[0,1,2]), ")\n";
  77     print "# expected: (", join(",", ($expected->rgba)[0,1,2]), ")\n";
  78   }
  79 }
  80
  81 sub test_colorf_glin {
  82   my ($im, $x, $y, @pels) = @_;
  83
  84   my @got = Imager::i_glinf($im, $x, $x+@pels, $y);
  85   is(@got, @pels, "check number of pixels ($x, $y)");
  86   ok(!grep(colorf_cmp($pels[$_], $got[$_], 0.005), 0..$#got),
  87      "check colors ($x, $y)");
  88 }
  89
  90 sub colorf_cmp {
  91   my ($c1, $c2, $epsilon) = @_;
  92
  93   defined $epsilon or $epsilon = 0;
  94
  95   my @s1 = $c1->rgba;
  96   my @s2 = $c2->rgba;
  97
  98   # print "# (",join(",", @s1[0..2]),") <=> (",join(",", @s2[0..2]),")\n";
  99   return abs($s1[0]-$s2[0]) >= $epsilon && $s1[0] <=> $s2[0]
 100     || abs($s1[1]-$s2[1]) >= $epsilon && $s1[1] <=> $s2[1]
 101       || abs($s1[2]-$s2[2]) >= $epsilon && $s1[2] <=> $s2[2];
 102 }
 103
 104 sub color_cmp {
 105   my ($c1, $c2) = @_;
 106
 107   my @s1 = $c1->rgba;
 108   my @s2 = $c2->rgba;
 109
 110   return $s1[0] <=> $s2[0]
 111     || $s1[1] <=> $s2[1]
 112       || $s1[2] <=> $s2[2];
 113 }
 114
 115 # these test the action of the channel mask on the image supplied
 116 # which should be an OO image.
 117 sub mask_tests {
 118   my ($im, $epsilon) = @_;
 119
 120   defined $epsilon or $epsilon = 0;
 121
 122   # we want to check all four of ppix() and plin(), ppix() and plinf()
 123   # basic test procedure:
 124   #   first using default/all 1s mask, set to white
 125   #   make sure we got white
 126   #   set mask to skip a channel, set to grey
 127   #   make sure only the right channels set
 128
 129   print "# channel mask tests\n";
 130   # 8-bit color tests
 131   my $white = NC(255, 255, 255);
 132   my $grey = NC(128, 128, 128);
 133   my $white_grey = NC(128, 255, 128);
 134
 135   print "# with ppix\n";
 136   ok($im->setmask(mask=>~0), "set to default mask");
 137   ok($im->setpixel(x=>0, 'y'=>0, color=>$white), "set to white all channels");
 138   test_color_gpix($im->{IMG}, 0, 0, $white);
 139   ok($im->setmask(mask=>0xF-0x2), "set channel to exclude channel1");
 140   ok($im->setpixel(x=>0, 'y'=>0, color=>$grey), "set to grey, no channel 2");
 141   test_color_gpix($im->{IMG}, 0, 0, $white_grey);
 142
 143   print "# with plin\n";
 144   ok($im->setmask(mask=>~0), "set to default mask");
 145   ok($im->setscanline(x=>0, 'y'=>1, pixels => [$white]),
 146      "set to white all channels");
 147   test_color_gpix($im->{IMG}, 0, 1, $white);
 148   ok($im->setmask(mask=>0xF-0x2), "set channel to exclude channel1");
 149   ok($im->setscanline(x=>0, 'y'=>1, pixels=>[$grey]),
 150      "set to grey, no channel 2");
 151   test_color_gpix($im->{IMG}, 0, 1, $white_grey);
 152
 153   # float color tests
 154   my $whitef = NCF(1.0, 1.0, 1.0);
 155   my $greyf = NCF(0.5, 0.5, 0.5);
 156   my $white_greyf = NCF(0.5, 1.0, 0.5);
 157
 158   print "# with ppixf\n";
 159   ok($im->setmask(mask=>~0), "set to default mask");
 160   ok($im->setpixel(x=>0, 'y'=>2, color=>$whitef), "set to white all channels");
 161   test_colorf_gpix($im->{IMG}, 0, 2, $whitef, $epsilon);
 162   ok($im->setmask(mask=>0xF-0x2), "set channel to exclude channel1");
 163   ok($im->setpixel(x=>0, 'y'=>2, color=>$greyf), "set to grey, no channel 2");
 164   test_colorf_gpix($im->{IMG}, 0, 2, $white_greyf, $epsilon);
 165
 166   print "# with plinf\n";
 167   ok($im->setmask(mask=>~0), "set to default mask");
 168   ok($im->setscanline(x=>0, 'y'=>3, pixels => [$whitef]),
 169      "set to white all channels");
 170   test_colorf_gpix($im->{IMG}, 0, 3, $whitef, $epsilon);
 171   ok($im->setmask(mask=>0xF-0x2), "set channel to exclude channel1");
 172   ok($im->setscanline(x=>0, 'y'=>3, pixels=>[$greyf]),
 173      "set to grey, no channel 2");
 174   test_colorf_gpix($im->{IMG}, 0, 3, $white_greyf, $epsilon);
 175
 176 }
 177
 178 sub NCF {
 179   return Imager::Color::Float->new(@_);
 180 }