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