From: Peter Rabbitson <ribasushi@cpan.org>
Date: Fri, 15 Jul 2011 15:50:02 +0000 (-0400)
Subject: Really fix t/53lean_startup.t
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=6a9e3dd5169417bc25cb531cd9a52b80c4ca50bb;p=dbsrgits%2FDBIx-Class-Historic.git

Really fix t/53lean_startup.t
---

diff --git a/Changes b/Changes
index 9d03176..5c66ce7 100644
--- a/Changes
+++ b/Changes
@@ -1,7 +1,7 @@
 Revision history for DBIx::Class
 
     * Fixes
-        - Fix spurious test failures caused by use of Data::Compare
+        - Overhaul t/53lean_startup.t to better dodge false positives
         - Fix $rs->populate([]) to be a no-op rather than an exception
 
 0.08193 2011-07-14 17:00 (UTC)
diff --git a/t/53lean_startup.t b/t/53lean_startup.t
index f5de896..0054f03 100644
--- a/t/53lean_startup.t
+++ b/t/53lean_startup.t
@@ -14,19 +14,14 @@ BEGIN {
 use strict;
 use warnings;
 use Test::More;
-# this is only being used because Data::Compare is dumb and has a weird
-# plugin infrastructure and ends up loading a bunch of random stuff for
-# various people
-use Data::Compare;
+use Data::Dumper;
 
 BEGIN {
   my $core_modules = { map { $_ => 1 } qw/
     strict
     warnings
-    vars
 
     base
-    parent
     mro
     overload
 
@@ -40,6 +35,7 @@ BEGIN {
     Scalar::Util
     List::Util
     Hash::Merge
+    Data::Compare
 
     DBI
     SQL::Abstract
@@ -48,9 +44,7 @@ BEGIN {
 
     Class::Accessor::Grouped
     Class::C3::Componentised
-
-    Data::Compare
-  /, $] < 5.010 ? 'MRO::Compat' : () };
+  /, $] < 5.010 ? ( 'Class::C3', 'MRO::Compat' ) : () }; # this is special-cased in DBIx/Class.pm
 
   $test_hook = sub {
 
@@ -58,21 +52,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 (
+      !$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);
+      }
     }
   };
 }