File Coverage

blib/lib/DBIx/PDlib.pm

Criterion	Covered	Total	%
statement	15	176	8.5
branch	0	118	0.0
condition	0	53	0.0
subroutine	5	19	26.3
pod	11	12	91.6
total	31	378	8.2

package DBIx::PDlib;

use 5.00503;
use strict;
use DBI;
use Carp;

require Exporter;
use vars qw($VERSION);

$VERSION = sprintf "%d.%03d", q$Revision: 1.9 $ =~ /(\d+)/g;
# $Date: 2004/03/15 13:46:14 $
# $Author: sjackson $

#############################################
# perl module to make sql operations easier #
#############################################

sub connect
{
	# options are exactly the same as DBI's
	my ($this) = shift;
	my $class = ref($this) || $this;

	# the connect code was borrowed heavily from DBIx::Abstract
	my($dbh,$data_source,$user,$pass);
	my $self = {};
	my ($config,$options) = @_;

	if (!defined($config))
	{
		croak "DBIx::PDlib->connect A connection configuration must be provided.";
	} elsif (ref($config) eq 'HASH') {
		if ($$config{'dbh'})
		{	# they provided the dbh connect string
			$dbh = $$config{'dbh'};
		} else {
			$user = $$config{'user'} || $$config{'username'};
			$pass = $$config{'password'} || $$config{'pass'};
			if (!defined($$config{'user'}) && $$config{'password'}) {
				$$config{'password'} = undef;
			}
			if (exists($$config{'dsn'})) {
				$data_source = $$config{'dsn'};
			} else {
				$$config{'driver'} ||= 'mysql'; # cause it's what I use
				$$config{'dbname'} ||= $$config{'db'} || '';
				$$config{'host'} ||= '';
				$$config{'port'} ||= '';
				$data_source = ___drivers($$config{'driver'},$config);
			}
		}
	} elsif (UNIVERSAL::isa($config,'DBI::db')) {
		$dbh = $config;
	} elsif (ref($config)) {
		croak "DBIx::PDlib->connect Config must be a hashref or a DBI object, not ".ref($config)."ref\n";
	} else {
		croak "DBIx::PDlib->connect Config must be a hashref or a DBI object, not a scalar.\n";
	}

	if ($data_source)
	{
		$dbh = DBI->connect($data_source,$user,$pass);
	} elsif (! $dbh) {
		croak "Could not understand data source.\n";
	}

	if (! $dbh) { return 0; }

	bless( $self, $class );

	if (ref($config) eq 'HASH' and !$$config{'dbh'})
	{
		$self->{'_dbh_args'} = {
			driver              => $$config{'driver'},
			dbname              => $$config{'dbname'},
			host                => $$config{'host'},
			port                => $$config{'port'},
			user                => $user,
			password            => $pass,
			data_source         => $data_source,
			};
	} else {
		$self->{'_dbh_args'} = { dbh => 1 };
	}
	$self->{'_dbh'} = $dbh;

	return $self;
}

sub ___drivers
{
	my ($driver,$config) = @_;
	my %drivers = (
		# Feel free to add new drivers... note that some DBD data_sources
		# do not translate well (eg Oracle).
		mysql       => "dbi:mysql:$$config{dbname}:$$config{host}:$$config{port}",
		msql        => "dbi:msql:$$config{dbname}:$$config{host}:$$config{port}",
		Pg          => "dbi:Pg:$$config{dbname}:$$config{host}:$$config{port}",
		# According to DBI, drivers should use the below if they have no
		# other preference.  It is ODBC style.
		DEFAULT     => "dbi:$driver:"
		);

	# Make Oracle look a little bit like other DBs.
	# Right now we only have one hack, but I can imagine there being
	# more...
	if ($driver eq 'Oracle') {
		$$config{'sid'} ||= delete($$config{'dbname'});
		$ENV{ORACLE_HOME} = $$config{'home'} unless (-d $ENV{ORACLE_HOME});
	}

	my @keys;
	foreach (keys(%$config)) {
		next if /^user$/;
		next if /^password$/;
		next if /^driver$/;
		push(@keys,"$_=$$config{$_}");
	}
	$drivers{'DEFAULT'} .= join(';',@keys);
	if ($drivers{$driver}) {
		return $drivers{$driver};
	} else {
		return $drivers{'DEFAULT'};
	}
}

sub raw_query
{
	#######################################################
	#######################################################
	##
	## This will allow you to send any raw SQL to the $dbh
	## handle. Mainly useful for CREATE and DROP type statements
	##

	ref(my $self = shift) or croak "instance variable needed";

	my $query = shift;

	# make sure connection is still up
	$self->_check_active_connection();

	my $return_value = $self->{_dbh}->do($query);
	return defined(wantarray()) ? ($return_value) : "";
}

