File Coverage

blib/lib/DBIx/ProcedureCall/Oracle.pm

Criterion	Covered	Total	%
statement	9	125	7.2
branch	0	50	0.0
condition	0	18	0.0
subroutine	3	8	37.5
pod			n/a
total	12	201	5.9

package DBIx::ProcedureCall::Oracle;

use strict;
use warnings;

use Carp qw(croak);

our $VERSION = '0.10';

our $ORA22905;

sub __run_procedure{
	shift;
	my $dbh = shift;
	my $name = shift;
	my $attr = shift;
	my $params;

	# if there is one more arg and it is a hashref, then we use named parameters
	if (@_ == 1 and ref $_[0] eq 'HASH') {
		return __run_procedure_named($dbh, $name, $attr, $_[0]);
	}
	# otherwise they are positional parameters
	my $sql = "begin $name";
	if (@_){
	$sql .= '(' . join (',' , map ({ '?'} @_  )) . ')';
	}
	$sql .= '; end;';
	# print $sql;
	# prepare
	$sql = $attr->{cached} ? $dbh->prepare_cached($sql)
		: $dbh->prepare($sql);
	# bind
	DBIx::ProcedureCall::__bind_params($sql, 1, \@_);
	# execute
	$sql->execute;
}

sub __run_procedure_named{
	my ($dbh, $name, $attr, $params) = @_;
	my $sql = "begin  $name";
	my @p = sort keys %$params;
	if (@p){
		@p = map { "$_ => :$_" } @p;
		$sql .= '(' . join (',', @p) . ')';
	}
	$sql .= '; end;';
	# print $sql;
	# prepare
	$sql = $attr->{cached} ? $dbh->prepare_cached($sql)
		: $dbh->prepare($sql);
	# bind
	DBIx::ProcedureCall::__bind_params($sql, undef, $params);
	# execute
	$sql->execute;
}

sub __run_function{
	shift;
	my $dbh = shift;
	my $name = shift;
	my $attr = shift;
	my $params;

	# any fetch implies cursor (unless it is a table function)
	if ( $attr->{'fetch'} and not $attr->{'table'}  ) {
		$attr->{'cursor'} = 1;
	}
	# if there is one more arg and it is a hashref , then we use with named parameters
	if (@_ == 1 and ref $_[0] eq 'HASH') {
		return __run_function_named($dbh, $name, $attr, $_[0]);
	}
	# otherwise they are positional parameters

	# table functions
	if ($attr->{table}){
		# workaround for pre-9.2.0.5.0
		if (@_ and $ORA22905){
			my $sql = "select * from table( $name (";
			$sql .= join ',', map{$dbh->quote($_) } @_ ;
			$sql .= '))';
			# prepare
			$sql = $dbh->prepare($sql);
			# execute
			$sql->execute;
			return $sql;
		}
		my $sql = "select * from table( $name";
		if (@_){
			$sql .= '(' . join (',' , map ({ '?'} @_  )) . ')';
		}
		$sql .= ')';
		eval{
			# prepare
			$sql = $attr->{cached} ? $dbh->prepare_cached($sql)
			: $dbh->prepare($sql);
		};
		# error: if 22905 turn on workaround and try again
		if ($@ and $dbh->err == 22905 and not defined $ORA22905){
			$ORA22905 = 1;
			return __run_function(__PACKAGE__, $dbh, $name, $attr, @_);
		}
		# bind
		DBIx::ProcedureCall::__bind_params($sql, 1, \@_);
		# execute
		$sql->execute;
		return $sql ;
	}

	my $sql;

	# boolean function needs a conversion wrapper
	if ($attr->{boolean}){
		$sql = 'declare perl_oracle_procedures_b0 boolean; perl_oracle_procedures_n0 number; ';
		$sql .= "begin perl_oracle_procedures_b0 := $name";
		if (@_){
			$sql .= '(' . join (',' , map ({ '?'} @_  )) . ')';
		}
		$sql .= '; if perl_oracle_procedures_b0 is null then perl_oracle_procedures_n0 := null;elsif perl_oracle_procedures_b0 then perl_oracle_procedures_n0 := 1;else perl_oracle_procedures_n0 := 0;end if; ? := perl_oracle_procedures_n0;end;';
	}
	else{
		$sql = "begin ? := $name";
		if (@_){
			$sql .= '(' . join (',' , map ({ '?'} @_  )) . ')';
		}
		$sql .= '; end;';
	}
	# prepare
	$sql = $attr->{cached} ? $dbh->prepare_cached($sql)
		: $dbh->prepare($sql);

	# bind
	my $i = 1;
	# boolean conversion wrapper requires the out value to be bound LAST
	if ($attr->{boolean}){
		DBIx::ProcedureCall::__bind_params($sql, $i, \@_);
		$i += @_;
	}
	my $r;

	if ($attr->{cursor}){
		$sql->bind_param_inout($i++, \$r,  0, {ora_type => DBD::Oracle::ORA_RSET()});
	}else{
		$sql->bind_param_inout($i++, \$r, 100);
	}

	unless ($attr->{boolean}){
		DBIx::ProcedureCall::__bind_params($sql, $i, \@_);
	}

	#execute
	$sql->execute;
	return $r;
}

sub __run_function_named{
	my ($dbh, $name, $attr, $params) = @_;
	# table functions
	if ($attr->{table}){
		croak "cannot execute the table function '$name' with named parameters: only positional parameters are supported.";
	}

	my $sql;
	my @p = sort keys %$params;
	# boolean function needs a conversion wrapper
	if ($attr->{boolean}){
		$sql = 'declare perl_oracle_procedures_b0 boolean; perl_oracle_procedures_n0 number; ';
		$sql .= "begin perl_oracle_procedures_b0 := $name";
		if (@p){
			@p = map { "$_ => :$_" } @p;
			$sql .= '(' . join (',', @p) . ')';
		}
		$sql .= '; if perl_oracle_procedures_b0 is null then perl_oracle_procedures_n0 := null;elsif perl_oracle_procedures_b0 then perl_oracle_procedures_n0 := 1;else perl_oracle_procedures_n0 := 0; end if; :perl_oracle_procedures_ret := perl_oracle_procedures_n0;end;';
	}
	else{
		$sql = "begin :perl_oracle_procedures_ret := $name";
		if (@p){
			@p = map { "$_ => :$_" } @p;
			$sql .= '(' . join (',', @p) . ')';
		}
		$sql .= '; end;';
	}


	# prepare
	$sql = $attr->{cached} ? $dbh->prepare_cached($sql)
		: $dbh->prepare($sql);
	# bind
	my $r;
	if ($attr->{cursor}){
		$sql->bind_param_inout(':perl_oracle_procedures_ret', \$r,  0, {ora_type => DBD::Oracle::ORA_RSET()});
	}else{
		$sql->bind_param_inout(':perl_oracle_procedures_ret', \$r, 100);
	}
	# bind
	DBIx::ProcedureCall::__bind_params($sql, undef, $params);

	# execute
	$sql->execute;
	return $r;
}

sub __close{
	shift;
	my $sth = shift;
	my $conn = $sth->{Database};
	my $sql = $conn->prepare('BEGIN   close :curref; END;');
	$sql->bind_param(":curref", $sth, {ora_type => DBD::Oracle::ORA_RSET()});
	$sql->execute;
}



1;
__END__