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