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