Commit | Line | Data |
88b1530a |
1 | BEGIN { |
2 | if ($] < 5.010) { |
6a0067ea |
3 | |
45638aed |
4 | # Pre-5.10 perls pollute %INC on unsuccesfull module |
5 | # require, making it appear as if the module is already |
6 | # loaded on subsequent require()s |
7 | # Can't seem to find the exact RT/perldelta entry |
8 | # |
9 | # The reason we can't just use a sane, clean loader, is because |
10 | # if a Module require()s another module the %INC will still |
11 | # get filled with crap and we are back to square one. A global |
12 | # fix is really the only way for this test, as we try to load |
13 | # each available module separately, and have no control (nor |
14 | # knowledge) over their common dependencies. |
15 | # |
16 | # we want to do this here, in the very beginning, before even |
17 | # warnings/strict are loaded |
18 | |
19 | unshift @INC, 't/lib'; |
20 | require DBICTest::Util::OverrideRequire; |
21 | |
22 | DBICTest::Util::OverrideRequire::override_global_require( sub { |
23 | my $res = eval { $_[0]->() }; |
6a0067ea |
24 | if ($@ ne '') { |
45638aed |
25 | delete $INC{$_[1]}; |
6a0067ea |
26 | die $@; |
88b1530a |
27 | } |
45638aed |
28 | return $res; |
29 | } ); |
88b1530a |
30 | } |
31 | } |
32 | |
9c1700e3 |
33 | use strict; |
34 | use warnings; |
35 | |
287a2737 |
36 | # FIXME This is a crock of shit, needs to go away |
37 | # currently here to work around https://rt.cpan.org/Ticket/Display.html?id=74151 |
38 | # kill with fire when PS::XS / RT#74151 is *finally* fixed |
39 | BEGIN { |
40 | my $PS_provider; |
41 | |
42 | if ( "$]" < 5.010 ) { |
43 | require Package::Stash::PP; |
44 | $PS_provider = 'Package::Stash::PP'; |
45 | } |
46 | else { |
47 | require Package::Stash; |
48 | $PS_provider = 'Package::Stash'; |
49 | } |
50 | eval <<"EOS" or die $@; |
51 | |
52 | sub stash_for (\$) { |
53 | $PS_provider->new(\$_[0]); |
54 | } |
55 | 1; |
56 | EOS |
57 | } |
58 | |
9c1700e3 |
59 | use Test::More; |
60 | |
8d6b1478 |
61 | use lib 't/lib'; |
62 | use DBICTest; |
63 | |
9c1700e3 |
64 | use File::Find; |
65 | use File::Spec; |
66 | use B qw/svref_2object/; |
67 | |
68 | # makes sure we can load at least something |
69 | use DBIx::Class; |
90cfe42b |
70 | use DBIx::Class::Carp; |
9c1700e3 |
71 | |
72 | my @modules = grep { |
f3ec358e |
73 | my ($mod) = $_ =~ /(.+)/; |
9c1700e3 |
74 | |
9c1700e3 |
75 | # not all modules are loadable at all times |
88b1530a |
76 | do { |
77 | # trap deprecation warnings and whatnot |
78 | local $SIG{__WARN__} = sub {}; |
79 | eval "require $mod"; |
80 | } ? $mod : do { |
81 | SKIP: { skip "Failed require of $mod: " . ($@ =~ /^(.+?)$/m)[0], 1 }; |
82 | (); # empty RV for @modules |
9c1700e3 |
83 | }; |
84 | |
9c1700e3 |
85 | } find_modules(); |
86 | |
87 | # have an exception table for old and/or weird code we are not sure |
88 | # we *want* to clean in the first place |
89 | my $skip_idx = { map { $_ => 1 } ( |
90 | (grep { /^DBIx::Class::CDBICompat/ } @modules), # too crufty to touch |
91 | 'SQL::Translator::Producer::DBIx::Class::File', # ditto |
92 | |
93 | # not sure how to handle type libraries |
94 | 'DBIx::Class::Storage::DBI::Replicated::Types', |
95 | 'DBIx::Class::Admin::Types', |
96 | |
97 | # G::L::D is unclean, but we never inherit from it |
98 | 'DBIx::Class::Admin::Descriptive', |
99 | 'DBIx::Class::Admin::Usage', |
cd122820 |
100 | |
101 | # this subclass is expected to inherit whatever crap comes |
102 | # from the parent |
103 | 'DBIx::Class::ResultSet::Pager', |
9f98c4b2 |
104 | |
b1dbf716 |
105 | # utility classes, not part of the inheritance chain |
9f98c4b2 |
106 | 'DBIx::Class::ResultSource::RowParser::Util', |
b1dbf716 |
107 | 'DBIx::Class::_Util', |
9c1700e3 |
108 | ) }; |
109 | |
bfcecabc |
110 | my $has_moose = eval { require Moose::Util }; |
9c1700e3 |
111 | |
112 | # can't use Class::Inspector for the mundane parts as it does not |
113 | # distinguish imports from anything else, what a crock of... |
bfcecabc |
114 | # Moose is not always available either - hence just do it ourselves |
9c1700e3 |
115 | |
116 | my $seen; #inheritance means we will see the same method multiple times |
117 | |
118 | for my $mod (@modules) { |
119 | SKIP: { |
120 | skip "$mod exempt from namespace checks",1 if $skip_idx->{$mod}; |
121 | |
90cfe42b |
122 | my %all_method_like = (map |
287a2737 |
123 | { %{stash_for($_)->get_all_symbols('CODE')} } |
90cfe42b |
124 | (reverse @{mro::get_linear_isa($mod)}) |
125 | ); |
9c1700e3 |
126 | |
127 | my %parents = map { $_ => 1 } @{mro::get_linear_isa($mod)}; |
128 | |
129 | my %roles; |
bfcecabc |
130 | if ($has_moose and my $mc = Moose::Util::find_meta($mod)) { |
9c1700e3 |
131 | if ($mc->can('calculate_all_roles_with_inheritance')) { |
132 | $roles{$_->name} = 1 for ($mc->calculate_all_roles_with_inheritance); |
133 | } |
134 | } |
135 | |
136 | for my $name (keys %all_method_like) { |
137 | |
6a0067ea |
138 | # overload is a funky thing - it is not cleaned, and its imports are named funny |
9c1700e3 |
139 | next if $name =~ /^\(/; |
140 | |
141 | my $gv = svref_2object($all_method_like{$name})->GV; |
142 | my $origin = $gv->STASH->NAME; |
143 | |
8b4d8064 |
144 | is ($gv->NAME, $name, "Properly named $name method at $origin" . ($origin eq $mod |
145 | ? '' |
146 | : " (inherited by $mod)" |
147 | )); |
9c1700e3 |
148 | |
70c28808 |
149 | next if $seen->{"${origin}:${name}"}++; |
150 | |
9c1700e3 |
151 | if ($origin eq $mod) { |
152 | pass ("$name is a native $mod method"); |
153 | } |
154 | elsif ($roles{$origin}) { |
155 | pass ("${mod}::${name} came from consumption of role $origin"); |
156 | } |
157 | elsif ($parents{$origin}) { |
158 | pass ("${mod}::${name} came from proper parent-class $origin"); |
159 | } |
160 | else { |
161 | my $via; |
162 | for (reverse @{mro::get_linear_isa($mod)} ) { |
163 | if ( ($_->can($name)||'') eq $all_method_like{$name} ) { |
164 | $via = $_; |
165 | last; |
166 | } |
167 | } |
287a2737 |
168 | |
169 | # exception time |
170 | if ( |
171 | ( $name eq 'import' and $via = 'Exporter' ) |
172 | ) { |
173 | pass("${mod}::${name} is a valid uncleaned import from ${name}"); |
174 | } |
175 | else { |
176 | fail ("${mod}::${name} appears to have entered inheritance chain by import into " |
177 | . ($via || 'UNKNOWN') |
178 | ); |
179 | } |
9c1700e3 |
180 | } |
181 | } |
70c28808 |
182 | |
183 | # some common import names (these should never ever be methods) |
184 | for my $f (qw/carp carp_once carp_unique croak confess cluck try catch finally/) { |
185 | if ($mod->can($f)) { |
186 | my $via; |
187 | for (reverse @{mro::get_linear_isa($mod)} ) { |
188 | if ( ($_->can($f)||'') eq $all_method_like{$f} ) { |
189 | $via = $_; |
190 | last; |
191 | } |
192 | } |
193 | fail ("Import $f leaked into method list of ${mod}, appears to have entered inheritance chain at " |
194 | . ($via || 'UNKNOWN') |
195 | ); |
196 | } |
197 | else { |
198 | pass ("Import $f not leaked into method list of $mod"); |
199 | } |
200 | } |
9c1700e3 |
201 | } |
202 | } |
203 | |
204 | sub find_modules { |
205 | my @modules; |
206 | |
207 | find({ |
208 | wanted => sub { |
209 | -f $_ or return; |
210 | s/\.pm$// or return; |
211 | s/^ (?: lib | blib . (?:lib|arch) ) . //x; |
212 | push @modules, join ('::', File::Spec->splitdir($_)); |
213 | }, |
214 | no_chdir => 1, |
215 | }, (-e 'blib' ? 'blib' : 'lib') ); |
216 | |
217 | return sort @modules; |
218 | } |
219 | |
9c1700e3 |
220 | done_testing; |