File Coverage

blib/lib/Test/NoOverride.pm

Criterion	Covered	Total	%
statement	71	73	97.2
branch	9	12	75.0
condition	2	3	66.6
subroutine	12	12	100.0
pod			n/a
total	94	100	94.0

package Test::NoOverride;
use strict;
use warnings;
use Module::Functions;
use Test::More;

our $VERSION = '0.03';

sub import {
    my $class = shift;

    my $caller = caller;
    no strict 'refs'; ## no critic
    for my $func (qw/ no_override /) {
        *{"${caller}::$func"} = \&{ __PACKAGE__. "::_$func" };
    }
}

sub _no_override {
    my ($klass, %opt) = @_;

    my %exclude;
    if (exists $opt{exclude}) {
        $exclude{$_} = 1 for @{$opt{exclude}};
    }
    unless ($opt{new}) {
        $exclude{new} = 1; # default ignore 'new' method
    }

    _load_class($klass);
    my @functions = _get_functions($klass);

    my @methods;
    _isa_list(\@methods, $klass);

    my $fail = 0;
    for my $func (@functions) {
        for my $m (@methods) {
            my ($class, $method) = %{$m};
            if ($func eq $method && !$exclude{$func}) {
                fail("[$klass\::$func] overrides [$class\::$method]");
                $fail++;
            }
        }
    }

    ok(1, "No Override: $klass") unless $fail;
}

sub _load_class {
    my $class = shift;

    my $class_path = $class;
    $class_path =~ s!::!/!g;
    require "$class_path\.pm"; ## no critic
    $class->import;
}

sub _isa_list {
    my ($methods, @klass_list) = @_;

    my @parents;
    for my $klass (@klass_list) {
        {
            no strict 'refs'; ## no critic
            push @parents, @{"$klass\::ISA"};
        }
        for my $parent_klass (@parents) {
            my @functions = _get_functions($parent_klass);
            for my $func (@functions) {
                push @{$methods}, { $parent_klass => $func };
            }
        }
    }

    if ( scalar @parents ) {
        _isa_list($methods, @parents);
    }

}

sub _get_functions {
    my $package = shift;

    my @functions = get_public_functions($package);

    {
        no strict 'refs'; ## no critic
        my %class = %{"${package}::"};
        while (my ($k, $v) = each %class) {
            push @functions, $k if $k =~ /^_.+/;
        }
    }

    return @functions;
}

1;

__END__