t/TEST

   1 #!./perl
   2
   3 # This is written in a peculiar style, since we're trying to avoid
   4 # most of the constructs we'll be testing for.  (This comment is
   5 # probably obsolete on the avoidance side, though still current
   6 # on the peculiarity side.)
   7
   8 # t/TEST and t/harness need to share code. The logical way to do this would be
   9 # to have the common code in a file both require or use. However, t/TEST needs
  10 # to still work, to generate test results, even if require isn't working, so
  11 # we cannot do that. t/harness has no such restriction, so it is quite
  12 # acceptable to have it require t/TEST.
  13
  14 # In which case, we need to stop t/TEST actually running tests, as all
  15 # t/harness needs are its subroutines.
  16
  17 # Measure the elapsed wallclock time.
  18 my $t0 = time();
  19
  20 # If we're doing deparse tests, ignore failures for these
  21 my $deparse_failures;
  22
  23 # And skip even running these
  24 my $deparse_skips;
  25
  26 my $deparse_skip_file = '../Porting/deparse-skips.txt';
  27
  28 # directories with special sets of test switches
  29 my %dir_to_switch =
  30     (base => '',
  31      comp => '',
  32      run => '',
  33      '../ext/File-Glob/t' => '-I.. -MTestInit', # FIXME - tests assume t/
  34      );
  35
  36 # "not absolute" is the default, as it saves some fakery within TestInit
  37 # which can perturb tests, and takes CPU. Working with the upstream author of
  38 # any of these, to figure out how to remove them from this list, considered
  39 # "a good thing".
  40 my %abs = (
  41            '../cpan/Archive-Tar' => 1,
  42            '../cpan/AutoLoader' => 1,
  43            '../cpan/CPAN' => 1,
  44            '../cpan/Encode' => 1,
  45            '../cpan/ExtUtils-Constant' => 1,
  46            '../cpan/ExtUtils-Install' => 1,
  47            '../cpan/ExtUtils-MakeMaker' => 1,
  48            '../cpan/ExtUtils-Manifest' => 1,
  49            '../cpan/File-Fetch' => 1,
  50            '../cpan/IPC-Cmd' => 1,
  51            '../cpan/IPC-SysV' => 1,
  52            '../cpan/Locale-Codes' => 1,
  53            '../cpan/Module-Load' => 1,
  54            '../cpan/Module-Load-Conditional' => 1,
  55            '../cpan/Pod-Simple' => 1,
  56            '../cpan/Test-Simple' => 1,
  57            '../cpan/podlators' => 1,
  58            '../dist/Cwd' => 1,
  59            '../dist/Devel-PPPort' => 1,
  60            '../dist/ExtUtils-ParseXS' => 1,
  61            '../dist/Tie-File' => 1,
  62           );
  63
  64 my %temp_no_core =
  65     ('../cpan/B-Debug' => 1,
  66      '../cpan/Compress-Raw-Bzip2' => 1,
  67      '../cpan/Compress-Raw-Zlib' => 1,
  68      '../cpan/Devel-PPPort' => 1,
  69      '../cpan/Getopt-Long' => 1,
  70      '../cpan/IO-Compress' => 1,
  71      '../cpan/MIME-Base64' => 1,
  72      '../cpan/parent' => 1,
  73      '../cpan/Pod-Simple' => 1,
  74      '../cpan/podlators' => 1,
  75      '../cpan/Test-Simple' => 1,
  76      '../cpan/Tie-RefHash' => 1,
  77      '../cpan/Unicode-Collate' => 1,
  78      '../dist/Unicode-Normalize' => 1,
  79     );
  80
  81 # temporary workaround Apr 2017.  These need '.' in @INC.
  82 # Ideally this # list will eventually be empty
  83
  84 my %temp_needs_dot  = map { $_ => 1 } qw(
  85     ../cpan/ExtUtils-Install
  86     ../cpan/Filter-Util-Call
  87     ../cpan/libnet
  88     ../cpan/Locale-Codes
  89     ../cpan/Math-BigInt
  90     ../cpan/Math-BigRat
  91     ../cpan/Test-Harness
  92     ../cpan/Test-Simple
  93     ../cpan/version
  94 );
  95
  96
  97 # delete env vars that may influence the results
  98 # but allow override via *_TEST env var if wanted
  99 # (e.g. PERL5OPT_TEST=-d:NYTProf)
 100 my @bad_env_vars = qw(
 101     PERL5LIB PERLLIB PERL5OPT
 102     PERL_YAML_BACKEND PERL_JSON_BACKEND
 103 );
 104
 105 for my $envname (@bad_env_vars) {
 106     my $override = $ENV{"${envname}_TEST"};
 107     if (defined $override) {
 108         warn "$0: $envname=$override\n";
 109         $ENV{$envname} = $override;
 110     }
 111     else {
 112         delete $ENV{$envname};
 113     }
 114 }
 115
 116 # Location to put the Valgrind log.
 117 our $Valgrind_Log;
 118
 119 my %skip = (
 120             '.' => 1,
 121             '..' => 1,
 122             'CVS' => 1,
 123             'RCS' => 1,
 124             'SCCS' => 1,
 125             '.svn' => 1,
 126            );
 127
 128
 129 if ($::do_nothing) {
 130     return 1;
 131 }
 132
 133 $| = 1;
 134
 135 # for testing TEST only
 136 #BEGIN { require '../lib/strict.pm'; "strict"->import() };
 137 #BEGIN { require '../lib/warnings.pm'; "warnings"->import() };
 138
 139 # remove empty elements due to insertion of empty symbols via "''p1'" syntax
 140 @ARGV = grep($_,@ARGV) if $^O eq 'VMS';
 141
 142 # String eval to avoid loading File::Glob on non-miniperl.
 143 # (Windows only uses this script for miniperl.)
 144 @ARGV = eval 'map glob, @ARGV' if $^O eq 'MSWin32';
 145
 146 our $show_elapsed_time = $ENV{HARNESS_TIMER} || 0;
 147
 148 # Cheesy version of Getopt::Std.  We can't replace it with that, because we
 149 # can't rely on require working.
 150 {
 151     my @argv = ();
 152     foreach my $idx (0..$#ARGV) {
 153         push( @argv, $ARGV[$idx] ), next unless $ARGV[$idx] =~ /^-(\S+)$/;
 154         $::benchmark = 1 if $1 eq 'benchmark';
 155         $::core    = 1 if $1 eq 'core';
 156         $::verbose = 1 if $1 eq 'v';
 157         $::torture = 1 if $1 eq 'torture';
 158         $::with_utf8 = 1 if $1 eq 'utf8';
 159         $::with_utf16 = 1 if $1 eq 'utf16';
 160         $::taintwarn = 1 if $1 eq 'taintwarn';
 161         if ($1 =~ /^deparse(,.+)?$/) {
 162             $::deparse = 1;
 163             $::deparse_opts = $1;
 164             _process_deparse_config();
 165         }
 166     }
 167     @ARGV = @argv;
 168 }
 169
 170 chdir 't' if -f 't/TEST';
 171 if (-f 'TEST' && -f 'harness' && -d '../lib') {
 172     @INC = '../lib';
 173 }
 174
 175 die "You need to run \"make test_prep\" first to set things up.\n"
 176   unless -e 'perl' or -e 'perl.exe' or -e 'perl.pm';
 177
 178 # check leakage for embedders
 179 $ENV{PERL_DESTRUCT_LEVEL} = 2 unless exists $ENV{PERL_DESTRUCT_LEVEL};
 180 # check existence of all symbols
 181 $ENV{PERL_DL_NONLAZY} = 1 unless exists $ENV{PERL_DL_NONLAZY};
 182
 183 $ENV{EMXSHELL} = 'sh';        # For OS/2
 184
 185 if ($show_elapsed_time) { require Time::HiRes }
 186 my %timings = (); # testname => [@et] pairs if $show_elapsed_time.
 187
 188 # Roll your own File::Find!
 189 sub _find_tests { our @found=(); push @ARGV, _find_files('\.t$', $_[0]) }
 190 sub _find_files {
 191     my($patt, @dirs) = @_;
 192     for my $dir (@dirs) {
 193         opendir DIR, $dir or die "Trouble opening $dir: $!";
 194         foreach my $f (sort { $a cmp $b } readdir DIR) {
 195             next if $skip{$f};
 196
 197             my $fullpath = "$dir/$f";
 198
 199             if (-d $fullpath) {
 200                 _find_files($patt, $fullpath);
 201             } elsif ($f =~ /$patt/) {
 202                 push @found, $fullpath;
 203             }
 204         }
 205     }
 206     @found;
 207 }
 208
 209
 210 # Scan the text of the test program to find switches and special options
 211 # we might need to apply.
 212 sub _scan_test {
 213     my($test, $type) = @_;
 214
 215     open(my $script, "<", $test) or die "Can't read $test.\n";
 216     my $first_line = <$script>;
 217
 218     $first_line =~ tr/\0//d if $::with_utf16;
 219
 220     my $switch = "";
 221     if ($first_line =~ /#!.*\bperl.*\s-\w*([tT])/) {
 222         $switch = "-$1";
 223     } else {
 224         if ($::taintwarn) {
 225             # not all tests are expected to pass with this option
 226             $switch = '-t';
 227         } else {
 228             $switch = '';
 229         }
 230     }
 231
 232     my $file_opts = "";
 233     if ($type eq 'deparse') {
 234         # Look for #line directives which change the filename
 235         while (<$script>) {
 236             $file_opts = $file_opts . ",-f$3$4"
 237               if /^#\s*line\s+(\d+)\s+((\w+)|"([^"]+)")/;
 238         }
 239     }
 240
 241     close $script;
 242
 243     my $perl = $^O eq 'MSWin32' ? '.\perl' : './perl';
 244     my $lib  = '../lib';
 245     my $run_dir;
 246     my $return_dir;
 247
 248     $test =~ /^(.+)\/[^\/]+/;
 249     my $dir = $1;
 250     my $testswitch = $dir_to_switch{$dir};
 251     if (!defined $testswitch) {
 252         if ($test =~ s!^(\.\./(cpan|dist|ext)/[^/]+)/t!t!) {
 253             $run_dir = $1;
 254             $return_dir = '../../t';
 255             $lib = '../../lib';
 256             $perl = '../../t/perl';
 257             $testswitch = "-I../.. -MTestInit=U2T";
 258             if ($2 eq 'cpan' || $2 eq 'dist') {
 259                 if($abs{$run_dir}) {
 260                     $testswitch = $testswitch . ',A';
 261                 }
 262                 if ($temp_no_core{$run_dir}) {
 263                     $testswitch = $testswitch . ',NC';
 264                 }
 265                 if($temp_needs_dot{$run_dir}) {
 266                     $testswitch = $testswitch . ',DOT';
 267                 }
 268             }
 269         } elsif ($test =~ m!^\.\./lib!) {
 270             $testswitch = '-I.. -MTestInit=U1'; # -T will remove . from @INC
 271         } else {
 272             $testswitch = '-I.. -MTestInit';  # -T will remove . from @INC
 273         }
 274     }
 275
 276     my $utf8 = ($::with_utf8 || $::with_utf16) ? "-I$lib -Mutf8" : '';
 277
 278     my %options = (
 279         perl => $perl,
 280         lib => $lib,
 281         test => $test,
 282         run_dir => $run_dir,
 283         return_dir => $return_dir,
 284         testswitch => $testswitch,
 285         utf8 => $utf8,
 286         file => $file_opts,
 287         switch => $switch,
 288     );
 289
 290     return \%options;
 291 }
 292
 293 sub _cmd {
 294     my($options, $type) = @_;
 295
 296     my $test = $options->{test};
 297
 298     my $cmd;
 299     if ($type eq 'deparse') {
 300         my $perl = "$options->{perl} $options->{testswitch}";
 301         my $lib = $options->{lib};
 302
 303         $cmd = (
 304           "$perl $options->{switch} -I$lib -MO=-qq,Deparse,-sv1.,".
 305           "-l$::deparse_opts$options->{file} ".
 306           "$test > $test.dp ".
 307           "&& $perl $options->{switch} -I$lib $test.dp"
 308         );
 309     }
 310     elsif ($type eq 'perl') {
 311         my $perl = $options->{perl};
 312         my $redir = $^O eq 'VMS' ? '2>&1' : '';
 313
 314         if ($ENV{PERL_VALGRIND}) {
 315             my $perl_supp = $options->{return_dir} ? "$options->{return_dir}/perl.supp" : "perl.supp";
 316             my $valgrind_exe = $ENV{VALGRIND} // 'valgrind';
 317             if ($options->{run_dir}) {
 318                 require Cwd;
 319                 $Valgrind_Log = Cwd::abs_path("$options->{run_dir}/$Valgrind_Log");
 320             }
 321             my $vg_opts = $ENV{VG_OPTS}
 322                //   "--log-file=$Valgrind_Log "
 323                   . "--suppressions=$perl_supp --leak-check=yes "
 324                   . "--leak-resolution=high --show-reachable=yes "
 325                   . "--num-callers=50 --track-origins=yes";
 326             # Force logging if not asked for (so cachegrind reporting works below)
 327             if ($vg_opts !~ /--log-file/) {
 328                 $vg_opts = "--log-file=$Valgrind_Log $vg_opts";
 329             }
 330             $perl = "$valgrind_exe $vg_opts $perl";
 331         }
 332
 333         my $args = "$options->{testswitch} $options->{switch} $options->{utf8}";
 334         $cmd = $perl . _quote_args($args) . " $test $redir";
 335     }
 336     return $cmd;
 337 }
 338
 339 sub _before_fork {
 340     my ($options) = @_;
 341
 342     if ($options->{run_dir}) {
 343         my $run_dir = $options->{run_dir};
 344         chdir $run_dir or die "Can't chdir to '$run_dir': $!";
 345     }
 346
 347     # Remove previous valgrind output otherwise it will interfere
 348     my $test = $options->{test};
 349
 350     (local $Valgrind_Log = "$test.valgrind-current") =~ s/^.*\///;
 351
 352     if ($ENV{PERL_VALGRIND} && -e $Valgrind_Log) {
 353         unlink $Valgrind_Log
 354             or warn "$0: Failed to unlink '$Valgrind_Log': $!\n";
 355     }
 356
 357     return;
 358 }
 359
 360 sub _after_fork {
 361     my ($options) = @_;
 362
 363     if ($options->{return_dir}) {
 364         my $return_dir = $options->{return_dir};
 365         chdir $return_dir
 366            or die "Can't chdir from '$options->{run_dir}' to '$return_dir': $!";
 367     }
 368
 369     return;
 370 }
 371
 372 sub _run_test {
 373     my ($test, $type) = @_;
 374
 375     my $options = _scan_test($test, $type);
 376     # $test might have changed if we're in ext/Foo, so don't use it anymore
 377     # from now on. Use $options->{test} instead.
 378
 379     _before_fork($options);
 380
 381     my $cmd = _cmd($options, $type);
 382
 383     open(my $results, "$cmd |") or print "can't run '$cmd': $!.\n";
 384
 385     _after_fork($options);
 386
 387     # Our environment may force us to use UTF-8, but we can't be sure that
 388     # anything we're reading from will be generating (well formed) UTF-8
 389     # This may not be the best way - possibly we should unset ${^OPEN} up
 390     # top?
 391     binmode $results;
 392
 393     return $results;
 394 }
 395
 396 sub _quote_args {
 397     my ($args) = @_;
 398     my $argstring = '';
 399
 400     foreach (split(/\s+/,$args)) {
 401        # In VMS protect with doublequotes because otherwise
 402        # DCL will lowercase -- unless already doublequoted.
 403        $_ = q(").$_.q(") if ($^O eq 'VMS') && !/^\"/ && length($_) > 0;
 404        $argstring = $argstring . ' ' . $_;
 405     }
 406     return $argstring;
 407 }
 408
 409 sub _populate_hash {
 410     return unless defined $_[0];
 411     return map {$_, 1} split /\s+/, $_[0];
 412 }
 413
 414 sub _tests_from_manifest {
 415     my ($extensions, $known_extensions) = @_;
 416     my %skip;
 417     my %extensions = _populate_hash($extensions);
 418     my %known_extensions = _populate_hash($known_extensions);
 419
 420     foreach (keys %known_extensions) {
 421         $skip{$_} = 1 unless $extensions{$_};
 422     }
 423
 424     my @results;
 425     my $mani = '../MANIFEST';
 426     if (open(MANI, $mani)) {
 427         while (<MANI>) {
 428             if (m!^((?:cpan|dist|ext)/(\S+)/+(?:[^/\s]+\.t|test\.pl)|lib/\S+?(?:\.t|test\.pl))\s!) {
 429                 my $t = $1;
 430                 my $extension = $2;
 431
 432                 # XXX Generates way too many error lines currently.  Skip for
 433                 # v5.22
 434                 next if $t =~ /^cpan/ && ord("A") != 65;
 435
 436                 if (!$::core || $t =~ m!^lib/[a-z]!) {
 437                     if (defined $extension) {
 438                         $extension =~ s!/t(:?/\S+)*$!!;
 439                         # XXX Do I want to warn that I'm skipping these?
 440                         next if $skip{$extension};
 441                         my $flat_extension = $extension;
 442                         $flat_extension =~ s!-!/!g;
 443                         next if $skip{$flat_extension}; # Foo/Bar may live in Foo-Bar
 444                     }
 445                     my $path = "../$t";
 446                     push @results, $path;
 447                     $::path_to_name{$path} = $t;
 448                 }
 449             }
 450         }
 451         close MANI;
 452     } else {
 453         warn "$0: cannot open $mani: $!\n";
 454     }
 455     return @results;
 456 }
 457
 458 unless (@ARGV) {
 459     # base first, as TEST bails out if that can't run
 460     # then comp, to validate that require works
 461     # then run, to validate that -M works
 462     # then we know we can -MTestInit for everything else, making life simpler
 463     foreach my $dir (qw(base comp run cmd io re opbasic op uni mro perf)) {
 464         _find_tests($dir);
 465     }
 466     unless ($::core) {
 467         _find_tests('porting');
 468         _find_tests("lib");
 469     }
 470     # Config.pm may be broken for make minitest. And this is only a refinement
 471     # for skipping tests on non-default builds, so it is allowed to fail.
 472     # What we want to to is make a list of extensions which we did not build.
 473     my $configsh = '../config.sh';
 474     my ($extensions, $known_extensions);
 475     if (-f $configsh) {
 476         open FH, $configsh or die "Can't open $configsh: $!";
 477         while (<FH>) {
 478             if (/^extensions=['"](.*)['"]$/) {
 479                 $extensions = $1;
 480             }
 481             elsif (/^known_extensions=['"](.*)['"]$/) {
 482                 $known_extensions = $1;
 483             }
 484         }
 485         if (!defined $known_extensions) {
 486             warn "No known_extensions line found in $configsh";
 487         }
 488         if (!defined $extensions) {
 489             warn "No extensions line found in $configsh";
 490         }
 491     }
 492     # The "complex" constructions of list return from a subroutine, and push of
 493     # a list, might fail if perl is really hosed, but they aren't needed for
 494     # make minitest, and the building of extensions will likely also fail if
 495     # something is that badly wrong.
 496     push @ARGV, _tests_from_manifest($extensions, $known_extensions);
 497     unless ($::core) {
 498         _find_tests('japh') if $::torture;
 499         _find_tests('benchmark') if $::benchmark or $ENV{PERL_BENCHMARK};
 500         _find_tests('bigmem') if $ENV{PERL_TEST_MEMORY};
 501     }
 502 }
 503 @ARGV= do {
 504     my @order= (
 505         "base",
 506         "comp",
 507         "run",
 508         "cmd",
 509         "io",
 510         "re",
 511         "opbasic",
 512         "op",
 513         "uni",
 514         "mro",
 515         "lib",
 516         "ext",
 517         "dist",
 518         "cpan",
 519         "perf",
 520         "porting",
 521     );
 522     my %order= map { $order[$_] => 1+$_ } 0..$#order;
 523     my $idx= 0;
 524     map {
 525         $_->[0]
 526     } sort {
 527             $a->[3] <=> $b->[3] ||
 528             $a->[1] <=> $b->[1]
 529     } map {
 530         my $root= /(\w+)/ ? $1 : "";
 531         [ $_, $idx++, $root, $order{$root}||=0 ]
 532     } @ARGV;
 533 };
 534
 535 if ($::deparse) {
 536     _testprogs('deparse', '',   @ARGV);
 537 }
 538 elsif ($::with_utf16) {
 539     for my $e (0, 1) {
 540         for my $b (0, 1) {
 541             print STDERR "# ENDIAN $e BOM $b\n";
 542             my @UARGV;
 543             for my $a (@ARGV) {
 544                 my $u = $a . "." . ($e ? "l" : "b") . "e" . ($b ? "b" : "");
 545                 my $f = $e ? "v" : "n";
 546                 push @UARGV, $u;
 547                 unlink($u);
 548                 if (open(A, $a)) {
 549                     if (open(U, ">$u")) {
 550                         print U pack("$f", 0xFEFF) if $b;
 551                         while (<A>) {
 552                             print U pack("$f*", unpack("C*", $_));
 553                         }
 554                         close(U);
 555                     }
 556                     close(A);
 557                 }
 558             }
 559             _testprogs('perl', '', @UARGV);
 560             unlink(@UARGV);
 561         }
 562     }
 563 }
 564 else {
 565     _testprogs('perl',    '',   @ARGV);
 566 }
 567
 568 sub _testprogs {
 569     my ($type, $args, @tests) = @_;
 570
 571     print <<'EOT' if ($type eq 'deparse');
 572 ------------------------------------------------------------------------------
 573 TESTING DEPARSER
 574 ------------------------------------------------------------------------------
 575 EOT
 576
 577     $::bad_files = 0;
 578
 579     foreach my $t (@tests) {
 580       unless (exists $::path_to_name{$t}) {
 581         my $tname = "t/$t";
 582         $::path_to_name{$t} = $tname;
 583       }
 584     }
 585     my $maxlen = 0;
 586     foreach (@::path_to_name{@tests}) {
 587         s/\.\w+\z/ /; # space gives easy doubleclick to select fname
 588         my $len = length ;
 589         $maxlen = $len if $len > $maxlen;
 590     }
 591     # + 3 : we want three dots between the test name and the "ok"
 592     my $dotdotdot = $maxlen + 3 ;
 593     my $grind_ct = 0;           # count of non-empty valgrind reports
 594     my $total_files = @tests;
 595     my $good_files = 0;
 596     my $tested_files  = 0;
 597     my $totmax = 0;
 598     my %failed_tests;
 599     my @unexpected_pass; # files where deparse-skips.txt says fail but passed
 600     my $toolnm;         # valgrind, cachegrind, perf
 601
 602     while (my $test = shift @tests) {
 603         my ($test_start_time, @starttimes) = 0;
 604         if ($show_elapsed_time) {
 605             $test_start_time = Time::HiRes::time();
 606             # times() reports usage by TEST, but we want usage of each
 607             # testprog it calls, so record accumulated times now,
 608             # subtract them out afterwards.  Ideally, we'd take times
 609             # in BEGIN/END blocks (giving better visibility of self vs
 610             # children of each testprog), but that would require some
 611             # IPC to send results back here, or a completely different
 612             # collection scheme (Storable isn't tuned for incremental use)
 613             @starttimes = times;
 614         }
 615         if ($test =~ /^$/) {
 616             next;
 617         }
 618         if ($type eq 'deparse' && $test =~ $deparse_skips) {
 619             next;
 620         }
 621         my $te = $::path_to_name{$test} . '.'
 622                     x ($dotdotdot - length($::path_to_name{$test})) .' ';
 623
 624         if ($^O ne 'VMS') {  # defer printing on VMS due to piping bug
 625             print $te;
 626             $te = '';
 627         }
 628
 629         (local $Valgrind_Log = "$test.valgrind-current") =~ s/^.*\///;
 630
 631         my $results = _run_test($test, $type);
 632
 633         my $failure;
 634         my $next = 0;
 635         my $seen_leader = 0;
 636         my $seen_ok = 0;
 637         my $trailing_leader = 0;
 638         my $max;
 639         my %todo;
 640         while (<$results>) {
 641             next if /^\s*$/; # skip blank lines
 642             if (/^1..$/ && ($^O eq 'VMS')) {
 643                 # VMS pipe bug inserts blank lines.
 644                 my $l2 = <$results>;
 645                 if ($l2 =~ /^\s*$/) {
 646                     $l2 = <$results>;
 647                 }
 648                 $_ = '1..' . $l2;
 649             }
 650             if ($::verbose) {
 651                 print $_;
 652             }
 653             unless (/^\#/) {
 654                 if ($trailing_leader) {
 655                     # shouldn't be anything following a postfix 1..n
 656                     $failure = 'FAILED--extra output after trailing 1..n';
 657                     last;
 658                 }
 659                 if (/^1\.\.([0-9]+)( todo ([\d ]+))?/) {
 660                     if ($seen_leader) {
 661                         $failure = 'FAILED--seen duplicate leader';
 662                         last;
 663                     }
 664                     $max = $1;
 665                     %todo = map { $_ => 1 } split / /, $3 if $3;
 666                     $totmax = $totmax + $max;
 667                     $tested_files = $tested_files + 1;
 668                     if ($seen_ok) {
 669                         # 1..n appears at end of file
 670                         $trailing_leader = 1;
 671                         if ($next != $max) {
 672                             $failure = "FAILED--expected $max tests, saw $next";
 673                             last;
 674                         }
 675                     }
 676                     else {
 677                         $next = 0;
 678                     }
 679                     $seen_leader = 1;
 680                 }
 681                 else {
 682                     if (/^(not )?ok(?: (\d+))?[^\#]*(\s*\#.*)?/) {
 683                         unless ($seen_leader) {
 684                             unless ($seen_ok) {
 685                                 $next = 0;
 686                             }
 687                         }
 688                         $seen_ok = 1;
 689                         $next = $next + 1;
 690                         my($not, $num, $extra, $istodo) = ($1, $2, $3, 0);
 691                         $num = $next unless $num;
 692
 693                         if ($num == $next) {
 694
 695                             # SKIP is essentially the same as TODO for t/TEST
 696                             # this still conforms to TAP:
 697                             # http://testanything.org/wiki/index.php/TAP_specification
 698                             $extra and $istodo = $extra =~ /#\s*(?:TODO|SKIP)\b/;
 699                             $istodo = 1 if $todo{$num};
 700
 701                             if( $not && !$istodo ) {
 702                                 $failure = "FAILED at test $num";
 703                                 last;
 704                             }
 705                         }
 706                         else {
 707                             $failure ="FAILED--expected test $next, saw test $num";
 708                             last;
 709                         }
 710                     }
 711                     elsif (/^Bail out!\s*(.*)/i) { # magic words
 712                         die "FAILED--Further testing stopped" . ($1 ? ": $1\n" : ".\n");
 713                     }
 714                     else {
 715                         # module tests are allowed extra output,
 716                         # because Test::Harness allows it
 717                         next if $test =~ /^\W*(cpan|dist|ext|lib)\b/;
 718                         $failure = "FAILED--unexpected output at test $next";
 719                         last;
 720                     }
 721                 }
 722             }
 723         }
 724         my  @junk = <$results>;  # dump remaining output to prevent SIGPIPE
 725                                  # (so far happens only on os390)
 726         close $results;
 727         undef @junk;
 728
 729         if (not defined $failure) {
 730             $failure = 'FAILED--no leader found' unless $seen_leader;
 731         }
 732
 733         _check_valgrind(\$toolnm, \$grind_ct, \$test);
 734
 735         if ($type eq 'deparse' && !$ENV{KEEP_DEPARSE_FILES}) {
 736             unlink "./$test.dp";
 737         }
 738         if (not defined $failure and $next != $max) {
 739             $failure="FAILED--expected $max tests, saw $next";
 740         }
 741
 742         if( !defined $failure  # don't mask a test failure
 743             and $? )
 744         {
 745             $failure = "FAILED--non-zero wait status: $?";
 746         }
 747
 748         # Deparse? Should it have passed or failed?
 749         if ($type eq 'deparse' && $test =~ $deparse_failures) {
 750             if (!$failure) {
 751                 # Wait, it didn't fail? Great news!
 752                 push @unexpected_pass, $test;
 753             } else {
 754                 # Bah, still failing. Mask it.
 755                 print "${te}skipped\n";
 756                 $tested_files = $tested_files - 1;
 757                 next;
 758             }
 759         }
 760
 761         if (defined $failure) {
 762             print "${te}$failure\n";
 763             $::bad_files = $::bad_files + 1;
 764             if ($test =~ /^base/ && ! defined &DynaLoader::boot_DynaLoader) {
 765                 # Die if running under minitest (no DynaLoader).  Otherwise
 766                 # keep going, as  we know that Perl basically works, or we
 767                 # would not have been able to actually compile it all the way.
 768                 die "Failed a basic test ($test) under minitest -- cannot continue.\n";
 769             }
 770             $failed_tests{$test} = 1;
 771         }
 772         else {
 773             if ($max) {
 774                 my ($elapsed, $etms) = ("", 0);
 775                 if ( $show_elapsed_time ) {
 776                     $etms = (Time::HiRes::time() - $test_start_time) * 1000;
 777                     $elapsed = sprintf(" %8.0f ms", $etms);
 778
 779                     my (@endtimes) = times;
 780                     $endtimes[$_] -= $starttimes[$_] for 0..$#endtimes;
 781                     splice @endtimes, 0, 2;    # drop self/harness times
 782                     $_ *= 1000 for @endtimes;  # and scale to ms
 783                     $timings{$test} = [$etms,@endtimes];
 784                     $elapsed .= sprintf(" %5.0f ms", $_) for @endtimes;
 785                 }
 786                 print "${te}ok$elapsed\n";
 787                 $good_files = $good_files + 1;
 788             }
 789             else {
 790                 print "${te}skipped\n";
 791                 $tested_files = $tested_files - 1;
 792             }
 793         }
 794     } # while tests
 795
 796     if ($::bad_files == 0) {
 797         if ($good_files) {
 798             print "All tests successful.\n";
 799             # XXX add mention of 'perlbug -ok' ?
 800         }
 801         else {
 802             die "FAILED--no tests were run for some reason.\n";
 803         }
 804     }
 805     else {
 806         my $pct = $tested_files ? sprintf("%.2f", ($tested_files - $::bad_files) / $tested_files * 100) : "0.00";
 807         my $s = $::bad_files == 1 ? "" : "s";
 808         warn "Failed $::bad_files test$s out of $tested_files, $pct% okay.\n";
 809         for my $test ( sort keys %failed_tests ) {
 810             print "\t$test\n";
 811         }
 812
 813         if (@unexpected_pass) {
 814             print <<EOF;
 815
 816 The following scripts were expected to fail under -deparse (at least
 817 according to $deparse_skip_file), but unexpectedly succeeded:
 818 EOF
 819             print "\t$_\n" for sort @unexpected_pass;
 820             print "\n";
 821         }
 822
 823         warn <<'SHRDLU_1';
 824 ### Since not all tests were successful, you may want to run some of
 825 ### them individually and examine any diagnostic messages they produce.
 826 ### See the INSTALL document's section on "make test".
 827 SHRDLU_1
 828         warn <<'SHRDLU_2' if $good_files / $total_files > 0.8;
 829 ### You have a good chance to get more information by running
 830 ###   ./perl harness
 831 ### in the 't' directory since most (>=80%) of the tests succeeded.
 832 SHRDLU_2
 833         if (eval {require Config; import Config; 1}) {
 834             if ($::Config{usedl} && (my $p = $::Config{ldlibpthname})) {
 835                 warn <<SHRDLU_3;
 836 ### You may have to set your dynamic library search path,
 837 ### $p, to point to the build directory:
 838 SHRDLU_3
 839                 if (exists $ENV{$p} && $ENV{$p} ne '') {
 840                     warn <<SHRDLU_4a;
 841 ###   setenv $p `pwd`:\$$p; cd t; ./perl harness
 842 ###   $p=`pwd`:\$$p; export $p; cd t; ./perl harness
 843 ###   export $p=`pwd`:\$$p; cd t; ./perl harness
 844 SHRDLU_4a
 845                 } else {
 846                     warn <<SHRDLU_4b;
 847 ###   setenv $p `pwd`; cd t; ./perl harness
 848 ###   $p=`pwd`; export $p; cd t; ./perl harness
 849 ###   export $p=`pwd`; cd t; ./perl harness
 850 SHRDLU_4b
 851                 }
 852                 warn <<SHRDLU_5;
 853 ### for csh-style shells, like tcsh; or for traditional/modern
 854 ### Bourne-style shells, like bash, ksh, and zsh, respectively.
 855 SHRDLU_5
 856             }
 857         }
 858     }
 859     printf "Elapsed: %d sec\n", time() - $t0;
 860     my ($user,$sys,$cuser,$csys) = times;
 861     my $tot = sprintf("u=%.2f  s=%.2f  cu=%.2f  cs=%.2f  scripts=%d  tests=%d",
 862                       $user,$sys,$cuser,$csys,$tested_files,$totmax);
 863     print "$tot\n";
 864     if ($good_files) {
 865         if (-d $show_elapsed_time) {
 866             # HARNESS_TIMER = <a-directory>.  Save timings etc to
 867             # storable file there.  NB: the test cds to ./t/, so
 868             # relative path must account for that, ie ../../perf
 869             # points to dir next to source tree.
 870             require Storable;
 871             my @dt = localtime;
 872             $dt[5] += 1900; $dt[4] += 1; # fix year, month
 873             my $fn = "$show_elapsed_time/".join('-', @dt[5,4,3,2,1]).".ttimes";
 874             Storable::store({ perf => \%timings,
 875                               gather_conf_platform_info(),
 876                               total => $tot,
 877                             }, $fn);
 878             print "wrote storable file: $fn\n";
 879         }
 880     }
 881
 882     _cleanup_valgrind(\$toolnm, \$grind_ct);
 883 }
 884 exit ($::bad_files != 0);
 885
 886 # Collect platform, config data that should allow comparing
 887 # performance data between different machines.  With enough data,
 888 # and/or clever statistical analysis, it should be possible to
 889 # determine the effect of config choices, more memory, etc
 890
 891 sub gather_conf_platform_info {
 892     # currently rather quick & dirty, and subject to change
 893     # for both content and format.
 894     require Config;
 895     my (%conf, @platform) = ();
 896     $conf{$_} = $Config::Config{$_} for
 897         grep /cc|git|config_arg\d+/, keys %Config::Config;
 898     if (-f '/proc/cpuinfo') {
 899         open my $fh, '/proc/cpuinfo' or warn "$!: /proc/cpuinfo\n";
 900         @platform = grep /name|cpu/, <$fh>;
 901         chomp $_ for @platform;
 902     }
 903     unshift @platform, $^O;
 904
 905     return (
 906         conf => \%conf,
 907         platform => {cpu => \@platform,
 908                      mem => [ grep s/\s+/ /,
 909                               grep chomp, `free` ],
 910                      load => [ grep chomp, `uptime` ],
 911         },
 912         host => (grep chomp, `hostname -f`),
 913         version => '0.03', # bump for conf, platform, or data collection changes
 914         );
 915 }
 916
 917 sub _check_valgrind {
 918     return unless $ENV{PERL_VALGRIND};
 919
 920     my ($toolnm, $grind_ct, $test) = @_;
 921
 922     $$toolnm = $ENV{VALGRIND};
 923     $$toolnm =~ s|.*/||;  # keep basename
 924     my @valgrind;       # gets content of file
 925     if (-e $Valgrind_Log) {
 926         if (open(V, $Valgrind_Log)) {
 927             @valgrind = <V>;
 928             close V;
 929         } else {
 930             warn "$0: Failed to open '$Valgrind_Log': $!\n";
 931         }
 932     }
 933     if ($ENV{VG_OPTS} =~ /(cachegrind)/ or $$toolnm =~ /(perf)/) {
 934         $$toolnm = $1;
 935         if ($$toolnm eq 'perf') {
 936             # append perfs subcommand, not just stat
 937             my ($sub) = split /\s/, $ENV{VG_OPTS};
 938             $$toolnm .= "-$sub";
 939         }
 940         if (rename $Valgrind_Log, "$$test.$$toolnm") {
 941             $$grind_ct++;
 942         } else {
 943             warn "$0: Failed to create '$$test.$$toolnm': $!\n";
 944         }
 945     }
 946     elsif (@valgrind) {
 947         my $leaks = 0;
 948         my $errors = 0;
 949         for my $i (0..$#valgrind) {
 950             local $_ = $valgrind[$i];
 951             if (/^==\d+== ERROR SUMMARY: (\d+) errors? /) {
 952                 $errors = $errors + $1;   # there may be multiple error summaries
 953             } elsif (/^==\d+== LEAK SUMMARY:/) {
 954                 for my $off (1 .. 4) {
 955                     if ($valgrind[$i+$off] =~
 956                         /(?:lost|reachable):\s+\d+ bytes in (\d+) blocks/) {
 957                             $leaks = $leaks + $1;
 958                     }
 959                 }
 960             }
 961         }
 962         if ($errors or $leaks) {
 963             if (rename $Valgrind_Log, "$$test.valgrind") {
 964                 $$grind_ct = $$grind_ct + 1;
 965             } else {
 966                 warn "$0: Failed to create '$$test.valgrind': $!\n";
 967             }
 968         }
 969     } else {
 970         # Quiet wasn't asked for? Something may be amiss
 971         if ($ENV{VG_OPTS} && $ENV{VG_OPTS} !~ /(^|\s)(-q|--quiet)(\s|$)/) {
 972             warn "No valgrind output?\n";
 973         }
 974     }
 975     if (-e $Valgrind_Log) {
 976         unlink $Valgrind_Log
 977             or warn "$0: Failed to unlink '$Valgrind_Log': $!\n";
 978     }
 979 }
 980
 981 sub _cleanup_valgrind {
 982     return unless $ENV{PERL_VALGRIND};
 983
 984     my ($toolnm, $grind_ct) = @_;
 985     my $s = $$grind_ct == 1 ? '' : 's';
 986     print "$$grind_ct valgrind report$s created.\n", ;
 987     if ($$toolnm eq 'cachegrind') {
 988         # cachegrind leaves a lot of cachegrind.out.$pid litter
 989         # around the tree, find and delete them
 990         unlink _find_files('cachegrind.out.\d+$',
 991                      qw ( ../t ../cpan ../ext ../dist/ ));
 992     }
 993 }
 994
 995 # Generate regexps of known bad filenames / skips from Porting/deparse-skips.txt
 996
 997 sub _process_deparse_config {
 998     my @deparse_failures;
 999     my @deparse_skips;
1000
1001     my $f = $deparse_skip_file;
1002
1003     my $skips;
1004     if (!open($skips, '<', $f)) {
1005         warn "Failed to find $f: $!\n";
1006         return;
1007     }
1008
1009     my $in;
1010     while(<$skips>) {
1011         if (/__DEPARSE_FAILURES__/) {
1012             $in = \@deparse_failures; next;
1013         } elsif (/__DEPARSE_SKIPS__/) {
1014             $in = \@deparse_skips; next;
1015         } elsif (!$in) {
1016             next;
1017         }
1018
1019         s/#.*$//; # Kill comments
1020         s/\s+$//; # And trailing whitespace
1021
1022         next unless $_;
1023
1024         push @$in, $_;
1025         warn "WARNING: $f:$.: excluded file doesn't exist: $_\n" unless -f $_;
1026     }
1027
1028     for my $f (@deparse_failures, @deparse_skips) {
1029         if ($f =~ m|/$|) { # Dir? Skip everything below it
1030             $f = qr/\Q$f\E.*/;
1031         } else {
1032             $f = qr/\Q$f\E/;
1033         }
1034     }
1035
1036     $deparse_failures = join('|', @deparse_failures);
1037     $deparse_failures = qr/^(?:$deparse_failures)$/;
1038
1039     $deparse_skips = join('|', @deparse_skips);
1040     $deparse_skips = qr/^(?:$deparse_skips)$/;
1041 }
1042
1043 # ex: set ts=8 sts=4 sw=4 noet: