Permalink
Browse files

Coverage for subs no longer in the symbol table.

If a reference to a subroutine in the smybol table is taken, that subroutine
is removed from the symbol table but the subroutine is called via the code
reference, coverage was previously not reported for that sub.  Now it is.

Fixes rt 13207.
  • Loading branch information...
pjcj committed Dec 31, 2012
1 parent 500a023 commit 3174b8f4d9f3095e93a439694762b436844bd77a
Showing with 98 additions and 8 deletions.
  1. +19 −8 lib/Devel/Cover.pm
  2. +59 −0 test_output/cover/redefine_sub.5.006001
  3. +20 −0 tests/redefine_sub
View
@@ -69,6 +69,7 @@ my $Pod = $INC{"Pod/Coverage/CountParents.pm"} ? "Pod::Coverage::CountParents" :
my %Pod; # Pod coverage data.
my @Cvs; # All the Cvs we want to cover.
+my %Cvs; # All the Cvs we want to cover.
my @Subs; # All the subs we want to cover.
my $Cv; # Cv we are looking in.
my $Sub_name; # Name of the sub we are looking in.
@@ -604,6 +605,7 @@ sub use_file
unless $Files{$file} || $Silent
|| $file =~ $Devel::Cover::DB::Ignore_filenames;
+ add_cvs(); # add CVs now in case of symbol table manipulation
$Files{$file}
}
@@ -629,12 +631,14 @@ sub B::GV::find_cv
return unless $$cv;
# print STDERR "find_cv $$cv\n" if check_file($cv);
- push @Cvs, $cv if check_file($cv);
- push @Cvs, grep check_file($_), $cv->PADLIST->ARRAY->ARRAY
- if $cv->can("PADLIST") &&
- $cv->PADLIST->can("ARRAY") &&
- $cv->PADLIST->ARRAY &&
- $cv->PADLIST->ARRAY->can("ARRAY");
+ $Cvs{$cv} ||= $cv if check_file($cv);
+ if ($cv->can("PADLIST") &&
+ $cv->PADLIST->can("ARRAY") &&
+ $cv->PADLIST->ARRAY &&
+ $cv->PADLIST->ARRAY->can("ARRAY"))
+ {
+ $Cvs{$_} ||= $_ for grep check_file($_), $cv->PADLIST->ARRAY->ARRAY;
+ }
};
sub sub_info
@@ -666,11 +670,16 @@ sub sub_info
($name, $start)
}
+sub add_cvs
+{
+ $Cvs{$_} ||= $_ for grep check_file($_), B::main_cv->PADLIST->ARRAY->ARRAY;
+}
+
sub check_files
{
# print STDERR "Checking files\n";
- @Cvs = grep check_file($_), B::main_cv->PADLIST->ARRAY->ARRAY;
+ add_cvs();
my %seen_pkg;
my %seen_cv;
@@ -692,11 +701,13 @@ sub check_files
($line, $name)
};
+ # print Dumper \%Cvs;
+
@Cvs = map $_->[0],
sort { $a->[1] <=> $b->[1] || $a->[2] cmp $b->[2] }
map [ $_, $l->($_) ],
grep !$seen_cv{$$_}++,
- @Cvs;
+ values %Cvs;
# Hack to bump up the refcount of the subs. If we don't do this then the
# subs in some modules don't seem to be around when we get to looking at
@@ -0,0 +1,59 @@
+Reading database from ...
+
+
+------------------------------------------ ------ ------ ------ ------ ------
+File stmt bran cond sub total
+------------------------------------------ ------ ------ ------ ------ ------
+tests/redefine_sub 100.0 100.0 n/a 100.0 100.0
+Total 100.0 100.0 n/a 100.0 100.0
+------------------------------------------ ------ ------ ------ ------ ------
+
+
+Run: ...
+Perl version: ...
+OS: ...
+Start: ...
+Finish: ...
+
+tests/redefine_sub
+
+line err stmt bran cond sub code
+1 #!/usr/bin/perl
+2
+3 sub s1 {
+4 2 2 my $t = shift;
+5 2 100 if ($t > 5) {
+6 1 print 5;
+7 } else {
+8 1 print $t;
+9 }
+10 }
+11
+12 1 my $c = *main::s1{CODE};
+13
+14 *main::s1 = sub {
+15 2 2 print "extra";
+16 2 &$c(@_);
+17 1 };
+18
+19 1 s1(1);
+20 1 s1(7);
+
+
+Branches
+--------
+
+line err % true false branch
+----- --- ------ ------ ------ ------
+5 100 1 1 if ($t > 5) { }
+
+
+Covered Subroutines
+-------------------
+
+Subroutine Count Location
+---------- ----- ---------------------
+__ANON__ 2 tests/redefine_sub:15
+s1 2 tests/redefine_sub:4
+
+
View
@@ -0,0 +1,20 @@
+#!/usr/bin/perl
+
+sub s1 {
+ my $t = shift;
+ if ($t > 5) {
+ print 5;
+ } else {
+ print $t;
+ }
+}
+
+my $c = *main::s1{CODE};
+
+*main::s1 = sub {
+ print "extra";
+ &$c(@_);
+};
+
+s1(1);
+s1(7);

0 comments on commit 3174b8f

Please sign in to comment.