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

    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;"
    );

        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}
	    }
	);

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;

    
has '$.plsql';

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

has '@.bind_in_variables';

has '@.bind_inout_variables';

has '@.bind_out_variables';

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

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

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

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

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();
}

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;
        }
    }
}

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

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);
}

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

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

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

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

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);
}

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

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

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;
}

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__