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