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 |
45638aed |
3 | # We will add the hook in a bit, got to load some regular stuff |
3b80fa31 |
4 | |
5 | my $test_hook; |
6 | BEGIN { |
45638aed |
7 | unshift @INC, 't/lib'; |
8 | require DBICTest::Util::OverrideRequire; |
9 | |
10 | DBICTest::Util::OverrideRequire::override_global_require( sub { |
11 | my $res = $_[0]->(); |
12 | $test_hook->($_[1]) if $test_hook; |
13 | return $res; |
14 | }); |
3b80fa31 |
15 | } |
16 | |
17 | use strict; |
18 | use warnings; |
19 | use Test::More; |
6fec58ca |
20 | use DBICTest::Util 'stacktrace'; |
3b80fa31 |
21 | |
45638aed |
22 | # Package::Stash::XS is silly and fails if a require hook contains regular |
23 | # expressions on perl < 5.8.7. Load the damned thing if the case |
24 | BEGIN { |
25 | require Package::Stash if $] < 5.008007; |
26 | } |
27 | |
f873b733 |
28 | my $expected_core_modules; |
29 | |
3b80fa31 |
30 | BEGIN { |
f873b733 |
31 | $expected_core_modules = { map { $_ => 1 } qw/ |
3b80fa31 |
32 | strict |
33 | warnings |
3b80fa31 |
34 | |
0d8817bc |
35 | constant |
36 | Config |
37 | |
3b80fa31 |
38 | base |
3b80fa31 |
39 | mro |
40 | overload |
6fec58ca |
41 | Exporter |
3b80fa31 |
42 | |
43 | B |
d6b39e46 |
44 | Devel::GlobalDestruction |
3b80fa31 |
45 | namespace::clean |
46 | Try::Tiny |
9345b14c |
47 | Context::Preserve |
3b80fa31 |
48 | Sub::Name |
49 | |
50 | Scalar::Util |
51 | List::Util |
52 | Hash::Merge |
6a9e3dd5 |
53 | Data::Compare |
3b80fa31 |
54 | |
55 | DBI |
af1f4f84 |
56 | DBI::Const::GetInfoType |
70c28808 |
57 | SQL::Abstract |
3b80fa31 |
58 | |
59 | Carp |
3b80fa31 |
60 | |
61 | Class::Accessor::Grouped |
62 | Class::C3::Componentised |
9345b14c |
63 | Moo |
64 | Sub::Quote |
6a9e3dd5 |
65 | /, $] < 5.010 ? ( 'Class::C3', 'MRO::Compat' ) : () }; # this is special-cased in DBIx/Class.pm |
3b80fa31 |
66 | |
67 | $test_hook = sub { |
68 | |
69 | my $req = $_[0]; |
70 | $req =~ s/\.pm$//; |
71 | $req =~ s/\//::/g; |
72 | |
6a9e3dd5 |
73 | return if $req =~ /^DBIx::Class|^DBICTest::/; |
3b80fa31 |
74 | |
75 | my $up = 1; |
76 | my @caller; |
77 | do { @caller = caller($up++) } while ( |
78 | @caller and ( |
6a9e3dd5 |
79 | # exclude our test suite, known "module require-rs" and eval frames |
80 | $caller[1] =~ /^ t [\/\\] /x |
81 | or |
3b80fa31 |
82 | $caller[0] =~ /^ (?: base | parent | Class::C3::Componentised | Module::Inspector) $/x |
83 | or |
6a9e3dd5 |
84 | $caller[3] eq '(eval)', |
3b80fa31 |
85 | ) |
86 | ); |
87 | |
6a9e3dd5 |
88 | # exclude everything where the current namespace does not match the called function |
89 | # (this works around very weird XS-induced require callstack corruption) |
90 | if ( |
f873b733 |
91 | !$expected_core_modules->{$req} |
6a9e3dd5 |
92 | and |
93 | @caller |
94 | and |
95 | $caller[0] =~ /^DBIx::Class/ |
96 | and |
97 | (caller($up))[3] =~ /\Q$caller[0]/ |
98 | ) { |
99 | fail ("Unexpected require of '$req' by $caller[0] ($caller[1] line $caller[2])"); |
100 | |
6fec58ca |
101 | diag( 'Require invoked' . stacktrace() ) if $ENV{TEST_VERBOSE}; |
3b80fa31 |
102 | } |
103 | }; |
104 | } |
105 | |
106 | use lib 't/lib'; |
107 | use DBICTest; |
108 | |
109 | # these envvars bring in more stuff |
110 | delete $ENV{$_} for qw/ |
111 | DBICTEST_SQLT_DEPLOY |
112 | DBIC_TRACE |
113 | /; |
114 | |
115 | my $schema = DBICTest->init_schema; |
116 | is ($schema->resultset('Artist')->next->name, 'Caterwauler McCrae'); |
117 | |
f873b733 |
118 | # check if anything we were expecting didn't actually load |
119 | my $nl; |
120 | for (keys %$expected_core_modules) { |
121 | my $mod = "$_.pm"; |
122 | $mod =~ s/::/\//g; |
123 | unless ($INC{$mod}) { |
124 | my $err = sprintf "Expected DBIC core module %s never loaded - %s needs adjustment", $_, __FILE__; |
45638aed |
125 | if (DBICTest::RunMode->is_smoker or DBICTest::RunMode->is_author) { |
f873b733 |
126 | fail ($err) |
127 | } |
128 | else { |
129 | diag "\n" unless $nl++; |
130 | diag $err; |
131 | } |
132 | } |
133 | } |
134 | |
3b80fa31 |
135 | done_testing; |