Commit | Line | Data |
9c1700e3 |
1 | use strict; |
2 | use warnings; |
3 | |
4 | use Test::More; |
5 | |
6 | use File::Find; |
7 | use File::Spec; |
8 | use B qw/svref_2object/; |
9 | |
10 | # makes sure we can load at least something |
11 | use DBIx::Class; |
12 | |
13 | my @modules = grep { |
14 | my $mod = $_; |
15 | |
16 | # trap deprecation warnings and whatnot |
17 | local $SIG{__WARN__} = sub {}; |
18 | |
19 | # not all modules are loadable at all times |
20 | eval "require $mod" ? $mod : do { |
a1249d49 |
21 | SKIP: { skip "Failed require of $mod: $@", 1 }; |
9c1700e3 |
22 | (); |
23 | }; |
24 | |
25 | |
26 | } find_modules(); |
27 | |
28 | # have an exception table for old and/or weird code we are not sure |
29 | # we *want* to clean in the first place |
30 | my $skip_idx = { map { $_ => 1 } ( |
31 | (grep { /^DBIx::Class::CDBICompat/ } @modules), # too crufty to touch |
32 | 'SQL::Translator::Producer::DBIx::Class::File', # ditto |
33 | |
34 | # not sure how to handle type libraries |
35 | 'DBIx::Class::Storage::DBI::Replicated::Types', |
36 | 'DBIx::Class::Admin::Types', |
37 | |
38 | # G::L::D is unclean, but we never inherit from it |
39 | 'DBIx::Class::Admin::Descriptive', |
40 | 'DBIx::Class::Admin::Usage', |
41 | ) }; |
42 | |
43 | my $has_cmop = eval { require Class::MOP }; |
44 | |
45 | # can't use Class::Inspector for the mundane parts as it does not |
46 | # distinguish imports from anything else, what a crock of... |
47 | # Class::MOP is not always available either - hence just do it ourselves |
48 | |
49 | my $seen; #inheritance means we will see the same method multiple times |
50 | |
51 | for my $mod (@modules) { |
52 | SKIP: { |
53 | skip "$mod exempt from namespace checks",1 if $skip_idx->{$mod}; |
54 | |
55 | my %all_method_like = do { |
56 | no strict 'refs'; |
57 | map { |
58 | my $m = $_; |
59 | map |
60 | { *{"${m}::$_"}{CODE} ? ( $_ => *{"${m}::$_"}{CODE} ) : () } |
61 | keys %{"${m}::"} |
62 | } (reverse @{mro::get_linear_isa($mod)}); |
63 | }; |
64 | |
65 | my %parents = map { $_ => 1 } @{mro::get_linear_isa($mod)}; |
66 | |
67 | my %roles; |
68 | if ($has_cmop and my $mc = Class::MOP::class_of($mod)) { |
69 | if ($mc->can('calculate_all_roles_with_inheritance')) { |
70 | $roles{$_->name} = 1 for ($mc->calculate_all_roles_with_inheritance); |
71 | } |
72 | } |
73 | |
74 | for my $name (keys %all_method_like) { |
75 | |
76 | # overload is a funky thing - it is neither cleaned, and its imports are named funny |
77 | next if $name =~ /^\(/; |
78 | |
79 | my $gv = svref_2object($all_method_like{$name})->GV; |
80 | my $origin = $gv->STASH->NAME; |
81 | |
9c1700e3 |
82 | TODO: { |
83 | local $TODO = 'CAG does not clean its BEGIN constants' if $name =~ /^__CAG_/; |
70c28808 |
84 | is ($gv->NAME, $name, "Properly named $name method at $origin" . ($origin eq $mod |
85 | ? '' |
86 | : " (inherited by $mod)" |
87 | )); |
9c1700e3 |
88 | } |
89 | |
70c28808 |
90 | next if $seen->{"${origin}:${name}"}++; |
91 | |
9c1700e3 |
92 | if ($origin eq $mod) { |
93 | pass ("$name is a native $mod method"); |
94 | } |
95 | elsif ($roles{$origin}) { |
96 | pass ("${mod}::${name} came from consumption of role $origin"); |
97 | } |
98 | elsif ($parents{$origin}) { |
99 | pass ("${mod}::${name} came from proper parent-class $origin"); |
100 | } |
101 | else { |
102 | my $via; |
103 | for (reverse @{mro::get_linear_isa($mod)} ) { |
104 | if ( ($_->can($name)||'') eq $all_method_like{$name} ) { |
105 | $via = $_; |
106 | last; |
107 | } |
108 | } |
109 | fail ("${mod}::${name} appears to have entered inheritance chain by import into " |
110 | . ($via || 'UNKNOWN') |
111 | ); |
112 | } |
113 | } |
70c28808 |
114 | |
115 | # some common import names (these should never ever be methods) |
116 | for my $f (qw/carp carp_once carp_unique croak confess cluck try catch finally/) { |
117 | if ($mod->can($f)) { |
118 | my $via; |
119 | for (reverse @{mro::get_linear_isa($mod)} ) { |
120 | if ( ($_->can($f)||'') eq $all_method_like{$f} ) { |
121 | $via = $_; |
122 | last; |
123 | } |
124 | } |
125 | fail ("Import $f leaked into method list of ${mod}, appears to have entered inheritance chain at " |
126 | . ($via || 'UNKNOWN') |
127 | ); |
128 | } |
129 | else { |
130 | pass ("Import $f not leaked into method list of $mod"); |
131 | } |
132 | } |
9c1700e3 |
133 | } |
134 | } |
135 | |
136 | sub find_modules { |
137 | my @modules; |
138 | |
139 | find({ |
140 | wanted => sub { |
141 | -f $_ or return; |
142 | s/\.pm$// or return; |
143 | s/^ (?: lib | blib . (?:lib|arch) ) . //x; |
144 | push @modules, join ('::', File::Spec->splitdir($_)); |
145 | }, |
146 | no_chdir => 1, |
147 | }, (-e 'blib' ? 'blib' : 'lib') ); |
148 | |
149 | return sort @modules; |
150 | } |
151 | |
152 | |
153 | done_testing; |