Acme-Sort-Sleep
view release on metacpan or search on metacpan
local/lib/perl5/Module/Build/Base.pm view on Meta::CPAN
}
sub log_debug {
my $self = shift;
print @_ if ref($self) && $self->debug;
}
sub log_warn {
# Try to make our call stack invisible
shift;
if (@_ and $_[-1] !~ /\n$/) {
my (undef, $file, $line) = caller();
warn @_, " at $file line $line.\n";
} else {
warn @_;
}
}
# install paths must be generated when requested to be sure all changes
# to config (from various sources) are included
sub _default_install_paths {
local/lib/perl5/Sub/Uplevel.pm view on Meta::CPAN
}
# modules to force reload if ":aggressive" is specified
my @reload_list = qw/Exporter Exporter::Heavy/;
sub import {
no strict 'refs'; ## no critic
my ($class, @args) = @_;
for my $tag ( @args, 'uplevel' ) {
if ( $tag eq 'uplevel' ) {
my $caller = caller(0);
*{"$caller\::uplevel"} = \&uplevel;
}
elsif( $tag eq ':aggressive' ) {
_force_reload( @reload_list );
}
else {
die qq{"$tag" is not exported by the $class module\n}
}
}
return;
local/lib/perl5/Sub/Uplevel.pm view on Meta::CPAN
#pod sub bar {
#pod uplevel 1, \&foo;
#pod }
#pod
#pod #line 11
#pod bar(); # main - foo.plx - 11
#pod
#pod =head1 DESCRIPTION
#pod
#pod Like Tcl's uplevel() function, but not quite so dangerous. The idea
#pod is just to fool caller(). All the really naughty bits of Tcl's
#pod uplevel() are avoided.
#pod
#pod B<THIS IS NOT THE SORT OF THING YOU WANT TO DO EVERYDAY>
#pod
#pod =over 4
#pod
#pod =item B<uplevel>
#pod
#pod uplevel $num_frames, \&func, @args;
#pod
#pod Makes the given function think it's being executed $num_frames higher
#pod than the current stack level. So when they use caller($frames) it
#pod will actually give caller($frames + $num_frames) for them.
#pod
#pod C<uplevel(1, \&some_func, @_)> is effectively C<goto &some_func> but
#pod you don't immediately exit the current subroutine. So while you can't
#pod do this:
#pod
#pod sub wrapper {
#pod print "Before\n";
#pod goto &some_func;
#pod print "After\n";
#pod }
local/lib/perl5/Sub/Uplevel.pm view on Meta::CPAN
#pod $Sub::Uplevel::CHECK_FRAMES = 1;
#pod }
#pod use Sub::Uplevel;
#pod
#pod Setting or changing the global after the module has been loaded will have
#pod no effect.
#pod
#pod =cut
# @Up_Frames -- uplevel stack
# $Caller_Proxy -- whatever caller() override was in effect before uplevel
our (@Up_Frames, $Caller_Proxy);
sub _apparent_stack_height {
my $height = 1; # start above this function
while ( 1 ) {
last if ! defined scalar $Caller_Proxy->($height);
$height++;
}
return $height - 1; # subtract 1 for this function
}
local/lib/perl5/Sub/Uplevel.pm view on Meta::CPAN
local @Up_Frames = (shift, @Up_Frames );
my $function = shift;
return $function->(@_);
}
sub _normal_caller (;$) { ## no critic Prototypes
my ($height) = @_;
$height++;
my @caller = CORE::caller($height);
if ( CORE::caller() eq 'DB' ) {
# Oops, redo picking up @DB::args
package DB;
@caller = CORE::caller($height);
}
return if ! @caller; # empty
return $caller[0] if ! wantarray; # scalar context
return @_ ? @caller : @caller[0..2]; # extra info or regular
}
sub _uplevel_caller (;$) { ## no critic Prototypes
my $height = $_[0] || 0;
local/lib/perl5/Sub/Uplevel.pm view on Meta::CPAN
#pod CORE::GLOBAL::caller
#pod Carp::short_error_loc 0
#pod Carp::shortmess_heavy 1 0
#pod Carp::croak 2 1
#pod try_croak 3 2
#pod uplevel 4
#pod function_that_called_uplevel 5
#pod caller_we_want_to_see 6 3
#pod its_caller 7 4
#pod
#pod So when caller(X) winds up below uplevel(), it only has to use
#pod CORE::caller(X+1) (to skip CORE::GLOBAL::caller). But when caller(X)
#pod winds up no or above uplevel(), it's CORE::caller(X+1+uplevel+1).
#pod
#pod Which means I'm probably going to have to do something nasty like walk
#pod up the call stack on each caller() to see if I'm going to wind up
#pod before or after Sub::Uplevel::uplevel().
#pod
#pod =end _private
#pod
#pod =begin _dagolden
#pod
#pod I found the description above a bit confusing. Instead, this is the logic
#pod that I found clearer when CORE::GLOBAL::caller is invoked and we have to
#pod walk up the call stack:
#pod
local/lib/perl5/Sub/Uplevel.pm view on Meta::CPAN
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
my $test_caller;
for ( my $up = 0; $up <= $height + $adjust; $up++ ) {
$test_caller = scalar CORE::caller($up + 1);
if( $test_caller && $test_caller 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 = $Caller_Proxy->($height + $adjust + 1);
if ( CORE::caller() eq 'DB' ) {
# Oops, redo picking up @DB::args
package DB;
@caller = $Sub::Uplevel::Caller_Proxy->($height + $adjust + 1);
}
return if ! @caller; # empty
return $caller[0] if ! wantarray; # scalar context
return @_ ? @caller : @caller[0..2]; # extra info or regular
}
local/lib/perl5/Sub/Uplevel.pm view on Meta::CPAN
#pod return @output;
#pod };
#pod
#pod If this code frightens you B<you should not use this module.>
#pod
#pod
#pod =head1 BUGS and CAVEATS
#pod
#pod Well, the bad news is uplevel() is about 5 times slower than a normal
#pod function call. XS implementation anyone? It also slows down every invocation
#pod of caller(), regardless of whether uplevel() is in effect.
#pod
#pod Sub::Uplevel overrides CORE::GLOBAL::caller temporarily for the scope of
#pod each uplevel call. It does its best to work with any previously existing
#pod CORE::GLOBAL::caller (both when Sub::Uplevel is first loaded and within
#pod each uplevel call) such as from Contextual::Return or Hook::LexWrap.
#pod
#pod However, if you are routinely using multiple modules that override
#pod CORE::GLOBAL::caller, you are probably asking for trouble.
#pod
#pod You B<should> load Sub::Uplevel as early as possible within your program. As
local/lib/perl5/Sub/Uplevel.pm view on Meta::CPAN
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";
}
local/lib/perl5/Sub/Uplevel.pm view on Meta::CPAN
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:
local/lib/perl5/Sub/Uplevel.pm view on Meta::CPAN
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? It also slows down every invocation
of caller(), regardless of whether uplevel() is in effect.
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.
You B<should> load Sub::Uplevel as early as possible within your program. As
local/lib/perl5/Test/Exception.pm view on Meta::CPAN
C<CORE::GLOBAL::caller> to hide your test blocks from the call stack. If this
use of global overrides concerns you, the L<Test::Fatal> module offers a more
minimalist alternative.
=cut
sub _quiet_caller (;$) { ## no critic Prototypes
my $height = $_[0];
$height++;
if ( CORE::caller() eq 'DB' ) {
# passthrough the @DB::args trick
package DB;
if( wantarray ) {
if ( !@_ ) {
return (CORE::caller($height))[0..2];
}
else {
# If we got here, we are within a Test::Exception test, and
# something is producing a stacktrace. In case this is a full
# trace (i.e. confess() ), we have to make sure that the sub
# args are not visible. If we do not do this, and the test in
# question is throws_ok() with a regex, it will end up matching
# against itself in the args to throws_ok().
#
# While it is possible (and maybe wise), to test if we are
# indeed running under throws_ok (by crawling the stack right
# up from here), the old behavior of Test::Exception was to
# simply obliterate @DB::args altogether in _quiet_caller, so
# we are just preserving the behavior to avoid surprises
#
my @frame_info = CORE::caller($height);
@DB::args = ();
return @frame_info;
}
}
# fallback if nothing above returns
return CORE::caller($height);
}
else {
if( wantarray and !@_ ) {
return (CORE::caller($height))[0..2];
}
else {
return CORE::caller($height);
}
}
}
sub _try_as_caller {
my $coderef = shift;
# local works here because Sub::Uplevel has already overridden caller
local *CORE::GLOBAL::caller;
{ no warnings 'redefine'; *CORE::GLOBAL::caller = \&_quiet_caller; }
local/lib/perl5/Test/Exception.pm view on Meta::CPAN
sub throws_ok (&$;$) {
my ( $coderef, $expecting, $description ) = @_;
unless (defined $expecting) {
require Carp;
Carp::croak( "throws_ok: must pass exception class/object or regex" );
}
$description = _exception_as_string( "threw", $expecting )
unless defined $description;
my $exception = _try_as_caller( $coderef );
my $regex = $Tester->maybe_regex( $expecting );
my $ok = $regex
? ( $exception =~ m/$regex/ )
: eval {
$exception->isa( ref $expecting ? ref $expecting : $expecting )
};
$Tester->ok( $ok, $description );
unless ( $ok ) {
$Tester->diag( _exception_as_string( "expecting:", $expecting ) );
$Tester->diag( _exception_as_string( "found:", $exception ) );
local/lib/perl5/Test/Exception.pm view on Meta::CPAN
A true value is returned if the test succeeds, false otherwise. On exit $@ is guaranteed to be the cause of death (if any).
Remember: This test will pass if the code dies for any reason. If you care about the reason it might be more sensible to write a more specific test using throws_ok().
The test description is optional, but recommended.
=cut
sub dies_ok (&;$) {
my ( $coderef, $description ) = @_;
my $exception = _try_as_caller( $coderef );
my $ok = $Tester->ok( _is_exception($exception), $description );
$@ = $exception;
return $ok;
}
=item B<lives_ok>
Checks that a piece of code doesn't die. This allows your test script to continue, rather than aborting if you get an unexpected exception. For example:
local/lib/perl5/Test/Exception.pm view on Meta::CPAN
# died: open failed (No such file or directory)
A true value is returned if the test succeeds, false otherwise. On exit $@ is guaranteed to be the cause of death (if any).
The test description is optional, but recommended.
=cut
sub lives_ok (&;$) {
my ( $coderef, $description ) = @_;
my $exception = _try_as_caller( $coderef );
my $ok = $Tester->ok( ! _is_exception( $exception ), $description );
$Tester->diag( _exception_as_string( "died:", $exception ) ) unless $ok;
$@ = $exception;
return $ok;
}
=item B<lives_and>
Run a test that may throw an exception. For example, instead of doing:
( run in 0.350 second using v1.01-cache-2.11-cpan-b61123c0432 )