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     $q =~ s/'/\\'/;
  84     return "'$q'";
  85 }
  86
  87 sub _qq {
  88     my $x = shift;
  89     return defined $x ? '"' . display ($x) . '"' : 'undef';
  90 };
  91
  92 # keys are the codes \n etc map to, values are 2 char strings such as \n
  93 my %backslash_escape;
  94 foreach my $x (split //, 'nrtfa\\\'"') {
  95     $backslash_escape{ord eval "\"\\$x\""} = "\\$x";
  96 }
  97 # A way to display scalars containing control characters and Unicode.
  98 # Trying to avoid setting $_, or relying on local $_ to work.
  99 sub display {
 100     my @result;
 101     foreach my $x (@_) {
 102         if (defined $x and not ref $x) {
 103             my $y = '';
 104             foreach my $c (unpack("U*", $x)) {
 105                 if ($c > 255) {
 106                     $y .= sprintf "\\x{%x}", $c;
 107                 } elsif ($backslash_escape{$c}) {
 108                     $y .= $backslash_escape{$c};
 109                 } else {
 110                     my $z = chr $c; # Maybe we can get away with a literal...
 111                     $z = sprintf "\\%03o", $c if $z =~ /[[:^print:]]/;
 112                     $y .= $z;
 113                 }
 114             }
 115             $x = $y;
 116         }
 117         return $x unless wantarray;
 118         push @result, $x;
 119     }
 120     return @result;
 121 }
 122
 123 sub is {
 124     my ($got, $expected, $name, @mess) = @_;
 125     my $pass = $got eq $expected;
 126     unless ($pass) {
 127         unshift(@mess, "#      got "._q($got)."\n",
 128                        "# expected "._q($expected)."\n");
 129     }
 130     _ok($pass, _where(), $name, @mess);
 131 }
 132
 133 sub isnt {
 134     my ($got, $isnt, $name, @mess) = @_;
 135     my $pass = $got ne $isnt;
 136     unless( $pass ) {
 137         unshift(@mess, "# it should not be "._q($got)."\n",
 138                        "# but it is.\n");
 139     }
 140     _ok($pass, _where(), $name, @mess);
 141 }
 142
 143 # Note: this isn't quite as fancy as Test::More::like().
 144 sub like {
 145     my ($got, $expected, $name, @mess) = @_;
 146     my $pass;
 147     if (ref $expected eq 'Regexp') {
 148         $pass = $got =~ $expected;
 149         unless ($pass) {
 150             unshift(@mess, "#      got '$got'\n",
 151                            "# expected /$expected/\n");
 152         }
 153     } else {
 154         $pass = $got =~ /$expected/;
 155         unless ($pass) {
 156             unshift(@mess, "#      got '$got'\n",
 157                            "# expected /$expected/\n");
 158         }
 159     }
 160     _ok($pass, _where(), $name, @mess);
 161 }
 162
 163 sub pass {
 164     _ok(1, '', @_);
 165 }
 166
 167 sub fail {
 168     _ok(0, _where(), @_);
 169 }
 170
 171 sub curr_test {
 172     return $test;
 173 }
 174
 175 sub next_test {
 176     $test++
 177 }
 178
 179 # Note: can't pass multipart messages since we try to
 180 # be compatible with Test::More::skip().
 181 sub skip {
 182     my $why = shift;
 183     my $n    = @_ ? shift : 1;
 184     for (1..$n) {
 185         print STDOUT "ok $test # skip: $why\n";
 186         $test++;
 187     }
 188     local $^W = 0;
 189     last SKIP;
 190 }
 191
 192 sub eq_array {
 193     my ($ra, $rb) = @_;
 194     return 0 unless $#$ra == $#$rb;
 195     for my $i (0..$#$ra) {
 196         return 0 unless $ra->[$i] eq $rb->[$i];
 197     }
 198     return 1;
 199 }
 200
 201 sub eq_hash {
 202   my ($orig, $suspect) = @_;
 203   my $fail;
 204   while (my ($key, $value) = each %$suspect) {
 205     # Force a hash recompute if this perl's internals can cache the hash key.
 206     $key = "" . $key;
 207     if (exists $orig->{$key}) {
 208       if ($orig->{$key} ne $value) {
 209         print "# key ", _qq($key), " was ", _qq($orig->{$key}),
 210           " now ", _qq($value), "\n";
 211         $fail = 1;
 212       }
 213     } else {
 214       print "# key ", _qq($key), " is ", _qq($value), ", not in original.\n";
 215       $fail = 1;
 216     }
 217   }
 218   foreach (keys %$orig) {
 219     # Force a hash recompute if this perl's internals can cache the hash key.
 220     $_ = "" . $_;
 221     next if (exists $suspect->{$_});
 222     print "# key ", _qq($_), " was ", _qq($orig->{$_}), " now missing.\n";
 223     $fail = 1;
 224   }
 225   !$fail;
 226 }
 227
 228 sub require_ok {
 229     my ($require) = @_;
 230     eval <<REQUIRE_OK;
 231 require $require;
 232 REQUIRE_OK
 233     _ok(!$@, _where(), "require $require");
 234 }
 235
 236 sub use_ok {
 237     my ($use) = @_;
 238     eval <<USE_OK;
 239 use $use;
 240 USE_OK
 241     _ok(!$@, _where(), "use $use");
 242 }
 243
 244 # runperl - Runs a separate perl interpreter.
 245 # Arguments :
 246 #   switches => [ command-line switches ]
 247 #   nolib    => 1 # don't use -I../lib (included by default)
 248 #   prog     => one-liner (avoid quotes)
 249 #   progfile => perl script
 250 #   stdin    => string to feed the stdin
 251 #   stderr   => redirect stderr to stdout
 252 #   args     => [ command-line arguments to the perl program ]
 253 #   verbose  => print the command line
 254
 255 my $is_mswin    = $^O eq 'MSWin32';
 256 my $is_netware  = $^O eq 'NetWare';
 257 my $is_macos    = $^O eq 'MacOS';
 258 my $is_vms      = $^O eq 'VMS';
 259
 260 sub _quote_args {
 261     my ($runperl, $args) = @_;
 262
 263     foreach (@$args) {
 264         # In VMS protect with doublequotes because otherwise
 265         # DCL will lowercase -- unless already doublequoted.
 266         $_ = q(").$_.q(") if $is_vms && !/^\"/;
 267         $$runperl .= ' ' . $_;
 268     }
 269 }
 270
 271 sub runperl {
 272     my %args = @_;
 273     my $runperl = $^X;
 274     if ($args{switches}) {
 275         _quote_args(\$runperl, $args{switches});
 276     }
 277     unless ($args{nolib}) {
 278         if ($is_macos) {
 279             $runperl .= ' -I::lib';
 280             # Use UNIX style error messages instead of MPW style.
 281             $runperl .= ' -MMac::err=unix' if $args{stderr};
 282         }
 283         else {
 284             $runperl .= ' "-I../lib"'; # doublequotes because of VMS
 285         }
 286     }
 287     if (defined $args{prog}) {
 288         if ($is_mswin || $is_netware || $is_vms) {
 289             $runperl .= qq( -e ") . $args{prog} . qq(");
 290         }
 291         else {
 292             $runperl .= qq( -e ') . $args{prog} . qq(');
 293         }
 294     } elsif (defined $args{progfile}) {
 295         $runperl .= qq( "$args{progfile}");
 296     }
 297     if (defined $args{stdin}) {
 298         # so we don't try to put literal newlines and crs onto the
 299         # command line.
 300         $args{stdin} =~ s/\n/\\n/g;
 301         $args{stdin} =~ s/\r/\\r/g;
 302
 303         if ($is_mswin || $is_netware || $is_vms) {
 304             $runperl = qq{$^X -e "print qq(} .
 305                 $args{stdin} . q{)" | } . $runperl;
 306         }
 307         else {
 308             $runperl = qq{$^X -e 'print qq(} .
 309                 $args{stdin} . q{)' | } . $runperl;
 310         }
 311     }
 312     if (defined $args{args}) {
 313         _quote_args(\$runperl, $args{args});
 314     }
 315     $runperl .= ' 2>&1'          if  $args{stderr} && !$is_macos;
 316     $runperl .= " \xB3 Dev:Null" if !$args{stderr} &&  $is_macos;
 317     if ($args{verbose}) {
 318         my $runperldisplay = $runperl;
 319         $runperldisplay =~ s/\n/\n\#/g;
 320         print STDOUT "# $runperldisplay\n";
 321     }
 322     my $result = `$runperl`;
 323     $result =~ s/\n\n/\n/ if $is_vms; # XXX pipes sometimes double these
 324     return $result;
 325 }
 326
 327
 328 sub BAILOUT {
 329     print STDOUT "Bail out! @_\n";
 330     exit;
 331 }
 332
 333 # A somewhat safer version of the sometimes wrong $^X.
 334 my $Perl;
 335 sub which_perl {
 336     unless (defined $Perl) {
 337         $Perl = $^X;
 338
 339         my $exe;
 340         eval "require Config; Config->import";
 341         if ($@) {
 342             warn "test.pl had problems loading Config: $@";
 343             $exe = '';
 344         } else {
 345             $exe = $Config{_exe};
 346         }
 347        $exe = '' unless defined $exe;
 348
 349         # This doesn't absolutize the path: beware of future chdirs().
 350         # We could do File::Spec->abs2rel() but that does getcwd()s,
 351         # which is a bit heavyweight to do here.
 352
 353         if ($Perl =~ /^perl\Q$exe\E$/i) {
 354             my $perl = "perl$exe";
 355             eval "require File::Spec";
 356             if ($@) {
 357                 warn "test.pl had problems loading File::Spec: $@";
 358                 $Perl = "./$perl";
 359             } else {
 360                 $Perl = File::Spec->catfile(File::Spec->curdir(), $perl);
 361             }
 362         }
 363
 364         # Its like this.  stat on Cygwin treats 'perl' to mean 'perl.exe'
 365         # but open does not.  This can get confusing, so to be safe we
 366         # always put the .exe on the end on Cygwin.
 367         $Perl .= $exe if $^O eq 'cygwin' && $Perl !~ /\Q$exe\E$/;
 368
 369         warn "which_perl: cannot find $Perl from $^X" unless -f $Perl;
 370
 371         # For subcommands to use.
 372         $ENV{PERLEXE} = $Perl;
 373     }
 374     return $Perl;
 375 }
 376
 377 sub unlink_all {
 378     foreach my $file (@_) {
 379         1 while unlink $file;
 380         print "# Couldn't unlink '$file': $!\n" if -f $file;
 381     }
 382 }
 383 1;