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