File Coverage

blib/lib/EZDBI.pm

Criterion	Covered	Total	%
statement	21	156	13.4
branch	0	90	0.0
condition	1	20	5.0
subroutine	6	18	33.3
pod	8	8	100.0
total	36	292	12.3

package EZDBI;
use DBI;
use strict;
use Carp;
use vars ('$E', '@EXPORT', '$VERSION', '$MAX_STH');
require 5;

my $DBH;
*E = \$DBI::errstr;
my $sth_cache;   # string to statement handle cache
my $sth_cacheA;  # oldest first (LRU)  handle order
$VERSION = 0.13;

# Note that this package does NOT inherit from Exporter
@EXPORT = qw(Connect Delete Disconnect Insert Select Sql Update Use);
sub import {
  no strict 'refs';
  my ($package, %parms) = @_;
  my $caller = caller;

  #This is per database handle
  $MAX_STH = $parms{maxQuery} || 10;

  for my $func (@EXPORT) {
    *{"$caller\::$func"} = \&$func;
  }
}

sub Connect {
  my ($type, @args) = @_;
  unless( $type ){
    defined($DBH) ? return $DBH : croak "Not connected to a database";
  }

  if( ref($type) eq 'HASH' ){
    my $cfg = _parseIni(-file=>
			$type->{ini}||
			$ENV{'DBIX_CONN'}||
			$ENV{HOME}.'/.appconfig-dbi',
			-label=>$type->{label});
    @args = (
	     $cfg->{user},
	     $cfg->{pass},
	     $type->{attr} ? {%{$cfg->{attr}}, %{$type->{attr}}} : $cfg->{attr}
	    );
    $cfg->{dsn} =~ s/^dbi://i;
    if( $cfg->{dsn} =~ /\?$/ ){
      croak("Section '$type->{label}' requires a database name") unless
	exists($type->{database});
      $cfg->{dsn} =~ s/\?$/$type->{database}/;
    }
    $type = $cfg->{dsn};
  }
  if ($type =~ /^Pg:(.*)/ && $1 !~ /dbname=/) {
    $type = "Pg:dbname=$1";
  }
  unless ($DBH = DBI->connect("DBI:$type", @args)) {
    croak "Couldn't connect to database: $E";
  }
  $sth_cacheA->{$DBH} = [];
  return $DBH;
}

sub Delete {
  my ($str, @args) = @_;
  my $sth = _substitute('Delete', $str, scalar @args);
  my $rc;
  unless ($rc = $sth->execute(@args)) {
    croak "Delete failed: $E";
  }
  $sth->finish();
  $rc;
}

sub Disconnect {
  defined($DBH) || croak "Not connected to a database";
  my $dbh = $_[0] || $DBH;
  delete($_->{$dbh}) for ($sth_cache, $sth_cacheA);
  $DBH->disconnect();
  undef($_[0]);
  undef($DBH);
}

sub Insert {
  my ($str, @args) = @_;

  if( ref($args[0]) eq 'HASH' ){
    my %hash = %{shift @args};
    my @cols = sort keys %hash;
    $str .= sprintf('(%s) Values(??L) %s',
		    join(', ', @cols), defined($args[1]) ? $args[1] : '');
    @args = @hash{@cols};
  }

  my $sth = _substitute('Insert', $str, scalar @args);
  my $rc;
  unless ($rc = $sth->execute(@args)) {
    croak "Insert failed: $E";
  }
  $sth->finish();
  $rc;
}

