##----------------------------------------------------------------------------
## Module Generic - ~/lib/Module/Generic/TieHash.pm
## Version v1.2.1
## Copyright(c) 2023 DEGUEST Pte. Ltd.
## Author: Jacques Deguest <jack@deguest.jp>
## Created 2021/03/20
## Modified 2023/09/19
## 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::TieHash;
BEGIN
{
    use strict;
    use warnings::register;
    use warnings;
    use Scalar::Util ();
    our $VERSION = 'v1.2.1';
};

use strict;
no warnings 'redefine';
my $mark = '__tiehash__';

sub TIEHASH
{
    my $this  = shift( @_ );
    my $opts  = {};
    $opts = shift( @_ ) if( @_ );
    if( ( Scalar::Util::reftype( $opts ) // '' ) ne 'HASH' )
    {
        warn( "Parameters provided ($opts) is not an hash reference.\n" ) if( warnings::enabled() );
        return;
    }
    my $disable = [];
    $disable = $opts->{disable} if( ( Scalar::Util::reftype( $opts->{disable} ) // '' ) eq 'ARRAY' );
    my $list = {};
    @$list{ @$disable } = (1) x scalar( @$disable );
    my $hash =
    {
    # The caller sets this to its class, so we can differentiate calls from inside and outside our caller's package
    disable => $list,
    debug => $opts->{debug},
    # When disabled, the Tie::Hash system will return hash key values directly under $self instead of $self->{data}
    # Disabled by default so the new() method can access its setup data directly under $self
    # Then new() can call enable to active it
    enable => 1,
    # Do we enable the use of object as hash key?
    key_object => $opts->{key_object} // 0,
    # Where to store the actual hash data
    data  => {},
    # object reference address -> value
    # This is used to store object as key
    object_repo => {},
    };
    my $self = bless( $hash => ( ref( $this ) || $this ) );
    return( $self );
}

sub CLEAR
{
    my $self = shift( @_ );
    my $data = $self->{data};
    my $repo = $self->{object_repo};
    %$repo = ();
    %$data = ();
}

sub DELETE
{
    my $self = shift( @_ );
    my $data = $self->{data};
    my $repo = $self->{object_repo};
    my $key  = shift( @_ );
    my $caller = caller;
    if( $self->_exclude( $caller ) || !$self->{enable} )
    {
        CORE::delete( $self->{ $key } );
    }
    else
    {
        if( ref( $key ) && $self->{key_object} )
        {
            CORE::delete( $repo->{ Scalar::Util::refaddr( $key ) } );
        }
        else
        {
            CORE::delete( $data->{ $key } );
        }
    }
}

sub EXISTS
{
    my $self = shift( @_ );
    my $data = $self->{data};
    my $repo = $self->{object_repo};
    my $key  = shift( @_ );
    my $caller = caller;
    if( $self->_exclude( $caller ) || !$self->{enable} )
    {
        CORE::exists( $self->{ $key } );
    }
    else
    {
        if( ref( $key ) && $self->{key_object} )
        {
            CORE::exists( $repo->{ Scalar::Util::refaddr( $key ) } );
        }
        else
        {
            CORE::exists( $data->{ $key } );
        }
    }
}

sub FETCH
{
    my $self = shift( @_ );
    my $data = $self->{data};
    my $repo = $self->{object_repo};
    my $key  = shift( @_ );
    my $caller = caller;
    if( $self->_exclude( $caller ) || !$self->{enable} )
    {
        #print( STDERR "FETCH($caller)[owner calling, enable=$self->{enable}] <- '$key' <- '$self->{$key}'\n" );
        return( $self->{ $key } )
    }
    else
    {
        if( ref( $key ) && $self->{key_object} )
        {
            return( $repo->{ Scalar::Util::refaddr( $key ) }->[1] );
        }
        else
        {
            #print( STDERR "FETCH($caller)[enable=$self->{enable}] <- '$key' <- '$data->{$key}'\n" );
            return( $data->{ $key } );
        }
    }
}

sub FIRSTKEY
{
    my $self = shift( @_ );
    my $data = $self->{data};
    my @keys = ();
    my $caller = caller;
    if( $self->_exclude( $caller ) || !$self->{enable} )
    {
        @keys = keys( %$self );
    }
    else
    {
        @keys = keys( %$data );
    }
    $self->{ITERATOR} = \@keys;
    return( $self->NEXTKEY );
}

sub NEXTKEY
{
    my $self = shift( @_ );
    my $data = $self->{data};
    my $repo = $self->{object_repo};
    my $keys = ref( $self->{ITERATOR} ) ? $self->{ITERATOR} : [];
    my $key = shift( @$keys );
    return if( !defined( $key ) );
    if( index( $key, $mark ) == 0 )
    {
        return( $repo->{ substr( $key, length( $mark ), -2 ) }->[0] );
    }
    return( $key );
}

sub SCALAR
{
    my $self  = shift( @_ );
    my $data = $self->{data};
    my $caller = caller;
    if( $self->_exclude( $caller ) || !$self->{enable} )
    {
        return( scalar( keys( %$self ) ) );
    }
    else
    {
        return( scalar( keys( %$data ) ) );
    }
}

sub STORE
{
    my $self  = shift( @_ );
    my $data = $self->{data};
    my $repo = $self->{object_repo};
    my( $key, $val ) = @_;
    my $caller = caller;
    if( $self->_exclude( $caller ) || !$self->{enable} )
    {
        #print( STDERR "STORE($caller)[owner calling] <- '$key' -> '$val'\n" );
        $self->{ $key } = $val;
    }
    else
    {
        # Ensure recursive tied hash
        if( ref( $val ) eq 'HASH' &&
            !tied( %$val ) )
        {
            my @items = %$val;
            my $this = tie( %$val, ref( $self ) );
            while( @items )
            {
                $this->STORE( splice( @items, 0, 2 ) );
            }
        }
        
        #print( STDERR "STORE($caller)[enable=$self->{enable}] <- '$key' -> '$val'\n" );
        if( ref( $key ) && $self->{key_object} )
        {
            my $addr = Scalar::Util::refaddr( $key );
            $repo->{ $addr } = [$key, $val];
            $data->{ "${mark}${addr}__" } = $val;
        }
        else
        {
            $data->{ $key } = $val;
        }
    }
}

sub enable
{
    my $self = shift( @_ );
    $self->{enable} = shift( @_ ) if( @_ );
    return( $self->{enable} );
}

sub key_object
{
    my $self = shift( @_ );
    $self->{key_object} = shift( @_ ) if( @_ );
    return( $self->{key_object} );
}

sub _exclude
{
    my $self = shift( @_ );
    my $caller = shift( @_ );
    return( CORE::exists( $self->{disable}->{ $caller } ) );
}

sub _message
{
    my $this = shift( @_ );
    my $self = ( ref( $this ) ? $this : {} );
    my $level = shift( @_ );
    return(1) if( $self->{debug} < $level );
    my( $pkg, $file, $line, @otherInfo ) = caller();
    my $sub = ( caller(1) )[3] // '';
    my $sub2 = substr( $sub, rindex( $sub, '::' ) + 2 );
    my $txt = join( '', map( ( ref( $_ ) eq 'CODE' ) ? $_->() : ( $_ // '' ), @_ ) );
    my $prefix = '#';
    $txt    =~ s/\n$//gs;
    my $mesg = "${prefix} " . join( "\n${prefix} ", split( /\n/, $txt ) );
    print( STDERR $mesg, "\n" );
}

sub FREEZE
{
    my( $self, $serialiser ) = @_;
    # $serialiser is 'JSON' for example.
    return( $self->TO_JSON );
}

sub STORABLE_freeze
{
    my( $self, $is_cloning ) = @_;
    my $data = $self->{data};
    my $repo = $self->{object_repo};
    # Array reference of array reference, each containing the original key-object -> the corresponding value
    my $objects = [values( %$repo )];
    my $options = {};
    @$options{qw( disable debug enable )} = @$self{qw( disable debug enable )};
    return( 'module_generic_tiehash', $options, $objects, $data );
}

sub STORABLE_thaw
{
    my( $self, $is_cloning, $serialized, $options, $objects, $data ) = @_;
    my @keys = keys( %$options );
    @$self{ @keys } = @$options{ @keys };
    $self->{data} = $data;
    $self->{object_repo} = {};
    my $repo = $self->{object_repo};
    foreach my $ref ( @$objects )
    {
        $repo->{ Scalar::Util::refaddr( $ref->[0] ) } = $ref;
    }
    return( $self );
}

# Hmm, not sure this is meaningful unless we can find the original tied hash from the object
sub THAW
{
    my( $class, $serialiser, $ref ) = @_;
    my( $options, $objects, $data ) = @$ref{qw( options objects data )};
    my %hash;
    my $self = tie( %hash, $class, $options );
    foreach my $ref ( @$objects )
    {
        $hash{ $ref->[0] } = $ref->[1];
    }
    foreach my $k ( keys( %$ref ) )
    {
        $hash{ $k } = $ref->{ $k };
    }
    return( $self );
}

sub TO_JSON
{
    my $self = shift( @_ );
    my $data = $self->{data};
    my $repo = $self->{object_repo};
#     my( $pack, $file, $line ) = caller;
    # Array reference of array reference, each containing the original key-object -> the corresponding value
    my $objects = [values( %$repo )];
    my $options = {};
    @$options{qw( disable debug enable )} = @$self{qw( disable debug enable )};
    return({ options => $options, objects => $objects, data => $data });
}

1;
# NOTE: POD
__END__

=encoding utf-8

=head1 NAME

Module::Generic::TieHash - Generic Tie Hash Mechanism for Object Oriented Hashes

=head1 SYNOPSIS

    use DateTime;
    my $tie = tie( my %hash, 'Module::Generic::TieHash', { key_object => 1 } );
    my $now = DateTime->now;
    my $array = [];
    my $ref = {};
    my $scalar = \"Hello";
    my $code = sub{1};
    my $glob = \*main;

    $hash{ $now } = 'today';
    $hash{ $array } = 'an array';
    $hash{ $ref } = 'an hash';
    $hash{ $scalar } = 'a scalar reference';
    $hash{ $code } = 'anonymous subroutine';
    $hash{ $glob } = 'a filehandle';
    $hash{name} = 'John Doe';

=head1 DESCRIPTION

This module implements a tied hash mechanism that accepts as keys strings or references, if the option C<key_object> is enabled, recursively, meaning, even embedded hash references within the top hash reference are also tied to this class.

It also supports callback hooks for L<Storable>

=head1 VERSION

    v1.2.1

=for Pod::Coverage key_object

=head1 AUTHOR

Jacques Deguest E<lt>F<jack@deguest.jp>E<gt>

=head1 COPYRIGHT & LICENSE

Copyright (c) 2020-2023 DEGUEST Pte. Ltd.

You can use, copy, modify and redistribute this package and associated
files under the same terms as Perl itself.

=cut
