#####
#      Synopsis -
#         use modDB ('Oracle','dbname','username','pass',{ flags=>'' });
#
#		If the same DSN, username, and flags are passed more than once,
#		modDB will not connect to the database again, it will cache the $dbh.
#
#

package modDB;

use DBI;
use strict;
use Carp qw(cluck);
use vars ('%db_cache');


my ($dbh,$CONTROL,$DEBUG,$DIE_ON_ERR,@ERRORS,%db_con,$hits);

   #########################################################################
   #   CONTROL                  		   #   DEBUG 	       #   DIE_ON_ERR   #
   #      0	= None                     #      0	= None    #      0			#
   #      1	= Read Only  (select)      #      1	= Selects #      1			#
   #      2	= Write Only (ins/upd/del) #      2	= Writes  #                #
   #      3	= Read/Write (normal mode) #      4	= Errors  #                #
   #                                   #          		    #                #
   #########################################################################

   $CONTROL    = 3;      # Default: read and write

   $DEBUG      = 6;      # Default: write and errors
   $DIE_ON_ERR = 0;      # Default: don't die on error





###################################################################################
#
#   Retrieval functions
#      - fetchHashref
#      - fetchCol
#      - fetchColArrayref
#      - fetchRow
#      - fetchHashrefList
#      - fetchArrayrefList
#

sub fetchRow
{  my $query = shift;
   my @binds = @_ ;
   my @rlist;

   (1 & $CONTROL) || return   warnDisabled($query);
   (1 & $DEBUG)   &&          warnQuery($query,@binds);

while(1){
   &Reconnect unless $dbh;
   eval { @rlist = $dbh->selectrow_array($query,undef,@binds); };
  last if(!$@ || $@ !~ /Lost connection to MySQL server during/);
  warn "Lost connection :$@: Going to retry";
}
  $hits++;
        return @rlist unless $@;

   (4 & $DEBUG) && warnError($query,@binds);
   return;
}


sub fetchHashref
{  my $query = shift;
   my @binds = @_; 
   my $href;

   (1 & $CONTROL) || return   warnDisabled($query);
   (1 & $DEBUG)   &&          warnQuery($query,@binds);

while(1)
{
   &Reconnect unless $dbh;
   eval {
      my $cmd = ref($query) eq "DBI::st" ? $query : $dbh->prepare($query);
     $cmd->execute(@binds);
      $href = $cmd->fetchrow_hashref('NAME_lc');
      $cmd->finish;
   };
  $hits++;
  last if(!$@ || $@ !~ /Lost connection to MySQL server during/);
  warn "Lost connection :$@: Going to retry";  
} 
 
  if ($@) {
      (4 & $DEBUG) && warnError($query,@binds);
      return;
   }   
  return $href || {};
  #return {map{(lc($_)=>$$href{$_})} keys %$href};
}


sub fetchCol
{  my $query = shift;
   my @binds = @_; 
   my $rval;

   (1 & $CONTROL) || return   warnDisabled($query);
   (1 & $DEBUG)   &&          warnQuery($query,@binds);
while(1){

   &Reconnect unless $dbh;
   eval {
      $rval = ($dbh->selectrow_array($query,undef,@binds))[0];
   };
  $hits++;

  last if(!$@ || $@ !~ /Lost connection to MySQL server during/);
  warn "Lost connection :$@: Going to retry";
}
   return $rval unless $@;
   
   (4 & $DEBUG) && warnError($query,@binds);
   return;
}



sub fetchColArrayref
{  my $query = shift;
   my @binds = @_ ;#|| '';
   my @rlist;

   (1 & $CONTROL) || return   warnDisabled($query);
   (1 & $DEBUG)   &&          warnQuery($query,@binds);
while(1){

   &Reconnect unless $dbh;
   eval {
      my $sth = ref($query) eq "DBI::st" ? $query : $dbh->prepare($query);
      $sth->execute(@binds);

      while (my $val = ($sth->fetchrow)[0]) {
         push @rlist, $val;
      }
      $sth->finish;
   };
  $hits++;
  last if(!$@ || $@ !~ /Lost connection to MySQL server during/);
  warn "Lost connection :$@: Going to retry";
}
   return \@rlist unless $@;

   (4 & $DEBUG) && warnError($query,@binds);
   return;
}

