t/TEST

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