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