lib/Devel/OverrideGlobalRequire.pm

   1 package Devel::OverrideGlobalRequire;
   2 # ABSTRACT: Override CORE::GLOBAL::require safely
   3 # VERSION
   4
   5 # no use/require of any kind - work bare
   6
   7 BEGIN {
   8   # Neat STDERR require call tracer
   9   #
  10   # 0 - no trace
  11   # 1 - just requires and return values
  12   # 2 - neat stacktrace (assumes that the supplied $override_cref does *not* (ab)use goto)
  13   # 3 - full stacktrace
  14   *TRACE = sub () { 0 };
  15 }
  16
  17 # Takes a single coderef and replaces CORE::GLOBAL::require with it.
  18 #
  19 # On subsequent require() calls, the coderef will be invoked with
  20 # two arguments - ($next_require, $module_name_copy)
  21 #
  22 # $next_require is a coderef closing over the module name. It needs
  23 # to be invoked at some point without arguments for the actual
  24 # require to take place (this way your coderef in essence becomes an
  25 # around modifier)
  26 #
  27 # $module_name_copy is a string-copy of what $next_require is closing
  28 # over. The reason for the copy is that you may trigger a side effect
  29 # on magical values, and subsequently abort the require (e.g.
  30 # require v.5.8.8 magic)
  31 #
  32 # All of this almost verbatim copied from Lexical::SealRequireHints
  33 # Zefram++
  34 sub override_global_require (&) {
  35   my $override_cref = shift;
  36
  37   our $next_require = defined(&CORE::GLOBAL::require)
  38     ? \&CORE::GLOBAL::require
  39     : sub {
  40
  41       my ($arg) = @_;
  42
  43       # The shenanigans with $CORE::GLOBAL::{require}
  44       # are required because if there's a
  45       # &CORE::GLOBAL::require when the eval is
  46       # executed then the CORE::require in there is
  47       # interpreted as plain require on some Perl
  48       # versions, leading to recursion.
  49       my $grequire = delete $CORE::GLOBAL::{require};
  50
  51       my $res = eval sprintf '
  52         local $SIG{__DIE__};
  53         $CORE::GLOBAL::{require} = $grequire;
  54         package %s;
  55         CORE::require($arg);
  56       ', scalar caller(0);  # the caller already had its package replaced
  57
  58       my $err = $@ if $@ ne '';
  59
  60       if( TRACE ) {
  61         if (TRACE == 1) {
  62           printf STDERR "Require of '%s' (returned: '%s')\n",
  63             (my $m_copy = $arg),
  64             (my $r_copy = $res),
  65           ;
  66         }
  67         else {
  68           my ($fr_num, @fr, @tr, $excise);
  69           while (@fr = caller($fr_num++)) {
  70
  71             # Package::Stash::XS is a cock and gets mightily confused if one
  72             # uses a regex in the require hook. Even though it happens only
  73             # on < 5.8.7 it's still rather embarassing (also wtf does P::S::XS
  74             # even need to regex its own module name?!). So we do not use re :)
  75             if (TRACE == 3 or (index($fr[1], '(eval ') != 0 and index($fr[1], __FILE__) != 0) ) {
  76               push @tr, [@fr]
  77             }
  78
  79             # the caller before this would be the override site - kill it away
  80             # if the cref writer uses goto - well tough, tracer won't work
  81             if ($fr[3] eq 'DBICTest::Util::OverrideRequire::__ANON__') {
  82               $excise ||= $tr[-2]
  83                 if TRACE == 2;
  84             }
  85           }
  86
  87           my @stack =
  88             map { "$_->[1], line $_->[2]" }
  89             grep { ! $excise or $_->[1] ne $excise->[1] or $_->[2] ne $excise->[2] }
  90             @tr
  91           ;
  92
  93           printf STDERR "Require of '%s' (returned: '%s')\n%s\n\n",
  94             (my $m_copy = $arg),
  95             (my $r_copy = $res||''),
  96             join "\n", (map { "    $_" } @stack)
  97           ;
  98         }
  99       }
 100
 101       die $err if defined $err;
 102
 103       return $res;
 104     }
 105   ;
 106
 107   # Need to suppress the redefinition warning, without
 108   # invoking warnings.pm.
 109   BEGIN { ${^WARNING_BITS} = ""; }
 110
 111   *CORE::GLOBAL::require = sub {
 112     die "wrong number of arguments to require\n"
 113       unless @_ == 1;
 114
 115     # the copy is to prevent accidental overload firing (e.g. require v5.8.8)
 116     my ($arg_copy) = our ($arg) = @_;
 117
 118     return $override_cref->(sub {
 119       die "The require delegate takes no arguments\n"
 120         if @_;
 121
 122       my $res = eval sprintf '
 123         local $SIG{__DIE__};
 124         package %s;
 125         $next_require->($arg);
 126       ', scalar caller(2);  # 2 for the indirection of the $override_cref around
 127
 128       die $@ if $@ ne '';
 129
 130       return $res;
 131
 132     }, $arg_copy);
 133   }
 134 }
 135
 136 1;
 137
 138 =for Pod::Coverage
 139 override_global_require
 140 TRACE
 141
 142
 143 =head1 SYNOPSIS
 144
 145   use Devel::OverrideGlobalRequire;
 146
 147   override_global_require( sub { ... } );
 148
 149 =head1 DESCRIPTION
 150
 151 This module overrides C<CORE::GLOBAL::require> with a code reference in a way
 152 that plays nice with any existing overloading and ensures the right calling
 153 package is in scope.
 154
 155 =cut
 156
 157 # vim: ts=4 sts=4 sw=4 et: