X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/b7c8007e17dac1921298ae21cba58fd10cfde840..2ca4a82e4992cef284e3ce9716fea66ec947e01d:/t/TEST diff --git a/t/TEST b/t/TEST index 876d88b..f2254d5 100755 --- a/t/TEST +++ b/t/TEST @@ -2,7 +2,7 @@ # This is written in a peculiar style, since we're trying to avoid # most of the constructs we'll be testing for. (This comment is -# probably obsolete on the avoidance side, though still currrent +# probably obsolete on the avoidance side, though still current # on the peculiarity side.) # t/TEST and t/harness need to share code. The logical way to do this would be @@ -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 = @@ -23,12 +28,36 @@ my %dir_to_switch = '../ext/File-Glob/t' => '-I.. -MTestInit', # FIXME - tests assume t/ ); -# I think in the end I'd like "not absolute" to be the default", as it saves -# some fakery within TestInit which can peturb tests, and takes CPU. -my %no_abs = - ('../ext/Pod-Parser' => 1, - ); - +# "not absolute" is the default, as it saves some fakery within TestInit +# which can perturb tests, and takes CPU. Working with the upstream author of +# any of these, to figure out how to remove them from this list, considered +# "a good thing". +my %abs = ( + '../cpan/Archive-Tar' => 1, + '../cpan/AutoLoader' => 1, + '../cpan/CPAN' => 1, + '../cpan/Devel-PPPort' => 1, + '../cpan/Encode' => 1, + '../cpan/ExtUtils-Command' => 1, + '../cpan/ExtUtils-Constant' => 1, + '../cpan/ExtUtils-MakeMaker' => 1, + '../cpan/File-Fetch' => 1, + '../cpan/IPC-Cmd' => 1, + '../cpan/IPC-SysV' => 1, + '../cpan/Locale-Codes' => 1, + '../cpan/Module-Load' => 1, + '../cpan/Module-Load-Conditional' => 1, + '../cpan/Parse-CPAN-Meta' => 1, + '../cpan/Pod-Simple' => 1, + '../cpan/Test-Simple' => 1, + '../cpan/podlators' => 1, + '../dist/Cwd' => 1, + '../dist/ExtUtils-Install' => 1, + '../dist/ExtUtils-Manifest' => 1, + '../dist/ExtUtils-ParseXS' => 1, + '../dist/Tie-File' => 1, + ); + my %temp_no_core = ('../cpan/B-Debug' => 1, '../cpan/Compress-Raw-Bzip2' => 1, @@ -36,27 +65,52 @@ my %temp_no_core = '../cpan/Devel-PPPort' => 1, '../cpan/Getopt-Long' => 1, '../cpan/IO-Compress' => 1, - '../cpan/Math-BigInt' => 1, - '../cpan/Math-BigRat' => 1, '../cpan/MIME-Base64' => 1, - '../cpan/NEXT' => 1, - '../ext/parent' => 1, + '../cpan/parent' => 1, '../cpan/Parse-CPAN-Meta' => 1, - '../ext/Pod-Simple' => 1, + '../cpan/Pod-Simple' => 1, '../cpan/podlators' => 1, - '../ext/Test-Simple' => 1, + '../cpan/Test-Simple' => 1, '../cpan/Tie-RefHash' => 1, - '../ext/Time-HiRes' => 1, '../cpan/Unicode-Collate' => 1, '../cpan/Unicode-Normalize' => 1, ); -if ($::do_nothing) { - return 1; +# delete env vars that may influence the results +# but allow override via *_TEST env var if wanted +# (e.g. PERL5OPT_TEST=-d:NYTProf) +my @bad_env_vars = qw( + PERL5LIB PERLLIB PERL5OPT + PERL_YAML_BACKEND PERL_JSON_BACKEND +); + +for my $envname (@bad_env_vars) { + my $override = $ENV{"${envname}_TEST"}; + if (defined $override) { + warn "$0: $envname=$override\n"; + $ENV{$envname} = $override; + } + else { + delete $ENV{$envname}; + } } # Location to put the Valgrind log. -my $Valgrind_Log = 'current.valgrind'; +our $Valgrind_Log; + +my %skip = ( + '.' => 1, + '..' => 1, + 'CVS' => 1, + 'RCS' => 1, + 'SCCS' => 1, + '.svn' => 1, + ); + + +if ($::do_nothing) { + return 1; +} $| = 1; @@ -64,10 +118,6 @@ $| = 1; #BEGIN { require '../lib/strict.pm'; "strict"->import() }; #BEGIN { require '../lib/warnings.pm'; "warnings"->import() }; -delete $ENV{PERL5LIB}; -delete $ENV{PERLLIB}; -delete $ENV{PERL5OPT}; - # remove empty elements due to insertion of empty symbols via "''p1'" syntax @ARGV = grep($_,@ARGV) if $^O eq 'VMS'; our $show_elapsed_time = $ENV{HARNESS_TIMER} || 0; @@ -85,10 +135,10 @@ our $show_elapsed_time = $ENV{HARNESS_TIMER} || 0; $::with_utf8 = 1 if $1 eq 'utf8'; $::with_utf16 = 1 if $1 eq 'utf16'; $::taintwarn = 1 if $1 eq 'taintwarn'; - $ENV{PERL_CORE_MINITEST} = 1 if $1 eq 'minitest'; if ($1 =~ /^deparse(,.+)?$/) { $::deparse = 1; $::deparse_opts = $1; + _process_deparse_config(); } } @ARGV = @argv; @@ -102,52 +152,35 @@ 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 +$ENV{PERL_DL_NONLAZY} = 1 unless exists $ENV{PERL_DL_NONLAZY}; $ENV{EMXSHELL} = 'sh'; # For OS/2 if ($show_elapsed_time) { require Time::HiRes } - -my %skip = ( - '.' => 1, - '..' => 1, - 'CVS' => 1, - 'RCS' => 1, - 'SCCS' => 1, - '.svn' => 1, - ); +my %timings = (); # testname => [@et] pairs if $show_elapsed_time. # Roll your own File::Find! -sub _find_tests { - my($dir) = @_; - opendir DIR, $dir or die "Trouble opening $dir: $!"; - foreach my $f (sort { $a cmp $b } readdir DIR) { - next if $skip{$f}; - - my $fullpath = "$dir/$f"; - - if (-d $fullpath) { - _find_tests($fullpath); - } elsif ($f =~ /\.t$/) { - push @ARGV, $fullpath; +sub _find_tests { our @found=(); push @ARGV, _find_files('\.t$', $_[0]) } +sub _find_files { + my($patt, @dirs) = @_; + for my $dir (@dirs) { + opendir DIR, $dir or die "Trouble opening $dir: $!"; + foreach my $f (sort { $a cmp $b } readdir DIR) { + next if $skip{$f}; + + my $fullpath = "$dir/$f"; + + if (-d $fullpath) { + _find_files($patt, $fullpath); + } elsif ($f =~ /$patt/) { + push @found, $fullpath; + } } } + @found; } @@ -177,7 +210,7 @@ sub _scan_test { if ($type eq 'deparse') { # Look for #line directives which change the filename while (<$script>) { - $file_opts .= ",-f$3$4" + $file_opts = $file_opts . ",-f$3$4" if /^#\s*line\s+(\d+)\s+((\w+)|"([^"]+)")/; } } @@ -193,24 +226,28 @@ sub _scan_test { my $dir = $1; my $testswitch = $dir_to_switch{$dir}; if (!defined $testswitch) { - if ($test =~ s!^(\.\./(?:cpan|dist|ext)/[^/]+)/t!t!) { + if ($test =~ s!^(\.\./(cpan|dist|ext)/[^/]+)/t!t!) { $run_dir = $1; $return_dir = '../../t'; $lib = '../../lib'; $perl = '../../t/perl'; $testswitch = "-I../.. -MTestInit=U2T"; - if (!$no_abs{$run_dir}) { - $testswitch = $testswitch . ',A'; - } - if ($temp_no_core{$run_dir}) { - $testswitch = $testswitch . ',NC'; + if ($2 eq 'cpan' || $2 eq 'dist') { + if($abs{$run_dir}) { + $testswitch = $testswitch . ',A'; + } + if ($temp_no_core{$run_dir}) { + $testswitch = $testswitch . ',NC'; + } } + } elsif ($test =~ m!^\.\./lib!) { + $testswitch = '-I.. -MTestInit=U1'; # -T will remove . from @INC } else { $testswitch = '-I.. -MTestInit'; # -T will remove . from @INC } } - my $utf8 = $::with_utf8 ? "-I$lib -Mutf8" : ''; + my $utf8 = ($::with_utf8 || $::with_utf16) ? "-I$lib -Mutf8" : ''; my %options = ( perl => $perl, @@ -249,19 +286,26 @@ sub _cmd { my $redir = $^O eq 'VMS' ? '2>&1' : ''; if ($ENV{PERL_VALGRIND}) { - my $valgrind = $ENV{VALGRIND} // '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} - // "--suppressions=perl.supp --leak-check=yes " - . "--leak-resolution=high --show-reachable=yes " - . "--num-callers=50"; - $perl = "$valgrind --log-fd=3 $vg_opts $perl"; - $redir = "3>$Valgrind_Log"; + // "--log-file=$Valgrind_Log " + . "--suppressions=$perl_supp --leak-check=yes " + . "--leak-resolution=high --show-reachable=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"; } my $args = "$options->{testswitch} $options->{switch} $options->{utf8}"; $cmd = $perl . _quote_args($args) . " $test $redir"; } - return $cmd; } @@ -273,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; } @@ -320,7 +374,7 @@ sub _quote_args { # In VMS protect with doublequotes because otherwise # DCL will lowercase -- unless already doublequoted. $_ = q(").$_.q(") if ($^O eq 'VMS') && !/^\"/ && length($_) > 0; - $argstring .= ' ' . $_; + $argstring = $argstring . ' ' . $_; } return $argstring; } @@ -337,7 +391,7 @@ sub _tests_from_manifest { my %known_extensions = _populate_hash($known_extensions); foreach (keys %known_extensions) { - $skip{$_}++ unless $extensions{$_}; + $skip{$_} = 1 unless $extensions{$_}; } my @results; @@ -349,7 +403,7 @@ sub _tests_from_manifest { my $extension = $2; if (!$::core || $t =~ m!^lib/[a-z]!) { if (defined $extension) { - $extension =~ s!/t$!!; + $extension =~ s!/t(:?/\S+)*$!!; # XXX Do I want to warn that I'm skipping these? next if $skip{$extension}; my $flat_extension = $extension; @@ -374,10 +428,13 @@ unless (@ARGV) { # then comp, to validate that require works # then run, to validate that -M works # then we know we can -MTestInit for everything else, making life simpler - foreach my $dir (qw(base comp run cmd io re op uni mro)) { + foreach my $dir (qw(base comp run cmd io re opbasic op uni mro)) { _find_tests($dir); } - _find_tests("lib") unless $::core; + unless ($::core) { + _find_tests('porting'); + _find_tests("lib"); + } # Config.pm may be broken for make minitest. And this is only a refinement # for skipping tests on non-default builds, so it is allowed to fail. # What we want to to is make a list of extensions which we did not build. @@ -406,10 +463,9 @@ unless (@ARGV) { # something is that badly wrong. push @ARGV, _tests_from_manifest($extensions, $known_extensions); unless ($::core) { - _find_tests('x2p'); - _find_tests('porting'); _find_tests('japh') if $::torture; _find_tests('t/benchmark') if $::benchmark or $ENV{PERL_BENCHMARK}; + _find_tests('bigmem') if $ENV{PERL_TEST_MEMORY}; } } @@ -465,43 +521,49 @@ EOT } my $maxlen = 0; foreach (@::path_to_name{@tests}) { - s/\.\w+\z/./; + s/\.\w+\z/ /; # space gives easy doubleclick to select fname my $len = length ; $maxlen = $len if $len > $maxlen; } # + 3 : we want three dots between the test name and the "ok" my $dotdotdot = $maxlen + 3 ; - my $valgrind = 0; + my $grind_ct = 0; # count of non-empty valgrind reports my $total_files = @tests; my $good_files = 0; my $tested_files = 0; my $totmax = 0; my %failed_tests; + my $toolnm; # valgrind, cachegrind, perf while (my $test = shift @tests) { - my $test_start_time = $show_elapsed_time ? Time::HiRes::time() : 0; - + my ($test_start_time, @starttimes) = 0; + if ($show_elapsed_time) { + $test_start_time = Time::HiRes::time(); + # times() reports usage by TEST, but we want usage of each + # testprog it calls, so record accumulated times now, + # subtract them out afterwards. Ideally, we'd take times + # in BEGIN/END blocks (giving better visibility of self vs + # children of each testprog), but that would require some + # IPC to send results back here, or a completely different + # collection scheme (Storable isn't tuned for incremental use) + @starttimes = times; + } 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})); + x ($dotdotdot - length($::path_to_name{$test})) .' '; if ($^O ne 'VMS') { # defer printing on VMS due to piping bug print $te; $te = ''; } + (local $Valgrind_Log = "$test.valgrind-current") =~ s/^.*\///; + my $results = _run_test($test, $type); my $failure; @@ -515,9 +577,9 @@ EOT next if /^\s*$/; # skip blank lines if (/^1..$/ && ($^O eq 'VMS')) { # VMS pipe bug inserts blank lines. - my $l2 = ; + my $l2 = <$results>; if ($l2 =~ /^\s*$/) { - $l2 = ; + $l2 = <$results>; } $_ = '1..' . $l2; } @@ -537,8 +599,8 @@ EOT } $max = $1; %todo = map { $_ => 1 } split / /, $3 if $3; - $totmax += $max; - $tested_files++; + $totmax = $totmax + $max; + $tested_files = $tested_files + 1; if ($seen_ok) { # 1..n appears at end of file $trailing_leader = 1; @@ -560,7 +622,7 @@ EOT } } $seen_ok = 1; - $next++; + $next = $next + 1; my($not, $num, $extra, $istodo) = ($1, $2, $3, 0); $num = $next unless $num; @@ -568,7 +630,7 @@ EOT # SKIP is essentially the same as TODO for t/TEST # this still conforms to TAP: - # http://search.cpan.org/dist/TAP/TAP.pm + # http://testanything.org/wiki/index.php/TAP_specification $extra and $istodo = $extra =~ /#\s*(?:TODO|SKIP)\b/; $istodo = 1 if $todo{$num}; @@ -601,65 +663,11 @@ EOT $failure = 'FAILED--no leader found' unless $seen_leader; } - if ($ENV{PERL_VALGRIND}) { - my @valgrind; - 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/) { - if (rename $Valgrind_Log, "$test.valgrind") { - $valgrind++; - } else { - warn "$0: Failed to create '$test.valgrind': $!\n"; - } - } - elsif (@valgrind) { - my $leaks = 0; - my $errors = 0; - for my $i (0..$#valgrind) { - local $_ = $valgrind[$i]; - if (/^==\d+== ERROR SUMMARY: (\d+) 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 += $1; - } - } - } - } - if ($errors or $leaks) { - if (rename $Valgrind_Log, "$test.valgrind") { - $valgrind++; - } 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"; } @@ -670,29 +678,50 @@ 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++; - if ($test =~ /^base/) { - die "Failed a basic test ($test) -- cannot continue.\n"; + $::bad_files = $::bad_files + 1; + 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}; + $failed_tests{$test} = 1; } else { if ($max) { - my $elapsed; + my ($elapsed, $etms) = ("", 0); if ( $show_elapsed_time ) { - $elapsed = sprintf( " %8.0f ms", (Time::HiRes::time() - $test_start_time) * 1000 ); - } - else { - $elapsed = ""; + $etms = (Time::HiRes::time() - $test_start_time) * 1000; + $elapsed = sprintf(" %8.0f ms", $etms); + + my (@endtimes) = times; + $endtimes[$_] -= $starttimes[$_] for 0..$#endtimes; + splice @endtimes, 0, 2; # drop self/harness times + $_ *= 1000 for @endtimes; # and scale to ms + $timings{$test} = [$etms,@endtimes]; + $elapsed .= sprintf(" %5.0f ms", $_) for @endtimes; } print "${te}ok$elapsed\n"; - $good_files++; + $good_files = $good_files + 1; } else { print "${te}skipped\n"; - $tested_files -= 1; + $tested_files = $tested_files - 1; } } } # while tests @@ -750,13 +779,185 @@ SHRDLU_5 } } my ($user,$sys,$cuser,$csys) = times; - print sprintf("u=%.2f s=%.2f cu=%.2f cs=%.2f scripts=%d tests=%d\n", - $user,$sys,$cuser,$csys,$tested_files,$totmax); - if ($ENV{PERL_VALGRIND}) { - my $s = $valgrind == 1 ? '' : 's'; - print "$valgrind valgrind report$s created.\n", ; + my $tot = sprintf("u=%.2f s=%.2f cu=%.2f cs=%.2f scripts=%d tests=%d", + $user,$sys,$cuser,$csys,$tested_files,$totmax); + print "$tot\n"; + if ($good_files) { + if (-d $show_elapsed_time) { + # HARNESS_TIMER = . Save timings etc to + # storable file there. NB: the test cds to ./t/, so + # relative path must account for that, ie ../../perf + # points to dir next to source tree. + require Storable; + my @dt = localtime; + $dt[5] += 1900; $dt[4] += 1; # fix year, month + my $fn = "$show_elapsed_time/".join('-', @dt[5,4,3,2,1]).".ttimes"; + Storable::store({ perf => \%timings, + gather_conf_platform_info(), + total => $tot, + }, $fn); + print "wrote storable file: $fn\n"; + } } + + _cleanup_valgrind(\$toolnm, \$grind_ct); } exit ($::bad_files != 0); +# Collect platform, config data that should allow comparing +# performance data between different machines. With enough data, +# and/or clever statistical analysis, it should be possible to +# determine the effect of config choices, more memory, etc + +sub gather_conf_platform_info { + # currently rather quick & dirty, and subject to change + # for both content and format. + require Config; + my (%conf, @platform) = (); + $conf{$_} = $Config::Config{$_} for + grep /cc|git|config_arg\d+/, keys %Config::Config; + if (-f '/proc/cpuinfo') { + open my $fh, '/proc/cpuinfo' or warn "$!: /proc/cpuinfo\n"; + @platform = grep /name|cpu/, <$fh>; + chomp $_ for @platform; + } + unshift @platform, $^O; + + return ( + conf => \%conf, + platform => {cpu => \@platform, + mem => [ grep s/\s+/ /, + grep chomp, `free` ], + load => [ grep chomp, `uptime` ], + }, + host => (grep chomp, `hostname -f`), + version => '0.03', # bump for conf, platform, or data collection changes + ); +} + +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: