# -*- perl -*-
##----------------------------------------------------------------------------
## Database Object Interface - ~/lib/DB/Object/Tables.pm
## Version 0.4.1
## Copyright(c) 2020 DEGUEST Pte. Ltd.
## Author: Jacques Deguest <jack@deguest.jp>
## Created 2017/07/19
## Modified 2020/01/19
## All rights reserved
## 
## This program is free software; you can redistribute  it  and/or  modify  it
## under the same terms as Perl itself.
##----------------------------------------------------------------------------
## This package's purpose is to separate the object of the tables from the main
## DB::Object package so that when they get DESTROY'ed, it does not interrupt
## the SQL connection
##----------------------------------------------------------------------------
package DB::Object::Tables;
BEGIN
{
    require 5.6.0;
    use strict;
    use DB::Object::Fields;
    our( $VERSION, $VERBOSE, $DEBUG, @ISA );
    @ISA    = qw( DB::Object );
    $VERSION    = '0.4.1';
    $VERBOSE    = 0;
    $DEBUG      = 0;
    use Devel::Confess;
};

sub init
{
    my $self  = shift( @_ );
    my $table = '';
    $table    = shift( @_ ) if( @_ && @_ % 2 );
    my %arg   = ( @_ );
    return( $self->error( "You must provide a table name to create a table object." ) ) if( !$table && !$arg{table} );
    $table ||= CORE::delete( $arg{table} );
    foreach my $k ( keys( %arg ) )
    {
        $self->{ $k } = $arg{ $k };
    }
    $self->{ 'table' }       = $table if( $table );
    $self->{ 'structure' } ||= {};
    $self->{ 'fields' }    ||= {};
    $self->{ 'default' }   ||= {};
    $self->{ 'null' }      ||= {};
    $self->{ 'types' }       = {};
    $self->{ 'alias' }       = {};
    $self->{ 'avoid' }       = [];
    ## The table type. It could be table or view
    $self->{ 'type' }         = '';
    ## The schema name, if any
    $self->{ 'schema' }         = '';
    $self->{ 'bind' }         = '';
    $self->{ 'cache' }         = '';
    $self->{ 'enhance' }     = '';
    ## Load table default, fields, structure informations
    ## my $db = $self->database();
    my $ref = $self->structure();
    return( $self->error( "There is no table by the name of $table" ) ) if( !%$ref );
    return( $self );
}

##----{ End of generic routines }----##
sub alter
{
    my $self  = shift( @_ );
    ## Expecting a reference to an array
    my $spec  = '';
    $spec     = shift( @_ ) if( @_ == 1 && ref( $_[ 0 ] ) );
    $spec     = [ @_ ] if( @_ && !$spec );
    my $table = $self->{ 'table' } ||
    return( $self->error( "No table was provided." ) );
    return( $self->error( "No proper ALTER specification was provided." ) ) if( !$spec || !ref( $spec ) || !@$spec );
    my $query = "ALTER TABLE $table " . CORE::join( ', ', @$spec );
    my $sth   = $self->prepare( $query ) ||
    return( $self->error( "Error while preparing ALTER query to modify table '$table':\n", $self->errstr() ) );
    if( !defined( wantarray() ) )
    {
        $sth->execute() ||
        return( $self->error( "Error while executing query to ALTER table '$table':\n", $self->as_string(), $sth->errstr() ) );
    }
    return( $sth );
}

sub constant
{
    my $self = shift( @_ );
    my( $pack, $file, $line ) = caller;
    ## $self->message( 3, "Called from package '$pack' in file '$file' at line '$line'." );
    my $base_class = $self->database_object->base_class;
    ## This does not work for calls made internally
    return( $self ) if( $pack =~ /^${base_class}\b/ );
    my $sth = $self->database_object->constant_queries_cache_get({
        pack => $pack,
        file => $file,
        line => $line,
    });
    ## $self->message( 3, "Statement handler returned is: '$sth'." );
    ## $sth returned may be void if no cache was found or if the caller's file mod time has changed
    my $q;
    if( $sth )
    {
        $q = $sth->query_object;
        $self->query_object( $q );
    }
    else
    {
        $q = $self->_reset_query;
    }
    $q->constant({
        sth => $sth,
        pack => $pack,
        file => $file,
        line => $line,
    });
    return( $self );
}

