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