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