## sub create must be superseded by sub classes
sub create
{
    my $self = shift( @_ );
    my $class = ref( $self );
    return( $self->error( "create() is not implemented by $class." ) );
}

sub create_info
{
    my $self = shift( @_ );
    my $class = ref( $self );
    return( $self->error( "create_info() is not implemented by $class." ) );
}

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

sub database_object { return( shift->{ 'dbo' } ); }

sub dbh { return( shift->_set_get( 'dbh', @_ ) ); }

sub default
{
    my $self = shift( @_ );
    $self->structure();
    my $default = $self->{ 'default' };
    return( wantarray() ? () : undef() ) if( !%$default );
    return( wantarray() ? %$default : \%$default );
}

sub drop
{
    my $self  = shift( @_ );
    my $table = $self->{ 'table' } || 
    return( $self->error( "No table was provided to drop." ) );
    my $query = "DROP TABLE $table";
    my $sth = $self->prepare( $query ) ||
    return( $self->error( "Error while preparing query to drop table '$table':\n$query", $self->errstr() ) );
    if( !defined( wantarray() ) )
    {
        $sth->execute() ||
        return( $self->error( "Error while executing query to drop table '$table':\n$query", $sth->errstr() ) );
    }
    return( $sth );
}

sub exists
{
    my $self = shift( @_ );
    my $class = ref( $self );
    return( $self->error( "exists() is not implemented by $class." ) );
}

sub fields
{
    my $self = shift( @_ );
    $self->structure();
    my $fields = $self->{fields};
    return( wantarray() ? () : undef() ) if( !%$fields );
    return( wantarray() ? %$fields : \%$fields );
}

sub fields_object
{
    my $self = shift( @_ );
    my $o = $self->{fields_object};
    return( $o ) if( $o && $self->_is_object( $o ) );
    my $db_name = $self->database_object->database;
    $db_name =~ tr/-/_/;
    $db_name =~ s/\_{2,}/_/g;
    $db_name = join( '', map( ucfirst( lc( $_ ) ), split( /\_/, $db_name ) ) );
    my $name = $self->name;
    my $new_class = $name;
    $new_class =~ tr/-/_/;
    $new_class =~ s/\_{2,}/_/g;
    $new_class = join( '', map( ucfirst( lc( $_ ) ), split( /\_/, $new_class ) ) );
    $class = ref( $self ) . "\::${db_name}\::${new_class}";
    unless( $self->_is_class_loaded( $class ) )
    {
        my $perl = <<EOT;
package $class;
BEGIN
{
    use strict;
    use parent qw( DB::Object::Fields );
};

1;

EOT
        # print( STDERR __PACKAGE__, "::_set_get_hash_as_object(): Evaluating\n$perl\n" );
        my $rc = eval( $perl );
        # print( STDERR __PACKAGE__, "::_set_get_hash_as_object(): Returned $rc\n" );
        die( "Unable to dynamically create module $class: $@" ) if( $@ );
    }
    $o = $class->new({
        table_object => $self,
        debug => $self->debug,
    });
    $o->prefixed( $self->{prefixed} );
    $self->{fields_object} = $o;
    return( $o );
}

sub fo { return( shift->fields_object( @_ ) ); }

sub lock
{
    my $self = shift( @_ );
    my $class = ref( $self );
    return( $self->error( "lock() is not implemented by $class." ) );
}

sub name
{
    ## Read-only
    return( shift->{table} );
}

sub null
{
    my $self = shift( @_ );
    $self->structure();
    my $null = $self->{ 'null' };
    return( wantarray() ? () : undef() ) if( !%$null );
    return( wantarray() ? %$null : $null );
}

