File Coverage

lib/Pod/Coverage/Careful.pm

Criterion	Covered	Total	%
statement	19	56	33.9
branch	0	14	0.0
condition	0	2	0.0
subroutine	7	9	77.7
pod	0	1	0.0
total	26	82	31.7

package Pod::Coverage::Careful;

use strict;
use warnings;

our $VERSION = "v1.1.0";

use B;
use Devel::Symdump;
use Pod::Coverage;
our @ISA = qw(Pod::Coverage);

BEGIN { *TRACE_ALL = \&Pod::Coverage::TRACE_ALL; }

sub name_of_coderef {
    require B;
    my($coderef) = @_;

    my $cv = B::svref_2object($coderef);
    return unless $cv->isa("B::CV");

    my $gv = $cv->GV;
    return if $gv->isa("B::SPECIAL");

    my $subname  = $gv->NAME;
    my $packname = $gv->STASH->NAME;

    return $packname . "::" . $subname;
}

# Shamelessly lifted from Pod::Coverage, which it
# modifies as needed.
# this one walks the symbol tree
sub _get_syms {
    my $self    = shift;
    my $package = shift;

    print "requiring '$package'\n" if TRACE_ALL;
    eval qq{ require $package };
    if ($@) {
        print "require failed with $@\n" if TRACE_ALL;
        $self->{why_unrated} = "requiring '$package' failed";
        return;
    }

    print "walking symbols\n" if TRACE_ALL;
    my $syms = Devel::Symdump->new($package);

    my @symbols;
    for my $sym ( $syms->functions ) {

        # See if said method wasn't just imported *FROM ELSEWHERE*; --tchrist
        my $glob = do { no strict 'refs'; \*{$sym} };
        my $cv = B::svref_2object($glob);

        # in 5.005 this flag is not exposed via B, though it exists
        my $imported_cv = eval { B::GVf_IMPORTED_CV() } || 0x80;
        if ($cv->GvFLAGS & $imported_cv) {
            # Only count if as absolved via import if its name hasn't changed; --tchrist
            my $was_name = name_of_coderef(*{$glob}{CODE});
            next if join("::", $package, $sym) eq $was_name;
            my $his_pack = $was_name;
            $his_pack =~ s/::[^:]*$//;
            next if $package ne $his_pack;
        }

        # check if it's on the whitelist
        $sym =~ s/$self->{package}:://;
        next if $self->_private_check($sym);

        push @symbols, $sym;
    }
    return @symbols;
}

1;

__END__