Commit | Line | Data |
3b80fa31 |
1 | # Use a require override instead of @INC munging (less common) |
2 | # Do the override as early as possible so that CORE::require doesn't get compiled away |
3b80fa31 |
3 | |
92fbedbc |
4 | BEGIN { |
5 | if ( $ENV{RELEASE_TESTING} ) { |
6 | require warnings and warnings->import; |
7 | require strict and strict->import; |
8 | } |
9 | } |
10 | |
11 | my ($initial_inc_contents, $expected_dbic_deps, $require_sites, %stack); |
3b80fa31 |
12 | BEGIN { |
45638aed |
13 | unshift @INC, 't/lib'; |
14 | require DBICTest::Util::OverrideRequire; |
15 | |
16 | DBICTest::Util::OverrideRequire::override_global_require( sub { |
17 | my $res = $_[0]->(); |
8c49cf15 |
18 | |
92fbedbc |
19 | return $res if $stack{neutralize_override}; |
20 | |
8c49cf15 |
21 | my $req = $_[1]; |
22 | $req =~ s/\.pm$//; |
23 | $req =~ s/\//::/g; |
24 | |
25 | my $up = 0; |
26 | my @caller; |
92fbedbc |
27 | do { @caller = CORE::caller($up++) } while ( |
8c49cf15 |
28 | @caller and ( |
29 | # exclude our test suite, known "module require-rs" and eval frames |
92fbedbc |
30 | $caller[1] =~ / (?: \A | [\/\\] ) x?t [\/\\] /x |
8c49cf15 |
31 | or |
cc782be2 |
32 | $caller[0] =~ /^ (?: base | parent | Class::C3::Componentised | Module::Inspector | Module::Runtime | DBIx::Class::Optional::Dependencies ) $/x |
8c49cf15 |
33 | or |
34 | $caller[3] eq '(eval)', |
35 | ) |
36 | ); |
37 | |
38 | push @{$require_sites->{$req}}, "$caller[1] line $caller[2]" |
39 | if @caller; |
40 | |
41 | return $res if $req =~ /^DBIx::Class|^DBICTest::/; |
42 | |
e8452b02 |
43 | # Some modules have a bare 'use $perl_version' as the first statement |
44 | # Since the use() happens before 'package' had a chance to switch |
45 | # the namespace, the shim thinks DBIC* tried to require this |
397056f9 |
46 | return $res if $req =~ /^v?[0-9.]+$/; |
92fbedbc |
47 | |
8c49cf15 |
48 | if ( |
49 | !$initial_inc_contents->{$req} |
50 | and |
51 | !$expected_dbic_deps->{$req} |
52 | and |
53 | @caller |
54 | and |
55 | $caller[0] =~ /^DBIx::Class/ |
8c49cf15 |
56 | ) { |
92fbedbc |
57 | local $stack{neutralize_override} = 1; |
58 | |
cc782be2 |
59 | # find last-most frame, to feed to T::B below |
60 | while( CORE::caller(++$up) ) { 1 } |
92fbedbc |
61 | |
62 | require('Test/More.pm'); |
63 | local $Test::Builder::Level = $up + 1; |
cc782be2 |
64 | |
65 | # work around the trainwreck that is https://github.com/doy/package-stash-xs/pull/4 |
66 | local $::TODO = 'sigh' if ( |
67 | $INC{'Package/Stash/XS.pm'} |
68 | and |
69 | $req eq 'utf8' |
70 | ); |
71 | |
8c49cf15 |
72 | Test::More::fail ("Unexpected require of '$req' by $caller[0] ($caller[1] line $caller[2])"); |
73 | |
cc782be2 |
74 | unless( $::TODO ) { |
75 | require('DBICTest/Util.pm'); |
76 | Test::More::diag( 'Require invoked' . DBICTest::Util::stacktrace() ); |
77 | } |
8c49cf15 |
78 | } |
79 | |
45638aed |
80 | return $res; |
81 | }); |
3b80fa31 |
82 | } |
83 | |
84 | use strict; |
85 | use warnings; |
86 | use Test::More; |
87 | |
45638aed |
88 | BEGIN { |
8c49cf15 |
89 | plan skip_all => 'A defined PERL5OPT may inject extra deps crashing this test' |
90 | if $ENV{PERL5OPT}; |
91 | |
26710bc9 |
92 | plan skip_all => 'Presence of sitecustomize.pl may inject extra deps crashing this test' |
93 | if grep { $_ =~ m| \/ sitecustomize\.pl $ |x } keys %INC; |
94 | |
8c49cf15 |
95 | plan skip_all => 'Dependency load patterns are radically different before perl 5.10' |
750a4ad2 |
96 | if "$]" < 5.010; |
8c49cf15 |
97 | |
26710bc9 |
98 | # these envvars *will* bring in more stuff than the baseline |
99 | delete @ENV{qw( |
100 | DBIC_TRACE |
58b92e31 |
101 | DBIC_SHUFFLE_UNORDERED_RESULTSETS |
26710bc9 |
102 | DBICTEST_SQLT_DEPLOY |
92fbedbc |
103 | DBICTEST_SQLITE_REVERSE_DEFAULT_ORDER |
26710bc9 |
104 | DBICTEST_VIA_REPLICATED |
105 | DBICTEST_DEBUG_CONCURRENCY_LOCKS |
106 | )}; |
107 | |
12e7015a |
108 | # ensures the checker won't be disabled in |
109 | # t/lib/DBICTest/BaseSchema.pm |
110 | $ENV{DBIC_ASSERT_NO_FAILING_SANITY_CHECKS} = 1; |
111 | |
26710bc9 |
112 | $ENV{DBICTEST_ANFANG_DEFANG} = 1; |
113 | |
114 | # make sure extras do not load even when this is set |
115 | $ENV{PERL_STRICTURES_EXTRA} = 1; |
116 | |
8c49cf15 |
117 | # add what we loaded so far |
118 | for (keys %INC) { |
119 | my $mod = $_; |
120 | $mod =~ s/\.pm$//; |
121 | $mod =~ s!\/!::!g; |
122 | $initial_inc_contents->{$mod} = 1; |
123 | } |
45638aed |
124 | } |
125 | |
8b60b921 |
126 | |
8c49cf15 |
127 | ####### |
128 | ### This is where the test starts |
129 | ####### |
3b80fa31 |
130 | |
8c49cf15 |
131 | # checking base schema load, no storage no connection |
132 | { |
133 | register_lazy_loadable_requires(qw( |
134 | B |
0d8817bc |
135 | constant |
8c49cf15 |
136 | overload |
0d8817bc |
137 | |
3b80fa31 |
138 | base |
8c49cf15 |
139 | Devel::GlobalDestruction |
3b80fa31 |
140 | mro |
3b80fa31 |
141 | |
8c49cf15 |
142 | Carp |
3b80fa31 |
143 | namespace::clean |
144 | Try::Tiny |
145 | Sub::Name |
cbd7f87a |
146 | Sub::Defer |
7f9a3f70 |
147 | Sub::Quote |
140bcb6a |
148 | attributes |
3b80fa31 |
149 | |
150 | Scalar::Util |
d7d45bdc |
151 | Storable |
3b80fa31 |
152 | |
3b80fa31 |
153 | Class::Accessor::Grouped |
154 | Class::C3::Componentised |
8c49cf15 |
155 | )); |
3b80fa31 |
156 | |
cc782be2 |
157 | # load Storable ourselves here - there are too many |
158 | # variations with DynaLoader and XSLoader making testing |
159 | # for it rather unstable |
160 | require Storable; |
161 | |
92fbedbc |
162 | require DBIx::Class::Schema; |
8c49cf15 |
163 | assert_no_missing_expected_requires(); |
164 | } |
3b80fa31 |
165 | |
8c49cf15 |
166 | # check schema/storage instantiation with no connect |
167 | { |
168 | register_lazy_loadable_requires(qw( |
169 | Moo |
cbd7f87a |
170 | Moo::Object |
171 | Method::Generate::Accessor |
172 | Method::Generate::Constructor |
8c49cf15 |
173 | Context::Preserve |
92fbedbc |
174 | SQL::Abstract |
8c49cf15 |
175 | )); |
3b80fa31 |
176 | |
92fbedbc |
177 | my $s = DBIx::Class::Schema->connect('dbi:SQLite::memory:'); |
8c49cf15 |
178 | ok (! $s->storage->connected, 'no connection'); |
179 | assert_no_missing_expected_requires(); |
180 | } |
3b80fa31 |
181 | |
8c49cf15 |
182 | # do something (deploy, insert) |
183 | { |
184 | register_lazy_loadable_requires(qw( |
185 | DBI |
8c49cf15 |
186 | Hash::Merge |
c9087040 |
187 | Data::Dumper |
8c49cf15 |
188 | )); |
189 | |
92fbedbc |
190 | { |
191 | eval <<'EOP' or die $@; |
192 | |
193 | package DBICTest::Result::Artist; |
194 | |
195 | use warnings; |
196 | use strict; |
197 | |
198 | use base 'DBIx::Class::Core'; |
199 | |
200 | __PACKAGE__->table("artist"); |
201 | |
202 | __PACKAGE__->add_columns( |
203 | artistid => { |
204 | data_type => 'integer', |
205 | is_auto_increment => 1, |
206 | }, |
207 | name => { |
208 | data_type => 'varchar', |
209 | size => 100, |
210 | is_nullable => 1, |
211 | }, |
212 | rank => { |
213 | data_type => 'integer', |
214 | default_value => 13, |
215 | }, |
216 | charfield => { |
217 | data_type => 'char', |
218 | size => 10, |
219 | is_nullable => 1, |
220 | }, |
221 | ); |
222 | |
223 | __PACKAGE__->set_primary_key('artistid'); |
224 | __PACKAGE__->add_unique_constraint(['name']); |
225 | __PACKAGE__->add_unique_constraint(u_nullable => [qw/charfield rank/]); |
226 | |
227 | 1; |
228 | |
229 | EOP |
230 | } |
231 | |
232 | my $s = DBIx::Class::Schema->connect('dbi:SQLite::memory:'); |
233 | |
234 | $s->register_class( Artist => 'DBICTest::Result::Artist' ); |
235 | |
8c49cf15 |
236 | $s->storage->dbh_do(sub { |
237 | $_[1]->do('CREATE TABLE artist ( |
238 | "artistid" INTEGER PRIMARY KEY NOT NULL, |
239 | "name" varchar(100), |
240 | "rank" integer NOT NULL DEFAULT 13, |
241 | "charfield" char(10) |
242 | )'); |
243 | }); |
3b80fa31 |
244 | |
8c49cf15 |
245 | my $art = $s->resultset('Artist')->create({ name => \[ '?' => 'foo'], rank => 42 }); |
246 | $art->discard_changes; |
247 | $art->update({ rank => 69, name => 'foo' }); |
58b92e31 |
248 | $s->resultset('Artist')->all; |
8c49cf15 |
249 | assert_no_missing_expected_requires(); |
250 | } |
6a9e3dd5 |
251 | |
92fbedbc |
252 | |
253 | # and do full DBICTest based populate() as well, just in case - shouldn't add new stuff |
8c49cf15 |
254 | { |
92fbedbc |
255 | # DBICTest needs File::Spec, but older versions of Storable load it alread |
256 | # Instead of adding a contrived conditional, just preempt the testing entirely |
257 | require File::Spec; |
258 | |
259 | require DBICTest; |
260 | DBICTest->import; |
261 | |
8c49cf15 |
262 | my $s = DBICTest->init_schema; |
92fbedbc |
263 | is ($s->resultset('Artist')->find(1)->name, 'Caterwauler McCrae', 'Expected find() result'); |
3b80fa31 |
264 | } |
265 | |
8c49cf15 |
266 | done_testing; |
92fbedbc |
267 | # one final quiet guard to run at all times |
268 | END { assert_no_missing_expected_requires('quiet') }; |
3b80fa31 |
269 | |
8c49cf15 |
270 | sub register_lazy_loadable_requires { |
271 | local $Test::Builder::Level = $Test::Builder::Level + 1; |
3b80fa31 |
272 | |
8c49cf15 |
273 | for my $mod (@_) { |
274 | (my $modfn = "$mod.pm") =~ s!::!\/!g; |
275 | fail(join "\n", |
276 | "Module $mod already loaded by require site(s):", |
277 | (map { "\t$_" } @{$require_sites->{$mod}}), |
278 | '', |
279 | ) if $INC{$modfn} and !$initial_inc_contents->{$mod}; |
280 | |
281 | $expected_dbic_deps->{$mod}++ |
282 | } |
283 | } |
3b80fa31 |
284 | |
f873b733 |
285 | # check if anything we were expecting didn't actually load |
8c49cf15 |
286 | sub assert_no_missing_expected_requires { |
92fbedbc |
287 | my $quiet = shift; |
288 | |
8c49cf15 |
289 | for my $mod (keys %$expected_dbic_deps) { |
290 | (my $modfn = "$mod.pm") =~ s/::/\//g; |
554484cb |
291 | fail sprintf ( |
292 | "Expected DBIC core dependency '%s' never loaded - %s needs adjustment", |
293 | $mod, |
294 | __FILE__ |
295 | ) unless $INC{$modfn}; |
f873b733 |
296 | } |
92fbedbc |
297 | |
8c49cf15 |
298 | pass(sprintf 'All modules expected at %s line %s loaded by DBIC: %s', |
299 | __FILE__, |
300 | (caller(0))[2], |
301 | join (', ', sort keys %$expected_dbic_deps ), |
92fbedbc |
302 | ) unless $quiet; |
f873b733 |
303 | } |