Sub::Uplevel - apparently run a function in a higher stack frame
use Sub::Uplevel;
sub foo { print join " - ", caller; }
sub bar { uplevel 1, \&foo; }
#line 11 bar(); # main - foo.plx - 11
Like Tcl's uplevel()
function, but not quite so dangerous. The idea
is just to fool caller()
. All the really naughty bits of Tcl's
uplevel()
are avoided.
THIS IS NOT THE SORT OF THING YOU WANT TO DO EVERYDAY
uplevel $num_frames, \&func, @args;
Makes the given function think it's being executed $num_frames higher
than the current stack level. So when they use caller($frames)
it
will actually give caller($frames + $num_frames) for them.
uplevel(1, \&some_func, @_)
is effectively goto &some_func
but
you don't immediately exit the current subroutine. So while you can't
do this:
sub wrapper { print "Before\n"; goto &some_func; print "After\n"; }
you can do this:
sub wrapper { print "Before\n"; my @out = uplevel 1, &some_func; print "After\n"; return @out; }
uplevel
will issue a warning if $num_frames
is more than the current call
stack depth.
=cut
my $saw_uplevel = 0; my $adjust = 0;
# walk up the call stack to fight the right package level to return; # look one higher than requested for each call to uplevel found # and adjust by the amount found in the Up_Frames stack for that call. # We *must* use CORE::caller here since we need the real stack not what # some other override says the stack looks like, just in case that other # override breaks things in some horrible way
for ( my $up = 0; $up <= $height + $adjust; $up++ ) { my @caller = CORE::caller($up + 1); if( defined $caller[0] && $caller[0] eq __PACKAGE__ ) { # add one for each uplevel call seen # and look into the uplevel stack for the offset $adjust += 1 + $Up_Frames[$saw_uplevel]; $saw_uplevel++; } }
# For returning values, we pass through the call to the proxy caller # function, just at a higher stack level my @caller; if ( CORE::caller() eq 'DB' ) { # passthrough the @DB::args trick package DB; @caller = $Sub::Uplevel::Caller_Proxy->($height + $adjust + 1); } else { @caller = $Caller_Proxy->($height + $adjust + 1); }
if( wantarray ) { if( !@_ ) { @caller = @caller[0..2]; } return @caller; } else { return $caller[0]; } }
The main reason I wrote this module is so I could write wrappers around functions and they wouldn't be aware they've been wrapped.
use Sub::Uplevel;
my $original_foo = \&foo;
*foo = sub { my @output = uplevel 1, $original_foo; print "foo() returned: @output"; return @output; };
If this code frightens you you should not use this module.
Well, the bad news is uplevel()
is about 5 times slower than a normal
function call. XS implementation anyone?
Sub::Uplevel overrides CORE::GLOBAL::caller temporarily for the scope of each uplevel call. It does its best to work with any previously existing CORE::GLOBAL::caller (both when Sub::Uplevel is first loaded and within each uplevel call) such as from Contextual::Return or Hook::LexWrap.
However, if you are routinely using multiple modules that override CORE::GLOBAL::caller, you are probably asking for trouble.
As of version 0.20, Sub::Uplevel requires Perl 5.6 or greater.
Those who do not learn from HISTORY are doomed to repeat it.
The lesson here is simple: Don't sit next to a Tcl programmer at the dinner table.
Thanks to Brent Welch, Damian Conway and Robin Houston.
David A Golden <dagolden@cpan.org> (current maintainer)
Michael G Schwern <schwern@pobox.com> (original author)
Original code Copyright (c) 2001 to 2007 by Michael G Schwern. Additional code Copyright (c) 2006 to 2008 by David A Golden.
This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.
See http://www.perl.com/perl/misc/Artistic.html
PadWalker (for the similar idea with lexicals), Hook::LexWrap,
Tcl's uplevel()
at http://www.scriptics.com/man/tcl8.4/TclCmd/uplevel.htm