File Coverage

inc/Sub/Uplevel.pm
Criterion Covered Total %
statement 29 66 43.9
branch 6 30 20.0
condition 0 5 0.0
subroutine 8 12 66.6
pod 1 1 100.0
total 44 114 38.6


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