X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FDevel%2FOverrideGlobalRequire.pm;fp=lib%2FDevel%2FOverrideGlobalRequire.pm;h=dd960e2924e4143449ecabd96b03ed628ca6b531;hb=1a80b58af1f0e592fc77aebfb0b95a85e2a45285;hp=0000000000000000000000000000000000000000;hpb=78fc3f319b11568f6d4f668ed5f70357033fcc1d;p=p5sagit%2FDevel-OverrideGlobalRequire.git

diff --git a/lib/Devel/OverrideGlobalRequire.pm b/lib/Devel/OverrideGlobalRequire.pm
new file mode 100644
index 0000000..dd960e2
--- /dev/null
+++ b/lib/Devel/OverrideGlobalRequire.pm
@@ -0,0 +1,157 @@
+package Devel::OverrideGlobalRequire;
+# ABSTRACT: Override CORE::GLOBAL::require safely
+# VERSION
+
+# no use/require of any kind - work bare
+
+BEGIN {
+  # Neat STDERR require call tracer
+  #
+  # 0 - no trace
+  # 1 - just requires and return values
+  # 2 - neat stacktrace (assumes that the supplied $override_cref does *not* (ab)use goto)
+  # 3 - 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. Even though it happens only
+            # on < 5.8.7 it's still rather embarassing (also wtf does P::S::XS
+            # even need to regex its own module name?!). So we do not use re :)
+            if (TRACE == 3 or (index($fr[1], '(eval ') != 0 and index($fr[1], __FILE__) != 0) ) {
+              push @tr, [@fr]
+            }
+
+            # the caller before this would be the override site - kill it away
+            # if the cref writer uses goto - well tough, tracer won't work
+            if ($fr[3] eq 'DBICTest::Util::OverrideRequire::__ANON__') {
+              $excise ||= $tr[-2]
+                if TRACE == 2;
+            }
+          }
+
+          my @stack =
+            map { "$_->[1], line $_->[2]" }
+            grep { ! $excise or $_->[1] ne $excise->[1] or $_->[2] ne $excise->[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;
+
+=for Pod::Coverage
+override_global_require
+TRACE
+
+
+=head1 SYNOPSIS
+
+  use Devel::OverrideGlobalRequire;
+
+  override_global_require( sub { ... } );
+
+=head1 DESCRIPTION
+
+This module overrides C<CORE::GLOBAL::require> with a code reference in a way
+that plays nice with any existing overloading and ensures the right calling
+package is in scope.
+
+=cut
+
+# vim: ts=4 sts=4 sw=4 et: