1 package DBICTest::Util::OverrideRequire;
3 # no use/require of any kind - work bare
6 # Neat STDERR require call tracer
9 # 1 - just requires and return values
10 # 2 - neat stacktrace (assumes that the supplied $override_cref does *not* (ab)use goto)
12 *TRACE = sub () { 0 };
15 # Takes a single coderef and replaces CORE::GLOBAL::require with it.
17 # On subsequent require() calls, the coderef will be invoked with
18 # two arguments - ($next_require, $module_name_copy)
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
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)
30 # All of this almost verbatim copied from Lexical::SealRequireHints
32 sub override_global_require (&) {
33 my $override_cref = shift;
35 our $next_require = defined(&CORE::GLOBAL::require)
36 ? \&CORE::GLOBAL::require
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};
49 my $res = eval sprintf '
51 $CORE::GLOBAL::{require} = $grequire;
54 ', scalar caller(0); # the caller already had its package replaced
56 my $err = $@ if $@ ne '';
60 printf STDERR "Require of '%s' (returned: '%s')\n",
66 my ($fr_num, @fr, @tr, $excise);
67 while (@fr = caller($fr_num++)) {
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) ) {
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__') {
86 map { "$_->[1], line $_->[2]" }
87 grep { ! $excise or $_->[1] ne $excise->[1] or $_->[2] ne $excise->[2] }
91 printf STDERR "Require of '%s' (returned: '%s')\n%s\n\n",
93 (my $r_copy = $res||''),
94 join "\n", (map { " $_" } @stack)
99 die $err if defined $err;
105 # Need to suppress the redefinition warning, without
106 # invoking warnings.pm.
107 BEGIN { ${^WARNING_BITS} = ""; }
109 *CORE::GLOBAL::require = sub {
110 die "wrong number of arguments to require\n"
113 # the copy is to prevent accidental overload firing (e.g. require v5.8.8)
114 my ($arg_copy) = our ($arg) = @_;
116 return $override_cref->(sub {
117 die "The require delegate takes no arguments\n"
120 my $res = eval sprintf '
123 $next_require->($arg);
124 ', scalar caller(2); # 2 for the indirection of the $override_cref around