File Coverage

blib/lib/SQL/SqlObject.pm

Criterion	Covered	Total	%
statement	75	346	21.6
branch	35	178	19.6
condition	5	54	9.2
subroutine	16	38	42.1
pod	17	25	68.0
total	148	641	23.0

package SQL::SqlObject;

#use 5.006;
use strict;
use warnings;
use Carp;
use DBI;
use SQL::SqlObject::Config;

# 110803 - VERSION incremented to 0.02 for first CPAN release
# 101903 - fixed argument verification for insert_select
#        - added connection arg cacheing
#        - we now cache db_name, db_dsn and db_pre if they
#          are provided as arguments to connect_string() -cz
# 011003 - arguments for constructor now come from
#          SQL::SqlObject::Config -cz
# 010803 - added constuctor_args/process_contructror args -cz
# 010603 - added AUTOLOAD to pass through method calls -cz
# 052699 - Minor fix to Hashes Sub -cz

our $VERSION     = '0.02';
our %SqlConfig;  # read from SQL::SqlObject::Config

sub new
{

    # install confguration, if necessary
    unless (%SqlConfig)
    {
	no strict 'refs';
	*SQL::SqlObject::SqlConfig = \%SQL::SqlObject::Config::SqlConfig;
    }

    my ($class) = @_;
    my $self;


    # we don't really support clones...
    if (ref $class)
    {
	# clones must have us somwhere in their ancestory
	unless (UNIVERSAL::isa($class, __PACKAGE__))
	{
		Carp::confess (
			       "process_constructor_args: attemp to clone",
			       " from unrelated class: ", ref $class
			      );
	}

	($class) = $class =~ /(.*?)=/;
    }

    $self = bless {}, $class;
    $self->process_constructor_args(@_);
    # post construction initialization
    $self->_init if $self->can('_init');

    return $self;
}

sub clone { shift->new(@_) }

sub DESTROY { $_[0]->disconnect }

