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',

        q{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',

        q{first frame's subroutine should be Devel::StackTrace::new}

    );

    is(

        $f[3]->subroutine, 'main::foo',

        q{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/,

        q{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 )

{

    ## no critic (ErrorHandling::RequireCheckingReturnValueOfEval)

    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' );

}

## no critic (Modules::ProhibitMultiplePackages)

{

    package    #hide

        StringOverloaded;

    use overload q{""} => 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 307

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 307

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, q{}, 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() );

    ## no critic (ErrorHandling::RequireCheckingReturnValueOfEval)

    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;

    }

}