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