sub fetchColsref
{ my $query = shift;
  my @binds = @_;
  my @rlist;
  (1 & $CONTROL) || return   warnDisabled($query);
  (1 & $DEBUG)   &&          warnQuery($query,@binds);

while(1){
  &Reconnect unless $dbh;
  eval {
      my $sth = ref($query) eq "DBI::st" ? $query : $dbh->prepare($query);
      $sth->execute(@binds);
 
      while (my $val = ($sth->fetchrow)[0]) {
      	push @rlist, $val;
      }
      $sth->finish;
   };
  $hits++;
  last if(!$@ || $@ !~ /Lost connection to MySQL server during/);
  warn "Lost connection :$@: Going to retry";
}
   return \@rlist unless $@;

   (4 & $DEBUG) && warnError($query,@binds);
   return;
}

sub fetchCols
{  my $query = shift;
   my @binds = @_ ;#|| '';
   my @rlist;

   (1 & $CONTROL) || return   warnDisabled($query);
   (1 & $DEBUG)   &&          warnQuery($query,@binds);

while(1){
   &Reconnect unless $dbh;
   eval {
      my $sth = ref($query) eq "DBI::st" ? $query : $dbh->prepare($query);
      $sth->execute(@binds);

      while (my $val = ($sth->fetchrow)[0]) {
         push @rlist, $val;
      }
      $sth->finish;
   };
  $hits++;
  last if(!$@ || $@ !~ /Lost connection to MySQL server during/);
  warn "Lost connection :$@: Going to retry";
}
   return @rlist unless $@;

   (4 & $DEBUG) && warnError($query,@binds);
   return;
}


sub fetchHashrefList
{  my $query = shift;
   my @binds = @_ ;
   my @rlist;

   (1 & $CONTROL) || return   warnDisabled($query);
   (1 & $DEBUG)   &&          warnQuery($query,@binds);

while(1){
   &Reconnect unless $dbh;
   eval
   {  my $sth = ref($query) eq "DBI::st" ? $query : $dbh->prepare($query);
      $sth->execute(@binds);
      while (my $href = $sth->fetchrow_hashref('NAME_lc'))
      {   push @rlist, $href;                                  #{map{(lc($_)=>$$href{$_});} keys %$href};
		}
      $sth->finish;
   };
  $hits++;
  last if(!$@ || $@ !~ /Lost connection to MySQL server during/);
  warn "Lost connection :$@: Going to retry";
}
	 return @rlist unless $@;
   
   (4 & $DEBUG) && warnError($query,@binds);
   return;
}

sub fetchArrayrefList
{  my $query = shift;
   my @binds = @_ ;
   my $rval;

   (1 & $CONTROL) || return   warnDisabled($query);
   (1 & $DEBUG)   &&          warnQuery($query,@binds);
while(1)
{
   &Reconnect unless $dbh;
   eval { $rval = $dbh->selectall_arrayref($query,undef,@binds); };
  last if(!$@ || $@ !~ /Lost connection to MySQL server during/);
  warn "Lost connection :$@: Going to retry";
}

  $hits++;
   return $rval unless $@;

   (4 & $DEBUG) && warnError($query,@binds);
   return;
}


sub execWhile
{
   my ($query,$code,@args) = @_;
   my (@ret,$sth);

	(1 & $CONTROL) || return warnDisabled($query);
	(1 & $DEBUG)   &&        warnQuery($query);

	return warnString('Not a code ref') unless ref($code) eq 'CODE';
while(1){

   &Reconnect unless $dbh;
   eval
   {
      $sth = $dbh->prepare($query);
      $sth->execute;
      while(my $href = $sth->fetchrow_hashref) 
      {   push @ret, &{$code}($href,@args);
      }
      $sth->finish;
	};

  last if(!$@ || $@ !~ /Lost connection to MySQL server during/);
  warn "Lost connection :$@: Going to retry";
}
  $hits++;
	return @ret unless $@;

	(4 & $DEBUG) && warnError($query);
	return;
}




########################################################################
#
#   dbDo -   Takes an SQL statement string OR a prepared statement handle
#            and a list of params to bind to it.
#   dbQuote - Quote a string. Memoize it.
#

