Permalink
Fetching contributors…
Cannot retrieve contributors at this time
201 lines (162 sloc) 4.98 KB
#!perl
use strict;
use warnings;
use Test::More;
my $extra_frames;
BEGIN {
my $class = 'Moo';
$extra_frames = 0;
if ($Throwable::_TEST_MOOSE) {
$class = 'Moose';
$extra_frames++ # the "do" in xt/moose.t adds a frame
}
eval qq{
package MyError;
use $class;
extends 'Throwable::Error';
package MyError1;
use $class;
extends 'Throwable::Error';
around stack_trace_args => sub {
my (\$orig, \$self, \@args) = \@_;
my \$args = \$self->\$orig;
push \@\$args, (message => 'Munged.');
return \$args;
};
package MyError2;
use $class;
extends 'Throwable::Error';
}.q{
use Carp qw(cluck);
around _build_stack_trace_args => sub {
my ($orig, $self) = (shift, shift);
return [
@{$self->$orig(@_)},
no_refs => 1,
respect_overload => 1,
];
};
1;
} or die $@;
}
sub throw_x {
$_[0]->throw({ message => 'foo bar baz' });
}
sub call_throw_x {
throw_x($_[0]);
}
for my $class (qw(MyError MyError1)) {
eval { call_throw_x($class); };
my $error = $@;
isa_ok($error, $class, 'the error');
isa_ok($error, 'Throwable::Error', 'the error');
is($error->message, q{foo bar baz}, "error message is correct");
my $trace = $error->stack_trace;
isa_ok($trace, 'Devel::StackTrace', 'the trace');
if ($class eq 'MyError1') {
like($trace->as_string, qr/Munged/, "trace message munged");
unlike($trace->as_string, qr/Trace begun/, "trace message munged");
} else {
unlike($trace->as_string, qr/Munged/, "trace message not munged");
like($trace->as_string, qr/Trace begun/, "trace message not munged");
}
my @frames = $trace->frames;
is(@frames, 4 + $extra_frames, "we have four frames in our trace");
is($frames[0]->subroutine, q{Throwable::throw}, 'correct frame 0');
is($frames[1]->subroutine, q{main::throw_x}, 'correct frame 1');
is($frames[2]->subroutine, q{main::call_throw_x}, 'correct frame 2');
is($frames[3]->subroutine, q{(eval)}, 'correct frame 3');
{
eval { sub { sub { die MyError->new_with_previous('a') }->() }->() };
my $error = $@;
is($error->message, q{a}, "error message is correct");
my $trace = $error->stack_trace;
my @frames = $trace->frames;
is(@frames, 4 + $extra_frames, "we have four frames in our trace");
is($frames[0]->subroutine, q{Throwable::new_with_previous}, 'correct frame 0');
is($frames[3]->subroutine, q{(eval)}, 'correct frame 3');
}
}
{
eval { MyError->throw('shucks howdy'); };
my $error = $@;
isa_ok($error, 'MyError', 'the error');
is($error->message, q{shucks howdy}, "error message is correct");
}
{
package HasError;
sub new { bless { error => MyError->new("flabba") } }
}
sub create_error { HasError->new->{error} }
{
my $error = create_error();
my @frames = $error->stack_trace->frames;
is(@frames, 2 + $extra_frames, "two frames from constructor");
is($frames[0]->subroutine, q{HasError::new}, 'correct constructor in frame 0');
is($frames[1]->subroutine, q{main::create_error}, 'correct frame 1');
}
{
package MyTrace;
use base 'Devel::StackTrace';
}
# make sure to catch intermittent failures due to attribute initialisation order
for my $i (1..10) {
eval { MyError->throw({ message => 'aieee!', stack_trace_class => 'MyTrace' }) };
my $error = $@;
isa_ok($error->stack_trace, 'MyTrace', "the trace (run $i)")
}
{
eval {
local $SIG{ALRM} = sub { fail('no_refs + respect_overload finishes'); exit 1; };
alarm 10;
MyError2->throw('aiee!');
};
alarm 0;
my $error = $@;
isa_ok($error, 'MyError2', 'the error');
}
{
eval { MyError->throw( { message => 'yikes!' } ); };
my $first_error = $@;
is( $first_error->previous_exception, q{}, 'no previous exception' );
eval {
$@ = 'foo';
MyError->throw( { message => 'argh!' } );
};
my $second_error = $@;
is( $second_error->previous_exception, 'foo',
'found previous exception foo' );
}
{
eval { die MyError->new_with_previous( { message => 'yikes!' } ); };
my $first_error = $@;
is( $first_error->previous_exception, q{}, 'no previous exception' );
eval {
$@ = 'foo';
die MyError->new_with_previous( { message => 'argh!' } );
};
my $second_error = $@;
is( $second_error->previous_exception, 'foo',
'found previous exception foo' );
}
{
eval {
eval { MyError->throw( { message => 'one' } ) };
eval { MyError->throw( { message => 'two' } ) };
MyError->throw( { message => 'argh!' } );
};
my $error = $@;
like( $error->previous_exception,
qr{two}, 'found previous exception two' );
is( $error->previous_exception->message,
'two', 'previous exception is an object' );
}
{
eval {
$@ = 0;
MyError->throw( { message => 'argh!' } );
};
my $second_error = $@;
is( $second_error->previous_exception, 0, 'found previous exception 0' );
}
done_testing();