git.maemo.org Git - pkg-perl/blob - deb-src/libsub-uplevel-perl/libsub-uplevel-perl-0.1901/lib/Sub/Uplevel.pm

   1 package Sub::Uplevel;
   2
   3 use strict;
   4 use vars qw($VERSION @ISA @EXPORT);
   5 $VERSION = '0.1901';
   6
   7 # We must override *CORE::GLOBAL::caller if it hasn't already been
   8 # overridden or else Perl won't see our local override later.
   9
  10 if ( not defined *CORE::GLOBAL::caller{CODE} ) {
  11     *CORE::GLOBAL::caller = \&_normal_caller;
  12 }
  13
  14 require Exporter;
  15 @ISA = qw(Exporter);
  16 @EXPORT = qw(uplevel);
  17
  18 =head1 NAME
  19
  20 Sub::Uplevel - apparently run a function in a higher stack frame
  21
  22 =begin wikidoc
  23
  24 = VERSION
  25
  26 This documentation describes version %%VERSION%%
  27
  28 =end wikidoc
  29
  30 =head1 SYNOPSIS
  31
  32   use Sub::Uplevel;
  33
  34   sub foo {
  35       print join " - ", caller;
  36   }
  37
  38   sub bar {
  39       uplevel 1, \&foo;
  40   }
  41
  42   #line 11
  43   bar();    # main - foo.plx - 11
  44
  45 =head1 DESCRIPTION
  46
  47 Like Tcl's uplevel() function, but not quite so dangerous.  The idea
  48 is just to fool caller().  All the really naughty bits of Tcl's
  49 uplevel() are avoided.
  50
  51 B<THIS IS NOT THE SORT OF THING YOU WANT TO DO EVERYDAY>
  52
  53 =over 4
  54
  55 =item B<uplevel>
  56
  57   uplevel $num_frames, \&func, @args;
  58
  59 Makes the given function think it's being executed $num_frames higher
  60 than the current stack level.  So when they use caller($frames) it
  61 will actually give caller($frames + $num_frames) for them.
  62
  63 C<uplevel(1, \&some_func, @_)> is effectively C<goto &some_func> but
  64 you don't immediately exit the current subroutine.  So while you can't
  65 do this:
  66
  67     sub wrapper {
  68         print "Before\n";
  69         goto &some_func;
  70         print "After\n";
  71     }
  72
  73 you can do this:
  74
  75     sub wrapper {
  76         print "Before\n";
  77         my @out = uplevel 1, &some_func;
  78         print "After\n";
  79         return @out;
  80     }
  81
  82
  83 =cut
  84
  85 use vars qw/@Up_Frames $Caller_Proxy/;
  86 # @Up_Frames -- uplevel stack
  87 # $Caller_Proxy -- whatever caller() override was in effect before uplevel
  88
  89 sub uplevel {
  90     my($num_frames, $func, @args) = @_;
  91
  92     local @Up_Frames = ($num_frames, @Up_Frames );
  93
  94     # backwards compatible version of "no warnings 'redefine'"
  95     my $old_W = $^W;
  96     $^W = 0;
  97
  98     # Update the caller proxy if the uplevel override isn't in effect
  99     local $Caller_Proxy = *CORE::GLOBAL::caller{CODE}
 100         if *CORE::GLOBAL::caller{CODE} != \&_uplevel_caller;
 101     local *CORE::GLOBAL::caller = \&_uplevel_caller;
 102
 103     # restore old warnings state
 104     $^W = $old_W;
 105
 106     return $func->(@args);
 107 }
 108
 109 sub _normal_caller (;$) { ## no critic Prototypes
 110     my $height = $_[0];
 111     $height++;
 112     if ( CORE::caller() eq 'DB' ) {
 113         # passthrough the @DB::args trick
 114         package DB;
 115         if( wantarray and !@_ ) {
 116             return (CORE::caller($height))[0..2];
 117         }
 118         else {
 119             return CORE::caller($height);
 120         }
 121     }
 122     else {
 123         if( wantarray and !@_ ) {
 124             return (CORE::caller($height))[0..2];
 125         }
 126         else {
 127             return CORE::caller($height);
 128         }
 129     }
 130 }
 131
 132 sub _uplevel_caller (;$) { ## no critic Prototypes
 133     my $height = $_[0] || 0;
 134
 135     # shortcut if no uplevels have been called
 136     # always add +1 to CORE::caller (proxy caller function)
 137     # to skip this function's caller
 138     return $Caller_Proxy->( $height + 1 ) if ! @Up_Frames;
 139
 140 =begin _private
 141
 142 So it has to work like this:
 143
 144     Call stack               Actual     uplevel 1
 145 CORE::GLOBAL::caller
 146 Carp::short_error_loc           0
 147 Carp::shortmess_heavy           1           0
 148 Carp::croak                     2           1
 149 try_croak                       3           2
 150 uplevel                         4
 151 function_that_called_uplevel    5
 152 caller_we_want_to_see           6           3
 153 its_caller                      7           4
 154
 155 So when caller(X) winds up below uplevel(), it only has to use
 156 CORE::caller(X+1) (to skip CORE::GLOBAL::caller).  But when caller(X)
 157 winds up no or above uplevel(), it's CORE::caller(X+1+uplevel+1).
 158
 159 Which means I'm probably going to have to do something nasty like walk
 160 up the call stack on each caller() to see if I'm going to wind up
 161 before or after Sub::Uplevel::uplevel().
 162
 163 =end _private
 164
 165 =begin _dagolden
 166
 167 I found the description above a bit confusing.  Instead, this is the logic
 168 that I found clearer when CORE::GLOBAL::caller is invoked and we have to
 169 walk up the call stack:
 170
 171 * if searching up to the requested height in the real call stack doesn't find
 172 a call to uplevel, then we can return the result at that height in the
 173 call stack
 174
 175 * if we find a call to uplevel, we need to keep searching upwards beyond the
 176 requested height at least by the amount of upleveling requested for that
 177 call to uplevel (from the Up_Frames stack set during the uplevel call)
 178
 179 * additionally, we need to hide the uplevel subroutine call, too, so we search
 180 upwards one more level for each call to uplevel
 181
 182 * when we've reached the top of the search, we want to return that frame
 183 in the call stack, i.e. the requested height plus any uplevel adjustments
 184 found during the search
 185
 186 =end _dagolden
 187
 188 =cut
 189
 190     my $saw_uplevel = 0;
 191     my $adjust = 0;
 192
 193     # walk up the call stack to fight the right package level to return;
 194     # look one higher than requested for each call to uplevel found
 195     # and adjust by the amount found in the Up_Frames stack for that call.
 196     # We *must* use CORE::caller here since we need the real stack not what
 197     # some other override says the stack looks like, just in case that other
 198     # override breaks things in some horrible way
 199
 200     for ( my $up = 0; $up <= $height + $adjust; $up++ ) {
 201         my @caller = CORE::caller($up + 1);
 202         if( defined $caller[0] && $caller[0] eq __PACKAGE__ ) {
 203             # add one for each uplevel call seen
 204             # and look into the uplevel stack for the offset
 205             $adjust += 1 + $Up_Frames[$saw_uplevel];
 206             $saw_uplevel++;
 207         }
 208     }
 209
 210     # For returning values, we pass through the call to the proxy caller
 211     # function, just at a higher stack level
 212     my @caller;
 213     if ( CORE::caller() eq 'DB' ) {
 214         # passthrough the @DB::args trick
 215         package DB;
 216         @caller = $Sub::Uplevel::Caller_Proxy->($height + $adjust + 1);
 217     }
 218     else {
 219         @caller = $Caller_Proxy->($height + $adjust + 1);
 220     }
 221
 222     if( wantarray ) {
 223         if( !@_ ) {
 224             @caller = @caller[0..2];
 225         }
 226         return @caller;
 227     }
 228     else {
 229         return $caller[0];
 230     }
 231 }
 232
 233 =back
 234
 235 =head1 EXAMPLE
 236
 237 The main reason I wrote this module is so I could write wrappers
 238 around functions and they wouldn't be aware they've been wrapped.
 239
 240     use Sub::Uplevel;
 241
 242     my $original_foo = \&foo;
 243
 244     *foo = sub {
 245         my @output = uplevel 1, $original_foo;
 246         print "foo() returned:  @output";
 247         return @output;
 248     };
 249
 250 If this code frightens you B<you should not use this module.>
 251
 252
 253 =head1 BUGS and CAVEATS
 254
 255 Well, the bad news is uplevel() is about 5 times slower than a normal
 256 function call.  XS implementation anyone?
 257
 258 Sub::Uplevel overrides CORE::GLOBAL::caller temporarily for the scope of
 259 each uplevel call.  It does its best to work with any previously existing
 260 CORE::GLOBAL::caller (both when Sub::Uplevel is first loaded and within
 261 each uplevel call) such as from Contextual::Return or Hook::LexWrap.
 262
 263 However, if you are routinely using multiple modules that override
 264 CORE::GLOBAL::caller, you are probably asking for trouble.
 265
 266 =head1 HISTORY
 267
 268 Those who do not learn from HISTORY are doomed to repeat it.
 269
 270 The lesson here is simple:  Don't sit next to a Tcl programmer at the
 271 dinner table.
 272
 273 =head1 THANKS
 274
 275 Thanks to Brent Welch, Damian Conway and Robin Houston.
 276
 277 =head1 AUTHORS
 278
 279 David A Golden E<lt>dagolden@cpan.orgE<gt> (current maintainer)
 280
 281 Michael G Schwern E<lt>schwern@pobox.comE<gt> (original author)
 282
 283 =head1 LICENSE
 284
 285 Original code Copyright (c) 2001 to 2007 by Michael G Schwern.
 286 Additional code Copyright (c) 2006 to 2008 by David A Golden.
 287
 288 This program is free software; you can redistribute it and/or modify it
 289 under the same terms as Perl itself.
 290
 291 See http://www.perl.com/perl/misc/Artistic.html
 292
 293 =head1 SEE ALSO
 294
 295 PadWalker (for the similar idea with lexicals), Hook::LexWrap,
 296 Tcl's uplevel() at http://www.scriptics.com/man/tcl8.4/TclCmd/uplevel.htm
 297
 298 =cut
 299
 300
 301 1;