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 $NO_ENDING = 0;
  10
  11 sub plan {
  12     my $n;
  13     if (@_ == 1) {
  14         $n = shift;
  15     } else {
  16         my %plan = @_;
  17         $n = $plan{tests};
  18     }
  19     print STDOUT "1..$n\n";
  20     $planned = $n;
  21 }
  22
  23 END {
  24     my $ran = $test - 1;
  25     if (!$NO_ENDING && defined $planned && $planned != $ran) {
  26         print STDOUT "# Looks like you planned $planned tests but ran $ran.\n";
  27     }
  28 }
  29
  30 sub skip_all {
  31     if (@_) {
  32         print STDOUT "1..0 - @_\n";
  33     } else {
  34         print STDOUT "1..0\n";
  35     }
  36     exit(0);
  37 }
  38
  39 sub _ok {
  40     my ($pass, $where, $name, @mess) = @_;
  41     # Do not try to microoptimize by factoring out the "not ".
  42     # VMS will avenge.
  43     my $out;
  44     if ($name) {
  45         # escape out '#' or it will interfere with '# skip' and such
  46         $name =~ s/#/\\#/g;
  47         $out = $pass ? "ok $test - $name" : "not ok $test - $name";
  48     } else {
  49         $out = $pass ? "ok $test" : "not ok $test";
  50     }
  51
  52     $out .= " # TODO $TODO" if $TODO;
  53     print STDOUT "$out\n";
  54
  55     unless ($pass) {
  56         print STDOUT "# Failed $where\n";
  57     }
  58
  59     # Ensure that the message is properly escaped.
  60     print STDOUT map { /^#/ ? "$_\n" : "# $_\n" }
  61                  map { split /\n/ } @mess if @mess;
  62
  63     $test++;
  64
  65     return $pass;
  66 }
  67
  68 sub _where {
  69     my @caller = caller(1);
  70     return "at $caller[1] line $caller[2]";
  71 }
  72
  73 sub ok {
  74     my ($pass, $name, @mess) = @_;
  75     _ok($pass, _where(), $name, @mess);
  76 }
  77
  78 sub _q {
  79     my $x = shift;
  80     return 'undef' unless defined $x;
  81     my $q = $x;
  82     $q =~ s/'/\\'/;
  83     return "'$q'";
  84 }
  85
  86 sub is {
  87     my ($got, $expected, $name, @mess) = @_;
  88     my $pass = $got eq $expected;
  89     unless ($pass) {
  90         unshift(@mess, "#      got "._q($got)."\n",
  91                        "# expected "._q($expected)."\n");
  92     }
  93     _ok($pass, _where(), $name, @mess);
  94 }
  95
  96 sub isnt {
  97     my ($got, $isnt, $name, @mess) = @_;
  98     my $pass = $got ne $isnt;
  99     unless( $pass ) {
 100         unshift(@mess, "# it should not be "._q($got)."\n",
 101                        "# but it is.\n");
 102     }
 103     _ok($pass, _where(), $name, @mess);
 104 }
 105
 106 # Note: this isn't quite as fancy as Test::More::like().
 107 sub like {
 108     my ($got, $expected, $name, @mess) = @_;
 109     my $pass;
 110     if (ref $expected eq 'Regexp') {
 111         $pass = $got =~ $expected;
 112         unless ($pass) {
 113             unshift(@mess, "#      got '$got'\n");
 114         }
 115     } else {
 116         $pass = $got =~ /$expected/;
 117         unless ($pass) {
 118             unshift(@mess, "#      got '$got'\n",
 119                            "# expected /$expected/\n");
 120         }
 121     }
 122     _ok($pass, _where(), $name, @mess);
 123 }
 124
 125 sub pass {
 126     _ok(1, '', @_);
 127 }
 128
 129 sub fail {
 130     _ok(0, _where(), @_);
 131 }
 132
 133 sub curr_test {
 134     return $test;
 135 }
 136
 137 sub next_test {
 138     $test++
 139 }
 140
 141 # Note: can't pass multipart messages since we try to
 142 # be compatible with Test::More::skip().
 143 sub skip {
 144     my $why = shift;
 145     my $n    = @_ ? shift : 1;
 146     for (1..$n) {
 147         print STDOUT "ok $test # skip: $why\n";
 148         $test++;
 149     }
 150     local $^W = 0;
 151     last SKIP;
 152 }
 153
 154 sub eq_array {
 155     my ($ra, $rb) = @_;
 156     return 0 unless $#$ra == $#$rb;
 157     for my $i (0..$#$ra) {
 158         return 0 unless $ra->[$i] eq $rb->[$i];
 159     }
 160     return 1;
 161 }
 162
 163 sub require_ok {
 164     my ($require) = @_;
 165     eval <<REQUIRE_OK;
 166 require $require;
 167 REQUIRE_OK
 168     _ok(!$@, _where(), "require $require");
 169 }
 170
 171 sub use_ok {
 172     my ($use) = @_;
 173     eval <<USE_OK;
 174 use $use;
 175 USE_OK
 176     _ok(!$@, _where(), "use $use");
 177 }
 178
 179 # runperl - Runs a separate perl interpreter.
 180 # Arguments :
 181 #   switches => [ command-line switches ]
 182 #   nolib    => 1 # don't use -I../lib (included by default)
 183 #   prog     => one-liner (avoid quotes)
 184 #   progfile => perl script
 185 #   stdin    => string to feed the stdin
 186 #   stderr   => redirect stderr to stdout
 187 #   args     => [ command-line arguments to the perl program ]
 188 #   verbose  => print the command line
 189
 190 my $is_mswin    = $^O eq 'MSWin32';
 191 my $is_netware  = $^O eq 'NetWare';
 192 my $is_macos    = $^O eq 'MacOS';
 193 my $is_vms      = $^O eq 'VMS';
 194
 195 sub _quote_args {
 196     my ($runperl, $args) = @_;
 197
 198     foreach (@$args) {
 199         # In VMS protect with doublequotes because otherwise
 200         # DCL will lowercase -- unless already doublequoted.
 201         $_ = q(").$_.q(") if $is_vms && !/^\"/;
 202         $$runperl .= ' ' . $_;
 203     }
 204 }
 205
 206 sub runperl {
 207     my %args = @_;
 208     my $runperl = $^X;
 209     if ($args{switches}) {
 210         _quote_args(\$runperl, $args{switches});
 211     }
 212     unless ($args{nolib}) {
 213         if ($is_macos) {
 214             $runperl .= ' -I::lib';
 215             # Use UNIX style error messages instead of MPW style.
 216             $runperl .= ' -MMac::err=unix' if $args{stderr};
 217         }
 218         else {
 219             $runperl .= ' "-I../lib"'; # doublequotes because of VMS
 220         }
 221     }
 222     if (defined $args{prog}) {
 223         if ($is_mswin || $is_netware || $is_vms) {
 224             $runperl .= qq( -e ") . $args{prog} . qq(");
 225         }
 226         else {
 227             $runperl .= qq( -e ') . $args{prog} . qq(');
 228         }
 229     } elsif (defined $args{progfile}) {
 230         $runperl .= qq( "$args{progfile}");
 231     }
 232     if (defined $args{stdin}) {
 233         # so we don't try to put literal newlines and crs onto the
 234         # command line.
 235         $args{stdin} =~ s/\n/\\n/g;
 236         $args{stdin} =~ s/\r/\\r/g;
 237
 238         if ($is_mswin || $is_netware || $is_vms) {
 239             $runperl = qq{$^X -e "print qq(} .
 240                 $args{stdin} . q{)" | } . $runperl;
 241         }
 242         else {
 243             $runperl = qq{$^X -e 'print qq(} .
 244                 $args{stdin} . q{)' | } . $runperl;
 245         }
 246     }
 247     if (defined $args{args}) {
 248         _quote_args(\$runperl, $args{args});
 249     }
 250     $runperl .= ' 2>&1'          if  $args{stderr} && !$is_macos;
 251     $runperl .= " \xB3 Dev:Null" if !$args{stderr} &&  $is_macos;
 252     if ($args{verbose}) {
 253         my $runperldisplay = $runperl;
 254         $runperldisplay =~ s/\n/\n\#/g;
 255         print STDOUT "# $runperldisplay\n";
 256     }
 257     my $result = `$runperl`;
 258     $result =~ s/\n\n/\n/ if $is_vms; # XXX pipes sometimes double these
 259     return $result;
 260 }
 261
 262
 263 sub BAILOUT {
 264     print STDOUT "Bail out! @_\n";
 265     exit;
 266 }
 267
 268
 269 # A way to display scalars containing control characters and Unicode.
 270 sub display {
 271     map { join("", map { $_ > 255 ? sprintf("\\x{%x}", $_) : chr($_) =~ /[[:cntrl:]]/ ? sprintf("\\%03o", $_) : chr($_) } unpack("U*", $_)) } @_;
 272 }
 273
 274
 275 # A somewhat safer version of the sometimes wrong $^X.
 276 my $Perl;
 277 sub which_perl {
 278     unless (defined $Perl) {
 279         $Perl = $^X;
 280
 281         my $exe;
 282         eval "require Config; Config->import";
 283         if ($@) {
 284             warn "test.pl had problems loading Config: $@";
 285             $exe = '';
 286         } else {
 287             $exe = $Config{_exe};
 288         }
 289
 290         # This doesn't absolutize the path: beware of future chdirs().
 291         # We could do File::Spec->abs2rel() but that does getcwd()s,
 292         # which is a bit heavyweight to do here.
 293
 294         if ($Perl =~ /^perl\Q$exe\E$/i) {
 295             my $perl = "perl$exe";
 296             eval "require File::Spec";
 297             if ($@) {
 298                 warn "test.pl had problems loading File::Spec: $@";
 299                 $Perl = "./$perl";
 300             } else {
 301                 $Perl = File::Spec->catfile(File::Spec->curdir(), $perl);
 302             }
 303         }
 304
 305         warn "which_perl: cannot find $Perl from $^X" unless -f $Perl;
 306
 307         # For subcommands to use.
 308         $ENV{PERLEXE} = $Perl;
 309     }
 310     return $Perl;
 311 }
 312
 313 1;