sub dbDo
{
   my ($query,@params) = @_;
   my ($stmt)     = $query;
   my ($rows);


   (2 & $CONTROL) || return   warnDisabled($stmt);
   (2 & $DEBUG)   &&          warnQuery($stmt,@params);
while(1)
{
   eval { $rows = ref($query) eq 'DBI::st' ? $query->execute(@params) : $dbh->do($query,undef,@params);  };
  $hits++;
  last if(!$@ || $@ !~ /Lost connection to MySQL server during/);
  warn "Lost connection :$@: Going to retry";
}


   return $rows unless $@;

   push @ERRORS, sprintf "%s failed",(caller(0))[3];
   (4 & $DEBUG) && warnError($stmt,@params);
   return;
}


sub dbQuote
{   $dbh->quote(shift());
}

sub dbUse
{  
        my ($query,@params) = @_;
        my $str = $dbh->prepare($query,@params);        
  $hits++;
        return $str;
} 






######################################################################
#
#   Functions to print debugging info to STDERR
#      - warnError($query)      - Error, query, caller, and stack trace
#      - warnQuery($query)      - Just query and caller
#      - warnDisabled($query)   - CONTROL error, query, and caller
#

sub warnError
{ 
  my $q = shift;
  my @binds = @_; 
  printf STDERR  "\nE---------------Error----------------\n%s".
                  "\nE---------------Query----------------> (%s)\n%s\n(%s)\n".
                  "\nE---------------Trace----------------\n",
      $@,(caller(1))[3],$q,join (',',@binds);
   print STDERR get_callers();
   die            "\nE---------------Dying----------------\n" if $DIE_ON_ERR;
}


sub warnQuery
{  
   my $q = shift; 
   my @binds = @_;	
   printf STDERR  "\nQ---------------Query----------------> (%s)\n%s\n(%s)\n\n",
      (caller(1))[3],ref($q) eq 'DBI::st' ? $q->{Statement}: $q, join (',',@binds);
   die            "\nQ---------------Dying----------------\n" if $DIE_ON_ERR;
}



{   my @status = ('DISABLED','READ ONLY','WRITE ONLY');
   
	sub warnDisabled
	{  my $desc = $status[($CONTROL <=> 1)+1];
	     printf STDERR  "\nD---------------Error----------------\n".
	                    "Query Failed: Database %s\n".
	                    "\nD---------------Query----------------> (%s)\n%s\n\n",
	            $desc,(caller(1))[3],shift;
	      push @ERRORS, "Database $desc";
	      die            "\nD---------------Dying----------------\n" if $DIE_ON_ERR;
	      return undef;
	}
}


sub warnString
{
   printf STDERR "\nS---------------Error----------------\n%s".
                 "\nS---------------Query----------------> (%s)\n%s\n",
                 $_[0],(caller(1))[3],$_[1];
	die           "\nS---------------Dying----------------\n" if $DIE_ON_ERR;
	return undef;
}


#####################################################################
#
#   Import function
#      Infects the namespace of the caller with the functions listed
#      in @default_export. Also takes parameters from the use statement
#      to connect to the database.
#


my $dbCacheKey;
my @def_export  = qw( fetchHashref      fetchHashrefList
                      fetchRow          fetchCol	fetchCols
                      fetchColArrayref  fetchArrayrefList
                      dbDo      dbQuote      dbErr
                      dbDebug   dbControl    dbInsertId
	dbErrReset	dbUse					 dbDSN
	dbHits	dbHitsReset
	import
                  );

sub import
{  
	################################################################################
	#	Two functions here:
	#		- Manage database handle caching
	#		- Export functions into the caller's namespace
	#
	#	The first argument is the package name. Don't care, kill it with a shift.
	#	Next we shift in the args for type, dbname, user and pass.
	#	Make the dsn from the type and dbname.
	#	Merge the def_flags hash with the flags hash argument. This will override any
	#		default flags if applicible.
	#	Make the cache hash key with this info. If a connection has already been made
	#	with this info, use that as the $dbh, otherwise connect to the db and cache
	#	the handle.
	#
	#	Now export functions into the caller's name space.
	shift;
      $db_con{$_}       = shift for qw(type name user pass host port);              
   $db_con{port} ||= '3306';
   $db_con{host} ||= 'localhost'; 
   $db_con{dsn}      = "DBI:$db_con{type}:$db_con{name}:$db_con{host}:$db_con{port}";      # create dsn

	my $def_flags     = getDefFlags($db_con{type});

   %{$db_con{flags}} = (%$def_flags, $_[0] ? %{$_[0]} : ());    # use new flags

	$dbCacheKey  = "$db_con{dsn}:$db_con{user}";
	$dbCacheKey .= ":$_:$db_con{flags}->{$_}" for (keys %{$db_con{flags}});

	if ($db_cache{$dbCacheKey})
	{	$dbh = $db_cache{$dbCacheKey};				## Used cached db conn ##
	}
	else
	{															## Connect to database ##
   	eval { $db_cache{$dbCacheKey} = $dbh =
					DBI->connect(@db_con{qw(dsn user pass flags)}); };
		die "$DBI::errstr $@\n" if ($@);
	}


	## Exporting stuff ##
   no strict 'refs';
   for (@def_export)
   {  my ($pre,$name) = /(\*\$\%\@\&)?(.+)/;        # Find out what type they are
      $pre = '&' unless $pre;                       # Assume sub if not specified
      my ($dest) = '*' . caller() . '::' . $name;   #   *namespace::function
      *$dest = eval "\\$pre$name";                  # alias this baby into existence
   }
}

