package DBIx::PLSQLHandler;

use warnings;
use strict;

use Abstract::Meta::Class ':has';
use Carp 'confess';
use base 'DBIx::SQLHandler';
use Data::Dumper;
use vars qw($VERSION);

$VERSION = 0.02;

use constant DEFAULT_TYPE => 'SQL_VARCHAR';
use constant DEFAULT_WIDTH => 32000;


=head1 NAME

DBIx::PLSQLHandler - PL/SQL procedural language handler.

=head1 SYNOPSIS

    use DBIx::PLSQLHandler;
    my $plsql = new DBIx::PLSQLHandler(
        connection => $connection,
        plsql      => "
DECLARE
    debit_amt    CONSTANT NUMBER(5,2) := 500.00;
BEGIN
    SELECT a.bal INTO :acct_balance FROM accounts a
    WHERE a.account_id = :acct AND a.debit > debit_amt;
    :extra_info := 'debit_amt: ' || debit_amt;
END;"
);

    my $result_set = $plsql->execute(acct => 000212);
    # $result_set->{acct_balance}; $result_set->{extra_info}
    ... do some stuff

    or

    use DBIx::Connection;

    ...

     my $plsql = $connection->plsql_handler(
            plsql      => "
    DECLARE
        debit_amt    CONSTANT NUMBER(5,2) := 500.00;
    BEGIN
        SELECT a.bal INTO :acct_balance FROM accounts a
        WHERE a.account_id = :acct AND a.debit > debit_amt;
        :extra_info := 'debit_amt: ' || debit_amt;
    END;"
    );


=head1 DESCRIPTION

Base class for PLSQL blocks hyandler(SQL Procedural Language).
It allows use independetly specyfig Procedural Language SQL dialect like PL/SQL (Oracle, mySQL), PL/pgSQL (PostgreSQL)
It uses ":" placeholers to bind variables in or out or inout.

By default it bind variable is defined as varchar,
however you can change it by specyfing your types in bind_variables parameter.


        my $plsql_handler = new DBIx::PLSQLHandler(
            name        => 'int_test',
            connection  => $connection,
            plsql       => "BEGIN
            :var1 := :var2 + :var3;
            :var4 := 'long text';
            END;",
	    bind_variables => {
		var1 => {type => 'SQL_INTEGER'},
                var4 => {type => 'SQL_VARCHAR', width => 30}
	    }
	);

In Oracle database it uses an anonymous PLSQL block,
In mysql procedure wraps the plsql block.
In postgresql function wraps the plsql block.
Name for the procedure/function wrapper is created as 'anonymous_' + $self->name 

=head2 ATTRIBUTES

=over

=item plsql

Plsql block

=cut

    
has '$.plsql';


=item bind_variables

Keeps information about binds variables and its types.

=cut

has '%.bind_variables' => (item_accessor => 'bind_variable');


=item bind_in_variales

Ordered list for binding in variables

=cut

has '@.bind_in_variables';


=item bind_inout_variales

Ordered list for binding in out variables

=cut

has '@.bind_inout_variables';


=item bind_out_variales

Ordered list for binding out variables

=cut

has '@.bind_out_variables';


=item default_type

default type binding

=cut

has '$.default_type' => (default => DEFAULT_TYPE);


=item default_width

default width binding

=cut

has '$.default_width' => (default => DEFAULT_WIDTH);

=back

=head2 METHODS

=over

=item new

=cut

sub new {
    my ($class, %args) = @_;
    my $specialisation_module = $args{connection}->load_module('PLSQL');
    my $self = $specialisation_module->new(%args);
    return $self;
}


=item initialise

Initialises handler.

=cut 

sub initialise {
    my ($self) = @_;
    $self->initialise_bind_variables();
    $self->SUPER::initialise();
}


=item initialise_bind_variables

Parses plsql for binding variables.
TODO replace this naive implementations.

=cut

sub initialise_bind_variables {
    my ($self) = @_;
    my $plsql = $self->plsql;
    my $bind_variables = $self->bind_variables;
    $plsql =~ s/\'[^\']*\'//g;
    while ($plsql =~ s/:(\w+)\s*(:*)//) {
        my $bind_variable = $1;
        my $out_flag = $2;
        my $variable = $bind_variables->{$bind_variable};
        if ($variable && $variable->{binding}) {
            $variable->{binding} = 'inout' if ($out_flag && $variable->{binding} eq 'in');
            
        } else {
            $variable = $bind_variables->{$bind_variable} = $self->default_variable_info
                unless $variable;
            $variable->{binding} = $out_flag ? 'out' : 'in';
        }
    }
    $self->set_binding_order();
}


