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 # 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 450unless (@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 527if ($::deparse) { 528 _testprogs('deparse', '', @ARGV); 529} 530elsif ($::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} 556else { 557 _testprogs('perl', '', @ARGV); 558} 559 560sub _testprogs { 561 my ($type, $args, @tests) = @_; 562 563 print <<'EOT' if ($type eq 'deparse'); 564------------------------------------------------------------------------------ 565TESTING DEPARSER 566------------------------------------------------------------------------------ 567EOT 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 808The following scripts were expected to fail under -deparse (at least 809according to $deparse_skip_file), but unexpectedly succeeded: 810EOF 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". 819SHRDLU_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. 824SHRDLU_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: 830SHRDLU_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 836SHRDLU_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 842SHRDLU_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. 847SHRDLU_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} 876exit ($::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 883sub 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 909sub _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 973sub _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 994sub _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: 1041