# select '* from TABLE WHERE...'
#   Single column: returns list of scalar    in list   context
#   Multi  column: returns list of arrayrefs in list   context
#                  returns closure/object    in scalar context
# closure/object   returns indvidual records as arrayref or hashref
sub Select {
  my ($str, @args) = @_;
  my ($columns) = ($str =~ /^\s*(.*\S+)\s+from\s+/i);

  croak "Select in void context" unless defined wantarray;

  my $sth = _substitute('Select', $str, scalar @args);
  unless ($sth->execute(@args)) {
    croak "Select failed: $E";
  }

  my $r;
  if( wantarray ){
    $r = $sth->fetchall_arrayref;
    #XXX * on a single column Table? check length of first row?
    unless( $columns =~ /^\*/ || $columns =~ /,/ ){
      $_ = $_->[0] foreach @{$r};
    }
    $sth->finish();
    return @$r;
  }
  my $finish;
  $r = sub {
    $_ = ref($_[0]);
    my $res =
      /HASH/ ? $sth->fetchrow_hashref :
	/ARRAY/ ? $sth->fetchrow_arrayref :
	  /SCALAR/ ? 0 :
	    croak qq(Select doesn't understand "$_[0]");
    unless( $res || $finish){
      $sth->finish();
      $finish = 1;
      return 0;
    }
  };
  #XXX This object cannot be inherited
  bless $r, 'EZDBI::Select';
}
sub EZDBI::Select::DESTROY{
  $_[0]->(\"_");
}

# Freeform execution
sub Sql {
  defined($DBH) || croak "Not connected to a database";
  my $caller = caller;
  unless ($DBH->do(@_)) {
    croak "Sql failed: $E";
  }
}

sub Update {
  my ($str, @args) = @_;

  if( ref($args[0]) eq 'HASH' ){
    my %hash = %{shift @args};
    my @cols = sort keys %hash;
    unless($str =~ /\bset\b\s*$/i){
      $str .= ' Set'
    }
    $str .= ' ' . join(', ', map{"$_=?"}@cols) .
      (defined($args[1]) ? shift @args : '');
    @args = (@hash{@cols}, @args);
  }

  my $sth = _substitute('Update', $str, scalar @args);
  my $rc;
  unless ($rc = $sth->execute(@args)) {
    croak "Update failed: $E";
  }
  $sth->finish();
  $rc;
}

#Multiple databases, whee!
sub Use{
   ref($_[0]) eq 'DBI::db' ? $DBH = $_[0] : croak("Not a DBI handle: $_[0]");
}

#Private Methods
sub _parseIni{
  my %parm = @_;
  my $self;
  open(my $INI, $parm{'-file'}) || croak("$!: $parm{-file}\n");
  while( <$INI> ){
    next if /^\s*$|(?:[\#\;])/;
    if( /^\s*\[$parm{'-label'}\]/ ..
	(/^\s*\[(?!$parm{'-label'})/ || eof($INI) ) ){
      /^\s*([^=]+?)\s*=\s*(.*)$/;
      $self->{$1} = $2 if $1;
    }
  }
  #Handle DBIx::Connect attr construct
  foreach my $key ( grep {/^attr/} keys %{$self} ){
    my $attr = $key;
    $attr =~ s/^attr\s+//i;
    $self->{attr}->{$attr} = delete($self->{$key});
  }

  croak("Section [$parm{'-label'}] does not exist in $parm{'-file'}") unless
    keys %{$self};
  return $self;
}

# given a query string,
sub _substitute {
  defined($DBH) || croak "Not connected to a database";
  my($function, $str, $args) = @_;

  if( $function eq 'Insert' ){
    my $list = join ',' , (('?') x $args);
    unless( $str =~ s/\?\?L|\(\s*\?\?L\s*\)/($list)/ ){
      if( $str =~ /\bvalues\b/i ){
        $str .= "($list)" unless $str =~ /\)\s*$/;
      }
      elsif( $args ){
        $str .= " values ($list)";
      }
    }
  }

  my $subct = $str =~ tr/?/?/;
  if( $subct > $args ){
    croak "Not enough arguments for $function ($subct required)";
  }
  elsif( $subct < $args ){
    croak "Too many arguments for $function ($subct required)";
  }

  my $sth;
  # was the statement handle cached already?
  if( $sth = $sth_cache->{$DBH}->{$str} ){
    # remove it from the MRU queue (if it is there) and add it to the end
    unless( $sth_cacheA->{$DBH}->[-1] eq $str ){
      $sth_cacheA->{$DBH} = [grep($_ ne $str, @{$sth_cacheA->{$DBH}}), $str];
    }
  }
  else{
    # expire old cache items if cache is full
    if( scalar @{$sth_cacheA->{$DBH}} >= $MAX_STH -1 ){
      delete(@{$sth_cache->{$DBH}}{splice(@{$sth_cacheA->{$DBH}},0,$MAX_STH/3)});
    }

    # prepare new handle
    $sth = $DBH->prepare("$function $str");
    croak "Couldn't prepare query for '$function $str': $E; aborting" unless $sth;

    # install new handle in cache
    $sth_cache->{$DBH}->{$str} = $sth;
    push(@{$sth_cacheA->{$DBH}}, $str);
  }
  return $sth;
}

1;
__END__