diff options
Diffstat (limited to 't/01-basic.t')
| -rw-r--r-- | t/01-basic.t | 573 |
1 files changed, 573 insertions, 0 deletions
diff --git a/t/01-basic.t b/t/01-basic.t new file mode 100644 index 0000000..4af30ee --- /dev/null +++ b/t/01-basic.t @@ -0,0 +1,573 @@ +use strict; +use warnings; + +use Test::More 0.88; + +use Devel::StackTrace; + +sub get_file_name { File::Spec->canonpath( ( caller(0) )[1] ) } +my $test_file_name = get_file_name(); + +# Test all accessors +{ + my $trace = foo(); + + my @f = (); + while ( my $f = $trace->prev_frame ) { push @f, $f; } + + my $cnt = scalar @f; + is( + $cnt, 4, + "Trace should have 4 frames" + ); + + @f = (); + while ( my $f = $trace->next_frame ) { push @f, $f; } + + $cnt = scalar @f; + is( + $cnt, 4, + "Trace should have 4 frames" + ); + + is( + $f[0]->package, 'main', + "First frame package should be main" + ); + + is( + $f[0]->filename, $test_file_name, + "First frame filename should be $test_file_name" + ); + + is( $f[0]->line, 1009, "First frame line should be 1009" ); + + is( + $f[0]->subroutine, 'Devel::StackTrace::new', + "First frame subroutine should be Devel::StackTrace::new" + ); + + is( $f[0]->hasargs, 1, "First frame hasargs should be true" ); + + ok( + !$f[0]->wantarray, + "First frame wantarray should be false" + ); + + my $trace_text = <<"EOF"; +Trace begun at $test_file_name line 1009 +main::baz(1, 2) called at $test_file_name line 1005 +main::bar(1) called at $test_file_name line 1001 +main::foo at $test_file_name line 13 +EOF + + is( $trace->as_string, $trace_text, 'trace text' ); +} + +# Test constructor params +{ + my $trace = SubTest::foo( ignore_class => 'Test' ); + + my @f = (); + while ( my $f = $trace->prev_frame ) { push @f, $f; } + + my $cnt = scalar @f; + + is( $cnt, 1, "Trace should have 1 frame" ); + + is( + $f[0]->package, 'main', + "The package for this frame should be main" + ); + + $trace = Test::foo( ignore_class => 'Test' ); + + @f = (); + while ( my $f = $trace->prev_frame ) { push @f, $f; } + + $cnt = scalar @f; + + is( $cnt, 1, "Trace should have 1 frame" ); + is( + $f[0]->package, 'main', + "The package for this frame should be main" + ); +} + +# 15 - stringification overloading +{ + my $trace = baz(); + + my $trace_text = <<"EOF"; +Trace begun at $test_file_name line 1009 +main::baz at $test_file_name line 99 +EOF + + my $t = "$trace"; + is( $t, $trace_text, 'trace text' ); +} + +# 16-18 - frame_count, frame, reset_pointer, frames methods +{ + my $trace = foo(); + + is( + $trace->frame_count, 4, + "Trace should have 4 frames" + ); + + my $f = $trace->frame(2); + + is( + $f->subroutine, 'main::bar', + "Frame 2's subroutine should be 'main::bar'" + ); + + $trace->next_frame; + $trace->next_frame; + $trace->reset_pointer; + + $f = $trace->next_frame; + is( + $f->subroutine, 'Devel::StackTrace::new', + "next_frame should return first frame after call to reset_pointer" + ); + + my @f = $trace->frames; + is( + scalar @f, 4, + "frames method should return four frames" + ); + + is( + $f[0]->subroutine, 'Devel::StackTrace::new', + "first frame's subroutine should be Devel::StackTrace::new" + ); + + is( + $f[3]->subroutine, 'main::foo', + "last frame's subroutine should be main::foo" + ); +} + +# Not storing references +{ + my $obj = RefTest->new; + + my $trace = $obj->{trace}; + + my $call_to_trace = ( $trace->frames )[1]; + + my @args = $call_to_trace->args; + + is( + scalar @args, 1, + "Only one argument should have been passed in the call to trace()" + ); + + like( + $args[0], qr/RefTest=HASH/, + "Actual object should be replaced by string 'RefTest=HASH'" + ); +} + +# Storing references +{ + my $obj = RefTest2->new; + + my $trace = $obj->{trace}; + + my $call_to_trace = ( $trace->frames )[1]; + + my @args = $call_to_trace->args; + + is( + scalar @args, 1, + "Only one argument should have been passed in the call to trace()" + ); + + isa_ok( $args[0], 'RefTest2' ); +} + +# Storing references (deprecated interface 1) +{ + my $obj = RefTestDep1->new; + + my $trace = $obj->{trace}; + + my $call_to_trace = ( $trace->frames )[1]; + + my @args = $call_to_trace->args; + + is( + scalar @args, 1, + "Only one argument should have been passed in the call to trace()" + ); + + isa_ok( $args[0], 'RefTestDep1' ); +} + +# No ref to Exception::Class::Base object without refs +if ( $Exception::Class::VERSION && $Exception::Class::VERSION >= 1.09 ) +{ + eval { + Exception::Class::Base->throw( + error => 'error', + show_trace => 1, + ); + }; + my $exc = $@; + eval { quux($exc) }; + + ok( !$@, 'create stacktrace with no refs and exception object on stack' ); +} + +{ + sub FooBar::some_sub { return Devel::StackTrace->new } + + my $trace = eval { FooBar::some_sub('args') }; + + my $f = ( $trace->frames )[2]; + + is( $f->subroutine, '(eval)', 'subroutine is (eval)' ); + + my @args = $f->args; + + is( scalar @args, 0, 'no args given to eval block' ); +} + +{ + { + package #hide + FooBarBaz; + + sub func2 { + return Devel::StackTrace->new( ignore_package => qr/^FooBar/ ); + } + sub func1 { FooBarBaz::func2() } + } + + my $trace = FooBarBaz::func1('args'); + + my @f = $trace->frames; + + is( scalar @f, 1, 'check regex as ignore_package arg' ); +} + +{ + package #hide + StringOverloaded; + + use overload '""' => sub { 'overloaded' }; +} + +{ + my $o = bless {}, 'StringOverloaded'; + + my $trace = baz($o); + + unlike( + $trace->as_string, qr/\boverloaded\b/, + 'overloading is ignored by default' + ); +} + +{ + my $o = bless {}, 'StringOverloaded'; + + my $trace = respect_overloading($o); + + like( + $trace->as_string, qr/\boverloaded\b/, + 'overloading is ignored by default' + ); +} + +{ + package #hide + BlowOnCan; + + sub can { die 'foo' } +} + +{ + my $o = bless {}, 'BlowOnCan'; + + my $trace = baz($o); + + like( + $trace->as_string, qr/BlowOnCan/, + 'death in overload::Overloaded is ignored' + ); +} + +{ + my $trace = max_arg_length('abcdefghijklmnop'); + + my $trace_text = <<"EOF"; +Trace begun at $test_file_name line 1021 +main::max_arg_length('abcdefghij...') called at $test_file_name line 305 +EOF + + is( $trace->as_string, $trace_text, 'trace text' ); + + my $trace_text_1 = <<"EOF"; +Trace begun at $test_file_name line 1021 +main::max_arg_length('abc...') called at $test_file_name line 305 +EOF + + is( + $trace->as_string( { max_arg_length => 3 } ), + $trace_text_1, + 'trace text, max_arg_length = 3', + ); +} + +SKIP: +{ + skip "Test only runs on Linux", 1 + unless $^O eq 'linux'; + + my $frame = Devel::StackTrace::Frame->new( + [ 'Foo', 'foo/bar///baz.pm', 10, 'bar', 1, 1, '', 0 ], + [] + ); + + is( $frame->filename, 'foo/bar/baz.pm', 'filename is canonicalized' ); +} + +{ + my $obj = RefTest4->new(); + + my $trace = $obj->{trace}; + + ok( + ( !grep { ref $_ } map { @{ $_->{args} } } @{ $trace->{raw} } ), + 'raw data does not contain any references when unsafe_ref_capture not set' + ); + + is( + $trace->{raw}[1]{args}[1], 'not a ref', + 'non-refs are preserved properly in raw data as well' + ); +} + +{ + my $trace = overload_no_stringify( CodeOverload->new() ); + + eval { $trace->as_string() }; + + is( + $@, q{}, + 'no error when respect_overload is true and object overloads but does not stringify' + ); +} + +{ + my $trace = Filter::foo(); + + my @frames = $trace->frames(); + is( scalar @frames, 2, 'frame_filtered trace has just 2 frames' ); + is( + $frames[0]->subroutine(), 'Devel::StackTrace::new', + 'first subroutine' + ); + is( + $frames[1]->subroutine(), 'Filter::bar', + 'second subroutine (skipped Filter::foo)' + ); +} + +{ + my $trace = FilterAllFrames::a_foo(); + + my @frames = $trace->frames(); + is( + scalar @frames, 2, + 'after filtering whole list of frames, got just 2 frames' + ); + is( + $frames[0]->subroutine(), 'FilterAllFrames::a_bar', + 'first subroutine' + ); + is( + $frames[1]->subroutine(), 'FilterAllFrames::a_foo', + 'second subroutine' + ); +} + +done_testing(); + +# This means I can move these lines down without constantly fiddling +# with the checks for line numbers in the tests. + +#line 1000 +sub foo { + bar( @_, 1 ); +} + +sub bar { + baz( @_, 2 ); +} + +sub baz { + Devel::StackTrace->new( @_ ? @_[ 0, 1 ] : () ); +} + +sub quux { + Devel::StackTrace->new(); +} + +sub respect_overloading { + Devel::StackTrace->new( respect_overload => 1 ); +} + +sub max_arg_length { + Devel::StackTrace->new( max_arg_length => 10 ); +} + +sub overload_no_stringify { + return Devel::StackTrace->new( respect_overload => 1 ); +} + +{ + package #hide + Test; + + sub foo { + trace(@_); + } + + sub trace { + Devel::StackTrace->new(@_); + } +} + +{ + package #hide + SubTest; + + use base qw(Test); + + sub foo { + trace(@_); + } + + sub trace { + Devel::StackTrace->new(@_); + } +} + +{ + package #hide + RefTest; + + sub new { + my $self = bless {}, shift; + + $self->{trace} = trace($self); + + return $self; + } + + sub trace { + Devel::StackTrace->new(); + } +} + +{ + package #hide + RefTest2; + + sub new { + my $self = bless {}, shift; + + $self->{trace} = trace($self); + + return $self; + } + + sub trace { + Devel::StackTrace->new( unsafe_ref_capture => 1 ); + } +} + +{ + package #hide + RefTestDep1; + + sub new { + my $self = bless {}, shift; + + $self->{trace} = trace($self); + + return $self; + } + + sub trace { + Devel::StackTrace->new( no_refs => 0 ); + } +} + +{ + package #hide + RefTest4; + + sub new { + my $self = bless {}, shift; + + $self->{trace} = trace( $self, 'not a ref' ); + + return $self; + } + + sub trace { + Devel::StackTrace->new(); + } +} + +{ + package #hide + CodeOverload; + + use overload '&{}' => sub { 'foo' }; + + sub new { + my $class = shift; + return bless {}, $class; + } +} + +{ + package #hide + Filter; + + sub foo { + bar(); + } + + sub bar { + return Devel::StackTrace->new( + frame_filter => sub { $_[0]{caller}[3] ne 'Filter::foo' } ); + } +} + +{ + package #hide + FilterAllFrames; + + sub a_foo { b_foo() } + sub b_foo { a_bar() } + sub a_bar { b_bar() } + + sub b_bar { + my $stacktrace = Devel::StackTrace->new(); + $stacktrace->frames( only_a_frames( $stacktrace->frames() ) ); + return $stacktrace; + } + + sub only_a_frames { + my @frames = @_; + return grep { $_->subroutine() =~ /^FilterAllFrames::a/ } @frames; + } +} |