=item set_binding_order

=cut

sub set_binding_order {
    my ($self) = @_;
    my $bind_variables = $self->bind_variables;
    my $bind_in_variables = $self->bind_in_variables;
    my $bind_inout_variables = $self->bind_inout_variables;
    my $bind_out_variables = $self->bind_out_variables;
    
    foreach my $k (sort keys %$bind_variables) {
        my $variable = $bind_variables->{$k};
        if ($variable->{binding} eq 'in') {
            push @$bind_in_variables, $k;
            
        } elsif ($variable->{binding} eq 'out') {
            push @$bind_out_variables, $k;
            
        } else {
            push @$bind_inout_variables, $k;
        }
    }
}


=item default_variable_info

Adds default variable meta data.

=cut

sub default_variable_info {
    my $self = shift;
    {type  => $self->default_type, width => $self->default_width, @_};
}


=item plsql_block_name

Returns plsql block name (used to create plsql block procedure or function wrapper)

=cut

sub plsql_block_name {
    my ($self) = @_;
    my $result = "anonymous_";
    if ($self->name =~ m/\s+/) {
        $result .= unpack("%32C*",$self->name);
    } else {
        $result .= $self->name;
    }
    substr($result, 0, 30);
}


=item plsql_block_declaration

=cut

sub plsql_block_declaration {
    my ($self) = @_;
    my $result = '';
    foreach my $k($self->bind_variable_order) {
        $result .= ($result ? ', ' : '') . $self->variable_declaration($k);
    }
    $result;
}


=item bind_variable_order

Return bind variable order

=cut

sub bind_variable_order {
    my ($self) = @_;
    ($self->bind_in_variables, $self->bind_inout_variables, $self->bind_out_variables);
}


=item binded_in_variables

Returns bind_in_variables + bind_inout_variables

=cut

sub binded_in_variables {
    my ($self) = @_;    
    ($self->bind_in_variables, $self->bind_inout_variables);
}


=item binded_out_variables

Returns bind_inout_variables + bind_out_variables

=cut

sub binded_out_variables {
    my ($self) = @_;
    ($self->bind_inout_variables, $self->bind_out_variables);
}   


=item variable_declaration

Returns variable definition for plsql block stub

=cut

sub variable_declaration {
    my ($self, $variable_name) = @_;
    my $variable = $self->bind_variable($variable_name);
    my $type = $variable->{type};
    uc($variable->{binding}) .' ' . $variable_name . ' ' . $self->get_type($type) . $self->type_precision($variable_name);
}


=item type_precision

Returns variable type precision, takes bind variable name.

=cut

sub type_precision {
    my ($self, $variable_name) = @_;
    my $variable = $self->bind_variable($variable_name);
    ($variable->{type} && $variable->{type} =~ /CHAR/ ? '(' . $variable->{width} . ')' : '')
}


=item block_source

Block source, used for comparision against database wrapper source.

=cut

sub block_source {
    my ($self) = @_;
    "BEGIN\n"
    . $self->parsed_plsql
    ."\nEND;";
}


=item parsed_plsql

Parses plsql code and replaces :var to var

=cut

sub parsed_plsql {
    my ($self) = @_;
    my $plsql = $self->plsql;
    my $bind_variables = $self->bind_variables;
    foreach my $variable (sort keys %$bind_variables) {
        $plsql =~ s/:$variable/$variable/g;
    }
    $plsql;
}


=item is_block_changed

Checks if plsql_block has been changed and return true otherwise false.

=cut

sub is_block_changed {
    my ($self, @bind_param) = @_;
    my $connection = $self->connection;
    my $record = $connection->record($self->sql_defintion('find_function'), @bind_param);
    my $routine_definition = $record->{routine_definition} or return 1;
    $routine_definition =~ s/[\n\r\s\t;]//g;
    my $block_source  = $self->block_source;
    $block_source =~ s/[\n\r\s\t;]//g;
    if ($block_source ne $routine_definition) {
        $self->drop_plsql_block;
        return 1
    };
    !! undef;
}


1;

__END__

=back

=head1 COPYRIGHT AND LICENSE

The DBIx::PLSQLHandler module is free software. You may distribute under the terms of
either the GNU General Public License or the Artistic License, as specified in
the Perl README file.

=head1 SEE ALSO

L<DBIx::QueryCursor>
L<DBIx::SQLHandler>

=head1 AUTHOR

Adrian Witas, adrian@webapp.strefa.pl

=cut