X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/4bda23b9621837bd0312f7e4011c13c212e8bdaa..c8191e192267f85bc25e6d4758e5c4344c984ffd:/t/TEST diff --git a/t/TEST b/t/TEST index 618db5f..5d25af6 100755 --- a/t/TEST +++ b/t/TEST @@ -14,6 +14,11 @@ # In which case, we need to stop t/TEST actually running tests, as all # t/harness needs are its subroutines. +# If we're doing deparse tests, ignore failures for these +my $deparse_failures; + +# And skip even running these +my $deparse_skips; # directories with special sets of test switches my %dir_to_switch = @@ -31,27 +36,24 @@ my %abs = ( '../cpan/Archive-Tar' => 1, '../cpan/AutoLoader' => 1, '../cpan/CPAN' => 1, - '../cpan/Class-ISA' => 1, '../cpan/Devel-PPPort' => 1, '../cpan/Encode' => 1, + '../cpan/ExtUtils-Command' => 1, '../cpan/ExtUtils-Constant' => 1, + '../cpan/ExtUtils-Install' => 1, '../cpan/ExtUtils-MakeMaker' => 1, + '../cpan/ExtUtils-Manifest' => 1, '../cpan/File-Fetch' => 1, '../cpan/IPC-Cmd' => 1, '../cpan/IPC-SysV' => 1, '../cpan/Locale-Codes' => 1, - '../cpan/Module-Build' => 1, '../cpan/Module-Load' => 1, '../cpan/Module-Load-Conditional' => 1, - '../cpan/Package-Constants' => 1, '../cpan/Parse-CPAN-Meta' => 1, '../cpan/Pod-Simple' => 1, '../cpan/Test-Simple' => 1, '../cpan/podlators' => 1, '../dist/Cwd' => 1, - '../dist/ExtUtils-Command' => 1, - '../dist/ExtUtils-Install' => 1, - '../dist/ExtUtils-Manifest' => 1, '../dist/ExtUtils-ParseXS' => 1, '../dist/Tie-File' => 1, ); @@ -93,13 +95,23 @@ for my $envname (@bad_env_vars) { } } +# Location to put the Valgrind log. +our $Valgrind_Log; + +my %skip = ( + '.' => 1, + '..' => 1, + 'CVS' => 1, + 'RCS' => 1, + 'SCCS' => 1, + '.svn' => 1, + ); + + if ($::do_nothing) { return 1; } -# Location to put the Valgrind log. -our $Valgrind_Log; - $| = 1; # for testing TEST only @@ -126,6 +138,7 @@ our $show_elapsed_time = $ENV{HARNESS_TIMER} || 0; if ($1 =~ /^deparse(,.+)?$/) { $::deparse = 1; $::deparse_opts = $1; + _process_deparse_config(); } } @ARGV = @argv; @@ -139,21 +152,6 @@ if (-f 'TEST' && -f 'harness' && -d '../lib') { die "You need to run \"make test\" first to set things up.\n" unless -e 'perl' or -e 'perl.exe' or -e 'perl.pm'; -if ($ENV{PERL_3LOG}) { # Tru64 third(1) tool, see perlhack - unless (-x 'perl.third') { - unless (-x '../perl.third') { - die "You need to run \"make perl.third first.\n"; - } - else { - print "Symlinking ../perl.third as perl.third...\n"; - die "Failed to symlink: $!\n" - unless symlink("../perl.third", "perl.third"); - die "Symlinked but no executable perl.third: $!\n" - unless -x 'perl.third'; - } - } -} - # check leakage for embedders $ENV{PERL_DESTRUCT_LEVEL} = 2 unless exists $ENV{PERL_DESTRUCT_LEVEL}; # check existence of all symbols @@ -164,15 +162,6 @@ $ENV{EMXSHELL} = 'sh'; # For OS/2 if ($show_elapsed_time) { require Time::HiRes } my %timings = (); # testname => [@et] pairs if $show_elapsed_time. -my %skip = ( - '.' => 1, - '..' => 1, - 'CVS' => 1, - 'RCS' => 1, - 'SCCS' => 1, - '.svn' => 1, - ); - # Roll your own File::Find! sub _find_tests { our @found=(); push @ARGV, _find_files('\.t$', $_[0]) } sub _find_files { @@ -299,16 +288,19 @@ sub _cmd { if ($ENV{PERL_VALGRIND}) { my $perl_supp = $options->{return_dir} ? "$options->{return_dir}/perl.supp" : "perl.supp"; my $valgrind_exe = $ENV{VALGRIND} // 'valgrind'; + if ($options->{run_dir}) { + $Valgrind_Log = "$options->{run_dir}/$Valgrind_Log"; + } my $vg_opts = $ENV{VG_OPTS} - // '--log-fd=3 ' + // "--log-file=$Valgrind_Log " . "--suppressions=$perl_supp --leak-check=yes " . "--leak-resolution=high --show-reachable=yes " - . "--num-callers=50 --track-origins=yes"; + . "--num-callers=50 --track-origins=yes"; + # Force logging if not asked for (so cachegrind reporting works below) + if ($vg_opts !~ /--log-file/) { + $vg_opts = "--log-file=$Valgrind_Log $vg_opts"; + } $perl = "$valgrind_exe $vg_opts $perl"; - $redir = "3>$Valgrind_Log"; - if ($options->{run_dir}) { - $Valgrind_Log = "$options->{run_dir}/$Valgrind_Log"; - } } my $args = "$options->{testswitch} $options->{switch} $options->{utf8}"; @@ -325,6 +317,16 @@ sub _before_fork { chdir $run_dir or die "Can't chdir to '$run_dir': $!"; } + # Remove previous valgrind output otherwise it will interfere + my $test = $options->{test}; + + (local $Valgrind_Log = "$test.valgrind-current") =~ s/^.*\///; + + if ($ENV{PERL_VALGRIND} && -e $Valgrind_Log) { + unlink $Valgrind_Log + or warn "$0: Failed to unlink '$Valgrind_Log': $!\n"; + } + return; } @@ -461,7 +463,6 @@ unless (@ARGV) { # something is that badly wrong. push @ARGV, _tests_from_manifest($extensions, $known_extensions); unless ($::core) { - _find_tests('x2p'); _find_tests('japh') if $::torture; _find_tests('t/benchmark') if $::benchmark or $ENV{PERL_BENCHMARK}; _find_tests('bigmem') if $ENV{PERL_TEST_MEMORY}; @@ -550,15 +551,8 @@ EOT if ($test =~ /^$/) { next; } - if ($type eq 'deparse') { - if ($test eq "comp/redef.t") { - # Redefinition happens at compile time - next; - } - elsif ($test =~ m{lib/Switch/t/}) { - # B::Deparse doesn't support source filtering - next; - } + if ($type eq 'deparse' && $test =~ $deparse_skips) { + next; } my $te = $::path_to_name{$test} . '.' x ($dotdotdot - length($::path_to_name{$test})) .' '; @@ -568,7 +562,8 @@ EOT $te = ''; } - (local $Valgrind_Log = "$test.valgrind-current") =~ s/^.*\///; + (local $Valgrind_Log = "$test.valgrind-current") =~ s/^.*\///; + my $results = _run_test($test, $type); my $failure; @@ -668,73 +663,11 @@ EOT $failure = 'FAILED--no leader found' unless $seen_leader; } - if ($ENV{PERL_VALGRIND}) { - $toolnm = $ENV{VALGRIND}; - $toolnm =~ s|.*/||; # keep basename - my @valgrind; # gets content of file - if (-e $Valgrind_Log) { - if (open(V, $Valgrind_Log)) { - @valgrind = ; - close V; - } else { - warn "$0: Failed to open '$Valgrind_Log': $!\n"; - } - } - if ($ENV{VG_OPTS} =~ /(cachegrind)/ or $toolnm =~ /(perf)/) { - $toolnm = $1; - if ($toolnm eq 'perf') { - # append perfs subcommand, not just stat - my ($sub) = split /\s/, $ENV{VG_OPTS}; - $toolnm .= "-$sub"; - } - if (rename $Valgrind_Log, "$test.$toolnm") { - $grind_ct++; - } else { - warn "$0: Failed to create '$test.$toolnm': $!\n"; - } - } - elsif (@valgrind) { - my $leaks = 0; - my $errors = 0; - for my $i (0..$#valgrind) { - local $_ = $valgrind[$i]; - if (/^==\d+== ERROR SUMMARY: (\d+) errors? /) { - $errors = $errors + $1; # there may be multiple error summaries - } elsif (/^==\d+== LEAK SUMMARY:/) { - for my $off (1 .. 4) { - if ($valgrind[$i+$off] =~ - /(?:lost|reachable):\s+\d+ bytes in (\d+) blocks/) { - $leaks = $leaks + $1; - } - } - } - } - if ($errors or $leaks) { - if (rename $Valgrind_Log, "$test.valgrind") { - $grind_ct = $grind_ct + 1; - } else { - warn "$0: Failed to create '$test.valgrind': $!\n"; - } - } - } else { - warn "No valgrind output?\n"; - } - if (-e $Valgrind_Log) { - unlink $Valgrind_Log - or warn "$0: Failed to unlink '$Valgrind_Log': $!\n"; - } - } - if ($type eq 'deparse') { + _check_valgrind(\$toolnm, \$grind_ct, \$test); + + if ($type eq 'deparse' && !$ENV{KEEP_DEPARSE_FILES}) { unlink "./$test.dp"; } - if ($ENV{PERL_3LOG}) { - my $tpp = $test; - $tpp =~ s:^\.\./::; - $tpp =~ s:/:_:g; - $tpp =~ s:\.t$:.3log:; - rename("perl.3log", $tpp) || - die "rename: perl3.log to $tpp: $!\n"; - } if (not defined $failure and $next != $max) { $failure="FAILED--expected $max tests, saw $next"; } @@ -745,11 +678,27 @@ EOT $failure = "FAILED--non-zero wait status: $?"; } + # Deparse? Should it have passed or failed? + if ($type eq 'deparse' && $test =~ $deparse_failures) { + if (!$failure) { + # Wait, it didn't fail? Great news! Tell someone! + $failure = "FAILED--all tests passed but test should have failed"; + } else { + # Bah, still failing. Mask it. + print "${te}skipped\n"; + $tested_files = $tested_files - 1; + next; + } + } + if (defined $failure) { print "${te}$failure\n"; $::bad_files = $::bad_files + 1; - if ($test =~ /^base/) { - die "Failed a basic test ($test) -- cannot continue.\n"; + if ($test =~ /^base/ && ! defined &DynaLoader::boot_DynaLoader) { + # Die if running under minitest (no DynaLoader). Otherwise + # keep going, as we know that Perl basically works, or we + # would not have been able to actually compile it all the way. + die "Failed a basic test ($test) under minitest -- cannot continue.\n"; } $failed_tests{$test} = 1; } @@ -850,16 +799,8 @@ SHRDLU_5 print "wrote storable file: $fn\n"; } } - if ($ENV{PERL_VALGRIND}) { - my $s = $grind_ct == 1 ? '' : 's'; - print "$grind_ct valgrind report$s created.\n", ; - if ($toolnm eq 'cachegrind') { - # cachegrind leaves a lot of cachegrind.out.$pid litter - # around the tree, find and delete them - unlink _find_files('cachegrind.out.\d+$', - qw ( ../t ../cpan ../ext ../dist/ )); - } - } + + _cleanup_valgrind(\$toolnm, \$grind_ct); } exit ($::bad_files != 0); @@ -894,4 +835,129 @@ sub gather_conf_platform_info { ); } +sub _check_valgrind { + return unless $ENV{PERL_VALGRIND}; + + my ($toolnm, $grind_ct, $test) = @_; + + $$toolnm = $ENV{VALGRIND}; + $$toolnm =~ s|.*/||; # keep basename + my @valgrind; # gets content of file + if (-e $Valgrind_Log) { + if (open(V, $Valgrind_Log)) { + @valgrind = ; + close V; + } else { + warn "$0: Failed to open '$Valgrind_Log': $!\n"; + } + } + if ($ENV{VG_OPTS} =~ /(cachegrind)/ or $$toolnm =~ /(perf)/) { + $$toolnm = $1; + if ($$toolnm eq 'perf') { + # append perfs subcommand, not just stat + my ($sub) = split /\s/, $ENV{VG_OPTS}; + $$toolnm .= "-$sub"; + } + if (rename $Valgrind_Log, "$$test.$$toolnm") { + $$grind_ct++; + } else { + warn "$0: Failed to create '$$test.$$toolnm': $!\n"; + } + } + elsif (@valgrind) { + my $leaks = 0; + my $errors = 0; + for my $i (0..$#valgrind) { + local $_ = $valgrind[$i]; + if (/^==\d+== ERROR SUMMARY: (\d+) errors? /) { + $errors = $errors + $1; # there may be multiple error summaries + } elsif (/^==\d+== LEAK SUMMARY:/) { + for my $off (1 .. 4) { + if ($valgrind[$i+$off] =~ + /(?:lost|reachable):\s+\d+ bytes in (\d+) blocks/) { + $leaks = $leaks + $1; + } + } + } + } + if ($errors or $leaks) { + if (rename $Valgrind_Log, "$$test.valgrind") { + $$grind_ct = $$grind_ct + 1; + } else { + warn "$0: Failed to create '$$test.valgrind': $!\n"; + } + } + } else { + # Quiet wasn't asked for? Something may be amiss + if ($ENV{VG_OPTS} && $ENV{VG_OPTS} !~ /(^|\s)(-q|--quiet)(\s|$)/) { + warn "No valgrind output?\n"; + } + } + if (-e $Valgrind_Log) { + unlink $Valgrind_Log + or warn "$0: Failed to unlink '$Valgrind_Log': $!\n"; + } +} + +sub _cleanup_valgrind { + return unless $ENV{PERL_VALGRIND}; + + my ($toolnm, $grind_ct) = @_; + my $s = $$grind_ct == 1 ? '' : 's'; + print "$$grind_ct valgrind report$s created.\n", ; + if ($$toolnm eq 'cachegrind') { + # cachegrind leaves a lot of cachegrind.out.$pid litter + # around the tree, find and delete them + unlink _find_files('cachegrind.out.\d+$', + qw ( ../t ../cpan ../ext ../dist/ )); + } +} + +# Generate regexps of known bad filenames / skips from Porting/deparse-skips.txt +my $in; + +sub _process_deparse_config { + my @deparse_failures; + my @deparse_skips; + + my $f = '../Porting/deparse-skips.txt'; + + my $skips; + if (!open($skips, '<', $f)) { + warn "Failed to find $f: $!\n"; + return; + } + + while(<$skips>) { + if (/__DEPARSE_FAILURES__/) { + $in = \@deparse_failures; next; + } elsif (/__DEPARSE_SKIPS__/) { + $in = \@deparse_skips; next; + } elsif (!$in) { + next; + } + + s/#.*$//; # Kill comments + s/\s+$//; # And trailing whitespace + + next unless $_; + + push @$in, $_; + } + + for my $f (@deparse_failures, @deparse_skips) { + if ($f =~ m|/$|) { # Dir? Skip everything below it + $f = qr/\Q$f\E.*/; + } else { + $f = qr/\Q$f\E/; + } + } + + $deparse_failures = join('|', @deparse_failures); + $deparse_failures = qr/^(?:$deparse_failures)$/; + + $deparse_skips = join('|', @deparse_skips); + $deparse_skips = qr/^(?:$deparse_skips)$/; +} + # ex: set ts=8 sts=4 sw=4 noet: