1 package Devel::OverrideGlobalRequire;
2 # ABSTRACT: Override CORE::GLOBAL::require safely
5 # no use/require of any kind - work bare
8 # Neat STDERR require call tracer
11 # 1 - just requires and return values
12 # 2 - neat stacktrace (assumes that the supplied $override_cref does *not* (ab)use goto)
14 *TRACE = sub () { 0 };
17 # Takes a single coderef and replaces CORE::GLOBAL::require with it.
19 # On subsequent require() calls, the coderef will be invoked with
20 # two arguments - ($next_require, $module_name_copy)
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
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)
32 # All of this almost verbatim copied from Lexical::SealRequireHints
34 sub override_global_require (&) {
35 my $override_cref = shift;
37 our $next_require = defined(&CORE::GLOBAL::require)
38 ? \&CORE::GLOBAL::require
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};
51 my $res = eval sprintf '
53 $CORE::GLOBAL::{require} = $grequire;
56 ', scalar caller(0); # the caller already had its package replaced
58 my $err = $@ if $@ ne '';
62 printf STDERR "Require of '%s' (returned: '%s')\n",
68 my ($fr_num, @fr, @tr, $excise);
69 while (@fr = caller($fr_num++)) {
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) ) {
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__') {
88 map { "$_->[1], line $_->[2]" }
89 grep { ! $excise or $_->[1] ne $excise->[1] or $_->[2] ne $excise->[2] }
93 printf STDERR "Require of '%s' (returned: '%s')\n%s\n\n",
95 (my $r_copy = $res||''),
96 join "\n", (map { " $_" } @stack)
101 die $err if defined $err;
107 # Need to suppress the redefinition warning, without
108 # invoking warnings.pm.
109 BEGIN { ${^WARNING_BITS} = ""; }
111 *CORE::GLOBAL::require = sub {
112 die "wrong number of arguments to require\n"
115 # the copy is to prevent accidental overload firing (e.g. require v5.8.8)
116 my ($arg_copy) = our ($arg) = @_;
118 return $override_cref->(sub {
119 die "The require delegate takes no arguments\n"
122 my $res = eval sprintf '
125 $next_require->($arg);
126 ', scalar caller(2); # 2 for the indirection of the $override_cref around
139 override_global_require
145 use Devel::OverrideGlobalRequire;
147 Devel::OverrideGlobalRequire::override_global_require( sub { ... } );
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
157 # vim: ts=4 sts=4 sw=4 et: