X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=t%2F53lean_startup.t;h=8af340ab5dc64a481f339baa9ef621842bd5b6e5;hb=9345b14c6c86aa8888bf5d47a569ee9bbde24f47;hp=83e7dc85d030c64984f85b8a3eba6d94938d3d4d;hpb=9859bf7a4ab106f41a4373d8910a84f820e2fcf8;p=dbsrgits%2FDBIx-Class.git

diff --git a/t/53lean_startup.t b/t/53lean_startup.t
index 83e7dc8..8af340a 100644
--- a/t/53lean_startup.t
+++ b/t/53lean_startup.t
@@ -1,28 +1,38 @@
 # Use a require override instead of @INC munging (less common)
 # Do the override as early as possible so that CORE::require doesn't get compiled away
-# We will replace $req_override in a bit
+# We will add the hook in a bit, got to load some regular stuff
 
 my $test_hook;
 BEGIN {
-  $test_hook = sub {}; # noop at first
-  *CORE::GLOBAL::require = sub {
-    $test_hook->(@_);
-    CORE::require($_[0]);
-  };
+  unshift @INC, 't/lib';
+  require DBICTest::Util::OverrideRequire;
+
+  DBICTest::Util::OverrideRequire::override_global_require( sub {
+    my $res = $_[0]->();
+    $test_hook->($_[1]) if $test_hook;
+    return $res;
+  });
 }
 
 use strict;
 use warnings;
 use Test::More;
+use Data::Dumper;
 
+# Package::Stash::XS is silly and fails if a require hook contains regular
+# expressions on perl < 5.8.7. Load the damned thing if the case
 BEGIN {
-  my $core_modules = { map { $_ => 1 } qw/
+  require Package::Stash if $] < 5.008007;
+}
+
+my $expected_core_modules;
+
+BEGIN {
+  $expected_core_modules = { map { $_ => 1 } qw/
     strict
     warnings
-    vars
 
     base
-    parent
     mro
     overload
 
@@ -31,11 +41,13 @@ BEGIN {
 
     namespace::clean
     Try::Tiny
+    Context::Preserve
     Sub::Name
 
     Scalar::Util
     List::Util
     Hash::Merge
+    Data::Compare
 
     DBI
     SQL::Abstract
@@ -44,9 +56,9 @@ BEGIN {
 
     Class::Accessor::Grouped
     Class::C3::Componentised
-
-    Data::Compare
-  /, $] < 5.010 ? 'MRO::Compat' : () };
+    Moo
+    Sub::Quote
+  /, $] < 5.010 ? ( 'Class::C3', 'MRO::Compat' ) : () }; # this is special-cased in DBIx/Class.pm
 
   $test_hook = sub {
 
@@ -54,21 +66,41 @@ BEGIN {
     $req =~ s/\.pm$//;
     $req =~ s/\//::/g;
 
-    return if $req =~ /^DBIx::Class|^DBICTest::Schema/;
+    return if $req =~ /^DBIx::Class|^DBICTest::/;
 
     my $up = 1;
     my @caller;
     do { @caller = caller($up++) } while (
       @caller and (
+        # exclude our test suite, known "module require-rs" and eval frames
+        $caller[1] =~ /^ t [\/\\] /x
+          or
         $caller[0] =~ /^ (?: base | parent | Class::C3::Componentised | Module::Inspector) $/x
           or
-        $caller[1] =~ / \( eval \s \d+ \) /x
+        $caller[3] eq '(eval)',
       )
     );
 
-    if ( $caller[0] =~ /^DBIx::Class/) {
-      fail ("Unexpected require of '$req' by $caller[0] ($caller[1] line $caller[2])")
-        unless $core_modules->{$req};
+    # exclude everything where the current namespace does not match the called function
+    # (this works around very weird XS-induced require callstack corruption)
+    if (
+      !$expected_core_modules->{$req}
+        and
+      @caller
+        and
+      $caller[0] =~ /^DBIx::Class/
+        and
+      (caller($up))[3] =~ /\Q$caller[0]/
+    ) {
+      fail ("Unexpected require of '$req' by $caller[0] ($caller[1] line $caller[2])");
+
+      if ($ENV{TEST_VERBOSE}) {
+        my ($i, @stack) = 1;
+        while (my @f = caller($i++) ) {
+          push @stack, \@f;
+        }
+        diag Dumper(\@stack);
+      }
     }
   };
 }
@@ -85,4 +117,21 @@ delete $ENV{$_} for qw/
 my $schema = DBICTest->init_schema;
 is ($schema->resultset('Artist')->next->name, 'Caterwauler McCrae');
 
+# check if anything we were expecting didn't actually load
+my $nl;
+for (keys %$expected_core_modules) {
+  my $mod = "$_.pm";
+  $mod =~ s/::/\//g;
+  unless ($INC{$mod}) {
+    my $err = sprintf "Expected DBIC core module %s never loaded - %s needs adjustment", $_, __FILE__;
+    if (DBICTest::RunMode->is_smoker or DBICTest::RunMode->is_author) {
+      fail ($err)
+    }
+    else {
+      diag "\n" unless $nl++;
+      diag $err;
+    }
+  }
+}
+
 done_testing;