1 | package Sub::Uplevel;
|
---|
2 |
|
---|
3 | use 5.006;
|
---|
4 |
|
---|
5 | use strict;
|
---|
6 | use vars qw($VERSION @ISA @EXPORT);
|
---|
7 | $VERSION = "0.14";
|
---|
8 |
|
---|
9 | # We have to do this so the CORE::GLOBAL versions override the builtins
|
---|
10 | _setup_CORE_GLOBAL();
|
---|
11 |
|
---|
12 | require Exporter;
|
---|
13 | @ISA = qw(Exporter);
|
---|
14 | @EXPORT = qw(uplevel);
|
---|
15 |
|
---|
16 | =head1 NAME
|
---|
17 |
|
---|
18 | Sub::Uplevel - apparently run a function in a higher stack frame
|
---|
19 |
|
---|
20 | =head1 SYNOPSIS
|
---|
21 |
|
---|
22 | use Sub::Uplevel;
|
---|
23 |
|
---|
24 | sub foo {
|
---|
25 | print join " - ", caller;
|
---|
26 | }
|
---|
27 |
|
---|
28 | sub bar {
|
---|
29 | uplevel 1, \&foo;
|
---|
30 | }
|
---|
31 |
|
---|
32 | #line 11
|
---|
33 | bar(); # main - foo.plx - 11
|
---|
34 |
|
---|
35 | =head1 DESCRIPTION
|
---|
36 |
|
---|
37 | Like Tcl's uplevel() function, but not quite so dangerous. The idea
|
---|
38 | is just to fool caller(). All the really naughty bits of Tcl's
|
---|
39 | uplevel() are avoided.
|
---|
40 |
|
---|
41 | B<THIS IS NOT THE SORT OF THING YOU WANT TO DO EVERYDAY>
|
---|
42 |
|
---|
43 | =over 4
|
---|
44 |
|
---|
45 | =item B<uplevel>
|
---|
46 |
|
---|
47 | uplevel $num_frames, \&func, @args;
|
---|
48 |
|
---|
49 | Makes the given function think it's being executed $num_frames higher
|
---|
50 | than the current stack level. So when they use caller($frames) it
|
---|
51 | will actually give caller($frames + $num_frames) for them.
|
---|
52 |
|
---|
53 | C<uplevel(1, \&some_func, @_)> is effectively C<goto &some_func> but
|
---|
54 | you don't immediately exit the current subroutine. So while you can't
|
---|
55 | do this:
|
---|
56 |
|
---|
57 | sub wrapper {
|
---|
58 | print "Before\n";
|
---|
59 | goto &some_func;
|
---|
60 | print "After\n";
|
---|
61 | }
|
---|
62 |
|
---|
63 | you can do this:
|
---|
64 |
|
---|
65 | sub wrapper {
|
---|
66 | print "Before\n";
|
---|
67 | my @out = uplevel 1, &some_func;
|
---|
68 | print "After\n";
|
---|
69 | return @out;
|
---|
70 | }
|
---|
71 |
|
---|
72 |
|
---|
73 | =cut
|
---|
74 |
|
---|
75 | our @Up_Frames; # uplevel stack
|
---|
76 |
|
---|
77 | sub uplevel {
|
---|
78 | my($num_frames, $func, @args) = @_;
|
---|
79 |
|
---|
80 | local @Up_Frames = ($num_frames, @Up_Frames );
|
---|
81 | return $func->(@args);
|
---|
82 | }
|
---|
83 |
|
---|
84 |
|
---|
85 | sub _setup_CORE_GLOBAL {
|
---|
86 | no warnings 'redefine';
|
---|
87 |
|
---|
88 | *CORE::GLOBAL::caller = sub(;$) {
|
---|
89 | my $height = $_[0] || 0;
|
---|
90 |
|
---|
91 | # shortcut if no uplevels have been called
|
---|
92 | # always add +1 to CORE::caller to skip this function's caller
|
---|
93 | return CORE::caller( $height + 1 ) if ! @Up_Frames;
|
---|
94 |
|
---|
95 | =begin _private
|
---|
96 |
|
---|
97 | So it has to work like this:
|
---|
98 |
|
---|
99 | Call stack Actual uplevel 1
|
---|
100 | CORE::GLOBAL::caller
|
---|
101 | Carp::short_error_loc 0
|
---|
102 | Carp::shortmess_heavy 1 0
|
---|
103 | Carp::croak 2 1
|
---|
104 | try_croak 3 2
|
---|
105 | uplevel 4
|
---|
106 | function_that_called_uplevel 5
|
---|
107 | caller_we_want_to_see 6 3
|
---|
108 | its_caller 7 4
|
---|
109 |
|
---|
110 | So when caller(X) winds up below uplevel(), it only has to use
|
---|
111 | CORE::caller(X+1) (to skip CORE::GLOBAL::caller). But when caller(X)
|
---|
112 | winds up no or above uplevel(), it's CORE::caller(X+1+uplevel+1).
|
---|
113 |
|
---|
114 | Which means I'm probably going to have to do something nasty like walk
|
---|
115 | up the call stack on each caller() to see if I'm going to wind up
|
---|
116 | before or after Sub::Uplevel::uplevel().
|
---|
117 |
|
---|
118 | =end _private
|
---|
119 |
|
---|
120 | =begin _dagolden
|
---|
121 |
|
---|
122 | I found the description above a bit confusing. Instead, this is the logic
|
---|
123 | that I found clearer when CORE::GLOBAL::caller is invoked and we have to
|
---|
124 | walk up the call stack:
|
---|
125 |
|
---|
126 | * if searching up to the requested height in the real call stack doesn't find
|
---|
127 | a call to uplevel, then we can return the result at that height in the
|
---|
128 | call stack
|
---|
129 |
|
---|
130 | * if we find a call to uplevel, we need to keep searching upwards beyond the
|
---|
131 | requested height at least by the amount of upleveling requested for that
|
---|
132 | call to uplevel (from the Up_Frames stack set during the uplevel call)
|
---|
133 |
|
---|
134 | * additionally, we need to hide the uplevel subroutine call, too, so we search
|
---|
135 | upwards one more level for each call to uplevel
|
---|
136 |
|
---|
137 | * when we've reached the top of the search, we want to return that frame
|
---|
138 | in the call stack, i.e. the requested height plus any uplevel adjustments
|
---|
139 | found during the search
|
---|
140 |
|
---|
141 | =end _dagolden
|
---|
142 |
|
---|
143 | =cut
|
---|
144 |
|
---|
145 | my $saw_uplevel = 0;
|
---|
146 | my $adjust = 0;
|
---|
147 |
|
---|
148 | # walk up the call stack to fight the right package level to return;
|
---|
149 | # look one higher than requested for each call to uplevel found
|
---|
150 | # and adjust by the amount found in the Up_Frames stack for that call
|
---|
151 |
|
---|
152 | for ( my $up = 0; $up <= $height + $adjust; $up++ ) {
|
---|
153 | my @caller = CORE::caller($up + 1);
|
---|
154 | if( defined $caller[0] && $caller[0] eq __PACKAGE__ ) {
|
---|
155 | # add one for each uplevel call seen
|
---|
156 | # and look into the uplevel stack for the offset
|
---|
157 | $adjust += 1 + $Up_Frames[$saw_uplevel];
|
---|
158 | $saw_uplevel++;
|
---|
159 | }
|
---|
160 | }
|
---|
161 |
|
---|
162 | my @caller = CORE::caller($height + $adjust + 1);
|
---|
163 |
|
---|
164 | if( wantarray ) {
|
---|
165 | if( !@_ ) {
|
---|
166 | @caller = @caller[0..2];
|
---|
167 | }
|
---|
168 | return @caller;
|
---|
169 | }
|
---|
170 | else {
|
---|
171 | return $caller[0];
|
---|
172 | }
|
---|
173 | }; # sub
|
---|
174 |
|
---|
175 | }
|
---|
176 |
|
---|
177 | =back
|
---|
178 |
|
---|
179 | =head1 EXAMPLE
|
---|
180 |
|
---|
181 | The main reason I wrote this module is so I could write wrappers
|
---|
182 | around functions and they wouldn't be aware they've been wrapped.
|
---|
183 |
|
---|
184 | use Sub::Uplevel;
|
---|
185 |
|
---|
186 | my $original_foo = \&foo;
|
---|
187 |
|
---|
188 | *foo = sub {
|
---|
189 | my @output = uplevel 1, $original_foo;
|
---|
190 | print "foo() returned: @output";
|
---|
191 | return @output;
|
---|
192 | };
|
---|
193 |
|
---|
194 | If this code frightens you B<you should not use this module.>
|
---|
195 |
|
---|
196 |
|
---|
197 | =head1 BUGS and CAVEATS
|
---|
198 |
|
---|
199 | Sub::Uplevel must be used as early as possible in your program's
|
---|
200 | compilation.
|
---|
201 |
|
---|
202 | Well, the bad news is uplevel() is about 5 times slower than a normal
|
---|
203 | function call. XS implementation anyone?
|
---|
204 |
|
---|
205 | Blows over any CORE::GLOBAL::caller you might have (and if you do,
|
---|
206 | you're just sick).
|
---|
207 |
|
---|
208 |
|
---|
209 | =head1 HISTORY
|
---|
210 |
|
---|
211 | Those who do not learn from HISTORY are doomed to repeat it.
|
---|
212 |
|
---|
213 | The lesson here is simple: Don't sit next to a Tcl programmer at the
|
---|
214 | dinner table.
|
---|
215 |
|
---|
216 |
|
---|
217 | =head1 THANKS
|
---|
218 |
|
---|
219 | Thanks to Brent Welch, Damian Conway and Robin Houston.
|
---|
220 |
|
---|
221 |
|
---|
222 | =head1 AUTHORS
|
---|
223 |
|
---|
224 | David A Golden E<lt>[email protected]<gt> (current maintainer)
|
---|
225 |
|
---|
226 | Michael G Schwern E<lt>[email protected]<gt> (original author)
|
---|
227 |
|
---|
228 | =head1 LICENSE
|
---|
229 |
|
---|
230 | Copyright by Michael G Schwern, David A Golden
|
---|
231 |
|
---|
232 | This program is free software; you can redistribute it and/or modify it
|
---|
233 | under the same terms as Perl itself.
|
---|
234 |
|
---|
235 | See http://www.perl.com/perl/misc/Artistic.html
|
---|
236 |
|
---|
237 |
|
---|
238 | =head1 SEE ALSO
|
---|
239 |
|
---|
240 | PadWalker (for the similar idea with lexicals), Hook::LexWrap,
|
---|
241 | Tcl's uplevel() at http://www.scriptics.com/man/tcl8.4/TclCmd/uplevel.htm
|
---|
242 |
|
---|
243 | =cut
|
---|
244 |
|
---|
245 |
|
---|
246 | 1;
|
---|