##----------------------------------------------------------------------------
## Database Object Interface - ~/lib//mnt/src/perl/DB-Object/lib/DB/Object/Fields.pm
## Version v1.3.0
## Copyright(c) 2024 DEGUEST Pte. Ltd.
## Author: Jacques Deguest <jack@deguest.jp>
## Created 2020/01/01
## Modified 2026/03/22
## All rights reserved
## 
## 
## This program is free software; you can redistribute  it  and/or  modify  it
## under the same terms as Perl itself.
##----------------------------------------------------------------------------
package DB::Object::Fields;
BEGIN
{
    use strict;
    use warnings;
    use common::sense;
    use parent qw( Module::Generic );
    use vars qw( $VERSION $EXCEPTION_CLASS );
    use DB::Object::Fields::Field;
    our $EXCEPTION_CLASS = $DB::Object::EXCEPTION_CLASS;
    our $VERSION = 'v1.3.0';
};

use strict;
use warnings;

sub init
{
    my $self = shift( @_ );
    $self->{prefixed} = 0;
    # Property 'query_object' not used anymore. Instead, we use table_object->query_object
    $self->{table_object} = '';
    # $self->{fatal} = 1;
    $self->{_init_strict_use_sub} = 1;
    $self->{_init_params_order}   = [qw( table_object query_object prefixed )];
    $self->{_exception_class}     = $EXCEPTION_CLASS;
    $self->SUPER::init( @_ );
    $self->{_fields} = [qw( prefixed )];
    return( $self->error( "No table object was provided" ) ) if( !$self->{table_object} );
    return( $self );
}

sub database_object { return( shift->table_object->database_object ); }