sub optimize
{
    my $self = shift( @_ );
    my $class = ref( $self );
    return( $self->error( "optimize() is not implemented by $class." ) );
}

sub prefix
{
    my $self = shift( @_ );
    my @val = ();
    CORE::push( @val, $self->database_object->database ) if( $self->{prefixed} > 2 );
    CORE::push( @val, $self->schema ) if( $self->{prefixed} > 1 && $self->schema );
    CORE::push( @val, $self->name ) if( $self->{prefixed} > 0 );
    return( '' ) if( !scalar( @val ) );
    return( CORE::join( '.', @val ) );
}

sub prefix_database { return( shift->{prefixed} > 2 ); }

sub prefix_schema { return( shift->{prefixed} > 1 ); }

sub prefix_table { return( shift->{prefixed} > 0 ); }

## This the prefix intended for field in query
sub prefixed
{
    my $self = shift( @_ );
    if( @_ )
    {
        $self->{prefixed} = ( $_[0] =~ /^\d+$/ ? $_[0] : ( $_[0] ? 1 : 0 ) );
    }
    else
    {
        $self->{prefixed} = 1;
    }
    my $fo = $self->{fields_object};
    $fo->prefixed( $self->{prefixed} ) if( $fo );
    return( $self );
}

sub primary
{
    my $self = shift( @_ );
    $self->structure();
    my $primary = $self->{primary};
    return( wantarray() ? () : undef() ) if( !$primary || !@$primary );
    return( wantarray() ? @$primary : \@$primary );
}

## In PostgreSQL, Oracle, SQL server this would be schema_name.table_name
sub qualified_name { return( shift->name ); }

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

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

sub rename
{
    my $self = shift( @_ );
    my $class = ref( $self );
    return( $self->error( "rename() is not implemented by $class." ) );
}

sub repair
{
    my $self = shift( @_ );
    my $class = ref( $self );
    return( $self->error( "repair() is not implemented by $class." ) );
}

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

sub stat
{
    my $self = shift( @_ );
    my $class = ref( $self );
    return( $self->error( "stat() is not implemented by $class." ) );
}

sub table { return( shift->{table} ); }

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

sub types
{
    my $self = shift( @_ );
    $self->structure();
    my $types = $self->{types};
    return( wantarray() ? () : undef() ) if( !%$types );
    return( wantarray() ? %$types : $types );
}

## sub structure must be superseded by sub classes
sub structure
{
    my $self = shift( @_ );
    my $class = ref( $self );
    return( $self->error( "structure() is not implemented by $class." ) );
}

sub unlock
{
    my $self = shift( @_ );
    my $class = ref( $self );
    return( $self->error( "unlock() is not implemented by $class." ) );
}

DESTROY
{
    ## Do nothing
    ## DB::Object::Tables are never destroyed.
    ## They are just gateway to tables, and they are cached by DB::Object::table()
    ## print( STDERR "DESTROY'ing table $self ($self->{ 'table' })\n" );
};

1;

__END__

=encoding utf8

=head1 NAME

DB::Object::Tables - Database Object Interface

=head1 SYNOPSIS

=head1 VERSION

    0.4.1

=head1 DESCRIPTION

=head1 CONSTRUCTOR

=over 4

=item B<new>( %arg )

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

=over 8

=item I<debug>

Toggles debug mode on/off

=back

=back

=head1 METHODS

=over 4

=item B<alter>()

=item B<create>()

=item B<create_info>()

=item B<database_object>()

=item B<dbh>()

=item B<default>()

=item B<drop>()

=item B<exists>()

=item B<fields>()

=item B<fields_object>()

=back

=head1 AUTHOR

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

=head1 SEE ALSO

L<perl>

=head1 COPYRIGHT & LICENSE

Copyright (c) 2019 DEGUEST Pte. Ltd.

All rights reserved

This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.

=cut


