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