sub Reconnect
{
	eval {$db_cache{$dbCacheKey} = $dbh =
       	         DBI->connect(@db_con{qw(dsn user pass flags)}); 
	};
      		die "$DBI::errstr\n" if ($@);
	warn "*" * 30;
	warn "Had to RECONNECT";
	$dbh;
}





##########################################################################
#
#   Utility Functions
#

# Read only

sub dbDSN         {   $db_con{dsn}   }
sub dbUser        {   $db_con{user}  }
sub dbHits	  {   $hits          }

# Write only

sub dbErrReset	  {   @ERRORS = ();	};
sub dbHitsReset   {   $hits = 0;	};


# Read write
sub dbErr         {   push @ERRORS,@_; @ERRORS }
sub dbDebug       {   $DEBUG        = shift || $DEBUG;       $DEBUG      }
sub dbControl     {   $CONTROL      = shift || $CONTROL;     $CONTROL    }
sub dbDieOnErr    {   $DIE_ON_ERR   = shift || $DIE_ON_ERR;  $DIE_ON_ERR }

sub dbInsertId
{	if ($db_con{type} eq 'mysql')
	{	return $dbh->{mysql_insertid};
	}
	return undef;
}

sub clearHandleCache { %db_cache=(); }		 # Clear cached $dbh's

sub get_callers			# Returns a stack trace
{ my ($i,$rstr,@callers);
  while (caller($i++)) {push @callers,[caller($i++)] }
  $i=0;
  for (reverse @callers)
   { my ($pkg, $file, $line, $sub, $hasargs, $wantarray, $evaltext, $is_require, $hints, $bitmask) = @{$_};
     $rstr .= sprintf "%s%-30s   %s %20s [%3d] %s\n",'  'x($i),$sub,"\b\b"x($i),$file,$line,$wantarray ? '(wantarray)' : '';
     $i++;
   }
  return $rstr;
}


sub getDefFlags		# Get the default set of flags for a database type, return the hashref
{	return {
		mysql  => {RaiseError => 1, AutoCommit => 1},
		Oracle => {RaiseError => 1, AutoCommit => 0},
	}->{$db_con{type}};
}




END
{  $dbh || return;
   if (exists $db_con{flags}->{AutoCommit} && !$db_con{flags}->{AutoCommit}) {
      @ERRORS ? $dbh->rollback : $dbh->commit; 
      print STDERR __PACKAGE__." issued rollback due to errors" if @ERRORS;
   }
   $dbh->disconnect
}

##########################################################################################################
#	Perl Docs! :)
#


=head1 NAME

modDB - Simple Interface for DBI

=head1 SYNOPSIS

   use modDB ('Oracle','dbname','username','pass',{AutoCommit=>0});

   dbDebug(7);                         # Print all queries to STDERR.
   $val = dbQuote($otherval);          # Does $dbh->quote memoized.
   dbDo("update tbl1 set col1=$val");  # Does $dbh->do.

=head1 ABSTRACT

    When this module was created we were looking for a uniform way to
 handle database errors, perform rollbacks, give debugging information,
 and turn off access to the database if needed. What we ended up doing
 is wrapping evals around all of $dbh's (the database handle) method
 calls within our own functions. We trapped errors, reported them if the
 debugging level was high enough, and flagged for a rollback or commit.
 $dbh itself is not even available to ::main. All database transactions
 must be done through modDB. Not all of the methods for $dbh have
 associated modDB functions therefore some functionality is missing.