sub iterated_select
{
	#######################################################
	#######################################################
	##
	## This will allow you to select a lot of stuff at once
	## usage should be self explanitory i hope =]
	##

	ref(my $self = shift) or croak "instance variable needed";

	my($select, $from, $where, $other) = @_;

	# make sure connection is still up
	$self->_check_active_connection();

	my $query = "SELECT $select ";
	$query .= "   FROM $from " if $from;
	$query .= "  WHERE $where " if $where;
	$query .= "        $other" if $other;

	my $handle = $self->{_dbh}->prepare($query);

	# If we can execute a statement then do it and send back the handle

	return $handle if ($handle->execute);

	# else we can finish things up and close the dbh
	my ($pkg,$file,$line) = caller;
	carp "Unable to execute handle at line $line in file $file package $pkg\n";
	$handle->finish;
	return;
}


sub select_hashref
{
	####################################################
	####################################################
	##
	## Useful SQL Select wrapper to cut down on code
	## in our friendly main scripts

	ref(my $self = shift) or croak "instance variable needed";

	my($select, $from, $where, $other) = @_;

	# make sure connection is still up
	$self->_check_active_connection();

	my $query = "SELECT $select ";
	$query .= "FROM $from " if $from;
	$query .= "WHERE $where " if $where;
	$query .= "$other" if $other;

	my $handle = $self->{_dbh}->prepare($query);

	unless ($handle->execute)
	{
		my ($pkg,$file,$line) = caller;
		carp "Unable to execute handle at line $line in file $file package $pkg\n";
		return;
	}
	my $hashref = $handle->fetchrow_hashref;
	$handle->finish;

	return $hashref;
}

sub select
{

	####################################################
	####################################################
	##
	## Useful SQL Select wrapper to cut down on code
	## in our friendly main scripts

	ref(my $self = shift) or croak "instance variable needed";

	my($select, $from, $where, $other) = @_;

	# make sure connection is still up
	$self->_check_active_connection();

	my $query = "SELECT $select ";
	$query .= "FROM $from " if $from;
	$query .= "WHERE $where " if $where;
	$query .= "$other" if $other;

	my $handle = $self->{_dbh}->prepare($query);

	unless ($handle->execute)
	{
		my ($pkg,$file,$line) = caller;
		carp "Unable to execute handle at line $line in file $file package $pkg\n";
		return;
	}
	my @array = $handle->fetchrow_array;
	$handle->finish;

	# return entire array if they're asking for an array,
	# otherwise return the first element
	return wantarray ? @array : $array[0];
}

sub select_all
{

	####################################################
	####################################################
	##
	## Useful SQL Select wrapper to cut down on code
	## in our friendly main scripts
	##
	## returns an array referance of all rows returns, containing
	## an array referance of columns returned for each row

	ref(my $self = shift) or croak "instance variable needed";

	my($select, $from, $where, $other) = @_;

	# make sure connection is still up
	$self->_check_active_connection();

	my $query = "SELECT $select ";
	$query .= "FROM $from " if $from;
	$query .= "WHERE $where " if $where;
	$query .= "$other" if $other;

	my $alldata = $self->{_dbh}->selectall_arrayref($query);
	if ($alldata)
	{
		return $alldata
	} else {
		my ($pkg,$file,$line) = caller;
		carp "Unable to execute handle at line $line in file $file package $pkg\n";
		return; # if there was an error, return nothing
	}
}

sub insert
{
	my ($pkg,$file,$line) = caller;
	####################################################
	####################################################
	##
	## Useful SQL Insert wrapper to cut down on code
	## in our friendly main scripts
	##
	## Usage: insert($tablename,$fields_array_ref,$values_array_ref);

	ref(my $self = shift) or croak "instance variable needed";

	my($table, $fields, $values) = @_;

	# make sure connection is still up
	$self->_check_active_connection();

	return unless ($table &&
	               (ref $fields eq "ARRAY") &&
	               (ref $values eq "ARRAY") &&
	               (@$fields == @$values)
	              );

	my $f_list = join(', ',@$fields);
	my $v_list = join(',', map { "?" } @$values );
	my $handle = $self->{_dbh}->prepare("INSERT INTO $table ($f_list) VALUES ($v_list)");
	if ($handle->execute(@$values))
	{	# will auto-quote stuff this way. pass 'undef' for NULL values
		$handle->finish;
		# return 1 (success) if they want a return value, or just return.
		return defined(wantarray()) ? (1) : "";
	} else {
		# couldn't execute it.
		carp "Unable to execute insert handle at line $line in file $file package $pkg\n";
		return;
	}
}

