#line 1
package Sub::Uplevel;
use 5.006;
use strict;
use vars qw($VERSION @ISA @EXPORT);
$VERSION = 0.09;
# We have to do this so the CORE::GLOBAL versions override the builtins
_setup_CORE_GLOBAL();
require Exporter;
@ISA = qw(Exporter);
@EXPORT = qw(uplevel);
#line 73
our $Up_Frames = 0;
sub uplevel {
my($num_frames, $func, @args) = @_;
local $Up_Frames = $num_frames + $Up_Frames;
return $func->(@args);
}
sub _setup_CORE_GLOBAL {
no warnings 'redefine';
*CORE::GLOBAL::caller = sub {
my $height = $_[0] || 0;
#line 115
$height++; # up one to avoid this wrapper function.
my $saw_uplevel = 0;
# Yes, we need a C style for loop here since $height changes
for( my $up = 1; $up <= $height + 1; $up++ ) {
my @caller = CORE::caller($up);
if( defined($caller[0]) and $caller[0] eq __PACKAGE__ ) {
$height++;
$height += $Up_Frames unless $saw_uplevel;
$saw_uplevel = 1;
}
}
return undef if $height < 0;
my @caller = CORE::caller($height);
if( wantarray ) {
if( !@_ ) {
@caller = @caller[0..2];
}
return @caller;
}
else {
return $caller[0];
}
};
}
#line 213
1;