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     my %printed_skip_warning;
 400
 401     foreach (keys %known_extensions) {
 402         $skip{$_} = 1 unless $extensions{$_};
 403     }
 404
 405     my @results;
 406     my $mani = '../MANIFEST';
 407     if (open(MANI, $mani)) {
 408         while (<MANI>) {
 409             if (m!^((?:cpan|dist|ext)/(\S+)/+(?:[^/\s]+\.t|test\.pl)|lib/\S+?(?:\.t|test\.pl))\s!) {
 410                 my $t = $1;
 411                 my $extension = $2;
 412
 413                 if (    ord "A" != 65
 414                      && defined $extension
 415                      && $extension =~ m! \b (?:
 416                                                 Archive-Tar/
 417                                               | Config-Perl-V/
 418                                               | CPAN-Meta/
 419                                               | CPAN-Meta-YAML/
 420                                               | Digest-SHA/
 421                                               | ExtUtils-MakeMaker/
 422                                               | HTTP-Tiny/
 423                                               | IO-Compress/
 424                                               | JSON-PP/
 425                                               | libnet/
 426                                               | MIME-Base64/
 427                                               | podlators/
 428                                               | Pod-Simple/
 429                                               | Pod-Checker/
 430                                               | Digest-MD5/
 431                                               | Test-Harness/
 432                                               | IPC-Cmd/
 433                                               | Encode/
 434                                               | Socket/
 435                                               | ExtUtils-Manifest/
 436                                               | Module-Metadata/
 437                                               | PerlIO-via-QuotedPrint/
 438                                             )
 439                                        !x)
 440                 {
 441                     print STDERR "Skipping testing of $extension on EBCDIC\n"
 442                                      unless $printed_skip_warning{$extension}++;
 443                     next;
 444                 }
 445
 446                 if (!$::core || $t =~ m!^lib/[a-z]!) {
 447                     if (defined $extension) {
 448                         $extension =~ s!/t(:?/\S+)*$!!;
 449                         # XXX Do I want to warn that I'm skipping these?
 450                         next if $skip{$extension};
 451                         my $flat_extension = $extension;
 452                         $flat_extension =~ s!-!/!g;
 453                         next if $skip{$flat_extension}; # Foo/Bar may live in Foo-Bar
 454                     }
 455                     my $path = "../$t";
 456                     push @results, $path;
 457                     $::path_to_name{$path} = $t;
 458                 }
 459             }
 460         }
 461         close MANI;
 462     } else {
 463         warn "$0: cannot open $mani: $!\n";
 464     }
 465     return @results;
 466 }
 467
 468 unless (@ARGV) {
 469     # base first, as TEST bails out if that can't run
 470     # then comp, to validate that require works
 471     # then run, to validate that -M works
 472     # then we know we can -MTestInit for everything else, making life simpler
 473     foreach my $dir (qw(base comp run cmd io re opbasic op uni mro perf)) {
 474         _find_tests($dir);
 475     }
 476     unless ($::core) {
 477         _find_tests('porting');
 478         _find_tests("lib");
 479     }
 480     # Config.pm may be broken for make minitest. And this is only a refinement
 481     # for skipping tests on non-default builds, so it is allowed to fail.
 482     # What we want to do is make a list of extensions which we did not build.
 483     my $configsh = '../config.sh';
 484     my ($extensions, $known_extensions);
 485     if (-f $configsh) {
 486         open FH, $configsh or die "Can't open $configsh: $!";
 487         while (<FH>) {
 488             if (/^extensions=['"](.*)['"]$/) {
 489                 $extensions = $1;
 490             }
 491             elsif (/^known_extensions=['"](.*)['"]$/) {
 492                 $known_extensions = $1;
 493             }
 494         }
 495         if (!defined $known_extensions) {
 496             warn "No known_extensions line found in $configsh";
 497         }
 498         if (!defined $extensions) {
 499             warn "No extensions line found in $configsh";
 500         }
 501     }
 502     # The "complex" constructions of list return from a subroutine, and push of
 503     # a list, might fail if perl is really hosed, but they aren't needed for
 504     # make minitest, and the building of extensions will likely also fail if
 505     # something is that badly wrong.
 506     push @ARGV, _tests_from_manifest($extensions, $known_extensions);
 507     unless ($::core) {
 508         _find_tests('japh') if $::torture;
 509         _find_tests('benchmark') if $::benchmark or $ENV{PERL_BENCHMARK};
 510         _find_tests('bigmem') if $ENV{PERL_TEST_MEMORY};
 511     }
 512 }
 513 @ARGV= do {
 514     my @order= (
 515         "base",
 516         "comp",
 517         "run",
 518         "cmd",
 519         "io",
 520         "re",
 521         "opbasic",
 522         "op",
 523         "uni",
 524         "mro",
 525         "lib",
 526         "ext",
 527         "dist",
 528         "cpan",
 529         "perf",
 530         "porting",
 531     );
 532     my %order= map { $order[$_] => 1+$_ } 0..$#order;
 533     my $idx= 0;
 534     map {
 535         $_->[0]
 536     } sort {
 537             $a->[3] <=> $b->[3] ||
 538             $a->[1] <=> $b->[1]
 539     } map {
 540         my $root= /(\w+)/ ? $1 : "";
 541         [ $_, $idx++, $root, $order{$root}||=0 ]
 542     } @ARGV;
 543 };
 544
 545 if ($::deparse) {
 546     _testprogs('deparse', '',   @ARGV);
 547 }
 548 elsif ($::with_utf16) {
 549     for my $e (0, 1) {
 550         for my $b (0, 1) {
 551             print STDERR "# ENDIAN $e BOM $b\n";
 552             my @UARGV;
 553             for my $a (@ARGV) {
 554                 my $u = $a . "." . ($e ? "l" : "b") . "e" . ($b ? "b" : "");
 555                 my $f = $e ? "v" : "n";
 556                 push @UARGV, $u;
 557                 unlink($u);
 558                 if (open(A, $a)) {
 559                     if (open(U, ">$u")) {
 560                         print U pack("$f", 0xFEFF) if $b;
 561                         while (<A>) {
 562                             print U pack("$f*", unpack("C*", $_));
 563                         }
 564                         close(U);
 565                     }
 566                     close(A);
 567                 }
 568             }
 569             _testprogs('perl', '', @UARGV);
 570             unlink(@UARGV);
 571         }
 572     }
 573 }
 574 else {
 575     _testprogs('perl',    '',   @ARGV);
 576 }
 577
 578 sub _testprogs {
 579     my ($type, $args, @tests) = @_;
 580
 581     print <<'EOT' if ($type eq 'deparse');
 582 ------------------------------------------------------------------------------
 583 TESTING DEPARSER
 584 ------------------------------------------------------------------------------
 585 EOT
 586
 587     $::bad_files = 0;
 588
 589     foreach my $t (@tests) {
 590       unless (exists $::path_to_name{$t}) {
 591         my $tname = "t/$t";
 592         $::path_to_name{$t} = $tname;
 593       }
 594     }
 595     my $maxlen = 0;
 596     foreach (@::path_to_name{@tests}) {
 597         s/\.\w+\z/ /; # space gives easy doubleclick to select fname
 598         my $len = length ;
 599         $maxlen = $len if $len > $maxlen;
 600     }
 601     # + 3 : we want three dots between the test name and the "ok"
 602     my $dotdotdot = $maxlen + 3 ;
 603     my $grind_ct = 0;           # count of non-empty valgrind reports
 604     my $total_files = @tests;
 605     my $good_files = 0;
 606     my $tested_files  = 0;
 607     my $totmax = 0;
 608     my %failed_tests;
 609     my @unexpected_pass; # files where deparse-skips.txt says fail but passed
 610     my $toolnm;         # valgrind, cachegrind, perf
 611
 612     while (my $test = shift @tests) {
 613         my ($test_start_time, @starttimes) = 0;
 614         if ($show_elapsed_time) {
 615             $test_start_time = Time::HiRes::time();
 616             # times() reports usage by TEST, but we want usage of each
 617             # testprog it calls, so record accumulated times now,
 618             # subtract them out afterwards.  Ideally, we'd take times
 619             # in BEGIN/END blocks (giving better visibility of self vs
 620             # children of each testprog), but that would require some
 621             # IPC to send results back here, or a completely different
 622             # collection scheme (Storable isn't tuned for incremental use)
 623             @starttimes = times;
 624         }
 625         if ($test =~ /^$/) {
 626             next;
 627         }
 628         if ($type eq 'deparse' && $test =~ $deparse_skips) {
 629             next;
 630         }
 631         my $te = $::path_to_name{$test} . '.'
 632                     x ($dotdotdot - length($::path_to_name{$test})) .' ';
 633
 634         if ($^O ne 'VMS') {  # defer printing on VMS due to piping bug
 635             print $te;
 636             $te = '';
 637         }
 638
 639         (local $Valgrind_Log = "$test.valgrind-current") =~ s/^.*\///;
 640
 641         my $results = _run_test($test, $type);
 642
 643         my $failure;
 644         my $next = 0;
 645         my $seen_leader = 0;
 646         my $seen_ok = 0;
 647         my $trailing_leader = 0;
 648         my $max;
 649         my %todo;
 650         while (<$results>) {
 651             next if /^\s*$/; # skip blank lines
 652             if (/^1..$/ && ($^O eq 'VMS')) {
 653                 # VMS pipe bug inserts blank lines.
 654                 my $l2 = <$results>;
 655                 if ($l2 =~ /^\s*$/) {
 656                     $l2 = <$results>;
 657                 }
 658                 $_ = '1..' . $l2;
 659             }
 660             if ($::verbose) {
 661                 print $_;
 662             }
 663             unless (/^\#/) {
 664                 if ($trailing_leader) {
 665                     # shouldn't be anything following a postfix 1..n
 666                     $failure = 'FAILED--extra output after trailing 1..n';
 667                     last;
 668                 }
 669                 if (/^1\.\.([0-9]+)( todo ([\d ]+))?/) {
 670                     if ($seen_leader) {
 671                         $failure = 'FAILED--seen duplicate leader';
 672                         last;
 673                     }
 674                     $max = $1;
 675                     %todo = map { $_ => 1 } split / /, $3 if $3;
 676                     $totmax = $totmax + $max;
 677                     $tested_files = $tested_files + 1;
 678                     if ($seen_ok) {
 679                         # 1..n appears at end of file
 680                         $trailing_leader = 1;
 681                         if ($next != $max) {
 682                             $failure = "FAILED--expected $max tests, saw $next";
 683                             last;
 684                         }
 685                     }
 686                     else {
 687                         $next = 0;
 688                     }
 689                     $seen_leader = 1;
 690                 }
 691                 else {
 692                     if (/^(not )?ok(?: (\d+))?[^\#]*(\s*\#.*)?/) {
 693                         unless ($seen_leader) {
 694                             unless ($seen_ok) {
 695                                 $next = 0;
 696                             }
 697                         }
 698                         $seen_ok = 1;
 699                         $next = $next + 1;
 700                         my($not, $num, $extra, $istodo) = ($1, $2, $3, 0);
 701                         $num = $next unless $num;
 702
 703                         if ($num == $next) {
 704
 705                             # SKIP is essentially the same as TODO for t/TEST
 706                             # this still conforms to TAP:
 707                             # http://testanything.org/wiki/index.php/TAP_specification
 708                             $extra and $istodo = $extra =~ /#\s*(?:TODO|SKIP)\b/;
 709                             $istodo = 1 if $todo{$num};
 710
 711                             if( $not && !$istodo ) {
 712                                 $failure = "FAILED at test $num";
 713                                 last;
 714                             }
 715                         }
 716                         else {
 717                             $failure ="FAILED--expected test $next, saw test $num";
 718                             last;
 719                         }
 720                     }
 721                     elsif (/^Bail out!\s*(.*)/i) { # magic words
 722                         die "FAILED--Further testing stopped" . ($1 ? ": $1\n" : ".\n");
 723                     }
 724                     else {
 725                         # module tests are allowed extra output,
 726                         # because Test::Harness allows it
 727                         next if $test =~ /^\W*(cpan|dist|ext|lib)\b/;
 728                         $failure = "FAILED--unexpected output at test $next";
 729                         last;
 730                     }
 731                 }
 732             }
 733         }
 734         my  @junk = <$results>;  # dump remaining output to prevent SIGPIPE
 735                                  # (so far happens only on os390)
 736         close $results;
 737         undef @junk;
 738
 739         if (not defined $failure) {
 740             $failure = 'FAILED--no leader found' unless $seen_leader;
 741         }
 742
 743         _check_valgrind(\$toolnm, \$grind_ct, \$test);
 744
 745         if ($type eq 'deparse' && !$ENV{KEEP_DEPARSE_FILES}) {
 746             unlink "./$test.dp";
 747         }
 748         if (not defined $failure and $next != $max) {
 749             $failure="FAILED--expected $max tests, saw $next";
 750         }
 751
 752         if( !defined $failure  # don't mask a test failure
 753             and $? )
 754         {
 755             $failure = "FAILED--non-zero wait status: $?";
 756         }
 757
 758         # Deparse? Should it have passed or failed?
 759         if ($type eq 'deparse' && $test =~ $deparse_failures) {
 760             if (!$failure) {
 761                 # Wait, it didn't fail? Great news!
 762                 push @unexpected_pass, $test;
 763             } else {
 764                 # Bah, still failing. Mask it.
 765                 print "${te}skipped\n";
 766                 $tested_files = $tested_files - 1;
 767                 next;
 768             }
 769         }
 770
 771         if (defined $failure) {
 772             print "${te}$failure\n";
 773             $::bad_files = $::bad_files + 1;
 774             if ($test =~ /^base/ && ! defined &DynaLoader::boot_DynaLoader) {
 775                 # Die if running under minitest (no DynaLoader).  Otherwise
 776                 # keep going, as  we know that Perl basically works, or we
 777                 # would not have been able to actually compile it all the way.
 778                 die "Failed a basic test ($test) under minitest -- cannot continue.\n";
 779             }
 780             $failed_tests{$test} = 1;
 781         }
 782         else {
 783             if ($max) {
 784                 my ($elapsed, $etms) = ("", 0);
 785                 if ( $show_elapsed_time ) {
 786                     $etms = (Time::HiRes::time() - $test_start_time) * 1000;
 787                     $elapsed = sprintf(" %8.0f ms", $etms);
 788
 789                     my (@endtimes) = times;
 790                     $endtimes[$_] -= $starttimes[$_] for 0..$#endtimes;
 791                     splice @endtimes, 0, 2;    # drop self/harness times
 792                     $_ *= 1000 for @endtimes;  # and scale to ms
 793                     $timings{$test} = [$etms,@endtimes];
 794                     $elapsed .= sprintf(" %5.0f ms", $_) for @endtimes;
 795                 }
 796                 print "${te}ok$elapsed\n";
 797                 $good_files = $good_files + 1;
 798             }
 799             else {
 800                 print "${te}skipped\n";
 801                 $tested_files = $tested_files - 1;
 802             }
 803         }
 804     } # while tests
 805
 806     if ($::bad_files == 0) {
 807         if ($good_files) {
 808             print "All tests successful.\n";
 809             # XXX add mention of 'perlbug -ok' ?
 810         }
 811         else {
 812             die "FAILED--no tests were run for some reason.\n";
 813         }
 814     }
 815     else {
 816         my $pct = $tested_files ? sprintf("%.2f", ($tested_files - $::bad_files) / $tested_files * 100) : "0.00";
 817         my $s = $::bad_files == 1 ? "" : "s";
 818         warn "Failed $::bad_files test$s out of $tested_files, $pct% okay.\n";
 819         for my $test ( sort keys %failed_tests ) {
 820             print "\t$test\n";
 821         }
 822
 823         if (@unexpected_pass) {
 824             print <<EOF;
 825
 826 The following scripts were expected to fail under -deparse (at least
 827 according to $deparse_skip_file), but unexpectedly succeeded:
 828 EOF
 829             print "\t$_\n" for sort @unexpected_pass;
 830             print "\n";
 831         }
 832
 833         warn <<'SHRDLU_1';
 834 ### Since not all tests were successful, you may want to run some of
 835 ### them individually and examine any diagnostic messages they produce.
 836 ### See the INSTALL document's section on "make test".
 837 SHRDLU_1
 838         warn <<'SHRDLU_2' if $good_files / $total_files > 0.8;
 839 ### You have a good chance to get more information by running
 840 ###   ./perl harness
 841 ### in the 't' directory since most (>=80%) of the tests succeeded.
 842 SHRDLU_2
 843         if (eval {require Config; import Config; 1}) {
 844             if ($::Config{usedl} && (my $p = $::Config{ldlibpthname})) {
 845                 warn <<SHRDLU_3;
 846 ### You may have to set your dynamic library search path,
 847 ### $p, to point to the build directory:
 848 SHRDLU_3
 849                 if (exists $ENV{$p} && $ENV{$p} ne '') {
 850                     warn <<SHRDLU_4a;
 851 ###   setenv $p `pwd`:\$$p; cd t; ./perl harness
 852 ###   $p=`pwd`:\$$p; export $p; cd t; ./perl harness
 853 ###   export $p=`pwd`:\$$p; cd t; ./perl harness
 854 SHRDLU_4a
 855                 } else {
 856                     warn <<SHRDLU_4b;
 857 ###   setenv $p `pwd`; cd t; ./perl harness
 858 ###   $p=`pwd`; export $p; cd t; ./perl harness
 859 ###   export $p=`pwd`; cd t; ./perl harness
 860 SHRDLU_4b
 861                 }
 862                 warn <<SHRDLU_5;
 863 ### for csh-style shells, like tcsh; or for traditional/modern
 864 ### Bourne-style shells, like bash, ksh, and zsh, respectively.
 865 SHRDLU_5
 866             }
 867         }
 868     }
 869     printf "Elapsed: %d sec\n", time() - $t0;
 870     my ($user,$sys,$cuser,$csys) = times;
 871     my $tot = sprintf("u=%.2f  s=%.2f  cu=%.2f  cs=%.2f  scripts=%d  tests=%d",
 872                       $user,$sys,$cuser,$csys,$tested_files,$totmax);
 873     print "$tot\n";
 874     if ($good_files) {
 875         if (-d $show_elapsed_time) {
 876             # HARNESS_TIMER = <a-directory>.  Save timings etc to
 877             # storable file there.  NB: the test cds to ./t/, so
 878             # relative path must account for that, ie ../../perf
 879             # points to dir next to source tree.
 880             require Storable;
 881             my @dt = localtime;
 882             $dt[5] += 1900; $dt[4] += 1; # fix year, month
 883             my $fn = "$show_elapsed_time/".join('-', @dt[5,4,3,2,1]).".ttimes";
 884             Storable::store({ perf => \%timings,
 885                               gather_conf_platform_info(),
 886                               total => $tot,
 887                             }, $fn);
 888             print "wrote storable file: $fn\n";
 889         }
 890     }
 891
 892     _cleanup_valgrind(\$toolnm, \$grind_ct);
 893 }
 894 exit ($::bad_files != 0);
 895
 896 # Collect platform, config data that should allow comparing
 897 # performance data between different machines.  With enough data,
 898 # and/or clever statistical analysis, it should be possible to
 899 # determine the effect of config choices, more memory, etc
 900
 901 sub gather_conf_platform_info {
 902     # currently rather quick & dirty, and subject to change
 903     # for both content and format.
 904     require Config;
 905     my (%conf, @platform) = ();
 906     $conf{$_} = $Config::Config{$_} for
 907         grep /cc|git|config_arg\d+/, keys %Config::Config;
 908     if (-f '/proc/cpuinfo') {
 909         open my $fh, '/proc/cpuinfo' or warn "$!: /proc/cpuinfo\n";
 910         @platform = grep /name|cpu/, <$fh>;
 911         chomp $_ for @platform;
 912     }
 913     unshift @platform, $^O;
 914
 915     return (
 916         conf => \%conf,
 917         platform => {cpu => \@platform,
 918                      mem => [ grep s/\s+/ /,
 919                               grep chomp, `free` ],
 920                      load => [ grep chomp, `uptime` ],
 921         },
 922         host => (grep chomp, `hostname -f`),
 923         version => '0.03', # bump for conf, platform, or data collection changes
 924         );
 925 }
 926
 927 sub _check_valgrind {
 928     return unless $ENV{PERL_VALGRIND};
 929
 930     my ($toolnm, $grind_ct, $test) = @_;
 931
 932     $$toolnm = $ENV{VALGRIND};
 933     $$toolnm =~ s|.*/||;  # keep basename
 934     my @valgrind;       # gets content of file
 935     if (-e $Valgrind_Log) {
 936         if (open(V, $Valgrind_Log)) {
 937             @valgrind = <V>;
 938             close V;
 939         } else {
 940             warn "$0: Failed to open '$Valgrind_Log': $!\n";
 941         }
 942     }
 943     if ($ENV{VG_OPTS} =~ /(cachegrind)/ or $$toolnm =~ /(perf)/) {
 944         $$toolnm = $1;
 945         if ($$toolnm eq 'perf') {
 946             # append perfs subcommand, not just stat
 947             my ($sub) = split /\s/, $ENV{VG_OPTS};
 948             $$toolnm .= "-$sub";
 949         }
 950         if (rename $Valgrind_Log, "$$test.$$toolnm") {
 951             $$grind_ct++;
 952         } else {
 953             warn "$0: Failed to create '$$test.$$toolnm': $!\n";
 954         }
 955     }
 956     elsif (@valgrind) {
 957         my $leaks = 0;
 958         my $errors = 0;
 959         for my $i (0..$#valgrind) {
 960             local $_ = $valgrind[$i];
 961             if (/^==\d+== ERROR SUMMARY: (\d+) errors? /) {
 962                 $errors = $errors + $1;   # there may be multiple error summaries
 963             } elsif (/^==\d+== LEAK SUMMARY:/) {
 964                 for my $off (1 .. 4) {
 965                     if ($valgrind[$i+$off] =~
 966                         /(?:lost|reachable):\s+\d+ bytes in (\d+) blocks/) {
 967                             $leaks = $leaks + $1;
 968                     }
 969                 }
 970             }
 971         }
 972         if ($errors or $leaks) {
 973             if (rename $Valgrind_Log, "$$test.valgrind") {
 974                 $$grind_ct = $$grind_ct + 1;
 975             } else {
 976                 warn "$0: Failed to create '$$test.valgrind': $!\n";
 977             }
 978         }
 979     } else {
 980         # Quiet wasn't asked for? Something may be amiss
 981         if ($ENV{VG_OPTS} && $ENV{VG_OPTS} !~ /(^|\s)(-q|--quiet)(\s|$)/) {
 982             warn "No valgrind output?\n";
 983         }
 984     }
 985     if (-e $Valgrind_Log) {
 986         unlink $Valgrind_Log
 987             or warn "$0: Failed to unlink '$Valgrind_Log': $!\n";
 988     }
 989 }
 990
 991 sub _cleanup_valgrind {
 992     return unless $ENV{PERL_VALGRIND};
 993
 994     my ($toolnm, $grind_ct) = @_;
 995     my $s = $$grind_ct == 1 ? '' : 's';
 996     print "$$grind_ct valgrind report$s created.\n", ;
 997     if ($$toolnm eq 'cachegrind') {
 998         # cachegrind leaves a lot of cachegrind.out.$pid litter
 999         # around the tree, find and delete them
1000         unlink _find_files('cachegrind.out.\d+$',
1001                      qw ( ../t ../cpan ../ext ../dist/ ));
1002     }
1003     elsif ($$toolnm eq 'valgrind') {
1004         # Remove empty, hence non-error, output files
1005         unlink grep { -z } _find_files('valgrind-current',
1006                      qw ( ../t ../cpan ../ext ../dist/ ));
1007     }
1008 }
1009
1010 # Generate regexps of known bad filenames / skips from Porting/deparse-skips.txt
1011
1012 sub _process_deparse_config {
1013     my @deparse_failures;
1014     my @deparse_skips;
1015
1016     my $f = $deparse_skip_file;
1017
1018     my $skips;
1019     if (!open($skips, '<', $f)) {
1020         warn "Failed to find $f: $!\n";
1021         return;
1022     }
1023
1024     my $in;
1025     while(<$skips>) {
1026         if (/__DEPARSE_FAILURES__/) {
1027             $in = \@deparse_failures; next;
1028         } elsif (/__DEPARSE_SKIPS__/) {
1029             $in = \@deparse_skips; next;
1030         } elsif (!$in) {
1031             next;
1032         }
1033
1034         s/#.*$//; # Kill comments
1035         s/\s+$//; # And trailing whitespace
1036
1037         next unless $_;
1038
1039         push @$in, $_;
1040         warn "WARNING: $f:$.: excluded file doesn't exist: $_\n" unless -f $_;
1041     }
1042
1043     for my $f (@deparse_failures, @deparse_skips) {
1044         if ($f =~ m|/$|) { # Dir? Skip everything below it
1045             $f = qr/\Q$f\E.*/;
1046         } else {
1047             $f = qr/\Q$f\E/;
1048         }
1049     }
1050
1051     $deparse_failures = join('|', @deparse_failures);
1052     $deparse_failures = qr/^(?:$deparse_failures)$/;
1053
1054     $deparse_skips = join('|', @deparse_skips);
1055     $deparse_skips = qr/^(?:$deparse_skips)$/;
1056 }
1057
1058 # ex: set ts=8 sts=4 sw=4 noet: