##----------------------------------------------------------------------------
## Module Generic - ~/lib/Module/Generic/Exception.pm
## Version v1.2.2
## Copyright(c) 2022 DEGUEST Pte. Ltd.
## Author: Jacques Deguest <jack@deguest.jp>
## Created 2021/03/20
## Modified 2023/01/11
## All rights reserved
## 
## This program is free software; you can redistribute  it  and/or  modify  it
## under the same terms as Perl itself.
##----------------------------------------------------------------------------
package Module::Generic::Exception;
BEGIN
{
    use strict;
    use warnings;
    use parent qw( Module::Generic );
    use vars qw( $CALLER_LEVEL $CALLER_INTERNAL );
    use Scalar::Util;
    use Devel::StackTrace;
    use overload (
        '""'    => 'as_string',
        '=='    => sub{ _obj_eq(@_) },
        '!='    => sub{ !_obj_eq(@_) },
        bool    => sub{ $_[0] },
        fallback => 1,
    );
    $CALLER_LEVEL = 0;
    $CALLER_INTERNAL->{'Module::Generic'}++;
    $CALLER_INTERNAL->{'Module::Generic::Exception'}++;
    our $VERSION = 'v1.2.2';
};

BEGIN
{
    Module::Generic->_implement_freeze_thaw( qw( Devel::StackTrace Devel::StackTrace::Frame ) );
};

use strict;
no warnings 'redefine';

sub init
{
    my $self = shift( @_ );
    $self->{code} = '' unless( length( $self->{code} ) );
    $self->{type} = '' unless( length( $self->{type} ) );
    $self->{file} = '' unless( length( $self->{file} ) );
    $self->{line} = '' unless( length( $self->{line} ) );
    $self->{message} = '' unless( length( $self->{message} ) );
    $self->{package} = '' unless( length( $self->{package} ) );
    $self->{retry_after} = '' unless( length( $self->{retry_after} ) );
    $self->{subroutine} = '' unless( length( $self->{subroutine} ) );
    my $args = {};
    if( @_ )
    {
        if( Scalar::Util::blessed( $_[0] ) && $_[0]->isa( 'Module::Generic::Exception' ) )
        {
            $args->{object} = shift( @_ );
        }
        elsif( ref( $_[0] ) eq 'HASH' )
        {
            $args  = shift( @_ );
        }
        else
        {
            $args->{message} = join( '', map( ref( $_ ) eq 'CODE' ? $_->() : $_, @_ ) );
        }
    }
    # $self->SUPER::init( @_ );
    
    unless( length( $args->{skip_frames} ) )
    {
        # NOTE: Taken from Carp to find the right point in the stack to start from
        no strict 'refs';
        my $caller_func;
        $caller_func = \&{"CORE::GLOBAL::caller"} if( defined( &{"CORE::GLOBAL::caller"} ) );
        my $call_pack = $caller_func ? $caller_func->() : caller();
        ## Check if this is an internal package or a package inheriting from us
        local $CALLER_LEVEL = ( $CALLER_INTERNAL->{ $call_pack } || bless( {} => $call_pack )->isa( 'Module::Generic::Exception' ) ) 
            ? $CALLER_LEVEL 
            : $CALLER_LEVEL + 1;
        my $error_start_frame = sub 
        {
            my $i;
            my $lvl = $CALLER_LEVEL;
            {
                ++$i;
                my @caller = $caller_func ? $caller_func->( $i ) : caller( $i );
                my $pkg = $caller[0];
                unless( defined( $pkg ) ) 
                {
                    if( defined( $caller[2] ) ) 
                    {
                        # this can happen when the stash has been deleted
                        # in that case, just assume that it's a reasonable place to
                        # stop (the file and line data will still be intact in any
                        # case) - the only issue is that we can't detect if the
                        # deleted package was internal (so don't do that then)
                        # -doy
                        redo unless( 0 > --$lvl );
                        last;
                    }
                    else 
                    {
                        return( 2 );
                    }
                }
                redo if( $CALLER_INTERNAL->{ $pkg } );
                redo unless( 0 > --$lvl );
            }
            return( $i - 1 );
        };
        
        $args->{skip_frames} = $error_start_frame->();
    }
    
    my $skip_frame = $args->{skip_frames} || 0;
    # Skip one frame to exclude us
    $skip_frame++;
    
    my $trace = Devel::StackTrace->new( skip_frames => $skip_frame, indent => 1 );
    my $frame = $trace->next_frame;
    my $frame2 = $trace->next_frame;
    $trace->reset_pointer;
    if( ref( $args->{object} ) && Scalar::Util::blessed( $args->{object} ) && $args->{object}->isa( 'Module::Generic::Exception' ) )
    {
        my $o = $args->{object};
        $self->{message} = $o->message;
        $self->{code} = $o->code;
        $self->{type} = $o->type;
        $self->{retry_after} = $o->retry_after;
    }
    else
    {
        # print( STDERR __PACKAGE__, "::init() Got here with args: ", Data::Dumper::Concise::Dumper( $args ), "\n" );
        $self->{message} = $args->{message} || '';
        $self->{code} = $args->{code} if( exists( $args->{code} ) );
        $self->{type} = $args->{type} if( exists( $args->{type} ) );
        $self->{retry_after} = $args->{retry_after} if( exists( $args->{retry_after} ) );
        # I do not want to alter the original hash reference, which may adversely affect the calling code if they depend on its content for further execution for example.
        my $copy = {};
        %$copy = %$args;
        CORE::delete( @$copy{ qw( message code type retry_after skip_frames ) } );
        # print( STDERR __PACKAGE__, "::init() Following non-standard keys to set up: '", join( "', '", sort( keys( %$copy ) ) ), "'\n" );
        # Do we have some non-standard parameters?
        foreach my $p ( keys( %$copy ) )
        {
            my $p2 = $p;
            $p2 =~ tr/-/_/;
            $p2 =~ s/[^a-zA-Z0-9\_]+//g;
            $p2 =~ s/^\d+//g;
            # We do not want to trigger an error by calling non-existing subroutines
            if( my $subref = $self->can( $p2 ) )
            {
                $subref->( $self => $copy->{ $p } );
            }
        }
    }
    $self->{file} = $frame->filename;
    $self->{line} = $frame->line;
    ## The caller sub routine ( caller( n ) )[3] returns the sub called by our caller instead of the sub that called our caller, so we go one frame back to get it
    $self->{subroutine} = $frame2->subroutine if( $frame2 );
    $self->{package} = $frame->package;
    $self->{trace} = $trace;
    return( $self );
}

# This is important as stringification is called by die, so as per the manual page, we need to end with new line
# And will add the stack trace
sub as_string
{
    no overloading;
    my $self = shift( @_ );
    return( $self->{_cache} ) if( $self->{_cache} );
    my $str = $self->message;
    $str =~ s/\r?\n$//g;
    $str .= sprintf( " within package %s at line %d in file %s\n%s", $self->package, $self->line, $self->file, $self->trace->as_string );
    $self->{_cache} = $str;
    return( $str );
}

sub caught 
{
    my( $class, $e ) = @_;
    return if( ref( $class ) );
    return unless( Scalar::Util::blessed( $e ) && $e->isa( $class ) );
    return( $e );
}

sub code { return( shift->_set_get_scalar( 'code', @_ ) ); }

sub file { return( shift->_set_get_scalar( 'file', @_ ) ); }

sub line { return( shift->_set_get_scalar( 'line', @_ ) ); }

sub message { return( shift->_set_get_scalar( 'message', @_ ) ); }

sub package { return( shift->_set_get_scalar( 'package', @_ ) ); }

# From perlfunc docmentation on "die":
# "If LIST was empty or made an empty string, and $@ contains an
# object reference that has a "PROPAGATE" method, that method will
# be called with additional file and line number parameters. The
# return value replaces the value in $@; i.e., as if "$@ = eval {
# $@->PROPAGATE(__FILE__, __LINE__) };" were called."
sub PROPAGATE
{
    my( $self, $file, $line ) = @_;
    if( defined( $file ) && defined( $line ) )
    {
        my $clone = $self->clone;
        $clone->file( $file );
        $clone->line( $line );
        return( $clone );
    }
    return( $self );
}

sub rethrow 
{
    my $self = shift( @_ );
    return if( !Scalar::Util::blessed( $self ) );
    die( $self );
}

