File Coverage

blib/lib/Test/TestCoverage.pm

Criterion	Covered	Total	%
statement	97	115	84.3
branch	18	38	47.3
condition	8	21	38.1
subroutine	16	19	84.2
pod	6	6	100.0
total	145	199	72.8

package Test::TestCoverage;

# ABSTRACT: Test if your test covers all "public" subroutines of the package

use strict;
use warnings;
use Devel::Symdump;
use Test::Builder;
use B;
use base qw(Exporter);

our @EXPORT = qw(
                 test_coverage
                 ok_test_coverage
                 all_test_coverage_ok
                 reset_test_coverage
                 reset_all_test_coverage
                 test_coverage_except
                );
our $VERSION = '0.12';

my $self    = {};
my $test    = Test::Builder->new();
my $invokes = {};
my $last    = '';


sub test_coverage {
    my ($package) = @_;
    return unless defined $package;
    $last = $package;
    _get_subroutines($package);

    $invokes->{$package} = {};

    my $moosified = $INC{"Moose.pm"} ? 1 : 0;

    for my $subref(@{$self->{subs}->{$package}}){
        my $sub      = $subref->[0];

        my $sub_with = $package . '::' . $sub;
        unless(exists $invokes->{$package}->{$sub}){
            $invokes->{$package}->{$sub} = 0;
        }

        no strict 'refs';
        no warnings 'redefine';

        my $old    = $package->can( $sub );
        my $mopped = 0;

        if ( $moosified ) {
            require Class::MOP;
            my $meta
                = $package->can('add_before_method_modifier')
                ? $package
                : Class::MOP::class_of( $package );

            if ( defined $meta ) {
                $mopped++;
                $meta->add_after_method_modifier( $sub, sub {
                    $invokes->{$package}->{$sub}++;
                } );
            }
        }

        if ( !$mopped ) {
            *{ $package . '::' . $sub } = sub {
                $invokes->{$package}->{$sub}++;
                $old->( @_ );
            };
        }
    }

    1;
}

sub test_coverage_except {
    my ($package,@subroutines) = @_;

    for my $subname(@subroutines){
        if(exists $invokes->{$package} and
           exists $invokes->{$package}->{$subname} and
           exists $self->{subs}->{$package}){
            @{$self->{subs}->{$package}} = grep{$_->[0] ne $subname}@{$self->{subs}->{$package}};
            delete $invokes->{$package}->{$subname};
        }
    }
}

sub all_test_coverage_ok {
    my ($msg) = @_;

    for my $package(keys %$invokes){
        ok_test_coverage($package,$msg);
    }
    1;
}

sub ok_test_coverage {
    my ($package,$msg) = @_;

    if(!$package or (!exists $invokes->{$package})
                     and $package !~ /^(?:\w+(?:::)?)+$/){
        $package = $last;
    }

    unless(exists $invokes->{$package}){
        warn $package.' was not tested';
        return;
    }

    my $bool_msg = defined $msg ? 1 : 0;
    my $title    = 'Test test-coverage ';
    my $missing;

    my $bool_coverage = 1;
    for my $sub(map{$_->[0]}@{$self->{subs}->{$package}}){
        if(!exists $invokes->{$package}->{$sub} or $invokes->{$package}->{$sub} == 0){
            $missing = defined $missing && !$bool_msg ? $missing . $sub . ' ' : $sub . ' ';
            $bool_coverage = 0;
        }
    }

    if(!$bool_msg){
        $msg  = $title;
        $msg .= $missing.' are missing' if(defined $missing);
    }

    $test->cmp_ok($bool_coverage,"==",1,$msg);
    1;
}

sub reset_test_coverage{
    my ($self,$pkg) = @_;
    for my $key(keys %{$invokes->{$pkg}}){
        $invokes->{$pkg}->{$key} = 0;
    }
}

sub reset_all_test_coverage{
    my ($self) = @_;
    for my $pkg(keys %{$invokes}){
        $self->reset_test_coverage($pkg);
    }
}

sub _get_subroutines{
    my ($pkg,$test) = @_;

    eval qq{ require $pkg };
    print STDERR $@ if $@;
    return if $@;

    $test ||= $pkg;

    my $symdump = Devel::Symdump->new($pkg);

    my @symbols;
    for my $func ($symdump->functions ) {
        my $owner = _get_sub(\&{$func});
        $owner =~ s/^\*(.*)::.*?$/$1/;
        next if $owner ne $test;

        # check if it's on the whitelist
        $func =~ s/${pkg}:://;

        push @symbols, [$func,$owner] unless $func =~ /^_/;
    }

    $self->{subs}->{$pkg} = \@symbols;

    1;
}

sub _get_sub {
    my ($svref) = @_;
    my $b_cv = B::svref_2object($svref);
    no strict 'refs';
    return *{ $b_cv->GV->STASH->NAME . "::" . $b_cv->GV->NAME };
}

1;

__END__