File Coverage

blib/lib/Test/NoOverride.pm
Criterion Covered Total %
statement 67 69 97.1
branch 8 10 80.0
condition 2 3 66.6
subroutine 12 12 100.0
pod n/a
total 89 94 94.6


line stmt bran cond sub pod time code
1             package Test::NoOverride;
2 2     2   59215 use strict;
  2         5  
  2         132  
3 2     2   11 use warnings;
  2         4  
  2         57  
4 2     2   1885 use Module::Functions;
  2         13827  
  2         138  
5 2     2   15 use Test::More;
  2         4  
  2         20  
6              
7             our $VERSION = '0.01';
8              
9             sub import {
10 2     2   21 my $class = shift;
11              
12 2         5 my $caller = caller;
13 2     2   773 no strict 'refs'; ## no critic
  2         10  
  2         947  
14 2         6 for my $func (qw/ no_override /) {
15 2         3 *{"${caller}::$func"} = \&{ __PACKAGE__. "::_$func" };
  2         1991  
  2         18  
16             }
17             }
18              
19             sub _no_override {
20 2     2   908 my ($klass, %opt) = @_;
21              
22 2         5 my %exclude;
23 2 100       10 if (exists $opt{exclude}) {
24 1         2 $exclude{$_} = 1 for @{$opt{exclude}};
  1         545  
25             }
26              
27 2         9 _load_class($klass);
28 2         2834 my @functions = _get_functions($klass);
29              
30 2         4 my @methods;
31 2         8 _isa_list(\@methods, $klass);
32              
33 2         4 my $fail = 0;
34 2         4 for my $func (@functions) {
35 2         4 for my $m (@methods) {
36 14         13 my ($class, $method) = %{$m};
  14         32  
37 14 50 66     56 if ($func eq $method && !$exclude{$func}) {
38 0         0 fail("[$klass\::$func] overrides [$class\::$method]");
39 0         0 $fail++;
40             }
41             }
42             }
43              
44 2 50       17 ok(1, "No Override: $klass") unless $fail;
45             }
46              
47             sub _load_class {
48 2     2   4 my $class = shift;
49              
50 2         13 $class =~ s!::!/!g;
51 2         1816 require "$class\.pm"; ## no critic
52             }
53              
54             sub _isa_list {
55 6     6   13 my ($methods, @klass_list) = @_;
56              
57 6         11 my @parents;
58 6         9 for my $klass (@klass_list) {
59             {
60 2     2   14 no strict 'refs'; ## no critic
  2         4  
  2         443  
  8         10  
61 8         9 push @parents, @{"$klass\::ISA"};
  8         33  
62             }
63 8         14 for my $parent_klass (@parents) {
64 6         12 my @functions = _get_functions($parent_klass);
65 6         12 for my $func (@functions) {
66 14         15 push @{$methods}, { $parent_klass => $func };
  14         60  
67             }
68             }
69             }
70              
71 6 100       43 if ( scalar @parents ) {
72 4         16 _isa_list($methods, @parents);
73             }
74              
75             }
76              
77             sub _get_functions {
78 8     8   13 my $package = shift;
79              
80 8         24 my @functions = get_public_functions($package);
81              
82             {
83 2     2   12 no strict 'refs'; ## no critic
  2         3  
  2         251  
  8         638  
84 8         10 my %class = %{"${package}::"};
  8         71  
85 8         40 while (my ($k, $v) = each %class) {
86 38 100       267 push @functions, $k if $k =~ /^_.+/;
87             }
88             }
89              
90 8         30 return @functions;
91             }
92              
93             1;
94              
95             __END__