package Test::TestCoverage;

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

our @EXPORT = qw(
                 test_coverage 
                 ok_test_coverage
                 reset_test_coverage
                 reset_all_test_coverage
                );
our $VERSION = '0.02';

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


sub test_coverage{
    my ($package) = @_;
    return unless defined $package;
    _get_subroutines($package);
    for my $subref(@{$self->{subs}->{$package}}){
        my $sub      = $subref->[0];
        my $sub_with = $package . '::' . $sub;
        unless(exists $invokes->{$package}->{$sub}){
            $invokes->{$package}->{$sub} = 0;
        }
        
        Hook::LexWrap::wrap($sub_with, 
            pre => sub{
                $invokes->{$package}->{$sub}++; 
            }
        );
    }
        
    1;
}

sub ok_test_coverage{
    my ($package,$msg) = @_;
    
    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__
# Below is stub documentation for your module. You'd better edit it!

=head1 NAME

Test::TestCoverage - Test if your test covers all 'public' methods of the package

=head1 SYNOPSIS

  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 methods 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');

=head1 DESCRIPTION

If a module is written, the tests cover just a few methods of the module.
This module aims to support the author in writing "complete" tests. If one
of the "public" methods are missed in the testscript, the test C<ok_test_coverage>
will fail.

"private" methods are defined as methods that names begin with C<_> like 
C<_private_sub{...}> and "public" is the opposite.

=head1 METHODS

=head2 test_coverage $module

Tells C<Test::TestCoverage> for what module the coverage should be tested

=head3 ok_test_coverage $module

Checks if all "public" methods of C<$module> were called in the testscript

=head3 reset_test_coverage $module

Resets the counter for all method invokations of C<$module>'s methods.

=head3 reset_all_test_coverage

Resets the counter for all methods of all modules that were registerd via
C<test_coverage>.

=head1 EXPORT

C<test_coverage>, C<ok_test_coverage>, C<reset_test_coverage>,
C<reset_all_test_coverage>

=head1 SEE ALSO

L<Test::SubCalls>, L<Test::Builder>, L<Test::More>

=head1 BUGS / TODO

There are a lot of things to do. If you experience any problems please contact
me. At the moment the methods have to be invoked with full qualified names.
Exported methods are not detected.

=head1 AUTHOR

Renee Baecker, E<lt>module@renee-baecker.deE<gt>

=head1 COPYRIGHT AND LICENSE

Copyright (C) 2006 by Renee Baecker

This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself, either Perl version 5.8.8 or,
at your option, any later version of Perl 5 you may have available.

=cut
