view release on metacpan or  search on metacpan

local/lib/perl5/Sub/Uplevel.pm  view on Meta::CPAN

    # to skip this function's caller
    return $Caller_Proxy->( $height + 1 ) if ! @Up_Frames;

#pod =begin _private
#pod
#pod So it has to work like this:
#pod
#pod     Call stack               Actual     uplevel 1
#pod CORE::GLOBAL::caller
#pod Carp::short_error_loc           0
#pod Carp::shortmess_heavy           1           0
#pod Carp::croak                     2           1
#pod try_croak                       3           2
#pod uplevel                         4            
#pod function_that_called_uplevel    5            
#pod caller_we_want_to_see           6           3
#pod its_caller                      7           4
#pod
#pod So when caller(X) winds up below uplevel(), it only has to use  
#pod CORE::caller(X+1) (to skip CORE::GLOBAL::caller).  But when caller(X)
#pod winds up no or above uplevel(), it's CORE::caller(X+1+uplevel+1).
#pod
#pod Which means I'm probably going to have to do something nasty like walk
#pod up the call stack on each caller() to see if I'm going to wind up   
#pod before or after Sub::Uplevel::uplevel().
#pod
#pod =end _private
#pod
#pod =begin _dagolden
#pod
#pod I found the description above a bit confusing.  Instead, this is the logic
#pod that I found clearer when CORE::GLOBAL::caller is invoked and we have to
#pod walk up the call stack:
#pod
#pod * if searching up to the requested height in the real call stack doesn't find
#pod a call to uplevel, then we can return the result at that height in the
#pod call stack
#pod
#pod * if we find a call to uplevel, we need to keep searching upwards beyond the
#pod requested height at least by the amount of upleveling requested for that
#pod call to uplevel (from the Up_Frames stack set during the uplevel call)
#pod
#pod * additionally, we need to hide the uplevel subroutine call, too, so we search
#pod upwards one more level for each call to uplevel
#pod
#pod * when we've reached the top of the search, we want to return that frame
#pod in the call stack, i.e. the requested height plus any uplevel adjustments
#pod found during the search
#pod
#pod =end _dagolden
#pod
#pod =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
    my $test_caller;
    for ( my $up = 0; $up <= $height + $adjust; $up++ ) {
        $test_caller = scalar CORE::caller($up + 1);
        if( $test_caller && $test_caller 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
}

#pod =back
#pod
#pod =head1 EXAMPLE
#pod
#pod The main reason I wrote this module is so I could write wrappers
#pod around functions and they wouldn't be aware they've been wrapped.
#pod
#pod     use Sub::Uplevel;
#pod
#pod     my $original_foo = \&foo;
#pod
#pod     *foo = sub {
#pod         my @output = uplevel 1, $original_foo;
#pod         print "foo() returned:  @output";
#pod         return @output;
#pod     };
#pod
#pod If this code frightens you B<you should not use this module.>
#pod
#pod
#pod =head1 BUGS and CAVEATS
#pod
#pod Well, the bad news is uplevel() is about 5 times slower than a normal
#pod function call.  XS implementation anyone?  It also slows down every invocation
#pod of caller(), regardless of whether uplevel() is in effect.
#pod
#pod Sub::Uplevel overrides CORE::GLOBAL::caller temporarily for the scope of
#pod each uplevel call.  It does its best to work with any previously existing
#pod CORE::GLOBAL::caller (both when Sub::Uplevel is first loaded and within 
#pod each uplevel call) such as from Contextual::Return or Hook::LexWrap.  
#pod
#pod However, if you are routinely using multiple modules that override 
#pod CORE::GLOBAL::caller, you are probably asking for trouble.
#pod