t/lib/DBICTest/Util/OverrideRequire.pm

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