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 matchn($$$$) {
  86   my ($num, $str, $re, $comment) = @_;
  87
  88   my $match = $str =~ $re;
  89   okn($num, $match, $comment);
  90   unless ($match) {
  91     $str =~ s/\\/\\\\/g;
  92     $str =~ s/[^\x20-\x7E]/"\\x".sprintf("%02X", ord($1))/ge;
  93     print "# The string '$str'\n";
  94     print "# did not match '$re'\n";
  95   }
  96   return $match;
  97 }
  98
  99 sub matchx($$$) {
 100   my ($str, $re, $comment) = @_;
 101
 102   matchn($TESTNUM++, $str, $re, $comment);
 103 }
 104
 105 sub isn ($$$$) {
 106   my ($num, $left, $right, $comment) = @_;
 107
 108   my $match;
 109   if (!defined $left && defined $right
 110      || defined $left && !defined $right) {
 111     $match = 0;
 112   }
 113   elsif (!defined $left && !defined $right) {
 114     $match = 1;
 115   }
 116   # the right of the || produces a string of \0 if $left is a PV
 117   # which is true
 118   elsif (!length $left  || ($left & ~$left) ||
 119          !length $right || ($right & ~$right)) {
 120     $match = $left eq $right;
 121   }
 122   else {
 123     $match = $left == $right;
 124   }
 125   okn($num, $match, $comment);
 126   unless ($match) {
 127     print "# the following two values were not equal:\n";
 128     print "# value: ",_sv_str($left),"\n";
 129     print "# other: ",_sv_str($right),"\n";
 130   }
 131
 132   $match;
 133 }
 134
 135 sub isx ($$$) {
 136   my ($left, $right, $comment) = @_;
 137
 138   isn($TESTNUM++, $left, $right, $comment);
 139 }
 140
 141 sub _sv_str {
 142   my ($value) = @_;
 143
 144   if (defined $value) {
 145     if (!length $value || ($value & ~$value)) {
 146       $value =~ s/\\/\\\\/g;
 147       $value =~ s/\r/\\r/g;
 148       $value =~ s/\n/\\n/g;
 149       $value =~ s/\t/\\t/g;
 150       $value =~ s/\"/\\"/g;
 151       $value =~ s/([^ -\x7E])/"\\x".sprintf("%02x", ord($1))/ge;
 152
 153       return qq!"$value"!;
 154     }
 155     else {
 156       return $value; # a number
 157     }
 158   }
 159   else {
 160     return "undef";
 161   }
 162 }
 163
 164 1;
 165