=head1 IMPLEMENTATION

    modDB exports a good portion of its functions automatically.
 Presently you can not specify which functions it will export. When
 specifying the use modDB statement, the following parameters are
 required: the database type (Oracle, mysql, etc.), database name,
 user name, password, and optionally a hashref of accepted flags as
 specified by DBD and DBI. Certain flags are assumed by default
 depending on the database type submitted. For example, with Oracle
 autocommit is off, for mysql it is on. If your program uses modDB
 more than once with the same paramaters, it will not connect to
 the database again but use a cached version of the $dbh.

    The functions that modDB exports all do their own error checking.
 Upon encountering an error, the error is added to an error array
 (accessible via the function dbErr()), depending on the debugging level
 a message may be sent to STDERR, and depending on the status of the
 die_on_err flag, the program may quit. If errors are encountered and
 the auto_commit flag is off, a rollback is sent to the database before
 the program quits. At any time you may call dbErr with string or array
 arguments and add your own errors to the error array. This will behave
 exactly like modDB had created the errors and thus cause a rollback.


=head1 SUBROUTINES


=head2 Data Retrieval Functions

    fetchHashref - Take an SQL query and return a hashref containing
    only the first row of the result set.

    fetchCol - Take an SQL query and return a scalar containing
    only the first column of the first row of the result set.

    fetchColArrayref - Take an SQL query and return an array
    containing only the first column of each row of the result set.

    fetchRow - Take an SQL query and return an array containing the
    data in the first row of the result set. Each array entry is
    a column. Same as $dbh->selectrow_array().

    fetchHashrefList - Take an SQL query and return an arrayref
    containing a hashref for every row of the result set.

    fetchArrayrefList - Take an SQL query and return an arrayref
    containing arrayrefs for every row of the result set. Same as
    $dbh->selectall_arrayref().

    execWhile - Take an SQL query, a code reference, and a list of
    arguments for the code ref. Loop through the result set and
    progressivly feed a row to the code ref via a hashref. Basically
    emulating while($href = $sth->fetchrow_hashref) { code }. This is
    still in beta mode, not sure if we want to proceed with the
    interface for this.

=head2 Assorted Functions

    dbDo - Take an SQL query and execute it, returning 1 on success
    or undef on failure. Previously you could pass a prepared
    statement handle to dbDo as well as a list of parameter and it
    would bind them before execution. Although the code is still there
    we do not do this anymore since your code should not have a
    statement handle, modDB should do it. Therefore we need to
    implement a way to mimic such behavior.

    dbQuote - Take a scalar and pass it to $dbh->quote. Memoize the
    results.

    dbDSN - Return the current DSN.

    dbUser - Return the current username used to connect to the database.

    dbErr - Optionally take a scalar or list of scalars and push them to
    the internal error array used for rolling back DB transactions. Return
    the current list of errors.

    dbDebug - Set and return the debugging level. Valid argument is a
    number 0-7. Explination follows in the DEBUG section.

    dbControl - Set and return the control level. Valid argument is a
    number 0-3. Explination follows in the CONTROL section.

    dbDieOnError - Set and return the die on error flag. Valid arguments
    are 1 and 0, corresponding to true and false.

    clearHandleCache - Remove the cached database handles.



=head1 DEBUG

      The debugging level is a value between 0 and 7. Basically there are
    three bits. Bit value 1 is select, bit value 2 is write, bit value 4 is
    error. Add the bit values together to get your debugging level. Therefore
    debugging level 6 is writes and errors. What this means is that when a
    query is executed, if it is a write to the database (insert/update/delete)
    the query will be printed to the error logs (since level 6 ANDs with 2).
    Likewise if there is an error, the error is sent to the error logs if the
    debugging level ANDs with 4. Therefore value 0 is no debugging, value 7
    means record every query to the error logs, even selects!

    This value may be changed at any time during execution via dbDebug($x).

       0 = None
       1 = Selects
       2 = Writes
       4 = Errors

=head1 CONTROL

       The control level is a value between 0 and 3. It uses the same bit
    string scheme used in DEBUG, but with one less combinations. Bit value 1
    is read access, value 2 is write access. Therefore value 0 is no access,
    and value 3 is all access. When a query function is called, it will check
    the control value to determine whether it should allow the query or not.
    If the function does not have access to execute the query due to the
    control value it will drop an error in the error logs. At some point this
    should be changed to look at the debug level before doing so.

    This value may be changed at any time during execution via dbControl($x).

       0 = None
       1 = Read
       2 = Write

=cut



1;