From: Peter Rabbitson <ribasushi@cpan.org>
Date: Thu, 24 Nov 2011 17:38:09 +0000 (+0100)
Subject: Abstract away the CORE::GLOBAL::require override code, foolproof tests
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=45638aed4f500330d6b63cecdcad25356026f392;p=dbsrgits%2FDBIx-Class-Historic.git

Abstract away the CORE::GLOBAL::require override code, foolproof tests

Rewrite prompted by some weirdness in Package::Stash::XS and require overrides
on older perls < 5.8.7. Besides the cleaner code add a kick-ass require
tracer.
---

diff --git a/Changes b/Changes
index 4e06e66..c899cc4 100644
--- a/Changes
+++ b/Changes
@@ -14,6 +14,7 @@ Revision history for DBIx::Class
           nasty memleak with version.pm on multiple ->VERSION invocations)
         - The internal carp module now correctly skips CAG frames when
           reporting a callsite
+        - Fix test failures on perl < 5.8.7 and new Package::Stash::XS
 
     * Misc
         - No longer depend on Variable::Magic now that a pure-perl
diff --git a/t/53lean_startup.t b/t/53lean_startup.t
index 81f9bca..072eac3 100644
--- a/t/53lean_startup.t
+++ b/t/53lean_startup.t
@@ -1,14 +1,17 @@
 # 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;
