t/testtools.pl

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