File Coverage

blib/lib/Sub/Uplevel.pm
Criterion Covered Total %
statement 66 67 98.5
branch 28 30 93.3
condition 5 5 100.0
subroutine 12 12 100.0
pod 1 1 100.0
total 112 115 97.3


line stmt bran cond sub pod time code
1             package Sub::Uplevel;
2 8     8   149185 use 5.006;
  8         24  
3 8     8   40 use strict;
  8         12  
  8         470  
4             # ABSTRACT: apparently run a function in a higher stack frame
5              
6             our $VERSION = '0.2600';
7              
8             # Frame check global constant
9             our $CHECK_FRAMES;
10             BEGIN {
11 8     8   226 $CHECK_FRAMES = !! $CHECK_FRAMES;
12             }
13 8     8   40 use constant CHECK_FRAMES => $CHECK_FRAMES;
  8         14  
  8         1197  
14              
15             # We must override *CORE::GLOBAL::caller if it hasn't already been
16             # overridden or else Perl won't see our local override later.
17              
18             if ( not defined *CORE::GLOBAL::caller{CODE} ) {
19             *CORE::GLOBAL::caller = \&_normal_caller;
20             }
21              
22             # modules to force reload if ":aggressive" is specified
23             my @reload_list = qw/Exporter Exporter::Heavy/;
24              
25             sub import {
26 8     8   40 no strict 'refs'; ## no critic
  8         19  
  8         1358  
27 10     10   94 my ($class, @args) = @_;
28 10         24 for my $tag ( @args, 'uplevel' ) {
29 11 100       1466 if ( $tag eq 'uplevel' ) {
    50          
30 10         24 my $caller = caller(0);
31 10         80 *{"$caller\::uplevel"} = \&uplevel;
  10         88  
32             }
33             elsif( $tag eq ':aggressive' ) {
34 1         2 _force_reload( @reload_list );
35             }
36             else {
37 0         0 die qq{"$tag" is not exported by the $class module\n}
38             }
39             }
40 10         5024 return;
41             }
42              
43             sub _force_reload {
44 8     8   44 no warnings 'redefine';
  8         12  
  8         6116  
45 1     1   3 local $^W = 0;
46 1         2 for my $m ( @_ ) {
47 2         28 $m =~ s{::}{/}g;
48 2         3 $m .= ".pm";
49 2 50       939 require $m if delete $INC{$m};
50             }
51             }
52              
53             #pod =head1 SYNOPSIS
54             #pod
55             #pod use Sub::Uplevel;
56             #pod
57             #pod sub foo {
58             #pod print join " - ", caller;
59             #pod }
60             #pod
61             #pod sub bar {
62             #pod uplevel 1, \&foo;
63             #pod }
64             #pod
65             #pod #line 11
66             #pod bar(); # main - foo.plx - 11
67             #pod
68             #pod =head1 DESCRIPTION
69             #pod
70             #pod Like Tcl's uplevel() function, but not quite so dangerous. The idea
71             #pod is just to fool caller(). All the really naughty bits of Tcl's
72             #pod uplevel() are avoided.
73             #pod
74             #pod B
75             #pod
76             #pod =over 4
77             #pod
78             #pod =item B
79             #pod
80             #pod uplevel $num_frames, \&func, @args;
81             #pod
82             #pod Makes the given function think it's being executed $num_frames higher
83             #pod than the current stack level. So when they use caller($frames) it
84             #pod will actually give caller($frames + $num_frames) for them.
85             #pod
86             #pod C is effectively C but
87             #pod you don't immediately exit the current subroutine. So while you can't
88             #pod do this:
89             #pod
90             #pod sub wrapper {
91             #pod print "Before\n";
92             #pod goto &some_func;
93             #pod print "After\n";
94             #pod }
95             #pod
96             #pod you can do this:
97             #pod
98             #pod sub wrapper {
99             #pod print "Before\n";
100             #pod my @out = uplevel 1, &some_func;
101             #pod print "After\n";
102             #pod return @out;
103             #pod }
104             #pod
105             #pod C has the ability to issue a warning if C<$num_frames> is more than
106             #pod the current call stack depth, although this warning is disabled and compiled
107             #pod out by default as the check is relatively expensive.
108             #pod
109             #pod To enable the check for debugging or testing, you should set the global
110             #pod C<$Sub::Uplevel::CHECK_FRAMES> to true before loading Sub::Uplevel for the
111             #pod first time as follows:
112             #pod
113             #pod #!/usr/bin/perl
114             #pod
115             #pod BEGIN {
116             #pod $Sub::Uplevel::CHECK_FRAMES = 1;
117             #pod }
118             #pod use Sub::Uplevel;
119             #pod
120             #pod Setting or changing the global after the module has been loaded will have
121             #pod no effect.
122             #pod
123             #pod =cut
124              
125             # @Up_Frames -- uplevel stack
126             # $Caller_Proxy -- whatever caller() override was in effect before uplevel
127             our (@Up_Frames, $Caller_Proxy);
128              
129             sub _apparent_stack_height {
130 2     2   3 my $height = 1; # start above this function
131 2         5 while ( 1 ) {
132 6 100       11 last if ! defined scalar $Caller_Proxy->($height);
133 4         4 $height++;
134             }
135 2         11 return $height - 1; # subtract 1 for this function
136             }
137              
138             sub uplevel {
139             # Backwards compatible version of "no warnings 'redefine'"
140 122     122 1 16195 my $old_W = $^W;
141 122         266 $^W = 0;
142              
143             # Update the caller proxy if the uplevel override isn't in effect
144             local $Caller_Proxy = *CORE::GLOBAL::caller{CODE}
145 122 100       602 if *CORE::GLOBAL::caller{CODE} != \&_uplevel_caller;
146 122         422 local *CORE::GLOBAL::caller = \&_uplevel_caller;
147              
148             # Restore old warnings state
149 122         159 $^W = $old_W;
150              
151 122         182 if ( CHECK_FRAMES and $_[0] >= _apparent_stack_height() ) {
152             require Carp;
153             Carp::carp("uplevel $_[0] is more than the caller stack");
154             }
155              
156 121         1055 local @Up_Frames = (shift, @Up_Frames );
157              
158 121         230 my $function = shift;
159 122         477 return $function->(@_);
160             }
161              
162             sub _normal_caller (;$) { ## no critic Prototypes
163 734     732   39551 my ($height) = @_;
164 734         1403 $height++;
165 732         8822 my @caller = CORE::caller($height);
166 732 100       2723 if ( CORE::caller() eq 'DB' ) {
167             # Oops, redo picking up @DB::args
168             package DB;
169 11         34 @caller = CORE::caller($height);
170             }
171              
172 732 100       3738 return if ! @caller; # empty
173 609 100       2345 return $caller[0] if ! wantarray; # scalar context
174 593 100       5104 return @_ ? @caller : @caller[0..2]; # extra info or regular
175             }
176              
177             sub _uplevel_caller (;$) { ## no critic Prototypes
178 692   100 692   7883 my $height = $_[0] || 0;
179              
180             # shortcut if no uplevels have been called
181             # always add +1 to CORE::caller (proxy caller function)
182             # to skip this function's caller
183 692 100       1904 return $Caller_Proxy->( $height + 1 ) if ! @Up_Frames;
184              
185             #pod =begin _private
186             #pod
187             #pod So it has to work like this:
188             #pod
189             #pod Call stack Actual uplevel 1
190             #pod CORE::GLOBAL::caller
191             #pod Carp::short_error_loc 0
192             #pod Carp::shortmess_heavy 1 0
193             #pod Carp::croak 2 1
194             #pod try_croak 3 2
195             #pod uplevel 4
196             #pod function_that_called_uplevel 5
197             #pod caller_we_want_to_see 6 3
198             #pod its_caller 7 4
199             #pod
200             #pod So when caller(X) winds up below uplevel(), it only has to use
201             #pod CORE::caller(X+1) (to skip CORE::GLOBAL::caller). But when caller(X)
202             #pod winds up no or above uplevel(), it's CORE::caller(X+1+uplevel+1).
203             #pod
204             #pod Which means I'm probably going to have to do something nasty like walk
205             #pod up the call stack on each caller() to see if I'm going to wind up
206             #pod before or after Sub::Uplevel::uplevel().
207             #pod
208             #pod =end _private
209             #pod
210             #pod =begin _dagolden
211             #pod
212             #pod I found the description above a bit confusing. Instead, this is the logic
213             #pod that I found clearer when CORE::GLOBAL::caller is invoked and we have to
214             #pod walk up the call stack:
215             #pod
216             #pod * if searching up to the requested height in the real call stack doesn't find
217             #pod a call to uplevel, then we can return the result at that height in the
218             #pod call stack
219             #pod
220             #pod * if we find a call to uplevel, we need to keep searching upwards beyond the
221             #pod requested height at least by the amount of upleveling requested for that
222             #pod call to uplevel (from the Up_Frames stack set during the uplevel call)
223             #pod
224             #pod * additionally, we need to hide the uplevel subroutine call, too, so we search
225             #pod upwards one more level for each call to uplevel
226             #pod
227             #pod * when we've reached the top of the search, we want to return that frame
228             #pod in the call stack, i.e. the requested height plus any uplevel adjustments
229             #pod found during the search
230             #pod
231             #pod =end _dagolden
232             #pod
233             #pod =cut
234              
235 684         802 my $saw_uplevel = 0;
236 684         639 my $adjust = 0;
237              
238             # walk up the call stack to fight the right package level to return;
239             # look one higher than requested for each call to uplevel found
240             # and adjust by the amount found in the Up_Frames stack for that call.
241             # We *must* use CORE::caller here since we need the real stack not what
242             # some other override says the stack looks like, just in case that other
243             # override breaks things in some horrible way
244 684         565 my $test_caller;
245 684         2090 for ( my $up = 0; $up <= $height + $adjust; $up++ ) {
246 5958         13572 $test_caller = scalar CORE::caller($up + 1);
247 5958 100 100     39812 if( $test_caller && $test_caller eq __PACKAGE__ ) {
248             # add one for each uplevel call seen
249             # and look into the uplevel stack for the offset
250 1220         3522 $adjust += 1 + $Up_Frames[$saw_uplevel];
251 1220         3070 $saw_uplevel++;
252             }
253             }
254              
255             # For returning values, we pass through the call to the proxy caller
256             # function, just at a higher stack level
257 684         3471 my @caller = $Caller_Proxy->($height + $adjust + 1);
258 684 100       2486 if ( CORE::caller() eq 'DB' ) {
259             # Oops, redo picking up @DB::args
260             package DB;
261 10         12 @caller = $Sub::Uplevel::Caller_Proxy->($height + $adjust + 1);
262             }
263              
264 684 100       2560 return if ! @caller; # empty
265 570 100       3550 return $caller[0] if ! wantarray; # scalar context
266 28 100       338 return @_ ? @caller : @caller[0..2]; # extra info or regular
267             }
268              
269             #pod =back
270             #pod
271             #pod =head1 EXAMPLE
272             #pod
273             #pod The main reason I wrote this module is so I could write wrappers
274             #pod around functions and they wouldn't be aware they've been wrapped.
275             #pod
276             #pod use Sub::Uplevel;
277             #pod
278             #pod my $original_foo = \&foo;
279             #pod
280             #pod *foo = sub {
281             #pod my @output = uplevel 1, $original_foo;
282             #pod print "foo() returned: @output";
283             #pod return @output;
284             #pod };
285             #pod
286             #pod If this code frightens you B
287             #pod
288             #pod
289             #pod =head1 BUGS and CAVEATS
290             #pod
291             #pod Well, the bad news is uplevel() is about 5 times slower than a normal
292             #pod function call. XS implementation anyone? It also slows down every invocation
293             #pod of caller(), regardless of whether uplevel() is in effect.
294             #pod
295             #pod Sub::Uplevel overrides CORE::GLOBAL::caller temporarily for the scope of
296             #pod each uplevel call. It does its best to work with any previously existing
297             #pod CORE::GLOBAL::caller (both when Sub::Uplevel is first loaded and within
298             #pod each uplevel call) such as from Contextual::Return or Hook::LexWrap.
299             #pod
300             #pod However, if you are routinely using multiple modules that override
301             #pod CORE::GLOBAL::caller, you are probably asking for trouble.
302             #pod
303             #pod You B load Sub::Uplevel as early as possible within your program. As
304             #pod with all CORE::GLOBAL overloading, the overload will not affect modules that
305             #pod have already been compiled prior to the overload. One module that often is
306             #pod unavoidably loaded prior to Sub::Uplevel is Exporter. To forcibly recompile
307             #pod Exporter (and Exporter::Heavy) after loading Sub::Uplevel, use it with the
308             #pod ":aggressive" tag:
309             #pod
310             #pod use Sub::Uplevel qw/:aggressive/;
311             #pod
312             #pod The private function C may be passed a list of
313             #pod additional modules to reload if ":aggressive" is not aggressive enough.
314             #pod Reloading modules may break things, so only use this as a last resort.
315             #pod
316             #pod As of version 0.20, Sub::Uplevel requires Perl 5.6 or greater.
317             #pod
318             #pod =head1 HISTORY
319             #pod
320             #pod Those who do not learn from HISTORY are doomed to repeat it.
321             #pod
322             #pod The lesson here is simple: Don't sit next to a Tcl programmer at the
323             #pod dinner table.
324             #pod
325             #pod =head1 THANKS
326             #pod
327             #pod Thanks to Brent Welch, Damian Conway and Robin Houston.
328             #pod
329             #pod See http://www.perl.com/perl/misc/Artistic.html
330             #pod
331             #pod =head1 SEE ALSO
332             #pod
333             #pod PadWalker (for the similar idea with lexicals), Hook::LexWrap,
334             #pod Tcl's uplevel() at http://www.scriptics.com/man/tcl8.4/TclCmd/uplevel.htm
335             #pod
336             #pod =cut
337              
338             1;
339              
340             __END__