File Coverage

inc/Sub/Uplevel.pm

Criterion	Covered	Total	%
statement	52	67	77.6
branch	17	30	56.6
condition	3	5	60.0
subroutine	10	12	83.3
pod	1	1	100.0
total	83	115	72.1

#line 1
package Sub::Uplevel;
use 5.006;
use strict;
# ABSTRACT: apparently run a function in a higher stack frame
our $VERSION = '0.24'; # VERSION

# Frame check global constant
our $CHECK_FRAMES;
BEGIN {
  $CHECK_FRAMES = !! $CHECK_FRAMES;
}
use constant CHECK_FRAMES => $CHECK_FRAMES;

# We must override *CORE::GLOBAL::caller if it hasn't already been
# overridden or else Perl won't see our local override later.

if ( not defined *CORE::GLOBAL::caller{CODE} ) {
  *CORE::GLOBAL::caller = \&_normal_caller;
}

# modules to force reload if ":aggressive" is specified
my @reload_list = qw/Exporter Exporter::Heavy/;

sub import {
  no strict 'refs'; ## no critic
  my ($class, @args) = @_;
  for my $tag ( @args, 'uplevel' ) {
    if ( $tag eq 'uplevel' ) {
      my $caller = caller(0);
      *{"$caller\::uplevel"} = \&uplevel;
    }
    elsif( $tag eq ':aggressive' ) {
      _force_reload( @reload_list );
    }
    else {
      die qq{"$tag" is not exported by the $class module\n}
    }
  }
  return;
}

sub _force_reload {
  no warnings 'redefine';
  local $^W = 0;
  for my $m ( @_ ) {
    $m =~ s{::}{/}g;
    $m .= ".pm";
    require $m if delete $INC{$m};
  }
}


# @Up_Frames -- uplevel stack
# $Caller_Proxy -- whatever caller() override was in effect before uplevel
our (@Up_Frames, $Caller_Proxy);

sub _apparent_stack_height {
    my $height = 1; # start above this function
    while ( 1 ) {
        last if ! defined scalar $Caller_Proxy->($height);
        $height++;
    }
    return $height - 1; # subtract 1 for this function
}

sub uplevel {
    # Backwards compatible version of "no warnings 'redefine'"
    my $old_W = $^W;
    $^W = 0;

    # Update the caller proxy if the uplevel override isn't in effect
    local $Caller_Proxy = *CORE::GLOBAL::caller{CODE}
        if *CORE::GLOBAL::caller{CODE} != \&_uplevel_caller;
    local *CORE::GLOBAL::caller = \&_uplevel_caller;

    # Restore old warnings state
    $^W = $old_W;

    if ( CHECK_FRAMES and $_[0] >= _apparent_stack_height() ) {
      require Carp;
      Carp::carp("uplevel $_[0] is more than the caller stack");
    }

    local @Up_Frames = (shift, @Up_Frames );

    my $function = shift;
    return $function->(@_);
}

sub _normal_caller (;$) { ## no critic Prototypes
    my ($height) = @_;
    $height++;
    my @caller = CORE::caller($height);
    if ( CORE::caller() eq 'DB' ) {
        # Oops, redo picking up @DB::args
        package DB;
        @caller = CORE::caller($height);
    }

    return if ! @caller;                  # empty
    return $caller[0] if ! wantarray;     # scalar context
    return @_ ? @caller : @caller[0..2];  # extra info or regular
}

sub _uplevel_caller (;$) { ## no critic Prototypes
    my $height = $_[0] || 0;

    # shortcut if no uplevels have been called
    # always add +1 to CORE::caller (proxy caller function)
    # to skip this function's caller
    return $Caller_Proxy->( $height + 1 ) if ! @Up_Frames;


    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 = $Caller_Proxy->($height + $adjust + 1);
    if ( CORE::caller() eq 'DB' ) {
        # Oops, redo picking up @DB::args
        package DB;
        @caller = $Sub::Uplevel::Caller_Proxy->($height + $adjust + 1);
    }

    return if ! @caller;                  # empty
    return $caller[0] if ! wantarray;     # scalar context
    return @_ ? @caller : @caller[0..2];  # extra info or regular
}


1;

__END__