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 STDOUT "1..$n\n";
  19     $planned = $n;
  20 }
  21
  22 END {
  23     my $ran = $test - 1;
  24     if (defined $planned && $planned != $ran) {
  25         print STDOUT "# Looks like you planned $planned tests but ran $ran.\n";
  26     }
  27 }
  28
  29 sub skip_all {
  30     if (@_) {
  31         print STDOUT "1..0 - @_\n";
  32     } else {
  33         print STDOUT "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 STDOUT "$out\n";
  51
  52     unless ($pass) {
  53         print STDOUT "# Failed $where\n";
  54     }
  55
  56     # Ensure that the message is properly escaped.
  57     print STDOUT 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 _q {
  76     my $x = shift;
  77     return 'undef' unless defined $x;
  78     my $q = $x;
  79     $q =~ s/'/\\'/;
  80     return "'$q'";
  81 }
  82
  83 sub is {
  84     my ($got, $expected, $name, @mess) = @_;
  85     my $pass = $got eq $expected;
  86     unless ($pass) {
  87         unshift(@mess, "#      got "._q($got)."\n",
  88                        "# expected "._q($expected)."\n");
  89     }
  90     _ok($pass, _where(), $name, @mess);
  91 }
  92
  93 sub isnt {
  94     my ($got, $isnt, $name, @mess) = @_;
  95     my $pass = $got ne $isnt;
  96     unless( $pass ) {
  97         unshift(@mess, "# it should not be "._q($got)."\n",
  98                        "# but it is.\n");
  99     }
 100     _ok($pass, _where(), $name, @mess);
 101 }
 102
 103 # Note: this isn't quite as fancy as Test::More::like().
 104 sub like {
 105     my ($got, $expected, $name, @mess) = @_;
 106     my $pass;
 107     if (ref $expected eq 'Regexp') {
 108         $pass = $got =~ $expected;
 109         unless ($pass) {
 110             unshift(@mess, "#      got '$got'\n");
 111         }
 112     } else {
 113         $pass = $got =~ /$expected/;
 114         unless ($pass) {
 115             unshift(@mess, "#      got '$got'\n",
 116                            "# expected /$expected/\n");
 117         }
 118     }
 119     _ok($pass, _where(), $name, @mess);
 120 }
 121
 122 sub pass {
 123     _ok(1, '', @_);
 124 }
 125
 126 sub fail {
 127     _ok(0, _where(), @_);
 128 }
 129
 130 sub curr_test {
 131     return $test;
 132 }
 133
 134 sub next_test {
 135     $test++
 136 }
 137
 138 # Note: can't pass multipart messages since we try to
 139 # be compatible with Test::More::skip().
 140 sub skip {
 141     my $why = shift;
 142     my $n    = @_ ? shift : 1;
 143     for (1..$n) {
 144         print STDOUT "ok $test # skip: $why\n";
 145         $test++;
 146     }
 147     local $^W = 0;
 148     last SKIP;
 149 }
 150
 151 sub eq_array {
 152     my ($ra, $rb) = @_;
 153     return 0 unless $#$ra == $#$rb;
 154     for my $i (0..$#$ra) {
 155         return 0 unless $ra->[$i] eq $rb->[$i];
 156     }
 157     return 1;
 158 }
 159
 160 sub require_ok {
 161     my ($require) = @_;
 162     eval <<REQUIRE_OK;
 163 require $require;
 164 REQUIRE_OK
 165     _ok(!$@, _where(), "require $require");
 166 }
 167
 168 sub use_ok {
 169     my ($use) = @_;
 170     eval <<USE_OK;
 171 use $use;
 172 USE_OK
 173     _ok(!$@, _where(), "use $use");
 174 }
 175
 176 # runperl - Runs a separate perl interpreter.
 177 # Arguments :
 178 #   switches => [ command-line switches ]
 179 #   nolib    => 1 # don't use -I../lib (included by default)
 180 #   prog     => one-liner (avoid quotes)
 181 #   progfile => perl script
 182 #   stdin    => string to feed the stdin
 183 #   stderr   => redirect stderr to stdout
 184 #   args     => [ command-line arguments to the perl program ]
 185 #   verbose  => print the command line
 186
 187 my $is_mswin    = $^O eq 'MSWin32';
 188 my $is_netware  = $^O eq 'NetWare';
 189 my $is_macos    = $^O eq 'MacOS';
 190 my $is_vms      = $^O eq 'VMS';
 191
 192 sub _quote_args {
 193     my ($runperl, $args) = @_;
 194
 195     foreach (@$args) {
 196         # In VMS protect with doublequotes because otherwise
 197         # DCL will lowercase -- unless already doublequoted.
 198         $_ = q(").$_.q(") if $is_vms && !/^\"/;
 199         $$runperl .= ' ' . $_;
 200     }
 201 }
 202
 203 sub runperl {
 204     my %args = @_;
 205     my $runperl = $^X;
 206     if ($args{switches}) {
 207         _quote_args(\$runperl, $args{switches});
 208     }
 209     unless ($args{nolib}) {
 210         if ($is_macos) {
 211             $runperl .= ' -I::lib';
 212             # Use UNIX style error messages instead of MPW style.
 213             $runperl .= ' -MMac::err=unix' if $args{stderr};
 214         }
 215         else {
 216             $runperl .= ' "-I../lib"'; # doublequotes because of VMS
 217         }
 218     }
 219     if (defined $args{prog}) {
 220         if ($is_mswin || $is_netware || $is_vms) {
 221             $runperl .= qq( -e ") . $args{prog} . qq(");
 222         }
 223         else {
 224             $runperl .= qq( -e ') . $args{prog} . qq(');
 225         }
 226     } elsif (defined $args{progfile}) {
 227         $runperl .= qq( "$args{progfile}");
 228     }
 229     if (defined $args{stdin}) {
 230         # so we don't try to put literal newlines and crs onto the
 231         # command line.
 232         $args{stdin} =~ s/\n/\\n/g;
 233         $args{stdin} =~ s/\r/\\r/g;
 234
 235         if ($is_mswin || $is_netware || $is_vms) {
 236             $runperl = qq{$^X -e "print qq(} .
 237                 $args{stdin} . q{)" | } . $runperl;
 238         }
 239         else {
 240             $runperl = qq{$^X -e 'print qq(} .
 241                 $args{stdin} . q{)' | } . $runperl;
 242         }
 243     }
 244     if (defined $args{args}) {
 245         _quote_args(\$runperl, $args{args});
 246     }
 247     $runperl .= ' 2>&1'          if  $args{stderr} && !$is_macos;
 248     $runperl .= " \xB3 Dev:Null" if !$args{stderr} &&  $is_macos;
 249     if ($args{verbose}) {
 250         my $runperldisplay = $runperl;
 251         $runperldisplay =~ s/\n/\n\#/g;
 252         print STDOUT "# $runperldisplay\n";
 253     }
 254     my $result = `$runperl`;
 255     $result =~ s/\n\n/\n/ if $is_vms; # XXX pipes sometimes double these
 256     return $result;
 257 }
 258
 259
 260 sub BAILOUT {
 261     print STDOUT "Bail out! @_\n";
 262     exit;
 263 }
 264
 265
 266 # A somewhat safer version of the sometimes wrong $^X.
 267 BEGIN: {
 268     eval {
 269         require File::Spec;
 270         require Config;
 271         Config->import;
 272     };
 273     warn "test.pl had problems loading other modules: $@" if $@;
 274 }
 275
 276 # We do this at compile time before the test might have chdir'd around
 277 # and make sure its absolute in case they do later.
 278 my $Perl = $^X;
 279 $Perl = File::Spec->rel2abs(File::Spec->catfile(File::Spec->curdir(), $Perl))
 280                if $^X eq "perl$Config{_exe}";
 281 warn "Can't generate which_perl from $^X" unless -f $Perl;
 282
 283 # For subcommands to use.
 284 $ENV{PERLEXE} = $Perl;
 285
 286 sub which_perl {
 287     return $Perl;
 288 }
 289
 290 1;