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 | |
8c49cf15 |
4 | my ($initial_inc_contents, $expected_dbic_deps, $require_sites); |
3b80fa31 |
5 | BEGIN { |
8c49cf15 |
6 | # these envvars *will* bring in more stuff than the baseline |
7 | delete @ENV{qw(DBICTEST_SQLT_DEPLOY DBIC_TRACE)}; |
8 | |
cbd7f87a |
9 | # make sure extras do not load even when this is set |
10 | $ENV{PERL_STRICTURES_EXTRA} = 1; |
11 | |
45638aed |
12 | unshift @INC, 't/lib'; |
13 | require DBICTest::Util::OverrideRequire; |
14 | |
15 | DBICTest::Util::OverrideRequire::override_global_require( sub { |
16 | my $res = $_[0]->(); |
8c49cf15 |
17 | |
18 | my $req = $_[1]; |
19 | $req =~ s/\.pm$//; |
20 | $req =~ s/\//::/g; |
21 | |
22 | my $up = 0; |
23 | my @caller; |
24 | do { @caller = caller($up++) } while ( |
25 | @caller and ( |
26 | # exclude our test suite, known "module require-rs" and eval frames |
27 | $caller[1] =~ /^ t [\/\\] /x |
28 | or |
29 | $caller[0] =~ /^ (?: base | parent | Class::C3::Componentised | Module::Inspector | Module::Runtime ) $/x |
30 | or |
31 | $caller[3] eq '(eval)', |
32 | ) |
33 | ); |
34 | |
35 | push @{$require_sites->{$req}}, "$caller[1] line $caller[2]" |
36 | if @caller; |
37 | |
38 | return $res if $req =~ /^DBIx::Class|^DBICTest::/; |
39 | |
40 | # exclude everything where the current namespace does not match the called function |
41 | # (this works around very weird XS-induced require callstack corruption) |
42 | if ( |
43 | !$initial_inc_contents->{$req} |
44 | and |
45 | !$expected_dbic_deps->{$req} |
46 | and |
47 | @caller |
48 | and |
49 | $caller[0] =~ /^DBIx::Class/ |
50 | and |
51 | (caller($up))[3] =~ /\Q$caller[0]/ |
52 | ) { |
53 | CORE::require('Test/More.pm'); |
54 | Test::More::fail ("Unexpected require of '$req' by $caller[0] ($caller[1] line $caller[2])"); |
55 | |
ba7892a8 |
56 | if ( $ENV{TEST_VERBOSE} or ! DBICTest::RunMode->is_plain ) { |
8c49cf15 |
57 | CORE::require('DBICTest/Util.pm'); |
58 | Test::More::diag( 'Require invoked' . DBICTest::Util::stacktrace() ); |
59 | } |
60 | } |
61 | |
45638aed |
62 | return $res; |
63 | }); |
3b80fa31 |
64 | } |
65 | |
66 | use strict; |
67 | use warnings; |
68 | use Test::More; |
69 | |
45638aed |
70 | BEGIN { |
8c49cf15 |
71 | plan skip_all => 'A defined PERL5OPT may inject extra deps crashing this test' |
72 | if $ENV{PERL5OPT}; |
73 | |
74 | plan skip_all => 'Dependency load patterns are radically different before perl 5.10' |
75 | if $] < 5.010; |
76 | |
77 | # add what we loaded so far |
78 | for (keys %INC) { |
79 | my $mod = $_; |
80 | $mod =~ s/\.pm$//; |
81 | $mod =~ s!\/!::!g; |
82 | $initial_inc_contents->{$mod} = 1; |
83 | } |
45638aed |
84 | } |
85 | |
8c49cf15 |
86 | ####### |
87 | ### This is where the test starts |
88 | ####### |
3b80fa31 |
89 | |
8c49cf15 |
90 | # checking base schema load, no storage no connection |
91 | { |
92 | register_lazy_loadable_requires(qw( |
93 | B |
0d8817bc |
94 | constant |
8c49cf15 |
95 | overload |
0d8817bc |
96 | |
3b80fa31 |
97 | base |
8c49cf15 |
98 | Devel::GlobalDestruction |
3b80fa31 |
99 | mro |
3b80fa31 |
100 | |
8c49cf15 |
101 | Carp |
3b80fa31 |
102 | namespace::clean |
103 | Try::Tiny |
104 | Sub::Name |
ba0e8d1c |
105 | strictures |
cbd7f87a |
106 | Sub::Defer |
7f9a3f70 |
107 | Sub::Quote |
3b80fa31 |
108 | |
109 | Scalar::Util |
110 | List::Util |
3b80fa31 |
111 | |
3b80fa31 |
112 | Class::Accessor::Grouped |
113 | Class::C3::Componentised |
b5ce6748 |
114 | SQL::Abstract |
8c49cf15 |
115 | )); |
3b80fa31 |
116 | |
8c49cf15 |
117 | require DBICTest::Schema; |
118 | assert_no_missing_expected_requires(); |
119 | } |
3b80fa31 |
120 | |
8c49cf15 |
121 | # check schema/storage instantiation with no connect |
122 | { |
123 | register_lazy_loadable_requires(qw( |
124 | Moo |
cbd7f87a |
125 | Moo::Object |
126 | Method::Generate::Accessor |
127 | Method::Generate::Constructor |
8c49cf15 |
128 | Context::Preserve |
129 | )); |
3b80fa31 |
130 | |
8c49cf15 |
131 | my $s = DBICTest::Schema->connect('dbi:SQLite::memory:'); |
132 | ok (! $s->storage->connected, 'no connection'); |
133 | assert_no_missing_expected_requires(); |
134 | } |
3b80fa31 |
135 | |
8c49cf15 |
136 | # do something (deploy, insert) |
137 | { |
138 | register_lazy_loadable_requires(qw( |
139 | DBI |
8c49cf15 |
140 | Hash::Merge |
141 | )); |
142 | |
143 | my $s = DBICTest::Schema->connect('dbi:SQLite::memory:'); |
144 | $s->storage->dbh_do(sub { |
145 | $_[1]->do('CREATE TABLE artist ( |
146 | "artistid" INTEGER PRIMARY KEY NOT NULL, |
147 | "name" varchar(100), |
148 | "rank" integer NOT NULL DEFAULT 13, |
149 | "charfield" char(10) |
150 | )'); |
151 | }); |
3b80fa31 |
152 | |
8c49cf15 |
153 | my $art = $s->resultset('Artist')->create({ name => \[ '?' => 'foo'], rank => 42 }); |
154 | $art->discard_changes; |
155 | $art->update({ rank => 69, name => 'foo' }); |
156 | assert_no_missing_expected_requires(); |
157 | } |
6a9e3dd5 |
158 | |
8c49cf15 |
159 | # and do full populate() as well, just in case - shouldn't add new stuff |
160 | { |
4a24dba9 |
161 | local $ENV{DBICTEST_SQLITE_REVERSE_DEFAULT_ORDER}; |
5e724964 |
162 | { |
163 | # in general we do not want DBICTest to load before sqla, but it is |
164 | # ok to cheat here |
165 | local $INC{'SQL/Abstract.pm'}; |
166 | require DBICTest; |
167 | } |
8c49cf15 |
168 | my $s = DBICTest->init_schema; |
fb88ca2c |
169 | is ($s->resultset('Artist')->find(1)->name, 'Caterwauler McCrae'); |
8c49cf15 |
170 | assert_no_missing_expected_requires(); |
3b80fa31 |
171 | } |
172 | |
cbd7f87a |
173 | # make sure we never loaded any of the strictures XS bullshit |
174 | { |
175 | ok( ! exists $INC{ Module::Runtime::module_notional_filename($_) }, "$_ load never attempted" ) |
176 | for qw(indirect multidimensional bareword::filehandles); |
177 | } |
178 | |
8c49cf15 |
179 | done_testing; |
3b80fa31 |
180 | |
8c49cf15 |
181 | sub register_lazy_loadable_requires { |
182 | local $Test::Builder::Level = $Test::Builder::Level + 1; |
3b80fa31 |
183 | |
8c49cf15 |
184 | for my $mod (@_) { |
185 | (my $modfn = "$mod.pm") =~ s!::!\/!g; |
186 | fail(join "\n", |
187 | "Module $mod already loaded by require site(s):", |
188 | (map { "\t$_" } @{$require_sites->{$mod}}), |
189 | '', |
190 | ) if $INC{$modfn} and !$initial_inc_contents->{$mod}; |
191 | |
192 | $expected_dbic_deps->{$mod}++ |
193 | } |
194 | } |
3b80fa31 |
195 | |
f873b733 |
196 | # check if anything we were expecting didn't actually load |
8c49cf15 |
197 | sub assert_no_missing_expected_requires { |
198 | my $nl; |
199 | for my $mod (keys %$expected_dbic_deps) { |
200 | (my $modfn = "$mod.pm") =~ s/::/\//g; |
201 | unless ($INC{$modfn}) { |
202 | my $err = sprintf "Expected DBIC core dependency '%s' never loaded - %s needs adjustment", $mod, __FILE__; |
203 | if (DBICTest::RunMode->is_smoker or DBICTest::RunMode->is_author) { |
204 | fail ($err) |
205 | } |
206 | else { |
207 | diag "\n" unless $nl->{$mod}++; |
208 | diag $err; |
209 | } |
f873b733 |
210 | } |
211 | } |
8c49cf15 |
212 | pass(sprintf 'All modules expected at %s line %s loaded by DBIC: %s', |
213 | __FILE__, |
214 | (caller(0))[2], |
215 | join (', ', sort keys %$expected_dbic_deps ), |
216 | ) unless $nl; |
f873b733 |
217 | } |