+++ /dev/null
-package Sub::Uplevel;
-
-use strict;
-use vars qw($VERSION @ISA @EXPORT);
-$VERSION = '0.1901';
-
-# We must override *CORE::GLOBAL::caller if it hasn't already been
-# overridden or else Perl won't see our local override later.
-
-if ( not defined *CORE::GLOBAL::caller{CODE} ) {
- *CORE::GLOBAL::caller = \&_normal_caller;
-}
-
-require Exporter;
-@ISA = qw(Exporter);
-@EXPORT = qw(uplevel);
-
-=head1 NAME
-
-Sub::Uplevel - apparently run a function in a higher stack frame
-
-=begin wikidoc
-
-= VERSION
-
-This documentation describes version %%VERSION%%
-
-=end wikidoc
-
-=head1 SYNOPSIS
-
- use Sub::Uplevel;
-
- sub foo {
- print join " - ", caller;
- }
-
- sub bar {
- uplevel 1, \&foo;
- }
-
- #line 11
- bar(); # main - foo.plx - 11
-
-=head1 DESCRIPTION
-
-Like Tcl's uplevel() function, but not quite so dangerous. The idea
-is just to fool caller(). All the really naughty bits of Tcl's
-uplevel() are avoided.
-
-B<THIS IS NOT THE SORT OF THING YOU WANT TO DO EVERYDAY>
-
-=over 4
-
-=item B<uplevel>
-
- uplevel $num_frames, \&func, @args;
-
-Makes the given function think it's being executed $num_frames higher
-than the current stack level. So when they use caller($frames) it
-will actually give caller($frames + $num_frames) for them.
-
-C<uplevel(1, \&some_func, @_)> is effectively C<goto &some_func> but
-you don't immediately exit the current subroutine. So while you can't
-do this:
-
- sub wrapper {
- print "Before\n";
- goto &some_func;
- print "After\n";
- }
-
-you can do this:
-
- sub wrapper {
- print "Before\n";
- my @out = uplevel 1, &some_func;
- print "After\n";
- return @out;
- }
-
-
-=cut
-
-use vars qw/@Up_Frames $Caller_Proxy/;
-# @Up_Frames -- uplevel stack
-# $Caller_Proxy -- whatever caller() override was in effect before uplevel
-
-sub uplevel {
- my($num_frames, $func, @args) = @_;
-
- local @Up_Frames = ($num_frames, @Up_Frames );
-
- # backwards compatible version of "no warnings 'redefine'"
- my $old_W = $^W;
- $^W = 0;
-
- # Update the caller proxy if the uplevel override isn't in effect
- local $Caller_Proxy = *CORE::GLOBAL::caller{CODE}
- if *CORE::GLOBAL::caller{CODE} != \&_uplevel_caller;
- local *CORE::GLOBAL::caller = \&_uplevel_caller;
-
- # restore old warnings state
- $^W = $old_W;
-
- return $func->(@args);
-}
-
-sub _normal_caller (;$) { ## no critic Prototypes
- my $height = $_[0];
- $height++;
- if ( CORE::caller() eq 'DB' ) {
- # passthrough the @DB::args trick
- package DB;
- if( wantarray and !@_ ) {
- return (CORE::caller($height))[0..2];
- }
- else {
- return CORE::caller($height);
- }
- }
- else {
- if( wantarray and !@_ ) {
- return (CORE::caller($height))[0..2];
- }
- else {
- return CORE::caller($height);
- }
- }
-}
-
-sub _uplevel_caller (;$) { ## no critic Prototypes
- my $height = $_[0] || 0;
-
- # shortcut if no uplevels have been called
- # always add +1 to CORE::caller (proxy caller function)
- # to skip this function's caller
- return $Caller_Proxy->( $height + 1 ) if ! @Up_Frames;
-
-=begin _private
-
-So it has to work like this:
-
- Call stack Actual uplevel 1
-CORE::GLOBAL::caller
-Carp::short_error_loc 0
-Carp::shortmess_heavy 1 0
-Carp::croak 2 1
-try_croak 3 2
-uplevel 4
-function_that_called_uplevel 5
-caller_we_want_to_see 6 3
-its_caller 7 4
-
-So when caller(X) winds up below uplevel(), it only has to use
-CORE::caller(X+1) (to skip CORE::GLOBAL::caller). But when caller(X)
-winds up no or above uplevel(), it's CORE::caller(X+1+uplevel+1).
-
-Which means I'm probably going to have to do something nasty like walk
-up the call stack on each caller() to see if I'm going to wind up
-before or after Sub::Uplevel::uplevel().
-
-=end _private
-
-=begin _dagolden
-
-I found the description above a bit confusing. Instead, this is the logic
-that I found clearer when CORE::GLOBAL::caller is invoked and we have to
-walk up the call stack:
-
-* if searching up to the requested height in the real call stack doesn't find
-a call to uplevel, then we can return the result at that height in the
-call stack
-
-* if we find a call to uplevel, we need to keep searching upwards beyond the
-requested height at least by the amount of upleveling requested for that
-call to uplevel (from the Up_Frames stack set during the uplevel call)
-
-* additionally, we need to hide the uplevel subroutine call, too, so we search
-upwards one more level for each call to uplevel
-
-* when we've reached the top of the search, we want to return that frame
-in the call stack, i.e. the requested height plus any uplevel adjustments
-found during the search
-
-=end _dagolden
-
-=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
-
- for ( my $up = 0; $up <= $height + $adjust; $up++ ) {
- my @caller = CORE::caller($up + 1);
- if( defined $caller[0] && $caller[0] 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;
- if ( CORE::caller() eq 'DB' ) {
- # passthrough the @DB::args trick
- package DB;
- @caller = $Sub::Uplevel::Caller_Proxy->($height + $adjust + 1);
- }
- else {
- @caller = $Caller_Proxy->($height + $adjust + 1);
- }
-
- if( wantarray ) {
- if( !@_ ) {
- @caller = @caller[0..2];
- }
- return @caller;
- }
- else {
- return $caller[0];
- }
-}
-
-=back
-
-=head1 EXAMPLE
-
-The main reason I wrote this module is so I could write wrappers
-around functions and they wouldn't be aware they've been wrapped.
-
- use Sub::Uplevel;
-
- my $original_foo = \&foo;
-
- *foo = sub {
- my @output = uplevel 1, $original_foo;
- print "foo() returned: @output";
- return @output;
- };
-
-If this code frightens you B<you should not use this module.>
-
-
-=head1 BUGS and CAVEATS
-
-Well, the bad news is uplevel() is about 5 times slower than a normal
-function call. XS implementation anyone?
-
-Sub::Uplevel overrides CORE::GLOBAL::caller temporarily for the scope of
-each uplevel call. It does its best to work with any previously existing
-CORE::GLOBAL::caller (both when Sub::Uplevel is first loaded and within
-each uplevel call) such as from Contextual::Return or Hook::LexWrap.
-
-However, if you are routinely using multiple modules that override
-CORE::GLOBAL::caller, you are probably asking for trouble.
-
-=head1 HISTORY
-
-Those who do not learn from HISTORY are doomed to repeat it.
-
-The lesson here is simple: Don't sit next to a Tcl programmer at the
-dinner table.
-
-=head1 THANKS
-
-Thanks to Brent Welch, Damian Conway and Robin Houston.
-
-=head1 AUTHORS
-
-David A Golden E<lt>dagolden@cpan.orgE<gt> (current maintainer)
-
-Michael G Schwern E<lt>schwern@pobox.comE<gt> (original author)
-
-=head1 LICENSE
-
-Original code Copyright (c) 2001 to 2007 by Michael G Schwern.
-Additional code Copyright (c) 2006 to 2008 by David A Golden.
-
-This program is free software; you can redistribute it and/or modify it
-under the same terms as Perl itself.
-
-See http://www.perl.com/perl/misc/Artistic.html
-
-=head1 SEE ALSO
-
-PadWalker (for the similar idea with lexicals), Hook::LexWrap,
-Tcl's uplevel() at http://www.scriptics.com/man/tcl8.4/TclCmd/uplevel.htm
-
-=cut
-
-
-1;
projects / pkg-perl / blobdiff