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