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 STDERR "# Looks like you planned $planned tests but ran $ran.\n";
  27     }
  28 }
  29
  30 # Use this instead of "print STDERR" when outputing failure diagnostic
  31 # messages
  32 sub _diag {
  33     my $fh = $TODO ? *STDOUT : *STDERR;
  34     print $fh @_;
  35 }
  36
  37 sub skip_all {
  38     if (@_) {
  39         print STDOUT "1..0 - @_\n";
  40     } else {
  41         print STDOUT "1..0\n";
  42     }
  43     exit(0);
  44 }
  45
  46 sub _ok {
  47     my ($pass, $where, $name, @mess) = @_;
  48     # Do not try to microoptimize by factoring out the "not ".
  49     # VMS will avenge.
  50     my $out;
  51     if ($name) {
  52         # escape out '#' or it will interfere with '# skip' and such
  53         $name =~ s/#/\\#/g;
  54         $out = $pass ? "ok $test - $name" : "not ok $test - $name";
  55     } else {
  56         $out = $pass ? "ok $test" : "not ok $test";
  57     }
  58
  59     $out .= " # TODO $TODO" if $TODO;
  60     print STDOUT "$out\n";
  61
  62     unless ($pass) {
  63         _diag "# Failed $where\n";
  64     }
  65
  66     # Ensure that the message is properly escaped.
  67     _diag map { /^#/ ? "$_\n" : "# $_\n" }
  68           map { split /\n/ } @mess if @mess;
  69
  70     $test++;
  71
  72     return $pass;
  73 }
  74
  75 sub _where {
  76     my @caller = caller(1);
  77     return "at $caller[1] line $caller[2]";
  78 }
  79
  80 sub ok {
  81     my ($pass, $name, @mess) = @_;
  82     _ok($pass, _where(), $name, @mess);
  83 }
  84
  85 sub _q {
  86     my $x = shift;
  87     return 'undef' unless defined $x;
  88     my $q = $x;
  89     $q =~ s/\\/\\\\/;
  90     $q =~ s/'/\\'/;
  91     return "'$q'";
  92 }
  93
  94 sub _qq {
  95     my $x = shift;
  96     return defined $x ? '"' . display ($x) . '"' : 'undef';
  97 };
  98
  99 # keys are the codes \n etc map to, values are 2 char strings such as \n
 100 my %backslash_escape;
 101 foreach my $x (split //, 'nrtfa\\\'"') {
 102     $backslash_escape{ord eval "\"\\$x\""} = "\\$x";
 103 }
 104 # A way to display scalars containing control characters and Unicode.
 105 # Trying to avoid setting $_, or relying on local $_ to work.
 106 sub display {
 107     my @result;
 108     foreach my $x (@_) {
 109         if (defined $x and not ref $x) {
 110             my $y = '';
 111             foreach my $c (unpack("U*", $x)) {
 112                 if ($c > 255) {
 113                     $y .= sprintf "\\x{%x}", $c;
 114                 } elsif ($backslash_escape{$c}) {
 115                     $y .= $backslash_escape{$c};
 116                 } else {
 117                     my $z = chr $c; # Maybe we can get away with a literal...
 118                     $z = sprintf "\\%03o", $c if $z =~ /[[:^print:]]/;
 119                     $y .= $z;
 120                 }
 121             }
 122             $x = $y;
 123         }
 124         return $x unless wantarray;
 125         push @result, $x;
 126     }
 127     return @result;
 128 }
 129
 130 sub is {
 131     my ($got, $expected, $name, @mess) = @_;
 132     my $pass = $got eq $expected;
 133     unless ($pass) {
 134         unshift(@mess, "#      got "._q($got)."\n",
 135                        "# expected "._q($expected)."\n");
 136     }
 137     _ok($pass, _where(), $name, @mess);
 138 }
 139
 140 sub isnt {
 141     my ($got, $isnt, $name, @mess) = @_;
 142     my $pass = $got ne $isnt;
 143     unless( $pass ) {
 144         unshift(@mess, "# it should not be "._q($got)."\n",
 145                        "# but it is.\n");
 146     }
 147     _ok($pass, _where(), $name, @mess);
 148 }
 149
 150 # Note: this isn't quite as fancy as Test::More::like().
 151 sub like {
 152     my ($got, $expected, $name, @mess) = @_;
 153     my $pass;
 154     if (ref $expected eq 'Regexp') {
 155         $pass = $got =~ $expected;
 156         unless ($pass) {
 157             unshift(@mess, "#      got '$got'\n",
 158                            "# expected /$expected/\n");
 159         }
 160     } else {
 161         $pass = $got =~ /$expected/;
 162         unless ($pass) {
 163             unshift(@mess, "#      got '$got'\n",
 164                            "# expected /$expected/\n");
 165         }
 166     }
 167     _ok($pass, _where(), $name, @mess);
 168 }
 169
 170 sub pass {
 171     _ok(1, '', @_);
 172 }
 173
 174 sub fail {
 175     _ok(0, _where(), @_);
 176 }
 177
 178 sub curr_test {
 179     return $test;
 180 }
 181
 182 sub next_test {
 183     $test++
 184 }
 185
 186 # Note: can't pass multipart messages since we try to
 187 # be compatible with Test::More::skip().
 188 sub skip {
 189     my $why = shift;
 190     my $n    = @_ ? shift : 1;
 191     for (1..$n) {
 192         print STDOUT "ok $test # skip: $why\n";
 193         $test++;
 194     }
 195     local $^W = 0;
 196     last SKIP;
 197 }
 198
 199 sub eq_array {
 200     my ($ra, $rb) = @_;
 201     return 0 unless $#$ra == $#$rb;
 202     for my $i (0..$#$ra) {
 203         return 0 unless $ra->[$i] eq $rb->[$i];
 204     }
 205     return 1;
 206 }
 207
 208 sub eq_hash {
 209   my ($orig, $suspect) = @_;
 210   my $fail;
 211   while (my ($key, $value) = each %$suspect) {
 212     # Force a hash recompute if this perl's internals can cache the hash key.
 213     $key = "" . $key;
 214     if (exists $orig->{$key}) {
 215       if ($orig->{$key} ne $value) {
 216         print STDOUT "# key ", _qq($key), " was ", _qq($orig->{$key}),
 217                      " now ", _qq($value), "\n";
 218         $fail = 1;
 219       }
 220     } else {
 221       print STDOUT "# key ", _qq($key), " is ", _qq($value),
 222                    ", not in original.\n";
 223       $fail = 1;
 224     }
 225   }
 226   foreach (keys %$orig) {
 227     # Force a hash recompute if this perl's internals can cache the hash key.
 228     $_ = "" . $_;
 229     next if (exists $suspect->{$_});
 230     print STDOUT "# key ", _qq($_), " was ", _qq($orig->{$_}), " now missing.\n";
 231     $fail = 1;
 232   }
 233   !$fail;
 234 }
 235
 236 sub require_ok {
 237     my ($require) = @_;
 238     eval <<REQUIRE_OK;
 239 require $require;
 240 REQUIRE_OK
 241     _ok(!$@, _where(), "require $require");
 242 }
 243
 244 sub use_ok {
 245     my ($use) = @_;
 246     eval <<USE_OK;
 247 use $use;
 248 USE_OK
 249     _ok(!$@, _where(), "use $use");
 250 }
 251
 252 # runperl - Runs a separate perl interpreter.
 253 # Arguments :
 254 #   switches => [ command-line switches ]
 255 #   nolib    => 1 # don't use -I../lib (included by default)
 256 #   prog     => one-liner (avoid quotes)
 257 #   progfile => perl script
 258 #   stdin    => string to feed the stdin
 259 #   stderr   => redirect stderr to stdout
 260 #   args     => [ command-line arguments to the perl program ]
 261 #   verbose  => print the command line
 262
 263 my $is_mswin    = $^O eq 'MSWin32';
 264 my $is_netware  = $^O eq 'NetWare';
 265 my $is_macos    = $^O eq 'MacOS';
 266 my $is_vms      = $^O eq 'VMS';
 267
 268 sub _quote_args {
 269     my ($runperl, $args) = @_;
 270
 271     foreach (@$args) {
 272         # In VMS protect with doublequotes because otherwise
 273         # DCL will lowercase -- unless already doublequoted.
 274         $_ = q(").$_.q(") if $is_vms && !/^\"/;
 275         $$runperl .= ' ' . $_;
 276     }
 277 }
 278
 279 sub runperl {
 280     my %args = @_;
 281     my $runperl = $^X;
 282     if ($args{switches}) {
 283         _quote_args(\$runperl, $args{switches});
 284     }
 285     unless ($args{nolib}) {
 286         if ($is_macos) {
 287             $runperl .= ' -I::lib';
 288             # Use UNIX style error messages instead of MPW style.
 289             $runperl .= ' -MMac::err=unix' if $args{stderr};
 290         }
 291         else {
 292             $runperl .= ' "-I../lib"'; # doublequotes because of VMS
 293         }
 294     }
 295     if (defined $args{prog}) {
 296         if ($is_mswin || $is_netware || $is_vms) {
 297             $runperl .= qq( -e ") . $args{prog} . qq(");
 298         }
 299         else {
 300             $runperl .= qq( -e ') . $args{prog} . qq(');
 301         }
 302     } elsif (defined $args{progfile}) {
 303         $runperl .= qq( "$args{progfile}");
 304     }
 305     if (defined $args{stdin}) {
 306         # so we don't try to put literal newlines and crs onto the
 307         # command line.
 308         $args{stdin} =~ s/\n/\\n/g;
 309         $args{stdin} =~ s/\r/\\r/g;
 310
 311         if ($is_mswin || $is_netware || $is_vms) {
 312             $runperl = qq{$^X -e "print qq(} .
 313                 $args{stdin} . q{)" | } . $runperl;
 314         }
 315         else {
 316             $runperl = qq{$^X -e 'print qq(} .
 317                 $args{stdin} . q{)' | } . $runperl;
 318         }
 319     }
 320     if (defined $args{args}) {
 321         _quote_args(\$runperl, $args{args});
 322     }
 323     $runperl .= ' 2>&1'          if  $args{stderr} && !$is_macos;
 324     $runperl .= " \xB3 Dev:Null" if !$args{stderr} &&  $is_macos;
 325     if ($args{verbose}) {
 326         my $runperldisplay = $runperl;
 327         $runperldisplay =~ s/\n/\n\#/g;
 328         print STDERR "# $runperldisplay\n";
 329     }
 330     my $result = `$runperl`;
 331     $result =~ s/\n\n/\n/ if $is_vms; # XXX pipes sometimes double these
 332     return $result;
 333 }
 334
 335
 336 sub DIE {
 337     print STDERR "# @_\n";
 338     exit 1;
 339 }
 340
 341 # A somewhat safer version of the sometimes wrong $^X.
 342 my $Perl;
 343 sub which_perl {
 344     unless (defined $Perl) {
 345         $Perl = $^X;
 346
 347         my $exe;
 348         eval "require Config; Config->import";
 349         if ($@) {
 350             warn "test.pl had problems loading Config: $@";
 351             $exe = '';
 352         } else {
 353             $exe = $Config{_exe};
 354         }
 355        $exe = '' unless defined $exe;
 356
 357         # This doesn't absolutize the path: beware of future chdirs().
 358         # We could do File::Spec->abs2rel() but that does getcwd()s,
 359         # which is a bit heavyweight to do here.
 360
 361         if ($Perl =~ /^perl\Q$exe\E$/i) {
 362             my $perl = "perl$exe";
 363             eval "require File::Spec";
 364             if ($@) {
 365                 warn "test.pl had problems loading File::Spec: $@";
 366                 $Perl = "./$perl";
 367             } else {
 368                 $Perl = File::Spec->catfile(File::Spec->curdir(), $perl);
 369             }
 370         }
 371
 372         # Build up the name of the executable file from the name of
 373         # the command.
 374
 375         if ($Perl !~ /\Q$exe\E$/i) {
 376             $Perl .= $exe;
 377         }
 378
 379         warn "which_perl: cannot find $Perl from $^X" unless -f $Perl;
 380
 381         # For subcommands to use.
 382         $ENV{PERLEXE} = $Perl;
 383     }
 384     return $Perl;
 385 }
 386
 387 sub unlink_all {
 388     foreach my $file (@_) {
 389         1 while unlink $file;
 390         print STDERR "# Couldn't unlink '$file': $!\n" if -f $file;
 391     }
 392 }
 393
 394
 395 my $tmpfile = "misctmp000";
 396 1 while -f ++$tmpfile;
 397 END { unlink_all $tmpfile }
 398
 399 sub kill_perl {
 400     my($prog, $expected, $runperl_args, $name) = @_;
 401
 402     $runperl_args ||= {};
 403     $runperl_args->{progfile} = $tmpfile;
 404     $runperl_args->{stderr} = 1;
 405
 406     open TEST, ">$tmpfile" or die "Cannot open $tmpfile: $!";
 407
 408     # VMS adjustments
 409     if( $^O eq 'VMS' ) {
 410         $prog =~ s#/dev/null#NL:#;
 411
 412         # VMS file locking
 413         $prog =~ s{if \(-e _ and -f _ and -r _\)}
 414                   {if (-e _ and -f _)}
 415     }
 416
 417     print TEST $prog, "\n";
 418     close TEST or die "Cannot close $tmpfile: $!";
 419
 420     my $results = runperl(%$runperl_args);
 421     my $status = $?;
 422
 423     # Clean up the results into something a bit more predictable.
 424     $results =~ s/\n+$//;
 425     $results =~ s/at\s+misctmp\d+\s+line/at - line/g;
 426     $results =~ s/of\s+misctmp\d+\s+aborted/of - aborted/g;
 427
 428     # bison says 'parse error' instead of 'syntax error',
 429     # various yaccs may or may not capitalize 'syntax'.
 430     $results =~ s/^(syntax|parse) error/syntax error/mig;
 431
 432     if ($^O eq 'VMS') {
 433         # some tests will trigger VMS messages that won't be expected
 434         $results =~ s/\n?%[A-Z]+-[SIWEF]-[A-Z]+,.*//;
 435
 436         # pipes double these sometimes
 437         $results =~ s/\n\n/\n/g;
 438     }
 439
 440     $expected =~ s/\n+$//;
 441
 442     my $pass = $results eq $expected;
 443     unless ($pass) {
 444         print STDERR "# PROG: $switch\n$prog\n";
 445         print STDERR "# EXPECTED:\n$expected\n";
 446         print STDERR "# GOT:\n$results\n";
 447         print STDERR "# STATUS: $status\n";
 448     }
 449
 450     ($name) = $prog =~ /^(.{1,35})/ unless $name;
 451
 452     _ok($pass, _where(), "kill_perl - $name");
 453 }
 454
 455 1;