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