Test::TestCoverage - Test if your test covers all "public" subroutines of the package

  use Test::TestCoverage;

  test_coverage('My::Module');

  my $obj = My::Module->new();
  $obj->foo();
  $obj->bar();

  # test will be ok, assumed that My::Module has the subroutines new, foo and bar
  ok_test_coverage('My::Module');

  reset_test_coverage('My::Module');
  reset_all_test_coverage();

  test_coverage('My::Module');

  my $obj = My::Method->new();
  $obj->foo();

  # test will be not ok, because bar is not invoked
  ok_test_coverage('My::Module');

  reset_test_coverage('My::Module');
  reset_all_test_coverage();

  test_coverage('My::Module');
  test_coverage_except('My::Module','bar');

  my $obj = My::Method->new();
  $obj->foo();

  # test will be ok, because bar is excepted of test
  ok_test_coverage('My::Module');

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.11';

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 );
        
        if ( !$moosified ) {
            *{ $package . '::' . $sub } = sub {
                $invokes->{$package}->{$sub}++; 
                $old->( @_ );
            };
        }
        else {
            require Class::MOP;
            my $meta
                = $package->can('add_before_method_modifier')
                ? $package
                : Class::MOP::class_of( $package );
            $meta->add_after_method_modifier( $sub, sub {
                $invokes->{$package}->{$sub}++; 
            } );
        }
    }
        
    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__