Commit | Line | Data |
45638aed |
1 | package DBICTest::Util::OverrideRequire; |
2 | |
3 | # no use/require of any kind - work bare |
4 | |
5 | BEGIN { |
c86376b4 |
6 | # Neat STDERR require call tracer |
7 | # |
45638aed |
8 | # 0 - no trace |
9 | # 1 - just requires and return values |
c86376b4 |
10 | # 2 - neat stacktrace (assumes that the supplied $override_cref does *not* (ab)use goto) |
11 | # 3 - full stacktrace |
45638aed |
12 | *TRACE = sub () { 0 }; |
13 | } |
14 | |
15 | # Takes a single coderef and replaces CORE::GLOBAL::require with it. |
16 | # |
17 | # On subsequent require() calls, the coderef will be invoked with |
18 | # two arguments - ($next_require, $module_name_copy) |
19 | # |
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 |
23 | # around modifier) |
24 | # |
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) |
29 | # |
30 | # All of this almost verbatim copied from Lexical::SealRequireHints |
31 | # Zefram++ |
32 | sub override_global_require (&) { |
33 | my $override_cref = shift; |
34 | |
35 | our $next_require = defined(&CORE::GLOBAL::require) |
36 | ? \&CORE::GLOBAL::require |
37 | : sub { |
38 | |
39 | my ($arg) = @_; |
40 | |
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}; |
48 | |
49 | my $res = eval sprintf ' |
50 | local $SIG{__DIE__}; |
51 | $CORE::GLOBAL::{require} = $grequire; |
52 | package %s; |
53 | CORE::require($arg); |
54 | ', scalar caller(0); # the caller already had its package replaced |
55 | |
56 | my $err = $@ if $@ ne ''; |
57 | |
58 | if( TRACE ) { |
59 | if (TRACE == 1) { |
60 | printf STDERR "Require of '%s' (returned: '%s')\n", |
61 | (my $m_copy = $arg), |
62 | (my $r_copy = $res), |
63 | ; |
64 | } |
65 | else { |
66 | my ($fr_num, @fr, @tr, $excise); |
67 | while (@fr = caller($fr_num++)) { |
68 | |
69 | # Package::Stash::XS is a cock and gets mightily confused if one |
c86376b4 |
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) ) { |
45638aed |
74 | push @tr, [@fr] |
75 | } |
76 | |
c86376b4 |
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 |
45638aed |
79 | if ($fr[3] eq 'DBICTest::Util::OverrideRequire::__ANON__') { |
c86376b4 |
80 | $excise ||= $tr[-2] |
81 | if TRACE == 2; |
45638aed |
82 | } |
83 | } |
84 | |
85 | my @stack = |
86 | map { "$_->[1], line $_->[2]" } |
c86376b4 |
87 | grep { ! $excise or $_->[1] ne $excise->[1] or $_->[2] ne $excise->[2] } |
45638aed |
88 | @tr |
89 | ; |
90 | |
91 | printf STDERR "Require of '%s' (returned: '%s')\n%s\n\n", |
92 | (my $m_copy = $arg), |
93 | (my $r_copy = $res||''), |
94 | join "\n", (map { " $_" } @stack) |
95 | ; |
96 | } |
97 | } |
98 | |
99 | die $err if defined $err; |
100 | |
101 | return $res; |
102 | } |
103 | ; |
104 | |
105 | # Need to suppress the redefinition warning, without |
106 | # invoking warnings.pm. |
107 | BEGIN { ${^WARNING_BITS} = ""; } |
108 | |
109 | *CORE::GLOBAL::require = sub { |
110 | die "wrong number of arguments to require\n" |
111 | unless @_ == 1; |
112 | |
113 | # the copy is to prevent accidental overload firing (e.g. require v5.8.8) |
114 | my ($arg_copy) = our ($arg) = @_; |
115 | |
116 | return $override_cref->(sub { |
117 | die "The require delegate takes no arguments\n" |
118 | if @_; |
119 | |
120 | my $res = eval sprintf ' |
121 | local $SIG{__DIE__}; |
122 | package %s; |
123 | $next_require->($arg); |
124 | ', scalar caller(2); # 2 for the indirection of the $override_cref around |
125 | |
126 | die $@ if $@ ne ''; |
127 | |
128 | return $res; |
129 | |
130 | }, $arg_copy); |
131 | } |
132 | } |
133 | |
134 | 1; |