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 sub skipn {
  33   my ($testnum, $count, $why) = @_;
  34
  35   $why = '' unless defined $why;
  36
  37   print "ok $_ # skip $why\n" for $testnum ... $testnum+$count-1;
  38 }
  39
  40 sub skipx {
  41   my ($count, $why) = @_;
  42
  43   skipn($TESTNUM, $count, $why);
  44   $TESTNUM += $count;
  45 }
  46
  47 sub okx ($$) {
  48   my ($ok, $comment) = @_;
  49
  50   return okn($TESTNUM++, $ok, $comment);
  51 }
  52
  53 sub okn ($$$) {
  54   my ($num, $ok, $comment) = @_;
  55
  56   defined $num or confess "No \$num supplied";
  57   defined $comment or confess "No \$comment supplied";
  58   if ($ok) {
  59     print "ok $num # $comment\n";
  60   }
  61   else {
  62     print "not ok $num # $comment\n";
  63   }
  64
  65   return $ok;
  66 }
  67
  68 sub requireokx {
  69   my ($file, $comment) = @_;
  70
  71   eval {
  72     require $file;
  73   };
  74   if ($@) {
  75     my $msg = $@;
  76     $msg =~ s/\n+$//;
  77     $msg =~ s/\n/\n# /g;
  78     okx(0, $comment);
  79     print "# $msg\n";
  80   }
  81   else {
  82     okx(1, $comment);
  83   }
  84 }
  85
  86 sub useokx {
  87   my ($module, $comment, @imports) = @_;
  88
  89   my $pack = caller;
  90   eval <<EOS;
  91 package $pack;
  92 require $module;
  93 $module->import(\@imports);
  94 EOS
  95   unless (okx(!$@, $comment)) {
  96     my $msg = $@;
  97     $msg =~ s/\n+$//;
  98     $msg =~ s/\n/\n# /g;
  99     print "# $msg\n";
 100     return 0;
 101   }
 102   else {
 103     return 1;
 104   }
 105 }
 106
 107 sub matchn($$$$) {
 108   my ($num, $str, $re, $comment) = @_;
 109
 110   my $match = defined($str) && $str =~ $re;
 111   okn($num, $match, $comment);
 112   unless ($match) {
 113     print "# The value: ",_sv_str($str),"\n";
 114     print "# did not match: qr/$re/\n";
 115   }
 116   return $match;
 117 }
 118
 119 sub matchx($$$) {
 120   my ($str, $re, $comment) = @_;
 121
 122   matchn($TESTNUM++, $str, $re, $comment);
 123 }
 124
 125 sub isn ($$$$) {
 126   my ($num, $left, $right, $comment) = @_;
 127
 128   my $match;
 129   if (!defined $left && defined $right
 130      || defined $left && !defined $right) {
 131     $match = 0;
 132   }
 133   elsif (!defined $left && !defined $right) {
 134     $match = 1;
 135   }
 136   # the right of the || produces a string of \0 if $left is a PV
 137   # which is true
 138   elsif (!length $left  || ($left & ~$left) ||
 139          !length $right || ($right & ~$right)) {
 140     $match = $left eq $right;
 141   }
 142   else {
 143     $match = $left == $right;
 144   }
 145   okn($num, $match, $comment);
 146   unless ($match) {
 147     print "# the following two values were not equal:\n";
 148     print "# value: ",_sv_str($left),"\n";
 149     print "# other: ",_sv_str($right),"\n";
 150   }
 151
 152   $match;
 153 }
 154
 155 sub isx ($$$) {
 156   my ($left, $right, $comment) = @_;
 157
 158   isn($TESTNUM++, $left, $right, $comment);
 159 }
 160
 161 sub _sv_str {
 162   my ($value) = @_;
 163
 164   if (defined $value) {
 165     if (!length $value || ($value & ~$value)) {
 166       $value =~ s/\\/\\\\/g;
 167       $value =~ s/\r/\\r/g;
 168       $value =~ s/\n/\\n/g;
 169       $value =~ s/\t/\\t/g;
 170       $value =~ s/\"/\\"/g;
 171       $value =~ s/([^ -\x7E])/"\\x".sprintf("%02x", ord($1))/ge;
 172
 173       return qq!"$value"!;
 174     }
 175     else {
 176       return $value; # a number
 177     }
 178   }
 179   else {
 180     return "undef";
 181   }
 182 }
 183
 184
 185 1;
 186
 187 sub test_colorf_gpix {
 188   my ($im, $x, $y, $expected, $epsilon) = @_;
 189   my $c = Imager::i_gpixf($im, $x, $y);
 190   ok($c, "got gpix ($x, $y)");
 191   unless (ok(colorf_cmp($c, $expected, $epsilon) == 0,
 192              "got right color ($x, $y)")) {
 193     print "# got: (", join(",", ($c->rgba)[0,1,2]), ")\n";
 194     print "# expected: (", join(",", ($expected->rgba)[0,1,2]), ")\n";
 195   }
 196 }
 197
 198 sub test_color_gpix {
 199   my ($im, $x, $y, $expected) = @_;
 200   my $c = Imager::i_get_pixel($im, $x, $y);
 201   ok($c, "got gpix ($x, $y)");
 202   unless (ok(color_cmp($c, $expected) == 0,
 203      "got right color ($x, $y)")) {
 204     print "# got: (", join(",", ($c->rgba)[0,1,2]), ")\n";
 205     print "# expected: (", join(",", ($expected->rgba)[0,1,2]), ")\n";
 206   }
 207 }
 208
 209 sub test_colorf_glin {
 210   my ($im, $x, $y, @pels) = @_;
 211
 212   my @got = Imager::i_glinf($im, $x, $x+@pels, $y);
 213   is(@got, @pels, "check number of pixels ($x, $y)");
 214   ok(!grep(colorf_cmp($pels[$_], $got[$_], 0.005), 0..$#got),
 215      "check colors ($x, $y)");
 216 }
 217
 218 sub colorf_cmp {
 219   my ($c1, $c2, $epsilon) = @_;
 220
 221   defined $epsilon or $epsilon = 0;
 222
 223   my @s1 = $c1->rgba;
 224   my @s2 = $c2->rgba;
 225
 226   # print "# (",join(",", @s1[0..2]),") <=> (",join(",", @s2[0..2]),")\n";
 227   return abs($s1[0]-$s2[0]) >= $epsilon && $s1[0] <=> $s2[0]
 228     || abs($s1[1]-$s2[1]) >= $epsilon && $s1[1] <=> $s2[1]
 229       || abs($s1[2]-$s2[2]) >= $epsilon && $s1[2] <=> $s2[2];
 230 }
 231
 232 sub color_cmp {
 233   my ($c1, $c2) = @_;
 234
 235   my @s1 = $c1->rgba;
 236   my @s2 = $c2->rgba;
 237
 238   return $s1[0] <=> $s2[0]
 239     || $s1[1] <=> $s2[1]
 240       || $s1[2] <=> $s2[2];
 241 }
 242
 243 # these test the action of the channel mask on the image supplied
 244 # which should be an OO image.
 245 sub mask_tests {
 246   my ($im, $epsilon) = @_;
 247
 248   defined $epsilon or $epsilon = 0;
 249
 250   # we want to check all four of ppix() and plin(), ppix() and plinf()
 251   # basic test procedure:
 252   #   first using default/all 1s mask, set to white
 253   #   make sure we got white
 254   #   set mask to skip a channel, set to grey
 255   #   make sure only the right channels set
 256
 257   print "# channel mask tests\n";
 258   # 8-bit color tests
 259   my $white = NC(255, 255, 255);
 260   my $grey = NC(128, 128, 128);
 261   my $white_grey = NC(128, 255, 128);
 262
 263   print "# with ppix\n";
 264   ok($im->setmask(mask=>~0), "set to default mask");
 265   ok($im->setpixel(x=>0, 'y'=>0, color=>$white), "set to white all channels");
 266   test_color_gpix($im->{IMG}, 0, 0, $white);
 267   ok($im->setmask(mask=>0xF-0x2), "set channel to exclude channel1");
 268   ok($im->setpixel(x=>0, 'y'=>0, color=>$grey), "set to grey, no channel 2");
 269   test_color_gpix($im->{IMG}, 0, 0, $white_grey);
 270
 271   print "# with plin\n";
 272   ok($im->setmask(mask=>~0), "set to default mask");
 273   ok($im->setscanline(x=>0, 'y'=>1, pixels => [$white]),
 274      "set to white all channels");
 275   test_color_gpix($im->{IMG}, 0, 1, $white);
 276   ok($im->setmask(mask=>0xF-0x2), "set channel to exclude channel1");
 277   ok($im->setscanline(x=>0, 'y'=>1, pixels=>[$grey]),
 278      "set to grey, no channel 2");
 279   test_color_gpix($im->{IMG}, 0, 1, $white_grey);
 280
 281   # float color tests
 282   my $whitef = NCF(1.0, 1.0, 1.0);
 283   my $greyf = NCF(0.5, 0.5, 0.5);
 284   my $white_greyf = NCF(0.5, 1.0, 0.5);
 285
 286   print "# with ppixf\n";
 287   ok($im->setmask(mask=>~0), "set to default mask");
 288   ok($im->setpixel(x=>0, 'y'=>2, color=>$whitef), "set to white all channels");
 289   test_colorf_gpix($im->{IMG}, 0, 2, $whitef, $epsilon);
 290   ok($im->setmask(mask=>0xF-0x2), "set channel to exclude channel1");
 291   ok($im->setpixel(x=>0, 'y'=>2, color=>$greyf), "set to grey, no channel 2");
 292   test_colorf_gpix($im->{IMG}, 0, 2, $white_greyf, $epsilon);
 293
 294   print "# with plinf\n";
 295   ok($im->setmask(mask=>~0), "set to default mask");
 296   ok($im->setscanline(x=>0, 'y'=>3, pixels => [$whitef]),
 297      "set to white all channels");
 298   test_colorf_gpix($im->{IMG}, 0, 3, $whitef, $epsilon);
 299   ok($im->setmask(mask=>0xF-0x2), "set channel to exclude channel1");
 300   ok($im->setscanline(x=>0, 'y'=>3, pixels=>[$greyf]),
 301      "set to grey, no channel 2");
 302   test_colorf_gpix($im->{IMG}, 0, 3, $white_greyf, $epsilon);
 303
 304 }
 305
 306 sub NCF {
 307   return Imager::Color::Float->new(@_);
 308 }