File Coverage

blib/lib/DBIx/Procedure/Oracle.pm

Criterion	Covered	Total	%
statement	4	6	66.6
branch			n/a
condition			n/a
subroutine	2	2	100.0
pod			n/a
total	6	8	75.0

package DBIx::Procedure::Oracle;

$VERSION = 0.2;

use DBI qw( :sql_types );
# sql_types are needed for binding dates and numbers
# ORA_NUMBER and ORA_DATE don't work but SQL_NUMERIC etc. do
use DBD::Oracle qw( :ora_types );
# but we do need ora_types so that we can bind cursors as ORA_RSET

sub new {
    my ($self,$dbh,%resolve) = @_;
    my $class = ref $self || $self;
    my $usage = <<'EOF';
Usage: $proc = DBIx::Procedure::Oracle->new($dbh
                                           ,[ owner => 'oracle_user' ]
                                           ,[ package_name => 'oracle_package' ]
                                           ,object_name => 'oracle_procedure'
                                           );
EOF

    unless( UNIVERSAL::isa($dbh,'DBI::db') && $dbh->{Driver}->{Name} =~ /^Oracle$/i ){
        die "$class - First argument must be a valid DBI handle for Oracle";
    }
    die "$class - No procedure name provided.\n$usage" unless exists $resolve{object_name};
    my $this = bless {}, $class;
    $this->{-args} = resolve_procedure( $dbh, \%resolve );
    my $sql = generate_sql( \%resolve, $this->{-args} );
    $this->{-sth} = $dbh->prepare($sql);
    $this->{-sql} = $sql;
    return $this;
}

sub DESTROY { $_[0]->{-sth}->finish if exists $_[0]->{-sth} }

sub resolve_procedure ($\%) {
    my ($dbh,$resolve) = @_;
    # if we don't provide a user we'll assume that its the current oracle user
    # if we don't provide a package we'll assume that the procedure isn't in one
    # In future: allow named argument syntax as well as positional arguments
    my $sql =<<'EOF';
select argument_name, position, sequence, data_type, in_out
from all_arguments
where ( owner = :1 or ( :1 is null and owner = user ) )
and   ( package_name = :2 or ( :2 is null and package_name is null ) )
and   object_name = :3
order by position
EOF
    my $sth = $dbh->prepare($sql);
    $sth->bind_param(1, uc $resolve->{owner}        );
    $sth->bind_param(2, uc $resolve->{package_name} );
    $sth->bind_param(3, uc $resolve->{object_name}  );
    $sth->execute;
    my @rows;
    while( my $row = $sth->fetchrow_hashref ){
        if( $row->{DATA_TYPE} =~ /VARCHAR/ ){ # not CHAR
            $row->{SQL_TYPE} = { sql_type => SQL_VARCHAR() };
        }elsif( $row->{DATA_TYPE} =~ /NUMBER/ ){ # should handle all numbers
            $row->{SQL_TYPE} = { sql_type => SQL_NUMERIC() };
        }elsif( $row->{DATA_TYPE} =~ /CURSOR/ ){
            $row->{SQL_TYPE} = { ora_type => ORA_RSET() }; # oracle cursors
        }elsif( $row->{DATA_TYPE} =~ /CHAR/ ){ # but not VARCHAR (see above)
            $row->{SQL_TYPE} = { sql_type => SQL_CHAR() };
        }elsif(    $row->{DATA_TYPE} =~ /DATE/
                || $row->{DATA_TYPE} =~ /TIME/
                || $row->{DATA_TYPE} =~ /INTERVAL/ ){
            $row->{SQL_TYPE} = { sql_type => SQL_DATE() }; # types i have seen
        }else{ # don't know. Try our best.
            $row->{SQL_TYPE} = { sql_type => SQL_UNKNOWN_TYPE() }; # catch all
        }
        push @rows, $row;
    }
    $sth->finish;
    return \@rows;
}

sub generate_sql (\%\@) {
    my($resolve, $args) = @_;
    my $sql = "begin\n\t" ; # nicely formatted anonymous pl/sql block
    my $start = 0;
    if( @$args && $args->[0]->{POSITION} == 0 ){ # is a function!
        $sql .= ':1 := ';
        $start = 1;
    }
    $sql .= "$resolve->{owner}."          if exists $resolve->{owner};
    $sql .= "$resolve->{package_name}."   if exists $resolve->{package_name};
    $sql .= $resolve->{object_name};
    if( @$args ){
        $sql .= '('; # brackets only necessary when there are arguments
        for( my $i = $start; $i < @$args; $i++ ){
            $sql .= ":$args->[$i]->{SEQUENCE},";
        }
        $sql =~ s/,$//;
        $sql .= ')';
    }
    $sql .= ";\nend;";
    return $sql;
}

sub execute {
    my $this = $_[0];
    my $sth = $this->{-sth};
    my $retval;
    my $start = 0;
    my @args = @{ $this->{-args} };
    if( $args[0]->{POSITION} == 0 ){ # function
        $sth->bind_param_inout(1, \$retval, $args[0]->{SQL_TYPE} );
        $start = 1;
    }
    for( my $i = $start; $i < @args; $i++ ){
        if ( $args[$i]->{IN_OUT} eq 'IN' ){
            $sth->bind_param( $args[$i]->{SEQUENCE}
                             ,$_[ $args[$i]->{POSITION} ]
                             ,$args[$i]->{SQL_TYPE}
                            );
        }else{
            $sth->bind_param_inout( $args[$i]->{SEQUENCE}
                                   ,\$_[ $args[$i]->{POSITION} ]
                                   ,$args[$i]->{SQL_TYPE}
                                  );
        }
    }
    $sth->execute;
    return $retval; # because its undef it hasn't been used
}

1;

__END__