File Coverage

blib/lib/DBIx/ProcedureCall.pm

Criterion	Covered	Total	%
statement	80	148	54.0
branch	19	80	23.7
condition			n/a
subroutine	11	17	64.7
pod	0	1	0.0
total	110	246	44.7

package DBIx::ProcedureCall;

use strict;
use warnings;

use Carp qw(croak);


our $VERSION = '0.11';

our %__loaded_drivers;

our %__known_attributes = qw~
	procedure  1
	function 	1
	cached	1
	package	1
	packaged  1
	cursor	1
	fetch()	1
	fetch[]	1
	fetch{}	1
	fetch[[]]	1
	fetch[{}]	1
	table	1
	boolean 1
~;

sub __run_procedure{
		my $dbh =$_[0];
		croak "expected a database handle as first parameter, but got nothing" unless $dbh;

		# determine database type
		my $dbtype = eval { $dbh->get_info(17); };  #  17 : SQL_DBMS_NAME
		croak "could not determine the database type from $dbh: $@. Is that really a DBI database handle? " unless $dbtype;

		my $name = $_[1];
		croak "expected a procedure name to run against the database, but got nothing" unless $name;

		# delegate to the driver
		unless ($__loaded_drivers{$dbtype}){
			eval  "require DBIx::ProcedureCall::$dbtype; \$__loaded_drivers{$dbtype} = 1;"
				or croak "failed to load driver for $dbtype database: $@";
		}

		"DBIx::ProcedureCall::$dbtype"->__run_procedure(@_);
}

sub __run_function{
		my $dbh = $_[0];
		croak "expected a database handle as first parameter, but got nothing" unless $dbh;

		# determine database type
		my $dbtype = eval { $dbh->get_info(17); };  #  17 : SQL_DBMS_NAME
		croak "could not determine the database type from $dbh: $@. Is that really a DBI database handle? " unless $dbtype;

		my $name = $_[1];
		croak "expected a function name to run against the database, but got nothing" unless $name;

		my $attr = $_[2];

		# delegate to the driver
		unless ($__loaded_drivers{$dbtype}){
			eval  "require DBIx::ProcedureCall::$dbtype; \$__loaded_drivers{$dbtype} = 1;"
				or croak "failed to load driver for $dbtype database: $@";
		}
		my $r = "DBIx::ProcedureCall::$dbtype"->__run_function(@_);
		return $r unless $attr->{fetch};

		#fetch cursor
		return __fetch($r, $attr, $dbtype);

}

sub __fetch{
	my ($sth, $attr, $dbtype) = @_;
	my $data;
	if ($attr->{'fetch[[]]'} ) { $data = $sth->fetchall_arrayref; }
	elsif ($attr->{'fetch()'} ) {
		my @data = $sth->fetchrow_array;
		"DBIx::ProcedureCall::$dbtype"->__close($sth) if $attr->{cursor};
		return @data;
	}
	elsif ($attr->{'fetch[{}]'} ) { $data = $sth->fetchall_arrayref({ }); }
	elsif ($attr->{'fetch{}'} ) { $data = $sth->fetchrow_hashref; }
	elsif ($attr->{'fetch[]'} ) { $data = $sth->fetchrow_arrayref; }

	"DBIx::ProcedureCall::$dbtype"->__close($sth)
		if $attr->{cursor};

	return $data;
}

sub __bind_params{
	my ($sql, $start_index, $params) = @_;
	my @binder;
	if (ref $params eq 'ARRAY'){
		my $i = $start_index;
		foreach (@$params){
			# special bind options
			if (ref $_ eq 'ARRAY'){
				@binder = @$_;
			}
			else
			{
				@binder = ( $_ );
			}
			# INOUT parameters
			if (ref $binder[0]){
				# default MAXLEN 100
				$binder[1] = 100 unless exists $binder[1];
				$sql->bind_param_inout($i++, @binder);
			}
			else{
				$sql->bind_param($i++, @binder);
			}
		}
	}
	else{
		foreach (keys %$params){
			# special bind options
			my $p = $params->{$_};
			if (ref $p eq 'ARRAY'){
				@binder = @$p;
			}
			else
			{
				@binder = ( $p );
			}
			# INOUT parameters
			if (ref $binder[0]){
				# default MAXLEN 100
				$binder[1] = 100 unless exists $binder[1];
				$sql->bind_param_inout(":$_", @binder);
			}
			else{
				$sql->bind_param(":$_", @binder);
			}
		}
	}
}

