use strict;
use warnings;

use File::Spec;

use Test::More 0.88;

use_ok('Exception::Class');

# There's actually a few tests here of the import routine.  I don't
# really know how to quantify them though.  If we fail to compile and
# there's an error from the Exception::Class::Base class then
# something here failed.
BEGIN {
    package FooException;

    use Exception::Class;
    use base qw(Exception::Class::Base);
}

use Exception::Class (
    'YAE' => { isa => 'SubTestException', alias => 'yae' },

    'SubTestException' => {
        isa         => 'TestException',
        description => q|blah'\\blah|
    },

    'TestException',

    'FooBarException' => { isa => 'FooException' },

    'FieldsException' => { isa => 'YAE', fields => [qw( foo bar )] },
    'MoreFieldsException' => { isa => 'FieldsException', fields => ['yip'] },

    'Exc::AsString',

    'Bool' => { fields => ['something'] },

    'ObjectRefs',
    'ObjectRefs2',
);

$Exception::Class::BASE_EXC_CLASS = 'FooException';
Exception::Class->import('BlahBlah');

# Accessors
{
    eval { Exception::Class::Base->throw( error => 'err' ); };

    my $e = $@;

    isa_ok( $e, 'Exception::Class::Base', '$@' );

    is(
        $e->error, 'err',
        "Exception's error message should be 'err'"
    );

    is(
        $e->message, 'err',
        "Exception's message should be 'err'"
    );

    is(
        $e->description, 'Generic exception',
        "Description should be 'Generic exception'"
    );

    is(
        $e->package, 'main',
        "Package should be 'main'"
    );

    my $expect = File::Spec->catfile( 't', 'basic.t' );
    is(
        $e->file, $expect,
        "File should be '$expect'"
    );

    is(
        $e->line, 49,
        "Line should be 49"
    );

    is(
        $e->pid, $$,
        "PID should be $$"
    );

    is(
        $e->context_hash->{pid}, $$,
        "PID is also in context_hash",
    );

    is(
        $e->uid, $<,
        "UID should be $<"
    );

    is(
        $e->euid, $>,
        "EUID should be $>"
    );

    is(
        $e->gid, $(,
        "GID should be $("
    );

    is(
        $e->egid, $),
        "EGID should be $)"
    );

    ok(
        defined $e->trace,
        "Exception object should have a stacktrace"
    );
}

# Test subclass creation
{
    eval { TestException->throw( error => 'err' ); };
    my $e = $@;

    isa_ok( $e, 'TestException' );

    is(
        $e->description, 'Generic exception',
        "Description should be 'Generic exception'"
    );

    eval { SubTestException->throw( error => 'err' ); };

    $e = $@;

    isa_ok( $e, 'SubTestException' );

    isa_ok( $e, 'TestException' );

    isa_ok( $e, 'Exception::Class::Base' );

    is(
        $e->description, q|blah'\\blah|,
        q|Description should be "blah'\\blah"|
    );

    eval { YAE->throw( error => 'err' ); };

    $e = $@;

    isa_ok( $e, 'SubTestException' );

    eval { BlahBlah->throw( error => 'yadda yadda' ); };

    $e = $@;

    isa_ok( $e, 'FooException' );

    isa_ok( $e, 'Exception::Class::Base' );
}

# Trace related tests
{
    ok(
        !Exception::Class::Base->Trace,
        "Exception::Class::Base class 'Trace' method should return false"
    );

    eval {
        Exception::Class::Base->throw(
            error      => 'has stacktrace',
            show_trace => 1,
        );
    };

    my $e = $@;

    like(
        $e->as_string, qr/Trace begun/,
        "Setting show_trace to true should override value of Trace"
    );

    Exception::Class::Base->Trace(1);

    ok(
        Exception::Class::Base->Trace,
        "Exception::Class::Base class 'Trace' method should return true"
    );

    eval { argh(); };

    $e = $@;

    ok(
        $e->trace->as_string,
        "Exception should have a stack trace"
    );

    eval {
        Exception::Class::Base->throw(
            error      => 'has stacktrace',
            show_trace => 0,
        );
    };

    $e = $@;

    unlike(
        $e->as_string, qr/Trace begun/,
        "Setting show_trace to false should override value of Trace"
    );

    my @f;
    while ( my $f = $e->trace->next_frame ) { push @f, $f; }

    ok(
        ( !grep { $_->package eq 'Exception::Class::Base' } @f ),
        "Trace should contain frames from Exception::Class::Base package"
    );
}

# overloading
{
    Exception::Class::Base->Trace(0);
    eval { Exception::Class::Base->throw( error => 'overloaded' ); };

    my $e = $@;

    is(
        "$e", 'overloaded',
        "Overloading in string context"
    );

    Exception::Class::Base->Trace(1);
    eval { Exception::Class::Base->throw( error => 'overloaded again' ); };

SKIP:
    {
        skip( "Perl 5.6.0 is broken.  See README.", 1 ) if $] == 5.006;

        my $re = qr/overloaded again.+eval \{...\}/s;

        my $x = "$@";
        like(
            $x, $re,
            "Overloaded stringification should include a stack trace"
        );
    }
}