@@ -16,6 +19,12 @@ 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 {
+  require Package::Stash if $] < 5.008007;
+}
+
 my $expected_core_modules;
 
 BEGIN {
@@ -112,7 +121,7 @@ for (keys %$expected_core_modules) {
   $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) {
+    if (DBICTest::RunMode->is_smoker or DBICTest::RunMode->is_author) {
       fail ($err)
     }
     else {
diff --git a/t/55namespaces_cleaned.t b/t/55namespaces_cleaned.t
index 8a9e337..6706966 100644
--- a/t/55namespaces_cleaned.t
+++ b/t/55namespaces_cleaned.t
@@ -1,57 +1,32 @@
-# Pre-5.10 perls pollute %INC on unsuccesfull module
-# require, making it appear as if the module is already
-# loaded on subsequent require()s
-# Can't seem to find the exact RT/perldelta entry
-#
-# we want to do this here, in the very beginning, before even
-# warnings/strict are loaded
 BEGIN {
   if ($] < 5.010) {
 
-    # All of this almost verbatim copied from Lexical::SealRequireHints
-    # Zefram++
-
-    # a potential caller() in $next_require must see the correct
-    # immediate frame caller
-    my $caller = caller(0);
-
-    our $next_require = defined(&CORE::GLOBAL::require)
-      ? \&CORE::GLOBAL::require
-      : sub {
-        my ($arg) = @_;
-
-        # The shenanigans with $CORE::GLOBAL::{require}
-        # are required because if there's a
-        # &CORE::GLOBAL::require when the eval is
-        # executed then the CORE::require in there is
-        # interpreted as plain require on some Perl
-        # versions, leading to recursion.
-        my $grequire = delete $CORE::GLOBAL::{require};
-
-        my $result = eval sprintf '
-          local $SIG{__DIE__};
-          $CORE::GLOBAL::{require} = $grequire;
-          package %s;
-          CORE::require($arg);
-        ', $caller;
-
-        die $@ if $@ ne '';
-        return $result;
-      }
-    ;
-
-    *CORE::GLOBAL::require = sub {
-      die "wrong number of arguments to require\n"
-        unless @_ == 1;
-
-      my $res = eval "package $caller; \$next_require->(\@_)";
+    # Pre-5.10 perls pollute %INC on unsuccesfull module
+    # require, making it appear as if the module is already
+    # loaded on subsequent require()s
+    # Can't seem to find the exact RT/perldelta entry
+    #
+    # The reason we can't just use a sane, clean loader, is because
+    # if a Module require()s another module the %INC will still
+    # get filled with crap and we are back to square one. A global
+    # fix is really the only way for this test, as we try to load
+    # each available module separately, and have no control (nor
+    # knowledge) over their common dependencies.
+    #
+    # we want to do this here, in the very beginning, before even
+    # warnings/strict are loaded
+
+    unshift @INC, 't/lib';
+    require DBICTest::Util::OverrideRequire;
+
+    DBICTest::Util::OverrideRequire::override_global_require( sub {
+      my $res = eval { $_[0]->() };
       if ($@ ne '') {
-        delete $INC{$_[0]};
+        delete $INC{$_[1]};
         die $@;
       }
-
-      $res;
-    };
+      return $res;
+    } );
   }
 }
 
@@ -211,5 +186,4 @@ sub find_modules {
   return sort @modules;
 }
 
-
 done_testing;
diff --git a/t/lib/DBICTest/Util/OverrideRequire.pm b/t/lib/DBICTest/Util/OverrideRequire.pm
new file mode 100644
index 0000000..d776267
--- /dev/null
+++ b/t/lib/DBICTest/Util/OverrideRequire.pm
@@ -0,0 +1,127 @@
+package DBICTest::Util::OverrideRequire;
+
+# no use/require of any kind - work bare
+
+BEGIN {
+  # 0 - no trace
+  # 1 - just requires and return values
+  # 2 - full stacktrace
+  *TRACE = sub () { 0 };
+}
+
+# Takes a single coderef and replaces CORE::GLOBAL::require with it.
+#
+# On subsequent require() calls, the coderef will be invoked with
+# two arguments - ($next_require, $module_name_copy)
+#
+# $next_require is a coderef closing over the module name. It needs
+# to be invoked at some point without arguments for the actual
+# require to take place (this way your coderef in essence becomes an
+# around modifier)
+#
+# $module_name_copy is a string-copy of what $next_require is closing
+# over. The reason for the copy is that you may trigger a side effect
+# on magical values, and subsequently abort the require (e.g.
+# require v.5.8.8 magic)
+#
+# All of this almost verbatim copied from Lexical::SealRequireHints
+# Zefram++
+sub override_global_require (&) {
+  my $override_cref = shift;
+
+  our $next_require = defined(&CORE::GLOBAL::require)
+    ? \&CORE::GLOBAL::require
+    : sub {
+
+      my ($arg) = @_;
+
+      # The shenanigans with $CORE::GLOBAL::{require}
+      # are required because if there's a
+      # &CORE::GLOBAL::require when the eval is
+      # executed then the CORE::require in there is
+      # interpreted as plain require on some Perl
+      # versions, leading to recursion.
+      my $grequire = delete $CORE::GLOBAL::{require};
+
+      my $res = eval sprintf '
+        local $SIG{__DIE__};
+        $CORE::GLOBAL::{require} = $grequire;
+        package %s;
+        CORE::require($arg);
+      ', scalar caller(0);  # the caller already had its package replaced
+
+      my $err = $@ if $@ ne '';
+
+      if( TRACE ) {
+        if (TRACE == 1) {
+          printf STDERR "Require of '%s' (returned: '%s')\n",
+            (my $m_copy = $arg),
+            (my $r_copy = $res),
+          ;
+        }
+        else {
+          my ($fr_num, @fr, @tr, $excise);
+          while (@fr = caller($fr_num++)) {
+
+            # Package::Stash::XS is a cock and gets mightily confused if one
+            # uses a regex in the require hook - go figure
+
+            if (index($fr[1], '(eval ') != 0 and index($fr[1], __FILE__) != 0) {
+              push @tr, [@fr]
+            }
+
+            if ($fr[3] eq 'DBICTest::Util::OverrideRequire::__ANON__') {
+              $excise ||= $tr[-2];
+            }
+          }
+
+          my @stack =
+            map { "$_->[1], line $_->[2]" }
+            grep { not ($_->[1] eq $excise->[1] and $_->[2] eq $_->[2]) }
+            @tr
+          ;
+
+          printf STDERR "Require of '%s' (returned: '%s')\n%s\n\n",
+            (my $m_copy = $arg),
+            (my $r_copy = $res||''),
+            join "\n", (map { "    $_" } @stack)
+          ;
+        }
+      }
+
+      die $err if defined $err;
+
+      return $res;
+    }
+  ;
+
+  # Need to suppress the redefinition warning, without
+  # invoking warnings.pm.
+  BEGIN { ${^WARNING_BITS} = ""; }
+
+  *CORE::GLOBAL::require = sub {
+    die "wrong number of arguments to require\n"
+      unless @_ == 1;
+
+    # the copy is to prevent accidental overload firing (e.g. require v5.8.8)
+    my ($arg_copy) = our ($arg) = @_;
+
+    return $override_cref->(sub {
+      die "The require delegate takes no arguments\n"
+        if @_;
+
+      my $res = eval sprintf '
+        local $SIG{__DIE__};
+        package %s;
+        $next_require->($arg);
+      ', scalar caller(2);  # 2 for the indirection of the $override_cref around
+
+      die $@ if $@ ne '';
+
+      return $res;
+
+    }, $arg_copy);
+  }
+}
+
+1;