File Coverage

blib/lib/DBIx/LazyMethod.pm

Criterion	Covered	Total	%
statement	70	231	30.3
branch	5	112	4.4
condition	1	28	3.5
subroutine	20	25	80.0
pod	2	2	100.0
total	98	398	24.6

package DBIx::LazyMethod;

#DBIx::LazyMethod for the lazy hest $Id: LazyMethod.pm,v 1.3 2004/03/27 13:45:58 cwg Exp $
#Lazy DBI encapsulation for simple DB handling

use 5.005;
use strict;
use Carp;
use DBI;
use Exporter;
use vars qw($VERSION $AUTOLOAD @EXPORT @ISA);

use constant RETURN_VALUES => qw(WANT_ARRAY WANT_ARRAYREF WANT_HASHREF WANT_ARRAY_HASHREF WANT_RETURN_VALUE WANT_AUTO_INCREMENT); #The return value names
@EXPORT 	= RETURN_VALUES;
@ISA    	= qw(Exporter);
$VERSION 	= do { my @r=(q$Revision: 1.3 $=~/\d+/g); sprintf "%d."."%02d"x$#r,@r };
my $PACKAGE 	= "[DBIx::LazyMethod]";

#Public exported constants
use constant WANT_ARRAY 		=> 1;
use constant WANT_ARRAYREF 		=> 2;
use constant WANT_HASHREF 		=> 3;
use constant WANT_ARRAY_HASHREF 	=> 4;
use constant WANT_RETURN_VALUE 		=> 5;
use constant WANT_AUTO_INCREMENT 	=> 6;
use constant WANT_METHODS 		=> (WANT_ARRAY,WANT_ARRAYREF,WANT_HASHREF,WANT_ARRAY_HASHREF,WANT_RETURN_VALUE,WANT_AUTO_INCREMENT); #The return values

#Private constants
use constant TRUE 			=> 1;
use constant FALSE 			=> 0;
use constant PRIVATE_METHODS 		=> qw(new AUTOLOAD DESTROY _connect _disconnect _error);

#debug constant
use constant DEBUG 			=> 0;

#methods
sub new {
	my $class = shift;
	my %args = @_;
	my $self = bless {}, ref $class || $class;

	#did we get methods?
	my $methods_ref = $args{'methods'};
	unless (ref $methods_ref eq 'HASH') {
		die "$PACKAGE invalid methods definition: argument methods must be hashref";
	}
	#anything in it?
	unless (keys %$methods_ref > 0) {
		die "$PACKAGE no methods in methods hash";
	}
	#lets check the stuff
	my ($dbd_name) = $args{'data_source'} =~ /^dbi:(.*?):/i;
	#this approach will have to change when we start to accept an already create DBI handle
	my $good_methods = 0;
	foreach my $meth (keys %$methods_ref) {
		#check for internal names / reserwed words in method names
		if (grep { $meth eq $_ } PRIVATE_METHODS) {
			die "$PACKAGE method name $meth is a reserved method name";
		}
		#A way to validate SQL could be nice.
		unless (defined ${%$methods_ref}{$meth}->{sql}) {
			die "$PACKAGE method $meth: missing SQL";
		}
		unless (defined ${%$methods_ref}{$meth}->{args}) {
			die "$PACKAGE method $meth: missing argument definition";
		}
		unless (defined ${%$methods_ref}{$meth}->{ret}) {
			die "$PACKAGE method $meth: missing return data definition";
		}
		unless (ref ${%$methods_ref}{$meth}->{args} eq 'ARRAY') {
			die "$PACKAGE method $meth: bad argument list";
		}

		#check if we got the right amout of args - Cleanup on isle 9!
		my $arg_count = @{${%$methods_ref}{$meth}->{args}};
		#we should probably rather get amount of placeholders from DBI at some point. But then we can't do it before a prepare.
		my @placeholders = ${%$methods_ref}{$meth}->{sql} =~ m/\?/g;

		unless ($arg_count == scalar @placeholders) {
			warn "$PACKAGE method $meth: argument list does not match number of placeholders in SQL. You should get an error from DBI.";
		}

		#check DBD specific issues
		if (${%$methods_ref}{$meth}->{ret} eq WANT_AUTO_INCREMENT) {
			unless (grep { lc $dbd_name eq $_ } qw(mysql pg)) {
				die "$PACKAGE return value type WANT_AUTO_INCREMENT not supported by $dbd_name DBD in method $meth";
			}
		}

		unless (grep { ${%$methods_ref}{$meth}->{ret} eq $_ } WANT_METHODS ) {
			die "$PACKAGE bad return value definition in method $meth";
		}

		# Since 'noprepare' causes us to do a $dbh->do, we cannot return anything else than WANT_RETURN_VALUE
		if ((${%$methods_ref}{$meth}->{ret} != WANT_RETURN_VALUE) && (defined ${%$methods_ref}{$meth}->{'noprepare'})) {
			die "$PACKAGE return value for $meth must be WANT_RETURN_VALUE if 'noprepare' option is used";
		}

		# Use of 'noquote' option is depending on 'noprepare' option. Check that it is set.
		if (defined (${%$methods_ref}{$meth}->{'noquote'}) && (!defined ${%$methods_ref}{$meth}->{'noprepare'})) {
			warn "$PACKAGE useless use of 'noquote' option without required 'noprepare' option for method $meth";
		}

		$good_methods++;
	}
	unless ($good_methods > 0) {
		die "$PACKAGE no usable methods in methods hashref";
	}

	#TODO: more input checking?
	#At some point an existing $dbh object could be passed as an argument to new() instead of this.
	$self->{'methods'} 		= $methods_ref;
	$self->{'_data_source'} 	= $args{'data_source'} 	|| die "Argument data_source missing";
	$self->{'_user'} 		= $args{'user'} 		|| "";
	$self->{'_pass'}  		= $args{'pass'} 		|| undef;
	$self->{'_attr'} 		= $args{'attr'} 		|| undef;
	#connect us
	$self->{'_dbh'} 		= $self->_connect;

	return $self;
}

sub AUTOLOAD {
	my $self = shift;
	my %args = @_;
	my ($meth) = $AUTOLOAD =~ /.*::([\w_]+)/;

	#clear the error register
	$self->_error(FALSE);

	#is it a DBI statement handle
        if ($AUTOLOAD =~ /.*::_sth_([\w_]+)/) {

                #unless it is already created
                return if defined $self->{'_sth_'.$1};

		#we need a DBI handle
                #exists $self->{_dbh} or return $self->_error("DBI handle missing");
		unless (exists $self->{_dbh} && ref $self->{_dbh} eq 'DBI::db') { return $self->_error("DBI handle missing"); }

		#and a matching method
                exists $self->{'methods'}{$1} or $self->_error("Method ".$1." not defined");

		#check special method and dbd bindings
		#unless (($self->{'methods'}{$1} eq 'mysql') && ($self->{_dbh}->{Driver}->{Name} eq 'mysql')) {
                #	die "You cannot use exists $self->{'methods'}{$1} or $self->_error("Method ".$1." not defined");

		#we create a new DBI statement handle - unless it's a no-prepare type
		if  (defined $self->{'methods'}{$1}->{'noprepare'}) {
			$self->{'_sth_'.$1} = TRUE; #faking it
		} else {
			print STDERR "$PACKAGE DEBUG: preparing ".$self->{'methods'}{$1}->{sql}."\n" if DEBUG;
                	$self->{'_sth_'.$1} =  $self->{_dbh}->prepare($self->{'methods'}{$1}->{sql}) or return $self->_error($meth." prepare failed");
		}

		# Use this DBI built-in some day
		# $self->{'_sth_'.$1}->{'NUM_OF_FIELDS'}
                return;
	}
	#is it a method
	elsif (defined $self->{'methods'}{$meth}) {

		#call the associated DBI statement handle (which is then automagically created)
		my $sthname = "_sth_".$meth;
		$self->$sthname();

		#and it the statement handle will appear on the self object
		my $sth = $self->{"_sth_".$meth};

		my ($argsref) = $self->{'methods'}{$meth}->{args};
		#put the required bind values here
		my @bind_values = ();
		my $cnt = 1;
		#run through the args defined for the method
		foreach (@$argsref) {
			unless (defined $args{$_}) {
				return $self->_error($meth." Insufficient parameters (".$_.")");
			}
			#the argument was provided, so we use it
			push @bind_values, $args{$_};
			#for checking argument count later
			delete $args{$_};

			#puha hack for placeholders til MySQL limit syntax
			#TODO: investigate how this can be done in Pg
			next unless ($self->{_dbh}->{Driver}->{Name} eq 'mysql');

			# If we haven't prepared the $sth, then don't call it
			next unless (defined $self->{'methods'}{$meth}->{'noprepare'});

			if ($_ =~ /^limit_/) { $self->{"_sth_".$meth}->bind_param($cnt,'',DBI::SQL_INTEGER); }
			$cnt++;
		}

		#warn if more arguments than needed was provided
		foreach (keys %args) {
			warn "$PACKAGE WARN: useless argument \"".$_."\" provided for method \"".$meth."\"";
		}

		#do it
		my $rv;
		if  (defined $self->{'methods'}{$meth}->{'noprepare'}) {
			# Execute the SQL directly - as we have no prepared $sth
			my $sql = $self->{'methods'}{$meth}->{sql};
			if (defined $self->{'methods'}{$meth}->{'noquote'}) {
				# HACK: danger will robinson. danger.
				my $sql = $self->{'methods'}{$meth}->{sql};
				$sql =~ s/\?+?/(shift @bind_values)/oe while (@bind_values);
				$rv = $self->{_dbh}->do($sql) or return $self->_error("_sth_".$meth." do failed : ".DBI::errstr);
			} else {
				# Let's quote the bind_values
				#$sql =~ s/\?+?/($self->{_dbh}->quote_identifier(shift @bind_values))/oe while (@bind_values);
				$rv = $self->{_dbh}->do($self->{'methods'}{$meth}->{sql},undef,@bind_values) or return $self->_error("_sth_".$meth." do failed : ".DBI::errstr);
			}
		} else {
			# Execute the query normally on the statement handle
			$rv = $sth->execute(@bind_values) or return $self->_error("_sth_".$meth." execute failed : ".DBI::errstr);
		}
		print STDERR "$PACKAGE DEBUG: $meth DBI: ".DBI::errstr."\n" if (!$rv && DEBUG);
		unless ($rv) { return $self->_error("DBI execute error: ".DBI::errstr); }

		my ($ret) = $self->{'methods'}{$meth}->{ret};
		print STDERR "Found ret for $meth: $ret\n" if DEBUG;

		if ($self->{'methods'}{$meth}->{ret} == WANT_ARRAY) {
			my @ret;
			while (my (@ref) = $sth->fetchrow_array) { push @ret,@ref }
			return @ret;
		} elsif ($self->{'methods'}{$meth}->{ret} == WANT_ARRAYREF) {
			my $ret = $sth->fetchrow_arrayref;
			if ((!defined $ret) || (ref $ret eq 'ARRAY')) {
				return $ret;
			} else {
				return $self->_error("_sth_".$meth." is doing fetching on a non-SELECT statement");
			}
		} elsif ($self->{'methods'}{$meth}->{ret} == WANT_HASHREF) {
			my $ret = $sth->fetchrow_hashref;
			if ((!defined $ret) || (ref $ret eq 'HASH')) {
				return $ret;
			} else {
				return $self->_error("_sth_".$meth." is doing fetching on a non-SELECT statement");
			}
		} elsif ($self->{'methods'}{$meth}->{ret} == WANT_ARRAY_HASHREF) {
			my @ret;
			while (my $ref = $sth->fetchrow_hashref) {
				push @ret, $ref;
			}
			return \@ret;
		} elsif ($self->{'methods'}{$meth}->{ret} == WANT_AUTO_INCREMENT) {

			my $cur_dbd = $self->{_dbh}->{Driver}->{Name};
			unless ($cur_dbd) { return $self->_error("Unknown DBD '".$cur_dbd."'"); }

			# TODO: check DBD version to make sure it supports the index/auto_increment stuff

			if (lc $cur_dbd eq 'mysql') {
				#MySQL index/auto_increment hack
				if (defined $sth->{'mysql_insertid'}) {
					return $sth->{'mysql_insertid'};
				} else {
					return $self->_error("_sth_".$meth." could not get mysql_insertid from mysql DBD");
				}
			}
			elsif (lc $cur_dbd eq 'pg') {
				#PostgreSQL index/auto_increment hack
				if (defined $sth->{'pg_oid_status'}) {
					return $sth->{'pg_oid_status'};
				} else {
					return $self->_error("_sth_".$meth." could not get pg_oid_status from Pg DBD");
				}
			} else {
				return $self->_error("_sth_".$meth." is using DBD specific AUTO_INCREMENT on unsupported DBD");
			}
		} elsif ($self->{'methods'}{$meth}->{ret} == WANT_RETURN_VALUE) {
			return $rv;
		} else {
			return $self->_error("No such return type for ".$meth);
		}

        } else {
                return $self->_error("No such method: $AUTOLOAD");
        }
}

sub DESTROY ($) {
	my $self = shift;
	#do we have any methods?
	if (defined $self->{'methods'}) {
		#remember to bury statement handles
		foreach (keys %{$self->{'methods'}}) {
			#ignore if we haven't used a sth
			next if (defined $self->{'methods'}{$_}->{'noprepare'});
			#if the sth of a methods is defined it has been used
        	        if (defined $self->{'_sth_'.$_}) {
				#finish the sth
                	        $self->{'_sth_'.$_}->finish;
               		        print STDERR "$PACKAGE DEBUG: meth DESTROY - finished _sth_".$_." handle\n" if DEBUG;
               	 	}
		}
	}
	#and hang up if we have a connection
        if (defined $self->{'_dbh'}) { $self->_disconnect(); }
}

sub _connect {
        my $self = shift;

	my $data_source =	$self->{'_data_source'};
        my $user 	= 	$self->{'_user'};
        my $auth  	= 	$self->{'_pass'};
        my $attr  	= 	$self->{'_attr'};

	#$dbh = DBI->connect($data_source, $username, $auth, \%attr);

	#TODO: validate args
	if (defined $attr) {
		unless ((ref $attr) eq 'HASH') { die "argument 'attr' must be hashref"; }
	}

	print STDERR "$PACKAGE DEBUG: DBIx::LazyMethod doing: DBI->connect($data_source, $user, $auth, $attr);\n" if DEBUG;
	my $dbh  = DBI->connect($data_source, $user, $auth, $attr) or return $self->_error("Connection failure [".DBI::errstr."]");
	return $dbh;
}

sub _disconnect {
        my $self = shift;
        my $dbh = $self->{'_dbh'};

        unless (defined $dbh) { return TRUE }

        if (!$dbh->disconnect) {
                $self->_error("Disconnect failed [".DBI::errstr."]");
        } else {
		print STDERR "$PACKAGE DEBUG: Disconnected dbh\n" if DEBUG;
        }
	return TRUE;
}

sub _error {
        my ($self,$data) = (shift,shift);
	if ($data eq FALSE) {
        	delete $self->{'errorstate'};
       		$self->{'errormessage'} = "[unknown]";
	} else {
        	$self->{'errorstate'} = TRUE;
        	$self->{'errormessage'} = $data;
        	warn "$PACKAGE ERROR: ".$data;
	}
        return;
}

sub is_error ($) {
	my $self = shift;
	return (defined $self->{'errorstate'})?TRUE:FALSE;
}

1;

__END__