sub __run{
	my $w = shift;
	my $name = shift;
	my $attr = shift;
	my $dbh = shift;
	# check function/procedure attribute
	$w = 0 if $attr->{function};
	$w = undef if $attr->{procedure};
	# in void context run a procedure
	return __run_procedure($dbh, $name, $attr, @_) unless defined $w;
	# in non-void context run a function
	return __run_function($dbh, $name, $attr, @_);
}

sub run{
	my $dbh = shift;
	my $n = shift;
	my ($name, @attr) = split ':', $n;
	my @err = grep { not exists $__known_attributes{lc $_} } @attr;
	croak "tried to set unknown attributes (@err) for stored procedure '$name' " if @err;

	my %attr = map { (lc($_) => 1) } @attr;

	# any fetch implies function
	if ( grep /^fetch/,  keys %attr ) {
		$attr{'function'} = 1;
		$attr{'fetch'} = 1;
	}

	# cursor implies function
	$attr{'function'} = 1 if $attr{'cursor'};

	# table implies function
	$attr{'function'} = 1 if $attr{'table'};


	return __run(wantarray, $name, \%attr, $dbh, @_);
}


sub import {
    my $class = shift;
    my $caller = (caller)[0];
    no strict 'refs';
    foreach (@_) {
	my ($name, @attr) = split ':';

	my @err = grep { not exists $__known_attributes{lc $_} } @attr;
	croak "tried to set unknown attributes (@err) for stored procedure '$name' " if @err;

	my %attr = map { (lc($_) => 1) } @attr;


	# any fetch implies function
	if ( grep /^fetch/,  keys %attr ) {
		$attr{'function'} = 1;
		$attr{'fetch'} = 1;
	}

	# cursor implies function
	$attr{'function'} = 1 if $attr{'cursor'};

	# table implies function
	$attr{'function'} = 1 if $attr{'table'};

	# boolean implies function
	$attr{'function'} = 1 if $attr{'boolean'};

	if ($attr{'package'}){
		delete $attr{'package'};
		my $pkgname = $name;
		$pkgname =~ s/\./::/g;
		$pkgname =~ s/[^:\w]/_/g;
		*{"${pkgname}::AUTOLOAD"} = sub {__pkg_autoload($name, \%attr, @_) };
		next;
	}
	if ($attr{'packaged'}){
		delete $attr{'packaged'};
		my @p = split '\.', $name;
		die "cannot create a package for unpackaged procedure $name (name contains no dots)"
			unless @p>1;
		my $subname = pop @p;
		my $pkgname = join '::', @p;
		$pkgname =~ s/[^:\w]/_/g;
		$subname =~ s/[^:\w]/_/g;
		*{"${pkgname}::$subname"} = sub {__run(wantarray,$name,\%attr, @_) };
		next;
	}

	my $subname = $name;
	$subname =~ s/\W/_/g;
        *{"${caller}::$subname"} = sub {
			__run(wantarray,$name,\%attr, @_)
		};
    }
}

sub __pkg_autoload{
	my $name = shift;
	my $attr = shift;
	my $pkgname = $name;
	$pkgname =~ s/\./::/g;
	$pkgname =~ s/[^:\w]/_/g;
	our $AUTOLOAD;
	my @p = split '::', $AUTOLOAD;
	my $subname = $p[-1];
	$name = "$name.$subname";
	my $sub =  sub {
			__run(wantarray,$name,$attr, @_);
		};
	no strict 'refs';
	*{"${pkgname}::$subname"} = $sub;
	$sub->(@_);
}


1;
__END__