sub process_constructor_args
{

    unless (@_>1) {
	Carp::confess "process_constructor_args: wrong number of parameters"
    }

    my $self  = shift;
    my $class = shift;

    # coerse input to hash reference
    my $args = {};
    if ($_ = ref $_[0])
    {
	if (/HASH/)
	{
	    while (my ($k, $v) = each %{ $_[0] })
	    {
	        my $arg_ix = SQL::SqlObject::Config::arg_index($k);
	        $k =~ y/A-Z-/a-z/d;
		$args->{$SqlConfig{ARGS}[ $arg_ix ][0]} = $v;
	    }
	}

	elsif (/ARRAY/)
	{
	    $args = {
		     map { $SqlConfig{ARGS}[$_][0] => $_[0][$_] } 0..$#{$_[0]}
		    };
	}

	else
	{
	    Carp::Confess (q(process_constructor_args encountered ),
			   q(unexpected reference type ), $_);
	}
    }

    elsif (@_)
    {
	if ($_[0] =~ /^-/)
	{
	    # input aleardy in key-value format
	    if (@_ % 2)
	    {
		Carp::confess ('process_constructor_args uneven number ',
			       'of input parameters')
	    }

	    for (my $input_ix = 0; $input_ix < @_; $input_ix += 2 )
	    {
		my $arg_ix = SQL::SqlObject::Config::arg_index($_[$input_ix] );
		$args->{ $SqlConfig{ARGS}[ $arg_ix ][0] } = $_[ $input_ix + 1 ];
	    }
	}

	else
	{
	    # input in ordered list format
	    for (0..$#_)
	    {
		$args->{ $SqlConfig{ARGS}[$_][0] } = $_[$_];
	    }
	}
    }

    # now try to supply values for all args
    ARG: for my $arg_id ( 0..$#{ $SqlConfig{ARGS} })
    {
	my $name = $SqlConfig{ARGS}[$arg_id][0];

	# see value if value was supplied as an argument
	if (exists $args->{$name})
        {
	    $self->$name( $args->{$name} );
	    next ARG;
	}

	# if we're cloning look at the parent object first
	if (ref $class and defined $class->$name)
	{
	    $self->$name($class->$name);
	    next ARG;
	}

	# search env variables if any we're supplied
	if ($SqlConfig{ARGS}[$arg_id][2])
	{
	    my $env = $SqlConfig{ARGS}[$arg_id][2];

	    if (ref $env)
	    {
		ENV: for (@$env)
		{
		    next ENV unless exists $ENV{$_};
		    $self->$name( $ENV{$_} );
		    next ARG;
		}
	    }

	    else
	    {
		if (exists $ENV{$env})
		{
		    $self->$name( $ENV{$env} );
		    next ARG;
		}
	    }
	}

	# use default if one was provided
	if ($SqlConfig{ARGS}[$arg_id][3] and
	    $_ = $SqlConfig{ $SqlConfig{ARGS}[$arg_id][3] })
	{
	    $self->$name( $_ );
	    next ARG;
	}
    }

    return $self;
}

# is_connected: toggled on  by dbh
#                       off by disconnect
sub is_connected : lvalue { $_[0]->{connected_P} }

# primary flock of accessors
sub db_name        : lvalue { delete $_[0]->{__connection_args};
                              $#_ and $_[0]->{name}   = $_[1]; $_[0]->{name}}
sub db_name_prefix : lvalue { delete $_[0]->{__connection_args};
                              $#_ and $_[0]->{pre}    = $_[1]; $_[0]->{pre}}
sub db_dsn         : lvalue { delete $_[0]->{__connection_args};
                              $#_ and $_[0]->{dsn}    = $_[1]; $_[0]->{dsn}}
sub db_user        : lvalue { delete $_[0]->{__connection_args};
                              $#_ and $_[0]->{user}   = $_[1]; $_[0]->{user}}
sub db_password    : lvalue { delete $_[0]->{__connection_args};
                              $#_ and $_[0]->{passwd} = $_[1]; $_[0]->{passwd}}
sub Error          : lvalue { $#_ and $DBI::errstr    = $_[1]; $DBI::errstr}
sub dbh            : lvalue
{
  unless ($_[0]->is_connected) {
    $_[0]->{dbh} = $_[0]->connect;
    $_[0]->is_connected = 1;
  }

  $_[0]->{dbh}
}

sub connect
{

    my $self = shift;

    if (@_)
      # cache the arguments, in case we have to reconnect
      # as seems to be needed for insert_select
      {
	$self->{__connection_args} = [ @_ ];
      }

    elsif ($self->{__connection_args})
      # load the connection args from the cache
      {
	@_ = @{ $self->{__connection_args} }
      }

    my $connect_string = $self->connect_string(@_);

    $self->is_connected and $self->disconnect;

    my $dbh  = DBI->connect($connect_string,$self->db_user,$self->db_password);

    my $err = $self->Error;
    $err and Carp::confess (
			    q(Whoops - couldn\'t connect to ),
			    $_[0] || $self->db_name, "\n",
			    'Error:', $err
			   );

    return $dbh;
}

# build the connect string
sub connect_string
{
    my ($self, $name, $dsn, $pre) = @_;

    $self->db_name        ||= $name if $name;
    $self->db_dsn         ||= $dsn  if $dsn;
    $self->db_name_prefix ||= $pre  if $pre;

    defined $name or $name = $self->db_name;
    defined $dsn  or $dsn  = $self->db_dsn
      or Carp::confess "No data source named for SqlObject connect string";
    defined $pre  or $pre  = $self->db_name_prefix;

    my $other = '';
    if ($SqlConfig{OTHER_ARGS})
    {
        if (ref $SqlConfig{OTHER_ARGS})
	{
	    for (@{$SqlConfig{OTHER_ARGS}})
	    {
	      my $val = $self->$_ or next;
	      my ($key) = (/^(?:.*?_)?(.*)$/);
	      $other .= "$SqlConfig{OTHER_ARG_SEP}$key=$val";
	    }
	}

	else
	{
	    my $meth = $SqlConfig{OTHER_ARGS};
	    my $val  = $self->$meth;
	    $other = "$SqlConfig{OTHER_ARG_SEP}$SqlConfig{OTHER_ARGS}=$val"
	      if defined $val;
	}
    }

    return "$dsn:$pre$name$other";
}

sub disconnect
{
    my $self = shift;

    if(exists $self->{'dbh'})
    {
	$self->dbh->disconnect;
	$self->is_connected = '';
	delete $self->{'dbh'};
    }
}

sub hash
{
    unless (@_==2) {
	Carp::confess qq(SqlObject: wrong number of arguments for hash);
    }

    my ($self,$query) = @_;

    my $sth = $self->prepare($query);
    $sth->execute();

    my $href = $sth->fetchrow_hashref;
    $sth->finish;

    return unless defined $href;
    return wantarray ? %$href : $href;
}

sub hashes
{
    if (@_<2 or @_>3) {
	Carp::confess "SqlObject: wrong number of arguments for hashes"
    }
    my ($self,$query,$cref) = @_;

    my $sth = $self->prepare($query); $sth->execute();

    if($cref)
    {
	my $href;
	$cref->($href) while $href = $sth->fetchrow_hashref;

	$sth->finish();
	return;
    } else
    {
	my @AoH = @{ $sth->fetchall_arrayref( {} ) };
	$sth->finish();

	return wantarray ? @AoH : \@AoH;
    }
}

sub array
{
    unless (@_==2) {
	Carp::confess "SqlObject: wrong number of arguments for array"
    }

    my $self  = shift;
    my $query = shift;

    my $sth = $self->prepare($query);

    if (my $err = $self->Error)
    {
	Carp::confess ("SqlObject: bad SQL for array \n",
		       "Query: '$query'\nError: '$err'")
    }

    $sth->execute();

    my @arr = $sth->fetchrow_array();
    $sth->finish;

    return wantarray ? @arr : \@arr;
}

#
# Execute the query and return a single element
#
sub value
{
    unless (@_==2) {
	Carp::confess "SqlObject: wrong number of arguments for value"
    }

    my $self  = shift;
    my $query = shift;

    my $sth = $self->prepare($query);

    if (my $err = $self->Error)
    {
	Carp::confess ("SqlObject: bad SQL for value \n",
		       "Query: '$query'\nError: '$err'")
    }

    $sth->execute();

    my ($val) = $sth->fetchrow_array;
    $sth->finish;

    return $val;
}

#
# Execute the query and return the first element of each result row
#
sub list {
    unless (@_==2) {
	Carp::confess "SqlObject: wrong number of arguments for list"
    }

  my $self  = shift;
  my $query = shift;

  my $sth = $self->prepare($query);

    if (my $err = $self->Error)
    {
	Carp::confess ("SqlObject: bad SQL for list \n",
		       "Query: '$query'\nError: '$err'")
    }

  $sth->execute();

  my @vals;
  push @vals, $_ while ($_) = $sth->fetchrow_array;
  $sth->finish;

  return wantarray ? @vals : \@vals;
}


sub delete {

    unless (@_>1 and @_<4)
    {
	Carp::confess "SqlObject: wrong number of arguments for delete"
    }

    my ($self,$table,$href) = @_;
    my ($err, $query);

    $self->_sql_quote_hash($href) if defined $href and ref $href;

    $query = $self->_sql_delete_query($table,$href);
    $self->do($query);
    $err = $self->Error();

    if ($err = $self->Error)
    {
	Carp::confess ("SqlObject: delete error\n",
		       "Query: '$query' Error: '$err'")
    }
}

sub insert
{
    unless (@_==3)
    {
	Carp::confess "SqlObject: wrong number of arguments for insert"
    }

    my ($self, $table, $href) = @_;
    my ($err, $query);

    $self->_sql_quote_hash($href);

    $query = $self->_sql_insert_query($table,$href);
    $self->do($query); $err = $self->Error();

    if ($err = $self->Error)
    {
	Carp::confess ("SqlObject: insert error\n",
		       "Query: '$query'\nError: '$err'")
    }
}

sub cond_insert {
    unless (@_>2 and @_<4)
    {
	Carp::confess "SqlObject: wrong number of arguments for insert"
    }

    my ($self, $table, $href, $whref) = @_;
    my ($found,$err, $exists_query);

    $self->_sql_quote_hash($href);

    if ($whref)
    {
	$self->_sql_quote_hash($href);
	$exists_query =
	    $self->_sql_select_query($table,[keys %$whref], $whref);
    } else
    {
	$exists_query =
	    $self->_sql_select_query($table, [keys %$href], $href);
    }

    $found = $self->value($exists_query);
    $err = $self->Error();

    if ($err)
    {
	Carp::confess ("SqlObject cond_insert exists error\n",
		       "Query: $exists_query\nError: $err")
    }

    return if $found;

    my $insert_query = $self->_sql_insert_query($table,$href);
    $self->do($insert_query);
    $err = $self->Error();
    if ($err)
    {
	Carp::confess ("SqlObject insert error\n",
		       "Query: $insert_query\nError: $err")
    }

    return 1;
}


sub insert_select {

    unless (@_>2 and @_ < 5)
    {
	Carp::confess "SqlObject: wrong number of arguments for insert_select"
    }

    my ($self, $table, $href, $column) = @_;
    my ($err, $insert_query);

    $column ||= join '_', $table, 'id';
    $column =~  s/^.*?(\w+)_id$/$1_id/;

    $self->_sql_quote_hash($href);

    $insert_query = $self->_sql_insert_query($table,$href);
    $self->do($insert_query);
    $err = $self->Error();

    if ($err)
    {
	Carp::confess ("SqlObject insert_select insert error\n",
		       "Query: $insert_query\nError: $err")
    }

    my $select_query = $self->_sql_select_query($table,[$column],$href);
    return $self->value($select_query);
}

sub cond_insert_select {

    unless (@_>2 and @_<6)
    {
	Carp::confess "SqlObject: wrong number of arguments for cond_insert_select"
    }

    my ($self, $table, $href, $arg4, $arg5) = splice @_, 0, 3;
    my ($whref,$column, $found, $err, $exists_query);

    $self->_sql_quote_hash($href);

    if (@_ == 1)
    {
	# we have whref or column but not both
	if (ref $_[0])
	{
	    $whref  = shift;
	}

        else
	{
	    $column = shift;
	}
    }
    elsif (@_ ==2)
    {
	# we have both	$whref = shift;
	$column = shift;
	last;
    }
    else
    {
	# we have neither
	$column = join '_',$table,'id';
    }

    if ($whref)
    {
	$self->_sql_quote_hash($href);
	$exists_query = $self->_sql_select_query($table, [$column], $whref);
    }
    else
    {
	$exists_query = $self->_sql_select_query($table, [$column], $href);
    }

    $found = $self->value($exists_query);
    $err = $self->Error();

    if ($err)
    {
	Carp::confess ("SqlObject cond_insert_select exists error\n",
		       "Query: $exists_query\nError: $err")
    }

    return $found if $found;

    my $insert_query = $self->_sql_insert_query($table,$href);
    my $select_query = $self->_sql_select_query($table,[$column],$href);

    $self->do($insert_query);
    $err = $self->Error();

    if ($err)
    {
	Carp::confess ("SqlObject insert_select insert error\n",
		       "Query: $insert_query\nError: $err")
    }

    return $self->value($select_query);
}

sub update
{

    unless (@_>2 and @_<5)
    {
	Carp::confess "SqlObject: wrong number of arguments for update"
    }

    my ($self, $table, $shref, $whref) = @_;
    my($err, $query);


    $self->_sql_quote_hash($shref);
    $self->_sql_quote_hash($whref) if defined $whref && ref $whref;

    $query  = $self->_sql_update_query($table,$shref,$whref);
    $self->do($query);
    $err = $self->Error();

    if ($err)
    {
	Carp::confess ("SqlObject update error\n",
		       "Query: $query\nError: $err")
    }
}


## Here be the private methods

sub _sql_quote_hash
{
    my $href = pop;

    while ( my ($k,$v) = each %$href)
    {
	$v =~ s|^'||;
	$v =~ s|'$||;
	$v =~ s|'|''|g;
	$v =  qq('') if $v=~/^\s*$/;
	$v =  qq('$v') if $v=~/[^0-9]/ and $v!~/^null$/i;
	$href->{$k}=$v;
    }
}

sub _sql_insert_query
{
    return unless @_ > 2;

    my ($self, $table, $href) = @_;

    my ($columns,$values);
    while (my ($k,$v)=each %$href)
    {
	$columns .= "$k,";
	$values  .= "$v,";
    }
    $columns =~ s|,$||;
    $values  =~ s|,$||;

    return qq(insert into $table ($columns) values($values));
}

sub _sql_select_query {
    return unless @_ > 2;

    my ($self,$table,$aref,$href) = @_;
    my $columns = join ',',@$aref;
    my $where;

    while (my ($k,$v)=each %$href)
    {
	    $where .= qq($k = $v and );
    }
    $where =~ s|\s*and\s*$||;

    return qq(select $columns from $table where $where);
}

sub _sql_delete_query
{
    return unless @_ > 1;

    my ($self, $table, $href) = @_;
    return "delete from $table" if $href == undef;

    my $where;
    while (my ($k,$v)=each %$href) {
	$where .= qq($k = $v and );
    }
    $where =~ s|\s*and\s*$||;

    return qq(delete from $table where $where);
}

sub _sql_update_query {
    return unless @_ > 2;

    my ($self, $table, $shref, $whref) = @_;

    my ($set,$where);
    while (my ($k,$v)=each %$shref)
    {
	$set .= qq($k = $v, );
    }
    $set =~ s|\s*,\s*$||;

    if (ref $whref)
    {
	while (my ($k,$v)=each %$whref)
        {
	    $where .= qq($k = $v and );
	}
	$where=~ s|\s*and\s*$||;
	$where = "where $where";
    }

    return qq(update $table set $set $where);
}

our $AUTOLOAD;
sub AUTOLOAD
{
    $AUTOLOAD =~ /::([a-zA-Z_][a-zA-Z_0-9]+)$/;
    my $func = $1 or do
    {
	my @caller = caller;
	die (qq[Database Handle unable to dispatch.\n],
	     qq[Method $AUTOLOAD called by $caller[1] line $caller[2].\n]);
    };

    my $self = shift;
    my $result;

    if (my $dbh  = eval { $self->dbh })
    {
	$result = eval { $dbh->$func(@_) };
    }

    if ($@)
    {
	# error while calling DBI function
	my @caller = caller;
	my $err = ref $_[0] && UNIVERSAL::isa($_[0],__PACKAGE__)
	          ? $_[0]->Error
		  : 'no object';
	die (qq[Database Handle encountered an error executing $func.\n],
	     qq[$AUTOLOAD called by $caller[1] line $caller[2].\n],
	     qq[Error: $@.\n],
	     qq[DBI Error: $err.\n]);
    }

    return $result;
}

1;

__END__