File Coverage

inc/Sub/Uplevel.pm
Criterion Covered Total %
statement 39 44 88.6
branch 12 18 66.6
condition 5 11 45.4
subroutine 6 6 100.0
pod 1 1 100.0
total 63 80 78.7


line stmt bran cond sub pod time code
1             #line 1
2             package Sub::Uplevel;
3 1     1   7  
  1         2  
  1         42  
4 1     1   20 use strict;
  1         2  
  1         168  
5             use vars qw($VERSION @ISA @EXPORT);
6             $VERSION = '0.1901';
7              
8             # We must override *CORE::GLOBAL::caller if it hasn't already been
9             # overridden or else Perl won't see our local override later.
10              
11             if ( not defined *CORE::GLOBAL::caller{CODE} ) {
12             *CORE::GLOBAL::caller = \&_normal_caller;
13             }
14              
15             require Exporter;
16             @ISA = qw(Exporter);
17             @EXPORT = qw(uplevel);
18              
19             #line 83
20              
21             use vars qw/@Up_Frames $Caller_Proxy/;
22             # @Up_Frames -- uplevel stack
23             # $Caller_Proxy -- whatever caller() override was in effect before uplevel
24              
25             sub uplevel {
26             my($num_frames, $func, @args) = @_;
27            
28             local @Up_Frames = ($num_frames, @Up_Frames );
29            
30             # backwards compatible version of "no warnings 'redefine'"
31             my $old_W = $^W;
32             $^W = 0;
33              
34             # Update the caller proxy if the uplevel override isn't in effect
35             local $Caller_Proxy = *CORE::GLOBAL::caller{CODE}
36             if *CORE::GLOBAL::caller{CODE} != \&_uplevel_caller;
37             local *CORE::GLOBAL::caller = \&_uplevel_caller;
38            
39             # restore old warnings state
40             $^W = $old_W;
41              
42             return $func->(@args);
43             }
44              
45             sub _normal_caller (;$) { ## no critic Prototypes
46             my $height = $_[0];
47             $height++;
48             if ( CORE::caller() eq 'DB' ) {
49             # passthrough the @DB::args trick
50             package DB;
51             if( wantarray and !@_ ) {
52             return (CORE::caller($height))[0..2];
53             }
54             else {
55             return CORE::caller($height);
56             }
57             }
58             else {
59             if( wantarray and !@_ ) {
60             return (CORE::caller($height))[0..2];
61             }
62             else {
63             return CORE::caller($height);
64             }
65             }
66             }
67              
68             sub _uplevel_caller (;$) { ## no critic Prototypes
69             my $height = $_[0] || 0;
70              
71             # shortcut if no uplevels have been called
72             # always add +1 to CORE::caller (proxy caller function)
73             # to skip this function's caller
74             return $Caller_Proxy->( $height + 1 ) if ! @Up_Frames;
75              
76             #line 188
77              
78             my $saw_uplevel = 0;
79             my $adjust = 0;
80              
81             # walk up the call stack to fight the right package level to return;
82             # look one higher than requested for each call to uplevel found
83             # and adjust by the amount found in the Up_Frames stack for that call.
84 1     1   6 # We *must* use CORE::caller here since we need the real stack not what
  1         3  
  1         530  
85             # some other override says the stack looks like, just in case that other
86             # override breaks things in some horrible way
87              
88             for ( my $up = 0; $up <= $height + $adjust; $up++ ) {
89 1     1 1 3 my @caller = CORE::caller($up + 1);
90             if( defined $caller[0] && $caller[0] eq __PACKAGE__ ) {
91 1         4 # add one for each uplevel call seen
92             # and look into the uplevel stack for the offset
93             $adjust += 1 + $Up_Frames[$saw_uplevel];
94 1         4 $saw_uplevel++;
95 1         3 }
96             }
97              
98 1 50       12 # For returning values, we pass through the call to the proxy caller
99             # function, just at a higher stack level
100 1         4 my @caller;
101             if ( CORE::caller() eq 'DB' ) {
102             # passthrough the @DB::args trick
103 1         3 package DB;
104             @caller = $Sub::Uplevel::Caller_Proxy->($height + $adjust + 1);
105 1         5 }
106             else {
107             @caller = $Caller_Proxy->($height + $adjust + 1);
108             }
109 3     3   34811  
110 3         6 if( wantarray ) {
111 3 50       15 if( !@_ ) {
112             @caller = @caller[0..2];
113             }
114 0 0 0     0 return @caller;
115 0         0 }
116             else {
117             return $caller[0];
118 0         0 }
119             }
120              
121             #line 298
122 3 100 66     21  
123 1         11  
124             1;