t/test.pl

   1 #
   2 # t/test.pl - most of Test::More functionality without the fuss
   3 #
   4
   5 my $test = 1;
   6 my $planned;
   7
   8 sub plan {
   9     my $n;
  10     if (@_ == 1) {
  11         $n = shift;
  12     } else {
  13         my %plan = @_;
  14         $n = $plan{tests};
  15     }
  16     print "1..$n\n";
  17     $planned = $n;
  18 }
  19
  20 END {
  21     my $ran = $test - 1;
  22     if (defined $planned && $planned != $ran) {
  23         print "# Looks like you planned $planned tests but ran $ran.\n";
  24     }
  25 }
  26
  27 sub skip_all {
  28     if (@_) {
  29         print "1..0 - @_\n";
  30     } else {
  31         print "1..0\n";
  32     }
  33     exit(0);
  34 }
  35
  36 sub _ok {
  37     my ($pass, $where, @mess) = @_;
  38     # Do not try to microoptimize by factoring out the "not ".
  39     # VMS will avenge.
  40     if (@mess) {
  41         print $pass ? "ok $test - @mess\n" : "not ok $test - @mess\n";
  42     } else {
  43         print $pass ? "ok $test\n" : "not ok $test\n";
  44     }
  45     unless ($pass) {
  46         print "# Failed $where\n";
  47     }
  48     $test++;
  49
  50     return $pass;
  51 }
  52
  53 sub _where {
  54     my @caller = caller(1);
  55     return "at $caller[1] line $caller[2]";
  56 }
  57
  58 sub ok {
  59     my ($pass, @mess) = @_;
  60     _ok($pass, _where(), @mess);
  61 }
  62
  63 sub is {
  64     my ($got, $expected, @mess) = @_;
  65     my $pass = $got eq $expected;
  66     unless ($pass) {
  67         unshift(@mess, "\n",
  68                 "#      got '$got'\n",
  69                 "# expected '$expected'\n");
  70     }
  71     _ok($pass, _where(), @mess);
  72 }
  73
  74 sub isnt {
  75     my ($got, $isnt, $name, @mess) = @_;
  76     my $pass = $got ne $isnt;
  77     unless( $pass ) {
  78         unshift(@mess, "# It should not be " .
  79                        ( defined $got ? $got : "undef" ) . "\n",
  80                        "# but it is.\n");
  81     }
  82     _ok($pass, _where(), $name, @mess);
  83 }
  84
  85 # Note: this isn't quite as fancy as Test::More::like().
  86 sub like {
  87     my ($got, $expected, @mess) = @_;
  88     my $pass;
  89     if (ref $expected eq 'Regexp') {
  90         $pass = $got =~ $expected;
  91         unless ($pass) {
  92             unshift(@mess, "\n",
  93                     "#      got '$got'\n");
  94         }
  95     } else {
  96         $pass = $got =~ /$expected/;
  97         unless ($pass) {
  98             unshift(@mess, "\n",
  99                     "#      got '$got'\n",
 100                     "# expected /$expected/\n");
 101         }
 102     }
 103     _ok($pass, _where(), @mess);
 104 }
 105
 106 sub pass {
 107     _ok(1, '', @_);
 108 }
 109
 110 sub fail {
 111     _ok(0, _where(), @_);
 112 }
 113
 114 sub next_test {
 115     $test++
 116 }
 117
 118 # Note: can't pass multipart messages since we try to
 119 # be compatible with Test::More::skip().
 120 sub skip {
 121     my $mess = shift;
 122     my $n    = @_ ? shift : 1;
 123     for (1..$n) {
 124         ok(1, "# skip:", $mess);
 125     }
 126     local $^W = 0;
 127     last SKIP;
 128 }
 129
 130 sub eq_array {
 131     my ($ra, $rb) = @_;
 132     return 0 unless $#$ra == $#$rb;
 133     for my $i (0..$#$ra) {
 134         return 0 unless $ra->[$i] eq $rb->[$i];
 135     }
 136     return 1;
 137 }
 138
 139 sub require_ok {
 140     my ($require) = @_;
 141     eval <<REQUIRE_OK;
 142 require $require;
 143 REQUIRE_OK
 144     _ok(!$@, _where(), "require $require");
 145 }
 146
 147 sub use_ok {
 148     my ($use) = @_;
 149     eval <<USE_OK;
 150 use $use;
 151 USE_OK
 152     _ok(!$@, _where(), "use $use");
 153 }
 154
 155 1;