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 1;
 184