Commit | Line | Data |
1a80b58a |
1 | package Devel::OverrideGlobalRequire; |
2 | # ABSTRACT: Override CORE::GLOBAL::require safely |
3 | # VERSION |
4 | |
5 | # no use/require of any kind - work bare |
6 | |
7 | BEGIN { |
8 | # Neat STDERR require call tracer |
9 | # |
10 | # 0 - no trace |
11 | # 1 - just requires and return values |
12 | # 2 - neat stacktrace (assumes that the supplied $override_cref does *not* (ab)use goto) |
13 | # 3 - full stacktrace |
14 | *TRACE = sub () { 0 }; |
15 | } |
16 | |
17 | # Takes a single coderef and replaces CORE::GLOBAL::require with it. |
18 | # |
19 | # On subsequent require() calls, the coderef will be invoked with |
20 | # two arguments - ($next_require, $module_name_copy) |
21 | # |
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 |
25 | # around modifier) |
26 | # |
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) |
31 | # |
32 | # All of this almost verbatim copied from Lexical::SealRequireHints |
33 | # Zefram++ |
34 | sub override_global_require (&) { |
35 | my $override_cref = shift; |
36 | |
37 | our $next_require = defined(&CORE::GLOBAL::require) |
38 | ? \&CORE::GLOBAL::require |
39 | : sub { |
40 | |
41 | my ($arg) = @_; |
42 | |
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}; |
50 | |
51 | my $res = eval sprintf ' |
52 | local $SIG{__DIE__}; |
53 | $CORE::GLOBAL::{require} = $grequire; |
54 | package %s; |
55 | CORE::require($arg); |
56 | ', scalar caller(0); # the caller already had its package replaced |
57 | |
58 | my $err = $@ if $@ ne ''; |
59 | |
60 | if( TRACE ) { |
61 | if (TRACE == 1) { |
62 | printf STDERR "Require of '%s' (returned: '%s')\n", |
63 | (my $m_copy = $arg), |
64 | (my $r_copy = $res), |
65 | ; |
66 | } |
67 | else { |
68 | my ($fr_num, @fr, @tr, $excise); |
69 | while (@fr = caller($fr_num++)) { |
70 | |
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) ) { |
76 | push @tr, [@fr] |
77 | } |
78 | |
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__') { |
82 | $excise ||= $tr[-2] |
83 | if TRACE == 2; |
84 | } |
85 | } |
86 | |
87 | my @stack = |
88 | map { "$_->[1], line $_->[2]" } |
89 | grep { ! $excise or $_->[1] ne $excise->[1] or $_->[2] ne $excise->[2] } |
90 | @tr |
91 | ; |
92 | |
93 | printf STDERR "Require of '%s' (returned: '%s')\n%s\n\n", |
94 | (my $m_copy = $arg), |
95 | (my $r_copy = $res||''), |
96 | join "\n", (map { " $_" } @stack) |
97 | ; |
98 | } |
99 | } |
100 | |
101 | die $err if defined $err; |
102 | |
103 | return $res; |
104 | } |
105 | ; |
106 | |
107 | # Need to suppress the redefinition warning, without |
108 | # invoking warnings.pm. |
109 | BEGIN { ${^WARNING_BITS} = ""; } |
110 | |
111 | *CORE::GLOBAL::require = sub { |
112 | die "wrong number of arguments to require\n" |
113 | unless @_ == 1; |
114 | |
115 | # the copy is to prevent accidental overload firing (e.g. require v5.8.8) |
116 | my ($arg_copy) = our ($arg) = @_; |
117 | |
118 | return $override_cref->(sub { |
119 | die "The require delegate takes no arguments\n" |
120 | if @_; |
121 | |
122 | my $res = eval sprintf ' |
123 | local $SIG{__DIE__}; |
124 | package %s; |
125 | $next_require->($arg); |
126 | ', scalar caller(2); # 2 for the indirection of the $override_cref around |
127 | |
128 | die $@ if $@ ne ''; |
129 | |
130 | return $res; |
131 | |
132 | }, $arg_copy); |
133 | } |
134 | } |
135 | |
136 | 1; |
137 | |
138 | =for Pod::Coverage |
139 | override_global_require |
140 | TRACE |
141 | |
142 | |
143 | =head1 SYNOPSIS |
144 | |
145 | use Devel::OverrideGlobalRequire; |
146 | |
3463573e |
147 | Devel::OverrideGlobalRequire::override_global_require( sub { ... } ); |
1a80b58a |
148 | |
149 | =head1 DESCRIPTION |
150 | |
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 |
153 | package is in scope. |
154 | |
155 | =cut |
156 | |
157 | # vim: ts=4 sts=4 sw=4 et: |