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