File Coverage

File:local/lib/perl5/Sub/Uplevel.pm
Coverage:38.9%

linestmtbrancondsubtimecode
1package Sub::Uplevel;
2
6
6
6
49
10
use 5.006;
3
6
6
6
6
8
5
160
use strict;
4# ABSTRACT: apparently run a function in a higher stack frame
5our $VERSION = '0.24'; # VERSION
6
7# Frame check global constant
8our $CHECK_FRAMES;
9BEGIN {
10
6
6
55
  $CHECK_FRAMES = !! $CHECK_FRAMES;
11}
12
6
6
6
6
10
4
338
use constant CHECK_FRAMES => $CHECK_FRAMES;
13
14# We must override *CORE::GLOBAL::caller if it hasn't already been
15# overridden or else Perl won't see our local override later.
16
17if ( not defined *CORE::GLOBAL::caller{CODE} ) {
18  *CORE::GLOBAL::caller = \&_normal_caller;
19}
20
21# modules to force reload if ":aggressive" is specified
22my @reload_list = qw/Exporter Exporter::Heavy/;
23
24sub import {
25
6
6
6
6
13
2
426
  no strict 'refs'; ## no critic
26
12
12
12
  my ($class, @args) = @_;
27
12
13
  for my $tag ( @args, 'uplevel' ) {
28
18
50
0
18
    if ( $tag eq 'uplevel' ) {
29
18
16
      my $caller = caller(0);
30
18
18
11
44
      *{"$caller\::uplevel"} = \&uplevel;
31    }
32    elsif( $tag eq ':aggressive' ) {
33
0
0
      _force_reload( @reload_list );
34    }
35    else {
36
0
0
      die qq{"$tag" is not exported by the $class module\n}
37    }
38  }
39
12
358
  return;
40}
41
42sub _force_reload {
43
6
6
6
6
13
4
1565
  no warnings 'redefine';
44
0
0
0
  local $^W = 0;
45
0
0
  for my $m ( @_ ) {
46
0
0
    $m =~ s{::}{/}g;
47
0
0
    $m .= ".pm";
48
0
0
0
    require $m if delete $INC{$m};
49  }
50}
51
52
53# @Up_Frames -- uplevel stack
54# $Caller_Proxy -- whatever caller() override was in effect before uplevel
55our (@Up_Frames, $Caller_Proxy);
56
57sub _apparent_stack_height {
58
0
0
0
    my $height = 1; # start above this function
59
0
0
    while ( 1 ) {
60
0
0
0
        last if ! defined scalar $Caller_Proxy->($height);
61
0
0
        $height++;
62    }
63
0
0
    return $height - 1; # subtract 1 for this function
64}
65
66sub uplevel {
67    # Backwards compatible version of "no warnings 'redefine'"
68
0
0
0
    my $old_W = $^W;
69
0
0
    $^W = 0;
70
71    # Update the caller proxy if the uplevel override isn't in effect
72
0
0
0
    local $Caller_Proxy = *CORE::GLOBAL::caller{CODE}
73        if *CORE::GLOBAL::caller{CODE} != \&_uplevel_caller;
74
0
0
    local *CORE::GLOBAL::caller = \&_uplevel_caller;
75
76    # Restore old warnings state
77
0
0
    $^W = $old_W;
78
79
0
0
    if ( CHECK_FRAMES and $_[0] >= _apparent_stack_height() ) {
80      require Carp;
81      Carp::carp("uplevel $_[0] is more than the caller stack");
82    }
83
84
0
0
    local @Up_Frames = (shift, @Up_Frames );
85
86
0
0
    my $function = shift;
87
0
0
    return $function->(@_);
88}
89
90sub _normal_caller (;$) { ## no critic Prototypes
91
71
71
44
    my ($height) = @_;
92
71
47
    $height++;
93
71
223
    my @caller = CORE::caller($height);
94
71
50
107
    if ( CORE::caller() eq 'DB' ) {
95        # Oops, redo picking up @DB::args
96        package DB;
97
0
0
        @caller = CORE::caller($height);
98    }
99
100
71
50
100
    return if ! @caller;                  # empty
101
71
100
129
    return $caller[0] if ! wantarray;     # scalar context
102
31
100
65
    return @_ ? @caller : @caller[0..2];  # extra info or regular
103}
104
105sub _uplevel_caller (;$) { ## no critic Prototypes
106
0
0
0
    my $height = $_[0] || 0;
107
108    # shortcut if no uplevels have been called
109    # always add +1 to CORE::caller (proxy caller function)
110    # to skip this function's caller
111
0
0
    return $Caller_Proxy->( $height + 1 ) if ! @Up_Frames;
112
113
114
0
    my $saw_uplevel = 0;
115
0
    my $adjust = 0;
116
117    # walk up the call stack to fight the right package level to return;
118    # look one higher than requested for each call to uplevel found
119    # and adjust by the amount found in the Up_Frames stack for that call.
120    # We *must* use CORE::caller here since we need the real stack not what
121    # some other override says the stack looks like, just in case that other
122    # override breaks things in some horrible way
123
124
0
    for ( my $up = 0; $up <= $height + $adjust; $up++ ) {
125
0
        my @caller = CORE::caller($up + 1);
126
0
0
0
        if( defined $caller[0] && $caller[0] eq __PACKAGE__ ) {
127            # add one for each uplevel call seen
128            # and look into the uplevel stack for the offset
129
0
            $adjust += 1 + $Up_Frames[$saw_uplevel];
130
0
            $saw_uplevel++;
131        }
132    }
133
134    # For returning values, we pass through the call to the proxy caller
135    # function, just at a higher stack level
136
0
    my @caller = $Caller_Proxy->($height + $adjust + 1);
137
0
0
    if ( CORE::caller() eq 'DB' ) {
138        # Oops, redo picking up @DB::args
139        package DB;
140
0
        @caller = $Sub::Uplevel::Caller_Proxy->($height + $adjust + 1);
141    }
142
143
0
0
    return if ! @caller;                  # empty
144
0
0
    return $caller[0] if ! wantarray;     # scalar context
145
0
0
    return @_ ? @caller : @caller[0..2];  # extra info or regular
146}
147
148
1491;
150