sub update
{
	my ($pkg,$file,$line) = caller;

	####################################################
	####################################################
	##
	## Useful SQL Update wrapper to cut down on code
	## in our friendly main scripts
	##
	## Usage: update($tablename,$fields_array_ref,$values_array_ref,$where_statement);

	ref(my $self = shift) or croak "instance variable needed";

	my($table, $fields, $values, $where) = @_;

	# make sure connection is still up
	$self->_check_active_connection();

	# they must give us everything. UPDATE's without $where are valid SQL, but
	# I see no reason we should have them called from any script using this
	# sql wrapper. So we make sure they give us some where statement,
	# and they can pass "$where=1" if they really know what they're doing.
	return unless ($table &&
	               (ref($fields) eq "ARRAY") &&
	               (ref($values) eq "ARRAY") &&
	               (@$fields == @$values) &&
	               $where
	              );
	my $query = "UPDATE $table SET " .
	            join(',', map { " $_ = ?" } @$fields ) .
	            " WHERE $where";

	my $handle = $self->{_dbh}->prepare($query);
	if ($handle->execute(@$values))
	{	# will auto-quote stuff this way.
		$handle->finish;
		# return 1 (success) if they want a return value, or just return.
		return defined(wantarray()) ? (1) : "";
	} else {
		# couldn't execute it.
		carp "Unable to execute update handle at line $line in file $file package $pkg\n";
		return;
	}
}

sub delete
{
	####################################################
	####################################################
	##
	## Useful delete wrapper to cut down on code
	## in our friendly main scripts

	ref(my $self = shift) or croak "instance variable needed";

	my($table,$where) = @_;

	# make sure connection is still up
	$self->_check_active_connection();

	if ($table && $where)
	{
		my $return_value = $self->{_dbh}->do("DELETE FROM $table WHERE $where");
		# return $return_value if they want a return value, or just return.
		return defined(wantarray()) ? ($return_value) : "";
	} else {
		return;
	}
}

sub quote
{
	## THIS SHOULDN'T BE NEEDED EXCEPT A FEW CASES (where statements)
	## MOST FUNCTIONS NEEDING QUOTING (inserts, updates)
	## WILL DO QUOTING THEMSELVES

	####################################################
	####################################################
	##
	## Useful for quoting text fields, since we don't
	## actually connect to DBI in the main scripts anymore
	## it's needed
	##
	## Usage:
	##	my @newvalues = quote(@values);
	##	my $firstquotedvalue = $newvalues[0];
	##	foreach (@newvalues) {
	##		# do something
	##	}

	ref(my $self = shift) or croak "instance variable needed";

	# make sure connection is still up
	$self->_check_active_connection();

	my(@toreturn);
	foreach my $toquote (@_)
	{
		my $temp = $self->{_dbh}->quote($toquote);
		push(@toreturn,$temp);
	}
	# return entire array if they're asking for an array,
	# otherwise return the first element
	return wantarray ? @toreturn : $toreturn[0];
}

sub disconnect
{
	ref(my $self = shift) or croak "instance variable needed";
	$self->{_dbh}->disconnect();
}

sub connected
{
	ref(my $self = shift) or croak "instance variable needed";
	my $rc = $self->{_dbh}->ping;
	return 1 if $rc;
}

sub _check_active_connection
{
	ref(my $self = shift) or croak "instance variable needed";

	unless ($self->connected())
	{	# we're not connected anymore, something died.
		if ($self->{_dbh_args}{data_source})
		{	# we can't do a reconnect if they passed in an active handle
			my $dbh = DBI->connect(
				$self->{_dbh_args}{datasource},
				$self->{_dbh_args}{user},
				$self->{_dbh_args}{password} );
			$self->{_dbh} = $dbh;
		}
	}
	# we could loop until ok, or return some error code if we're still
	# not connected, but I'm just hoping this fixes things. We've been getting:
#DBD::mysql::st execute failed: MySQL server has gone away at /usr/local/apache/public-dns.purifieddata.net/lib/PDlib_dns.pm line 64.
#Unable to execute handle at line 87 in file /usr/local/apache/public-dns.purifieddata.net/lib/utils_dns.pm package utils_dns
#[Tue Aug 19 22:20:07 2003] [error] Can't call method "fetchrow_array" on an undefined value at /usr/local/apache/public-dns.purifieddata.net/lib/utils_dns.pm line 88.
}


1;

__END__