sub retry_after { return( shift->_set_get_scalar( 'retry_after', @_ ) ); }

sub subroutine { return( shift->_set_get_scalar( 'subroutine', @_ ) ); }

sub throw
{
    my $self = shift( @_ );
    my $e;
    if( @_ )
    {
        my $msg  = shift( @_ );
        $e = $self->new({
            skip_frames => 1,
            message => $msg,
        });
    }
    else
    {
        $e = $self;
    }
    die( $e );
}

# Devel::StackTrace has a stringification overloaded so users can use the object to get more information or simply use it as a string to get the stack trace equivalent of doing $trace->as_string
sub trace { return( shift->_set_get_object( 'trace', 'Devel::StackTrace', @_ ) ); }

sub type { return( shift->_set_get_scalar( 'type', @_ ) ); }

sub _obj_eq
{
    ##return overload::StrVal( $_[0] ) eq overload::StrVal( $_[1] );
    no overloading;
    my $self = shift( @_ );
    my $other = shift( @_ );
    my $me;
    if( Scalar::Util::blessed( $other ) && $other->isa( 'Module::Generic::Exception' ) )
    {
        if( $self->message eq $other->message &&
            $self->file eq $other->file &&
            $self->line == $other->line )
        {
            return( 1 );
        }
        else
        {
            return( 0 );
        }
    }
    # Compare error message
    elsif( !ref( $other ) )
    {
        my $me = $self->message;
        return( $me eq $other );
    }
    # Otherwise some reference data to which we cannot compare
    return( 0 ) ;
}

# NOTE: AUTOLOAD
AUTOLOAD
{
    my( $method ) = our $AUTOLOAD =~ /([^:]+)$/;
    no overloading;
    my $self = shift( @_ );
    my $class = ref( $self ) || $self;
    my $code;
    if( $code = $self->can( $method ) )
    {
        return( $code->( @_ ) );
    }
    else
    {
        eval( "sub ${class}::${method} { return( shift->_set_get_scalar( '$method', \@_ ) ); }" );
        die( $@ ) if( $@ );
        return( $self->$method( @_ ) );
    }
};

sub FREEZE
{
    my $self = CORE::shift( @_ );
    my $serialiser = CORE::shift( @_ ) // '';
    my $class = CORE::ref( $self );
    my %hash  = %$self;
    # Return an array reference rather than a list so this works with Sereal and CBOR
    # On or before Sereal version 4.023, Sereal did not support multiple values returned
    CORE::return( [$class, \%hash] ) if( $serialiser eq 'Sereal' && Sereal::Encoder->VERSION <= version->parse( '4.023' ) );
    # But Storable want a list with the first element being the serialised element
    CORE::return( $class, \%hash );
}

sub STORABLE_freeze { return( shift->FREEZE( @_ ) ); }

sub STORABLE_thaw { return( shift->THAW( @_ ) ); }

# NOTE: CBOR will call the THAW method with the stored classname as first argument, the constant string CBOR as second argument, and all values returned by FREEZE as remaining arguments.
# NOTE: Storable calls it with a blessed object it created followed with $cloning and any other arguments initially provided by STORABLE_freeze
sub THAW
{
    my( $self, undef, @args ) = @_;
    my $ref = ( CORE::scalar( @args ) == 1 && CORE::ref( $args[0] ) eq 'ARRAY' ) ? CORE::shift( @args ) : \@args;
    my $class = ( CORE::defined( $ref ) && CORE::ref( $ref ) eq 'ARRAY' && CORE::scalar( @$ref ) > 1 ) ? CORE::shift( @$ref ) : ( CORE::ref( $self ) || $self );
    my $hash = CORE::ref( $ref ) eq 'ARRAY' ? CORE::shift( @$ref ) : {};
    my $new;
    # Storable pattern requires to modify the object it created rather than returning a new one
    if( CORE::ref( $self ) )
    {
        foreach( CORE::keys( %$hash ) )
        {
            $self->{ $_ } = CORE::delete( $hash->{ $_ } );
        }
        $new = $self;
    }
    else
    {
        $new = CORE::bless( $hash => $class );
    }
    CORE::return( $new );
}

sub TO_JSON { return( shift->as_string ); }

1;

__END__
