1 package DBICTest::Util::OverrideRequire;
3 # no use/require of any kind - work bare
7 # 1 - just requires and return values
12 # Takes a single coderef and replaces CORE::GLOBAL::require with it.
14 # On subsequent require() calls, the coderef will be invoked with
15 # two arguments - ($next_require, $module_name_copy)
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
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)
27 # All of this almost verbatim copied from Lexical::SealRequireHints
29 sub override_global_require (&) {
30 my $override_cref = shift;
32 our $next_require = defined(&CORE::GLOBAL::require)
33 ? \&CORE::GLOBAL::require
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};
46 my $res = eval sprintf '
48 $CORE::GLOBAL::{require} = $grequire;
51 ', scalar caller(0); # the caller already had its package replaced
53 my $err = $@ if $@ ne '';
57 printf STDERR "Require of '%s' (returned: '%s')\n",
63 my ($fr_num, @fr, @tr, $excise);
64 while (@fr = caller($fr_num++)) {
66 # Package::Stash::XS is a cock and gets mightily confused if one
67 # uses a regex in the require hook - go figure
69 if (index($fr[1], '(eval ') != 0 and index($fr[1], __FILE__) != 0) {
73 if ($fr[3] eq 'DBICTest::Util::OverrideRequire::__ANON__') {
79 map { "$_->[1], line $_->[2]" }
80 grep { not ($_->[1] eq $excise->[1] and $_->[2] eq $_->[2]) }
84 printf STDERR "Require of '%s' (returned: '%s')\n%s\n\n",
86 (my $r_copy = $res||''),
87 join "\n", (map { " $_" } @stack)
92 die $err if defined $err;
98 # Need to suppress the redefinition warning, without
99 # invoking warnings.pm.
100 BEGIN { ${^WARNING_BITS} = ""; }
102 *CORE::GLOBAL::require = sub {
103 die "wrong number of arguments to require\n"
106 # the copy is to prevent accidental overload firing (e.g. require v5.8.8)
107 my ($arg_copy) = our ($arg) = @_;
109 return $override_cref->(sub {
110 die "The require delegate takes no arguments\n"
113 my $res = eval sprintf '
116 $next_require->($arg);
117 ', scalar caller(2); # 2 for the indirection of the $override_cref around