# Test using message as hash key to constructor
{
    eval { Exception::Class::Base->throw( message => 'err' ); };

    my $e = $@;

    is(
        $e->error, 'err',
        "Exception's error message should be 'err'"
    );

    is(
        $e->message, 'err',
        "Exception's message should be 'err'"
    );
}

{
    {

        package X::Y;

        use Exception::Class (__PACKAGE__);

        sub xy_die () { __PACKAGE__->throw( error => 'dead' ); }

        eval {xy_die};
    }

    my $e = $@;

    is(
        $e->error, 'dead',
        "Error message should be 'dead'"
    );
}

# subclass overriding as_string

sub Exc::AsString::as_string { return uc $_[0]->error }

{
    eval { Exc::AsString->throw( error => 'upper case' ) };

    my $e = $@;

    is(
        "$e", 'UPPER CASE',
        "Overriding as_string in subclass"
    );
}

# fields

{
    eval { FieldsException->throw( error => 'error', foo => 5 ) };

    my $e = $@;

    can_ok( $e, 'foo' );

    is(
        $e->foo, 5,
        "Exception's foo method should return 5"
    );

    is_deeply(
      $@->field_hash,
      { foo => 5, bar => undef },
      "Exception's fields_hash should contain foo=>5,bar=>undef",
    );
}

# more fields.
{
    eval {
        MoreFieldsException->throw( error => 'error', yip => 10, foo => 15 );
    };

    my $e = $@;

    can_ok( $e, 'foo' );

    is(
        $e->foo, 15,
        "Exception's foo method should return 15"
    );

    can_ok( $e, 'yip' );

    is(
        $e->yip, 10,
        "Exception's foo method should return 10"
    );
}

sub FieldsException::full_message {
    return join ' ', $_[0]->message, "foo = " . $_[0]->foo;
}

# fields + full_message

{
    eval { FieldsException->throw( error => 'error', foo => 5 ) };

    my $e = $@;

    like(
        "$e", qr/error foo = 5/,
        "FieldsException should stringify to include the value of foo"
    );
}

# single arg constructor
{
    eval { YAE->throw('foo') };

    my $e = $@;

    ok(
        $e,
        "Single arg constructor should work"
    );

    is(
        $e->error, 'foo',
        "Single arg constructor should just set error/message"
    );
}

# no refs
{
    ObjectRefs2->NoRefs(0);

    eval { Foo->new->bork2 };
    my $exc = $@;

    my @args = ( $exc->trace->frames )[1]->args;

    ok(
        ref $args[0],
        "References should be saved in the stack trace"
    );
}

# aliases
{

    package FooBar;

    use Exception::Class (
        'SubAndFields' => {
            fields => 'thing',
            alias  => 'throw_saf',
        }
    );

    eval { throw_saf 'an error' };
    my $e = $@;

    ::ok( $e, "Throw exception via convenience sub (one param)" );
    ::is( $e->error, 'an error', 'check error message' );

    eval { throw_saf error => 'another error', thing => 10 };
    $e = $@;

    ::ok( $e, "Throw exception via convenience sub (named params)" );
    ::is( $e->error, 'another error', 'check error message' );
    ::is( $e->thing, 10, 'check "thing" field' );

    ::is( $e->package, __PACKAGE__, 'package matches current package' );
}

{

    package BarBaz;

    use overload '""' => sub {'overloaded'};
}

{
    sub throw { TestException->throw( error => 'dead' ) }

    TestException->Trace(1);

    eval { throw( bless {}, 'BarBaz' ) };
    my $e = $@;

    unlike(
        $e->as_string, qr/\boverloaded\b/,
        'overloading is ignored by default'
    );

    TestException->RespectOverload(1);

    eval { throw( bless {}, 'BarBaz' ) };
    $e = $@;

    like( $e->as_string, qr/\boverloaded\b/, 'overloading is now respected' );
}

{
    my %classes = map { $_ => 1 } Exception::Class::Classes();

    ok( $classes{TestException},
        'TestException should be in the return from Classes()' );
}

{
    sub throw2 { TestException->throw( error => 'dead' ); }

    eval { throw2('abcdefghijklmnop') };
    my $e = $@;

    like( $e->as_string, qr/'abcdefghijklmnop'/,
        'arguments are not truncated by default' );

    TestException->MaxArgLength(10);

    eval { throw2('abcdefghijklmnop') };
    $e = $@;

    like(
        $e->as_string, qr/'abcdefghij\.\.\.'/,
        'arguments are now truncated'
    );
}

done_testing();

sub argh {
    Exception::Class::Base->throw( error => 'ARGH' );
}

package Foo;

sub new {
    return bless {}, shift;
}

sub bork {
    my $self = shift;

    ObjectRefs->throw('kaboom');
}

sub bork2 {
    my $self = shift;

    ObjectRefs2->throw('kaboom');
}