#---------------------------------------------------------------
# ____                   _ _         ____  _
#|  _ \ ___  _   _  __ _| | |_ _   _/ ___|| |__   __ _ _ __ ___
#| |_) / _ \| | | |/ _` | | __| | | \___ \| '_ \ / _` | '__/ _ \
#|  _ < (_) | |_| | (_| | | |_| |_| |___) | | | | (_| | | |  __/
#|_| \_\___/ \__, |\__,_|_|\__|\__, |____/|_| |_|\__,_|_|  \___|
#            |___/             |___/
#
# Copyright (C) 2011 RoyaltyShare, Inc.   All Rights Reserved
#---------------------------------------------------------------
use strict;
use warnings;
use Data::Dumper;

use lib '/app/tools/common/lib';
use Common::Assert;

package Common::Exception;

# This class is the base class for our Exception objects.
# To 'throw' one of these, you do something like this:
#
# die Common::Exception->new("Something terrible happened");
#
# You can pass any number of arguments to the constructor.  If any
# of these are references, Data::Dumper will be invoked to display it.
#

use overload ( '""' => \&Common::Exception::stringify );

sub new {
    my ( $class, @messages ) = @_;

    my $self = bless {}, $class;
    return $self->_init(@messages);
}

sub _init {
    my ( $self, @messages ) = @_;

    foreach my $msg (@messages) {
        $self->{details} .= ref($msg) ? Data::Dumper::Dump($msg) : $msg;
        $self->{details} .= "\n";
    }

    # $. is a magical perl variable that corresponds to
    # the line number of the 'current' open file handle.
    #
    $self->{lineNum} = $. if ($.);

    # For debugging purposes, we're probably going to want to see the
    # call stack from the point the exception was raised.
    # !!! Passing '1' to skip over the call to 'new' in this package.
    #
    $self->{_callStack} = ret_backtrace(1);

    #    my @callStack;
    #    my $depth = 0;
    #    while (my @stackFrame = caller($depth))
    #    {
    #        push @callStack, \@stackFrame;
    #        $depth++;
    #    }
    #    $self->{_callStack} = \@callStack;

    return $self;
}

# This is a one-liner that describes the type of exception.
# Classes that inherit from this class ought to override this.
#
sub error {
    my ($self) = @_;
    return '-- EXCEPTION --';
}

sub details {
    my ($self) = @_;
    return $self->{details};
}

# This method returns a 'formatted' error message.
#
sub errorMessage {
    my ($self) = @_;

    my $msg = $self->error();

    $msg .= " (file IO line " . $self->{lineNum} . ' )' if $self->{lineNum};

    $msg .= ": " . $self->details();

    return $msg;
}

# This method returns the call stack, rendered pretty for logging.
#
sub stackTrace {
    my ($self) = @_;
    return $self->{_callStack};
}

# !!! We'll probably want to overload 'stringify', to return the message and a full stack
# !!! trace.  This is what would get invoked if nobody catches the exception (and therefore
# !!! provides the most complete debugging information).

sub stringify {
    my ($self) = @_;
    return $self->errorMessage() . "\n" . $self->stackTrace() . "\n";
}

# JPK - The following routines are taken from the perl 5.10.0 implementation of Carp.
# Carp doesn't by default export any method to get access to it's stacktrack code, outside
# of calling 'confess' (which halts execution).
# Since this code is undocumented and internal to Carp, it's safer to just copy this code into
# our module (rather that trying to invoke 'Carp::Heavy::ret_backtrace()' directly), since the whole
# package might get re-written at any time.
#
my $MaxEvalLen = 0;
my $Verbose    = 0;
my $CarpLevel  = 0;
my $MaxArgLen  = 0;    # How much of each argument to print. 0 = all.
my $MaxArgNums = 0;    # How many arguments to print. 0 = all.

sub caller_info {
    my $i = shift(@_) + 1;

    package DB;
    my %call_info;
    @call_info{ qw(pack file line sub has_args wantarray evaltext is_require) } = caller($i);

    unless ( defined $call_info{pack} ) {
        return ();
    }

    my $sub_name = Common::Exception::get_subname( \%call_info );
    if ( $call_info{has_args} ) {
        my @args = map { Common::Exception::format_arg($_) } @DB::args;
        if ( $MaxArgNums and @args > $MaxArgNums ) {    # More than we want to show?
            $#args = $MaxArgNums;
            push @args, '...';
        }

        # Push the args onto the subroutine
        $sub_name .= '(' . join( ', ', @args ) . ')';
    }
    $call_info{sub_name} = $sub_name;
    return wantarray() ? %call_info : \%call_info;
}

# Transform an argument to a function into a string.
sub format_arg {
    my $arg = shift;
    if ( ref($arg) ) {
        $arg = defined($overload::VERSION) ? overload::StrVal($arg) : "$arg";
    }
    if ( defined($arg) ) {
        $arg =~ s/'/\\'/g;
        $arg = str_len_trim( $arg, $MaxArgLen );

        # Quote it?
        $arg = "'$arg'" unless $arg =~ /^-?[\d.]+\z/;
    } else {
        $arg = 'undef';
    }

    # The following handling of "control chars" is direct from
    # the original code - it is broken on Unicode though.
    # Suggestions?
    utf8::is_utf8($arg)
      or $arg =~ s/([[:cntrl:]]|[[:^ascii:]])/sprintf("\\x{%x}",ord($1))/eg;
    return $arg;
}

# Returns a full stack backtrace starting from where it is
# told.
sub ret_backtrace {
    my ( $i, @error ) = @_;
    my $mess;
    my $err = join '', @error;
    $i++;

    my $tid_msg = '';
    if ( defined &threads::tid ) {
        my $tid = threads->tid;
        $tid_msg = " thread $tid" if $tid;
    }

    my %i = caller_info($i);
    $mess = "$err at $i{file} line $i{line}$tid_msg\n";

    while ( my %i = caller_info( ++$i ) ) {
        $mess .= "\t$i{sub_name} called at $i{file} line $i{line}$tid_msg\n";
    }

    return $mess;
}

sub ret_summary {
    my ( $i, @error ) = @_;
    my $err = join '', @error;
    $i++;

    my $tid_msg = '';
    if ( defined &threads::tid ) {
        my $tid = threads->tid;
        $tid_msg = " thread $tid" if $tid;
    }

    my %i = caller_info($i);
    return "$err at $i{file} line $i{line}$tid_msg\n";
}

# If a string is too long, trims it with ...
sub str_len_trim {
    my $str = shift;
    my $max = shift || 0;
    if ( 2 < $max and $max < length($str) ) {
        substr( $str, $max - 3 ) = '...';
    }
    return $str;
}

# Takes the info from caller() and figures out the name of
# the sub/require/eval
sub get_subname {
    my $info = shift;
    if ( defined( $info->{evaltext} ) ) {
        my $eval = $info->{evaltext};
        if ( $info->{is_require} ) {
            return "require $eval";
        } else {
            $eval =~ s/([\\\'])/\\$1/g;
            return "eval '" . str_len_trim( $eval, $MaxEvalLen ) . "'";
        }
    }

    return ( $info->{sub} eq '(eval)' ) ? 'eval {...}' : $info->{sub};
}

1;