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