# To manually create a new table field
sub new_field
{
    my $self = shift( @_ );
    my $opts = $self->_get_args_as_hash( @_ );
    if( !exists( $opts->{name} ) || 
        $self->_is_empty( $opts->{name} ) )
    {
        return( $self->error( "No field name was provided." ) );
    }
    elsif( !exists( $opts->{type} ) || 
        $self->_is_empty( $opts->{type} ) )
    {
        return( $self->error( "No field type was provided." ) );
    }
    $opts->{type} = lc( $opts->{type} );
    # But actually we ignore it; users should not provide it
    if( exists( $opts->{constant} ) &&
        defined( $opts->{constant} ) &&
        ref( $opts->{constant} ) eq 'HASH' )
    {
        $opts->{datatype} = delete( $opts->{constant} );
    }
    my $datatype_dict = $self->database_object->datatype_dict;
    if( !exists( $datatype_dict->{ $opts->{type} } ) )
    {
        return( $self->error( "Field type provided ($opts->{type}) is not supported by driver ", $self->database_object->driver ) );
    }
    my $def = $datatype_dict->{ $opts->{type} };
    $opts->{debug} = $self->debug unless( exists( $opts->{debug} ) && length( $opts->{debug} // '' ) );
    my $fo = DB::Object::Fields::Field->new(
        datatype => {
            constant => $def->{constant},
            name => $def->{name},
            type => $def->{type},
        },
        debug => $opts->{debug},
        ( !$self->_is_empty( $opts->{default} ) ? ( default => $opts->{default} ) : () ),
        ( !$self->_is_empty( $opts->{is_array} ) ? ( is_array => $opts->{is_array} ) : () ),
        ( !$self->_is_empty( $opts->{is_nullable} ) ? ( is_nullable => $opts->{is_nullable} ) : () ),
        name => $opts->{name},
        ( !$self->_is_empty( $opts->{pos} ) ? ( pos => $opts->{pos} ) : () ),
        query_object => $self->query_object,
        ( !$self->_is_empty( $opts->{size} ) ? ( size => $opts->{size} ) : () ),
        table_object => $self->table_object,
        type => $opts->{type},
    ) || return( $self->pass_error( DB::Object::Fields::Field->error ) );
    return( $fo );
}

sub prefixed
{
    my $self = shift( @_ );
    if( @_ )
    {
        $self->{prefixed} = ( $_[0] =~ /^\d+$/ ? $_[0] : ( $_[0] ? 1 : 0 ) );
    }
    else
    {
        $self->{prefixed} = 1;
    }
    my $fields = $self->table_object->fields;
    foreach my $f ( keys( %$fields ) )
    {
        next if( !CORE::length( $self->{ $f } ) );
        next if( !$self->_is_object( $self->{ $f } ) );
        my $o = $self->{ $f };
        $o->prefixed( $self->{prefixed} );
    }
    return( $self );
}

# sub query_object { return( shift->_set_get_object_without_init( 'query_object', 'DB::Object::Query', @_ ) ); }
sub query_object { return( shift->table_object->query_object ); }

sub table_object { return( shift->_set_get_object_without_init( 'table_object', 'DB::Object::Tables', @_ ) ); }

sub _initiate_field_object
{
    my $self = shift( @_ );
    my $field = shift( @_ ) || return( $self->error( "No field was provided to get its object." ) );
    my $class = ref( $self ) || $self;
    my $tbl = $self->table_object;
    my $fields = $tbl->fields;
    $self->messagec( 5, "Instantiating field {green}${field}{/} object for class {green}${class}{/} and table {green}", $tbl->name, "{/} having alias of {green}", ( $tbl->as // 'undef' ), "{/} ({green}", $self->{prefixed}, "{/})" );
    return( $self->error( "Table ", $tbl->name, " has no such field \"$field\"." ) ) if( !CORE::exists( $fields->{ $field } ) );
    my $code = $self->can( $field );
    unless( defined( $code ) )
    {
        $code = sub
        {
            my $self = shift( @_ );
            unless( $self->{ $field } )
            {
                my $fo = $tbl->fields( $field );
                $fo->debug( ( $self->debug // 0 ) );
                $fo->prefixed( $self->{prefixed} );
                $fo->query_object( $self->table_object->query_object );
                $fo->table_object( $self->table_object );
                $self->{ $field } = $fo;
            }
            return( $self->{ $field } );
        };
        no strict 'refs';
        *{"$field"} = $code;
    }
    my $o = $code->( $self );
    return( $o );
}

# NOTE: AUTOLOAD
AUTOLOAD
{
    my( $method ) = our $AUTOLOAD =~ /([^:]+)$/;
    # my( $class, $method ) = our $AUTOLOAD =~ /^(.*?)::([^\:]+)$/;
    no overloading;
    my $self = shift( @_ );
    my $fields = $self->table_object->fields;
    $self->messagec( 5, "Called for method {green}${method}{/}" );
    if( my $code = $self->can( $method ) )
    {
        return( $code->( $self, @_ ) );
    }
    elsif( exists( $fields->{ $method } ) )
    {
        $self->messagec( 5, "Instantiating a new field object for {green}${method}{/}" );
        return( $self->_initiate_field_object( $method ) );
    }
    else
    {
        # This is an unrecoverable error. We have no choice, but to die.
        my $error = "Table " . $self->table_object->name . " has no such field \"$method\"";
        $self->_load_class( 'Module::Generic::Exception' ) || die( $self->error );
        my $exception = Module::Generic::Exception->new( $error );
        my $on_unknown_field = $self->table_object->database_object->unknown_field;
        if( ref( $on_unknown_field ) eq 'CODE' )
        {
            return( $on_unknown_field->({
                table => $self->table_object,
                field => $method,
                error => $exception,
            }) );
        }
        elsif( defined( $on_unknown_field ) && ( $on_unknown_field eq 'die' || $on_unknown_field eq 'fatal' ) )
        {
            die( $exception );
        }
        else
        {
            $self->_load_class( 'DB::Object::Fields::Unknown' ) ||
                die( "${error}, and I could not load the module DB::Object::Fields::Unknown: ", $self->error );
            my $unknown = DB::Object::Fields::Unknown->new(
                table => $self->table_object->name,
                error => $exception,
                field => $method,
            ) || die( "${error}, and I could not instantiate a new instance of the module DB::Object::Fields::Unknown: ", DB::Object::Fields::Unknown->error );
            warn( "Table ", $self->table_object->name, " has no such field \"$method\".\n" ) if( $self->_is_warnings_enabled( 'DB::Object' ) );
            # return( $self->error( "Table ", $self->table_object->name, " has no such field \"$method\"." ) );
            #die( "Table ", $self->table_object->name, " has no such field \"$method\".\n" );
            return( $unknown );
        }
    }
};

sub FREEZE
{
    my $self       = CORE::shift( @_ );
    my $serialiser = CORE::shift( @_ ) // '';
    my $class      = CORE::ref( $self );

    # We keep a strict allow-list to avoid accidentally freezing DBI handles or other
    # process-local state.
    my @props = @{$self->{_fields}};

    my $hash = {};
    foreach my $prop ( @props )
    {
        if( CORE::exists( $self->{ $prop } ) &&
            defined( $self->{ $prop } ) &&
            CORE::ref( $self->{ $prop } ) ne 'CODE' )
        {
            $hash->{ $prop } = $self->{ $prop };
        }
    }

    # Return an array reference rather than a list so this works with Sereal and CBOR.
    # Before Sereal version 4.023, Sereal did not support multiple values returned.
    if( $serialiser eq 'Sereal' )
    {
        require Sereal::Encoder;
        require version;

        if( version->parse( Sereal::Encoder->VERSION ) < version->parse( '4.023' ) )
        {
            CORE::return( [$class, $hash] );
        }
    }

    # But Storable wants 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( @_ ) ); }

sub THAW
{
    # STORABLE_thaw would issue $cloning as the 2nd argument, while CBOR would issue
    # 'CBOR' as the second value.
    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 );
}

1;
# NOTE: POD
__END__

=encoding utf8

=head1 NAME

DB::Object::Fields - Tables Fields Object Accessor

=head1 SYNOPSIS

    my $dbh = DB::Object->connect({
        driver => 'Pg',
        conf_file => $conf,
        database => 'my_shop',
        host => 'localhost',
        login => 'super_admin',
        schema => 'auth',
        unknown_field => 'fatal',
        # debug => 3,
    }) || bailout( "Unable to connect to sql server on host localhost: ", DB::Object->error );

    my $tbl = $dbh->some_table || die( "No table \"some_table\" could be found: ", $dbh->error, "\n" );
    my $fo = $tbl->fields_object || die( $tbl->error );
    my $expr = $fo->id == 2;
    print "Expression is: $expr\n"; # Expression is: id = 2

    my $tbl_object = $dbh->customers || die( "Unable to get the customers table object: ", $dbh->error, "\n" );
    my $fields = $tbl_object->fields;
    print( "Fields for table \"", $tbl_object->name, "\": ", Dumper( $fields ), "\n" );
    my $c = $tbl_object->fo->currency;
    print( "Got field object for currency: \"", ref( $c ), "\": '$c'\n" );
    printf( "Name: %s\n", $c->name );
    printf( "Type: %s\n", $c->type );
    printf( "Default: %s\n", $c->default );
    printf( "Position: %s\n", $c->pos );
    printf( "Table: %s\n", $c->table );
    printf( "Database: %s\n", $c->database );
    printf( "Schema: %s\n", $c->schema );
    printf( "Next field: %s (%s)\n", $c->next, ref( $c->next ) );
    print( "Showing name fully qualified: ", $c->prefixed( 3 )->name, "\n" );
    ## would print: my_shop.public.customers.currency
    print( "Trying again (should keep prefix): ", $c->name, "\n" );
    ## would print again: my_shop.public.customers.currency
    print( "Now cancel prefixing at the table fields level.\n" );
    $tbl_object->fo->prefixed( 0 );
    print( "Showing name fully qualified again (should not be prefixed): ", $c->name, "\n" );
    ## would print currency
    print( "First element is: ", $c->first, "\n" );
    print( "Last element is: ", $c->last, "\n" );
    # Works also with the operators +, -, *, /, %, <, <=, >, >=, !=, <<, >>, &, |, ^, ==
    my $table = $dbh->dummy;
    $table->select( $c + 10 ); # SELECT currency + 10 FROM dummy;
    $c == 'NULL' # currency IS NULL

    # if DB::Object unknown_field option is set to fatal, this will die. By default, it will simply be ignored
    my $unknown_field = $tbl->unknown;

=head1 VERSION

    v1.3.0

=head1 DESCRIPTION

The purpose of this module is to enable access to the table fields as L<DB::Object::Fields::Field> objects.

The way this works is by having L<DB::Object::Tables/fields_object> or L<DB::Object::Tables/fo> for short, dynamically create a class based on the database name and table name. For example if the database driver were C<PostgreSQL>, the database were C<my_shop> and the table C<customers>, the dynamically created package would become C<DB::Object::Postgres::Tables::MyShop::Customers>. This class would inherit from this package L<DB::Object::Fields>.

Field objects can than be dynamically instantiated by accessing them, such as (assuming the table object C<$tbl_object> here represent the table C<customers>) C<$tbl_object->fo->last_name>. This will return a L<DB::Object::Fields::Field> object.

A note on the design: there had to be a separate this separate package L<DB::Object::Fields>, because access to table fields is done through the C<AUTOLOAD> and the methods within the package L<DB::Object::Tables> and its inheriting packages would clash with the tables fields. This package has very few methods, so the risk of a sql table field clashing with a method name is very limited. In any case, if you have in your table a field with the same name as one of those methods here (see below for the list), then you can instantiate a field object with:

    $tbl_object->_initiate_field_object( 'last_name' );

If you call an unknown field, its behaviour will change depending on the option value C<unknown_field> of L<DB::Object> upon instantiation:

=over 4

=item * C<ignore> (default)

The unknown field will be ignored and a warning will be emitted that this field does not exist in the given database table.

=item * C<fatal> or C<die>

This will trigger a L</die> using a L<Module::Generic::Exception> object. So you could catch it like this:

    use Nice::Try;

    try
    {
        # $opts contains the property 'unknown_field' set to 'die'
        my $dbh = DB::Object::Postgres->connect( $opts ) || die( "Unable to connect" );
        my $tbl = $dbh->some_table || die( "Unable to get the database table \"some_table\": ", $dbh->error );
        $tbl->where( $dbh->AND(
            $tbl->fo->faulty_field == '?',
            $tbl->fo->status == 'live',
        ) );
        my $ref = $tbl->select->fetchrow_hashref;
    }
    catch( $e isa( 'Module::Generic::Exception' ) )
    {
        die( "Caught error preparing SQL: $e" );
    }
    else
    {
        die( "Caught some other error." );
    }

=item * C<code reference>

When the option C<unknown_field> is set to a code reference, this will be executed and passed an hash reference that will contain 3 properties:

=over 8

=item 1. C<table>

The L<table object|DB::Object::Tables>

=item 2. C<field>

A regular string containing the unknown field name

=item 3. C<error>

The L<error object|Module::Generic::Exception>, which includes the error string and a stack trace

=back

=back

By default, the unknown field will be ignored.

=head1 CONSTRUCTOR

=head2 new

Creates a new L<DB::Object::Fields> objects. It may also take an hash like arguments, that also are method of the same name.

=over 4

=item I<debug>

Toggles debug mode on/off

=back

=head1 METHODS

=head2 database_object

The database object, which is a L<DB::Object> object or one of its descendant.

=head2 new_field

This takes an hash or hash reference of parameters and instantiate a new L<DB::Object::Fields::Field> object and return it.

If an error occurred, it sets an L<error object|Module::Generic::Exception> and return an empty list in list context or C<undef> in scalar context.

=head2 prefixed

This si the prefix level, from 0 to 2.

2 or higher including the database, higher than 1 includes the schema name and above 0 includes the table name. 0 includes nothing.

When this value is changed, it is propagated to all the fields objects.

=head2 query_object

The query object, which is a L<DB::Object::Query> object or one of its descendant.

=head2 table_object

The query object, which is a L<DB::Object::Tables> object or one of its descendant.

=head2 _initiate_field_object

This method is called from C<AUTOLOAD>

Provided with a table column name and this will create a new L<DB::Object::Fields::Field> object and add dynamically the associated method for this column in the current package so that next time, it returns the cached object without using C<AUTOLOAD>

=head1 AUTOLOAD

Called with a column name and this will check if the given column name actually exists in this table. If it does, it will call L</_initiate_field_object> to instantiate a new field object and returns it.

If the column does not exist, it returns an error.

=head1 SEE ALSO

L<perl>

=head1 AUTHOR

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

=head1 COPYRIGHT & LICENSE

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

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

=cut
