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