# High Availability package for DBI
#
# Copyright (c) 2003-2006 Henri Asseily <henri@asseily.com>. All rights reserved.
# This program is free software; you can redistribute it and/or
# modify it under the same terms as Perl itself.

{
package DBIx::HA;

use 5.006000;

use constant DBIx_HA_DEBUG => $ENV{DBIX_HA_DEBUG} || 0;
use Data::Dumper;
use DBI 1.49 ();
use Sys::SigAction qw( set_sig_handler );
use Exporter ();
use strict;
use vars qw ( @ISA $prefix );
@ISA = qw ( DBI );

our $loaded_Apache = 0;
our $loaded_Apache_DBI = 0;
our $logdir;

BEGIN {
	$DBIx::HA::VERSION = 1.00;

	# Sample Fail Test Functions for different Database Servers
	# They are used in the configuration 
	# Input is ($ErrorID, $ErrorString)
	# Output is boolean: If true, then we'll consider the error a critical condition, ok to failover
	# If false, then DBIx::HA will not act on it and pass it straight through to the client
	sub FTF_SybaseASE { $_[0] > 10 ? 0 : 1 }; # Fail Test Function for Sybase ASE
}

our $prefix = "[$$] DBIx::HA:           "; 

sub initialize {
	if ($Apache::VERSION) {
		$loaded_Apache = 1;
	}
	if ($Apache::DBI::VERSION) {
		$loaded_Apache_DBI = 1;
	}
	if ($loaded_Apache_DBI) {
		$Apache::DBI::DEBUG = DBIx_HA_DEBUG;	# If we're debugging here, we should also debug Apache::DBI
	}
	if (DBIx_HA_DEBUG > 1) {
		warn "$prefix in initialize:\n";
		warn Dumper %DATABASE::conf;
	}
	my $dbname;
	foreach $dbname (keys %DATABASE::conf) {
		# set default failover to process (i.e. each process is independent from others
		# choices are : process, application
		if (! $DATABASE::conf{$dbname}->{'failoverlevel'}) {
			$DATABASE::conf{$dbname}->{'failoverlevel'} = 'process';
		}
		# add default timeouts for connection and execution
		if (! $DATABASE::conf{$dbname}->{'connecttimeout'}) {
			$DATABASE::conf{$dbname}->{'connecttimeout'} = 30;
		}
		if (! $DATABASE::conf{$dbname}->{'executetimeout'}) {
			$DATABASE::conf{$dbname}->{'executetimeout'} = 30;
		}
		# add default failover rule based on DBI error
		# default is to not request failover, whatever the error
		# do not ever set the default to always request failover, as any SQL error would trigger failover!
		if (! $DATABASE::conf{$dbname}->{'failtest_function'}) {
			$DATABASE::conf{$dbname}->{'failtest_function'} = sub { 0 };
		}
		$DATABASE::conf{$dbname}->{'end_of_stack'} = 0;	# error condition reaching end of stack
		foreach (@{$DATABASE::conf{$dbname}->{'db_stack'}}) {
			# create an easy reverse-lookup table for finding the db server name from the dsn
			$DBIx::HA::finddbserver{$_->[0]}  = $dbname;
			# add timeout when within Apache::DBI
			# default to no ping (-1)
			if ($loaded_Apache_DBI) {
				if ($Apache::DBI::VERSION < 0.89) {
					die "$prefix Requirement unmet. Apache::DBI must be at version 0.89 or above";
				}
				# create a cached lookup table for finding the Apache::DBI cache key index from the dsn
				$DBIx::HA::ApacheDBIidx{$_->[0]}  = _getApacheDBIidx(@$_);
				Apache::DBI->setPingTimeOut($_->[0], $DATABASE::conf{$dbname}->{'pingtimeout'} || -1);
			}
		};
		# set the active database to be the first in the stack
		_writesharedfile($dbname, 0) unless ($DATABASE::conf{$dbname}->{'active_db'});

		# hook up the child initialization routine
		if(Apache->can('push_handlers') && ($Apache::ServerStarting == 1)) {
			Apache->push_handlers(PerlChildInitHandler => \&_init_child);
		}
		# do not force a connection here
		# as we may be in the parent process. Connect in _init_child instead.
	};
}

sub _init_child {
	# Set up debugging PID for children
	$DBIx::HA::prefix = "[$$] DBIx::HA:           "; 
	$DBIx::HA::st::prefix = "[$$] DBIx::HA:st:        "; 
	$DBIx::HA::db::prefix = "[$$] DBIx::HA:db:        "; 
	if (DBIx_HA_DEBUG > 1) {
		warn "$prefix in init_child:\n";
	}
	my $dbname;
	foreach $dbname (keys %DATABASE::conf) {
		# under application failover, maybe we already have an active db.
		# set the active database to be the first in the stack unless we got it earlier.
		_readsharedfile($dbname);
		_writesharedfile($dbname, 0) unless ($DATABASE::conf{$dbname}->{'active_db'});

		# allow for connect on initialization
		if ($DATABASE::conf{$dbname}->{'connectoninit'} && $loaded_Apache_DBI) {
			warn "$prefix Connecting to $dbname on init_child\n" if (DBIx_HA_DEBUG);
			DBIx::HA->connect($dbname);
		}
	};
}


sub _readsharedfile {
	# reads from file-based shared memory to get active database under Apache
	my $dbname = shift;
	if ($DATABASE::conf{$dbname}->{'failoverlevel'} eq 'application') {
		# do this only if we're doing application failover and not process failover
		if ($loaded_Apache && (-f "$logdir/DBIxHA_activedb_$dbname")) {
			open IN, "$logdir/DBIxHA_activedb_$dbname";
			my $dbidx = <IN>;
			chomp $dbidx;
			close IN;
			if ($dbidx == -1) {	# we're told that we're at the end of the stack. No db server is available.
				$DATABASE::conf{$dbname}->{'end_of_stack'} = 1;
				return 0;
			}
			$DATABASE::conf{$dbname}->{'end_of_stack'} = 0;
			if (($dbidx =~ /^\d+$/o) && $DATABASE::conf{$dbname}->{'db_stack'}->[$dbidx]) {
				$DATABASE::conf{$dbname}->{'active_db'} = $DATABASE::conf{$dbname}->{'db_stack'}->[$dbidx];
				$DBIx::HA::activeserver{$dbname}  = $dbidx;
				unless ($Apache::ServerStarting == 1) {
					my $r = Apache->request;
					$r->notes("activedb_$dbname", $dbidx) if (ref $r);
				}
			} else {
				warn "$prefix in _readsharedfile: $dbname shared file has erroneous content, overwriting.\n";
				_writesharedfile($dbname, $DBIx::HA::activeserver{$dbname});
				return 0;
			}
		}
	}
	return 1;
}

sub _writesharedfile {
	my $dbname = shift;
	my $dbidx = shift;
	# updates the active handle
	# and writes to file-based shared memory for active database under Apache
	warn "$prefix in _writesharedfile: activating index $dbidx for database $dbname\n" if (DBIx_HA_DEBUG);
	$DATABASE::conf{$dbname}->{'active_db'} = $DATABASE::conf{$dbname}->{'db_stack'}->[$dbidx];
	$DBIx::HA::activeserver{$dbname}  = $dbidx;

	if ($DATABASE::conf{$dbname}->{'failoverlevel'} eq 'application') {
	# do this only if we're doing application failover and not process failover
		if ($loaded_Apache) {
			unless ($Apache::ServerStarting == 1) {
				my $r = Apache->request;
				$r->notes("activedb_$dbname", $dbidx) if (ref $r);
			}
			$logdir = Apache::server_root_relative(undef,'logs');
			open IN, ">/$logdir/DBIxHA_activedb_$dbname" || return 0;
			print IN $DBIx::HA::activeserver{$dbname};
			close IN;
			if ($Apache::ServerStarting == 1) {
				chmod 0666, "$logdir/DBIxHA_activedb_$dbname";
			}
		}
	}
	return 1;
}

sub _getdbname {
	# returns the db server name when given the dsn string
	my $dsn = shift;
	warn "$prefix in _getdbname: $DBIx::HA::finddbserver{$dsn} \n" if (DBIx_HA_DEBUG > 2);
	return $DBIx::HA::finddbserver{$dsn};
}

sub _isactivedb {
	# returns true if the db server in use is the one that should be active
	my $dsn = shift;
	my $dbname = _getdbname ($dsn);
	_readsharedfile($dbname);
	if ($DATABASE::conf{$dbname}->{'end_of_stack'}) {
		# we're not in the active db, because there is no active database, the end of stack is reached.
		return 0;
	}
	if ($dsn eq $DATABASE::conf{$dbname}->{'active_db'}->[0]) {
		warn "$prefix in _isactivedb: ".$dsn." is the active one \n" if (DBIx_HA_DEBUG > 2);
		return 1;
	}
	warn "$prefix in _isactivedb: ".$dsn." is NOT active \n" if (DBIx_HA_DEBUG > 2);
	$DATABASE::retries{$DATABASE::conf{$dbname}->{'active_db'}->[0]} = 0;	# reset the active db's retries for this process
	return 0;
}

sub _getnextdb {
	# returns the proper db server arrayref to use if the current one is dead
	my $dsn = shift;
	my $dbname = _getdbname ($dsn);
	if (_isactivedb ($dsn)) {
		# do this only if we are the first to look for a good db server
		# otherwise just return the active db server
		my $foundmatch = 0;
		my $idxnextdb = 0;
		my $stackcount = scalar(@{$DATABASE::conf{$dbname}->{'db_stack'}});
		foreach (@{$DATABASE::conf{$dbname}->{'db_stack'}}) {
			$idxnextdb++;
			if ($dsn eq $_->[0]) {
				# we got to the current db server in the stack
				# next db server in the stack is the correct one
				$foundmatch = 1;
				last;
			}
		}
		if (! $foundmatch) {	# didn't find a match, current dsn is invalid
			warn "$prefix in _getnextdb: current dsn is invalid for $dbname: $dsn \n" if (DBIx_HA_DEBUG);
			$idxnextdb = 0;
		} elsif ($idxnextdb > ($stackcount - 1)) {
			warn "$prefix in _getnextdb: Reached end of db server stack for $dbname. Staying there.\n" if (DBIx_HA_DEBUG);
			$DATABASE::conf{$dbname}->{'end_of_stack'} = 1;
			_writesharedfile($dbname, -1);
			return undef;
		}
		_writesharedfile($dbname, $idxnextdb);
		warn "$prefix in _getnextdb: activated ".$DATABASE::conf{$dbname}->{'active_db'}->[0]." \n" if (DBIx_HA_DEBUG);
	} elsif ($DATABASE::conf{$dbname}->{'end_of_stack'}) {
		return undef;
	} else {
		warn "$prefix in _getnextdb: found different active db server, switching to ".$DATABASE::conf{$dbname}->{'active_db'}->[0]."\n" if (DBIx_HA_DEBUG);
	}
	return $DATABASE::conf{$dbname}->{'active_db'}->[0];
}

sub _getApacheDBIidx {
	# generates the ApacheDBI cache idx key from the passed dsn info
	if (! $loaded_Apache_DBI) {
		# Apache::DBI isn't loaded, exit.
		return undef;
	}
	# first generate the same $idx key entry as ApacheDBI does
	my @args   = map { defined $_ ? $_ : "" } @_;
	if ($args[0] =~ /^dbi:/i) { $args[0] =~ s/^dbi:[^:]+://io; };	# remove the dbi:driver: piece
	my $idx = join $;, $args[0], $args[1], $args[2];

	if (3 == $#args and ref $args[3] eq "HASH") {
		map { $idx .= "$;$_=$args[3]->{$_}" } sort keys %{$args[3]};
	}
	warn "$prefix in getApacheDBIidx: generated idx: $idx , from dsn $args[0]\n" if (DBIx_HA_DEBUG > 1);
	return $idx;
}

sub _reconnect {
	my $currdsn = shift;
	my $dbh = shift || undef;
	my $olddsn = $currdsn;	# old dsn to delete from Apache::DBI
	my $conn_str;
	my $selrow;
	my $dbname = _getdbname ($currdsn);
	my $newdbh;
	my $i;

	if (! _isactivedb ($currdsn)) {	# wrong database server, use the active one
		$currdsn = _getnextdb ($currdsn);
	}
	if (! $currdsn) {
		warn "$prefix in _reconnect: No data source available, end of stack is reached. dbh is undefined. \n";
		eval { $dbh->disconnect if ((defined $dbh) && (ref $dbh)); undef $dbh; };
		return ($currdsn, undef);	# bad dbh and dsn
	}

	FINDDB: {
	my $dbstackindex = 0;	# pointer to position in the stack
	foreach $selrow (@{$DATABASE::conf{$dbname}->{'db_stack'}}) {	# loop through the stack
		if ($currdsn eq $selrow->[0]) {	# found the proper db server in the stack
			if ($loaded_Apache_DBI) { # delete the cached ApacheDBI entry
				my $ApacheDBIConnections = Apache::DBI::all_handlers();
				delete $$ApacheDBIConnections{$DBIx::HA::ApacheDBIidx{$olddsn}} if ($DBIx::HA::ApacheDBIidx{$olddsn});
				warn "$prefix in _reconnect: deleted cached ApacheDBI entry ".$DBIx::HA::ApacheDBIidx{$olddsn}."\n" if (DBIx_HA_DEBUG);
			}
			warn "$prefix in _reconnect: retrying ".$selrow->[0]."\n" if (DBIx_HA_DEBUG);
			$i=0;
			$DATABASE::retries{$currdsn} = 0 if (! $DATABASE::retries{$currdsn});
			for ($i=$DATABASE::retries{$currdsn}; $i < $DATABASE::conf{$dbname}->{'max_retries'}; $i++) {	# retry max_retries
				$DATABASE::retries{$currdsn}++;
				# now we're going to create a new good database handle and swap it with the old bad one
				$newdbh = _connect_with_timeout (@$selrow);
				if (defined $newdbh) {
					# we managed to create a new database handle
					if ((defined $dbh) && (ref $dbh)) {
						# the old one still exists, so we're going to swap it and then destroy it
						warn "$prefix in _reconnect: Pointing dbh to newdbh\n" if (DBIx_HA_DEBUG);
						$dbh->swap_inner_handle($newdbh);
						# wipe the old database handle (which in turn finishes all its children sth's)
						# If we're using DBD::Sybase, make sure syb_flush_finish is off so we don't get remaining results
                                                $newdbh->{syb_flush_finish} = 0 if $newdbh->{syb_flush_finish}
                                                    and $newdbh->{Driver}{Name} ne 'Gofer';
						eval { undef $newdbh; };
					} else {
						# there was no previous active database handle, so that's easy
						$dbh = $newdbh;
					}
					warn "$prefix Successfully reconnected to $currdsn\n";
					$DATABASE::retries{$currdsn} = 0; # reset the retries counter
					_writesharedfile($dbname, $dbstackindex);
					# Do callback if it exists
					if ( ref $DATABASE::conf{$dbname}->{'callback_function'}) {
						&{$DATABASE::conf{$dbname}->{'callback_function'}}($dbh, $dbname);
					}
					return ($currdsn, $dbh); 
				} #if
				warn "$prefix in _reconnect: failed ".($i+1)." times to connect to $currdsn\n" if (DBIx_HA_DEBUG > 1);
				select undef, undef, undef, 0.2; # wait a fraction of a second
			} #for
			# we found our db server in the stack, but couldn't connect to it
			# Get another one, and try again, assuming we've not exhausted the stack!
			$olddsn = $currdsn;			# remember the old one to delete it from Apache::DBI
			$currdsn = _getnextdb ($currdsn);	# go to next dsn
			if (! $currdsn) {			# we reached the end of the stack!
				warn "$prefix *** ERROR: Exhausted DBI failover stack. Last DSN is: $olddsn \n";
				return ($olddsn, undef);
			}
			warn "$prefix in _reconnect: dbstackindex: $dbstackindex; Trying another db server: $currdsn \n";
			goto FINDDB;
		} #if
		$dbstackindex++;
	} #foreach
	} # FINDDB
	warn "$prefix in _reconnect: Couldn't find a good data source, dbh is undefined. Pointing to $currdsn\n";
	return ($currdsn, undef);	# bad dbh! (multiple tries failed)
}

sub connect {
	warn "$prefix Apache::DBI handlers are: \n" if (DBIx_HA_DEBUG > 1);
	warn Dumper Apache::DBI::all_handlers() if (DBIx_HA_DEBUG > 1 && $loaded_Apache_DBI);
	my $class = shift;
	my $dbname = shift;
	my $conf = $DATABASE::conf{$dbname}
            or Carp::croak("No entry for '$dbname' in %DATABASE::conf");
	my $active_db = $conf->{'active_db'}
            or Carp::croak("No active_db for '$dbname' (did you call initialize?)");
	my ($dsn, $username, $auth, $attrs) = @$active_db;

	# Update the active db. If it's been updated, switch to it
	if (! _isactivedb($dsn)) {
		($dsn, $username, $auth, $attrs) = @{$DATABASE::conf{$dbname}->{'active_db'}};
		warn "$prefix in connect: switching to active db $dsn" if (DBIx_HA_DEBUG);
	}

	# now we've got the right data source. Go ahead.
	$DATABASE::retries{$dsn} = 0;	# initialize # of retries for the dsn
	my $dbh = _connect_with_timeout($dsn, $username, $auth, $attrs);
	if (defined $dbh) {
		warn "$prefix in connect: first try worked for $dsn\n" if (DBIx_HA_DEBUG);
	} else {
		warn "$prefix in connect: retrying connect of $dsn\n" if (DBIx_HA_DEBUG);
		($dsn, $dbh) = _reconnect ($dsn, $dbh);
	}
	return $dbh;
}

sub _connect_with_timeout {
	my ($dsn, $username, $auth, $attrs) = @_;
	warn "$prefix in _connect_with_timeout: dsn: $dsn \n" if (DBIx_HA_DEBUG > 1);
	my $res;
	my $dbh;
	my $timeout = 0;
	eval {
		no strict;
		my $h = set_sig_handler(
			'ALRM', 
			sub { $timeout = 1; die 'TIMEOUT'; },
			{ mask=>['ALRM'], safe=>1 }
		);
		alarm($DATABASE::conf{_getdbname($dsn)}->{'connecttimeout'});
		$dbh = DBI->connect($dsn, $username, $auth, $attrs);
		alarm(0);
	};
	alarm(0);
	if ($@ or $timeout) {	# there's a problem above
		if ($timeout) {	# it's a timeout
			warn "$prefix *** CONNECT TIMED OUT in $dsn";
			eval { $dbh->disconnect };
			$dbh = undef;
		} else {	# problem in the connection
			warn "$prefix Error in DBI::connect: $@\n" if $@;
		}
	}
        $dbh->{private_dbixha_dsn} = $dsn if $dbh;
	return $dbh;
}
} # end package DBIx::HA

{
package DBIx::HA::db;
use strict;
use constant DBIx_HA_DEBUG => DBIx::HA::DBIx_HA_DEBUG;
use vars qw ( @ISA );
@ISA = qw(DBI::db DBIx::HA);
our $prefix = "[$$] DBIx::HA:db:        "; 

# note that the DBI::db methods do not fail if the database connection is dead
sub prepare {
	my $dbh = shift;
	my $sql = shift;
	my $sth;
	my $dsn = $dbh->{private_dbixha_dsn} || die "panic: no private_dbixha_dsn";
	warn "$prefix in prepare: dsn: $dsn ; sql: $sql \n" if (DBIx_HA_DEBUG > 1);
	if (DBIx::HA::_isactivedb ($dsn)) {
		warn join "\n", "$prefix Statement handle being prepared while existing statement handle still open!",
                        "\tdbh:\t\t$dsn",
                        "\tprevious statement:\t".$dbh->{Statement},
                        "\tcurrent statement:\t$sql",
                        "\tACTIVE KIDS: ".$dbh->{ActiveKids}."\n"
                    if $dbh->{ActiveKids};
	} else {
		my $dbname = DBIx::HA::_getdbname($dsn);
		($dsn, $dbh) = DBIx::HA::_reconnect ($dsn, $dbh);
		if (! defined $dbh) { # we couldn't connect at all
			warn "$prefix in prepare: couldn't prepare sql: $sql\n";
			return undef;
		}
	}
	$sth = $dbh->SUPER::prepare($sql);
	return $sth;
}
	
} # end package DBIx::HA::db

{
package DBIx::HA::st;
use strict;
use constant DBIx_HA_DEBUG => DBIx::HA::DBIx_HA_DEBUG;
use Sys::SigAction qw( set_sig_handler );
use vars qw ( @ISA $prefix );
@ISA = qw(DBI::st DBIx::HA);
our $prefix = "[$$] DBIx::HA:st:        "; 

sub execute {
	my $sth = shift;
	my $dbh = $sth->{Database};
	my $sql = $dbh->{Statement};
	my $dsn = $dbh->{private_dbixha_dsn} || die "panic: no private_dbixha_dsn";
	my $dbname = DBIx::HA::_getdbname($dsn);
	my $res;
	my $to;	# did we trip a timeout on the execution?
	my $orig_error_code;
	my $orig_error_string;
	my $max_executions = $DATABASE::conf{$dbname}->{'max_retries'} * scalar(@{$DATABASE::conf{$dbname}->{'db_stack'}});

	warn "=================\n" if (DBIx_HA_DEBUG > 1);
	warn "$prefix in execute: dsn: $dsn ; sql: $sql \n" if (DBIx_HA_DEBUG > 1);
	if (DBIx::HA::_isactivedb ($dsn)) {
		($res, $to) = &_execute_with_timeout ($dsn, $sth);
		$orig_error_code = $DBI::err;
		$orig_error_string = $DBI::errstr;
		if ($to || ((! defined $res) && &{$DATABASE::conf{$dbname}->{'failtest_function'}}($orig_error_code, $orig_error_string))) {
			# It was a timeout error or a critical network library error (connection in a bad state)
			warn "$prefix in execute: timeout error or network lib error, reexecuting: $sql ; dsn: $dsn \n" if (DBIx_HA_DEBUG);
			for (my $count_execs = 0; $count_execs < $max_executions; $count_execs++) {
				($dsn, $sth, $res) = _reexecute ($dsn, $sql, $sth);
				last if (defined $res); # reexecution worked (or failed hard with -666)
			} 
		} elsif (! defined $res) {
			# We got an error code from the server upon statement execution.
			# We will let the client decide what to do and let it be.
			warn "$prefix *** ERROR: $orig_error_code; $orig_error_string \n" if (DBIx_HA_DEBUG);
			warn "$prefix in execute: bad sql: $sql ; dsn: $dsn \n" if (DBIx_HA_DEBUG);
		}
	} else { # current db is not active
		for (my $count_execs = 0; $count_execs < $max_executions; $count_execs++) {
			($dsn, $sth, $res) = _reexecute ($dsn, $sql, $sth);
			last if (defined $res); # reexecution worked (or failed hard with -666)
		}
	}
	if (! defined $res) { # Execution failed
		warn "$prefix in execute: result is undefined, statement execution failed! statement: $sql ; dsn: $dsn \n" if (DBIx_HA_DEBUG);
		warn "+++++++++++++++++\n" if (DBIx_HA_DEBUG > 1);
		return undef;
	}
	if ($res == -666) { # the devil killed you! We couldn't connect to the db!
		warn "$prefix in execute: statement couldn't be executed because connect failed abnormally. statement: $sql ; dsn: $dsn \n";
		warn "+++++++++++++++++\n" if (DBIx_HA_DEBUG > 1);
		return undef;
	}
	warn "$prefix in execute: statement executed successfully! statement: $sql ; dsn: $dsn \n" if (DBIx_HA_DEBUG);
	warn "$prefix in execute: res: $res ; errstr: $DBI::errstr \n" if (DBIx_HA_DEBUG);
	$DATABASE::retries{$dsn} = 0;	# flush the retries to this dsn, since executing worked
	undef $@; # don't make an upstream eval die because of what happened here, since we're fine now
	warn "+++++++++++++++++\n" if (DBIx_HA_DEBUG > 1);
	return $res;
}

sub _execute_with_timeout {
	my $dsn = shift;
	my $sth = shift;
	my $sql = $sth->{Statement};
	warn "$prefix in _execute_with_timeout: dsn: $dsn ; sql : $sql \n" if (DBIx_HA_DEBUG > 1);
	my $res;
	my $timeout = 0;
	eval {
		my $h = set_sig_handler(
			'ALRM',
			sub { $timeout = 1; die 'TIMEOUT'; },
			{ mask=>['ALRM'],
			safe=>1 }
		);
		alarm($DATABASE::conf{DBIx::HA::_getdbname($dsn)}->{'executetimeout'});
		$res = $sth->SUPER::execute;
		alarm(0);
	};
	alarm(0);
	if ($@ or $timeout) {	# there's a problem above
		if ($timeout) {	# it's a timeout
			warn "$prefix *** EXECUTION TIMED OUT in $dsn ; SQL: $sql";
		} else {	# problem in the execution
			warn "$prefix Error in DBI::execute: $@\n" if $@;
		}
		eval { $sth->finish; };
		$sth = undef;
		$res = undef;
	}
	return ($res, $timeout);
}

sub _reexecute {
	# reexecute the statement in the following way:
	# reconnect with a new dbh
	# redo prepare and execute until it works
	my $dsn = shift;
	my $sql = shift;
	my $sth = shift || undef;
	my $dbh = undef;
	my $newsth;
	my $res;
	my $to;

	warn "$prefix in _reexecute: dsn: $dsn \n" if (DBIx_HA_DEBUG > 1);
	warn "$prefix Reexecuting statement: $sql" if (DBIx_HA_DEBUG > 1);
	if (defined $sth) {
		$dbh = $sth->{Database};
	}
	($dsn, $dbh) = DBIx::HA::_reconnect ($dsn, $dbh);
	if (! defined $dbh) { return ($dsn, $sth, -666); } # we couldn't connect at all
	$newsth = $dbh->prepare($sql);
	($res, $to) = &_execute_with_timeout ($dsn, $newsth);
	if (! $res) {	# execute_with_timeout failed
		warn "$prefix in _reexecute: reexecuting failed. dsn: $dsn  ; statement: $sql\n" if (DBIx_HA_DEBUG);
		eval { $sth->finish; };
		return ($dsn, $sth, undef);
	}
	if (defined $sth) {
		$sth->swap_inner_handle($newsth, 1);	# allow reparenting of the statement handle
		eval { $newsth->finish; };
		undef $newsth;
	} else {
		$sth = $newsth;
	}
	return ($dsn, $sth, $res);
}

} # end package DBIx::HA::st

1;

__END__

=head1 NAME

DBIx::HA - High Availability package for DBI

=head1 SYNOPSIS

 use DBIx::HA;

 $connect_attributes = {
         syb_flush_finish => 1,
         AutoCommit => 1,
         ChopBlanks => 1,
         PrintError => 0,
         RaiseError => 0,
         RootClass  => 'DBIx::HA'
         };

 $DATABASE::conf{'test'} = {
    max_retries => 2,
    db_stack => [
        [ 'dbi:Sybase:server=prod1;database=test', 'user1', 'password1', $connect_attributes ],
        [ 'dbi:Sybase:server=prod2;database=test', 'user2', 'password2', $connect_attributes ],
        [ 'dbi:Sybase:server=prod3;database=test', 'user3', 'password3', $connect_attributes ],
        ],
    connectoninit   => 0,
    pingtimeout     => -1,
    failoverlevel   => 'application',
    connecttimeout  => 1,
    executetimeout  => 8,
    callback_function => \&MyCallbackFunction,
	failtest_function   => \&DBIx::HA::FTF_SybaseASE,
    };

 DBIx::HA->initialize();
 $dbh = DBIx::HA->connect('test');
    
 $sth = $dbh->prepare($statement);
 $rv = $sth->execute;

=head1 DESCRIPTION

C<DBIx::HA> is a High Availability module for C<DBI>. It is implemented by
overloading the DBI C<connect>, C<prepare> and C<execute> methods and can
be seamlessly used without code modification except for initialization.

C<DBIx::HA> also works seamlessly with C<Apache::DBI> when available, and
ensures that cached database handles in the Apache::DBI module are properly
updated when failing over.

Features of C<DBIx::HA> are:

=over 4

=item multiple failovers

Should a datasource become unavailable, queries are automatically sent to
the next available datasource in a user-configured datasource stack.
All subsequent queries continue to hit the failover server until
reinitialized. This ensures that a failed datasource can be properly brought
back online before it is put back in service.

=item timeouts

Database calls are wrapped in user-configurable timeouts. Connect and execute
timeouts are handled independently. As of version 0.62, timeouts are 
handled through Sys::SigAction for consistent signal handling behavior across
Perl versions.

=item configurable retries

Queries can be retried n times before a datasource is considered failed.
Starting with version 0.95, the retry counter is reset whenever a reconnect
works.

=item callback function

A user-defined callback function can be called upon abnormal failure and
disconnection from a datasource in order to clean locally cached handles and
perform other housekeeping tasks.

=item inter-process automatic failover under mod_perl

Failover can be triggered for a single process or a set of processes at the
application level. Specifically designed for Apache's multi-process model,
if one mod_perl process triggers a failover, it is propagated to all other
mod_perl processes using the same database handle.

=back

C<DBIx::HA> was designed primarily for reliability and speed. Functionality
that would compromise speed was not considered. This module has been tested
extensively at very high loads in the Apache/mod_perl/Sybase environment.

=head1 CONFIGURATION

The hash I<%DATABASE::conf> is currently the configuration repository for
C<DBIx::HA>. It must be manually and directly populated by the user prior
to initialization and usage of C<DBIx::HA>.

Each key of I<%DATABASE::conf> is the name of a virtual database handle.
The corresponding value is a hashref with the following keys:

=over 4

=item db_stack REQUIRED

db_stack is an arrayref of arrayrefs. Each entry is of the format:

[ $dsn, $username, $password, \%connection_attributes ]

See the C<DBI> documentation for more information.
The order of the db_stack entries is very important. It determines the
order by which each dsn will be tried upon triggering a failover. The
first entry is the main dsn that will be used at start.

=item max_retries REQUIRED

max_retries takes an integer > 0 as value. It determines the number of times
a datasource will be consecutively retried upon failure. It B<is reset> upon
success of a retry. This is a change in behavior starting in version 0.95.
For example, if max_retries is 3, if datasource #1 can't be reached three
times in a row then I<_reconnect()> will reset the number of tries and go to
datasource #2 if available.

=item connectoninit ( DEFAULT: 0 )

If set to 1, then during the I<initialize()> phase this database connections
will be instantiated with its currently  active db_stack entry.
This is very useful under mod_perl and replaces the C<Apache::DBI>
I<connect_on_init()> method. 

=item pingtimeout ( DEFAULT: -1 )

this is only useful in conjunction with C<Apache::DBI>. The default of -1
disables pinging the datasource. It is recommended not to modify it. See
C<Apache::DBI> for more information on ping timeouts. Timeout is in seconds.

=item failoverlevel ( DEFAULT: process )

I<failoverlevel> determines whether a process will notify its sisters when fails
over to another datasource. 

=over 4

=item process

no notification is made, and each process independently manages its datasource
availability. Within a mod_perl environment, this means that each Apache process
could be potentially hitting a different physical database server.

=item application

a file-based interprocess communication is used to notify Apache/mod_perl
processes of the currently active datasource. This allows all processes to fail
over near-simultaneously. A process in the middle of an I<execute> will do it
on the next call to I<prepare> or I<execute>. This is only available under
mod_perl.

=back

=item connecttimeout ( DEFAULT: 30 )

timeout for connecting to a datasource, in seconds.

=item executetimeout ( DEFAULT: 30 )

timeout for execution of a statement, in seconds. If the timeout is triggered,
the database handle is deleted and a new connect is tried. If the connect
succeeds, we assume that the problem is with a runaway SQL statement or bad
indexing. If the connect fails, then we fail over.

=item callback_function ( DEFAULT: I<none> )

reference to a function to call whenever the datasource is changed due to a
failover. See the TIPS sections for a usage example.

=item failtest_function ( DEFAULT: sub{0} )

reference to a function to call to test if a DBI error is a candidate for
failover or not.
Input is ($ErrorID, $ErrorString)
Output is boolean: If true, then we'll consider the error a critical
condition, ok to failover. If false, then DBIx::HA will not act on it
and pass it straight through to the client.

This Fail Test Function (FTF) function is extremely important for the proper
functioning of DBIx::HA. You must be careful  in defining it
precisely, based on the database engine that you are using. As a
convenience to the user, DBIx::HA defines some sample functions that
you can use. At this time, only the following samples are defined:

 DBIx::HA::FTF_SybaseASE

Example use is in the synopsis

=back

=head1 USER METHODS

These methods provide a user interface to C<DBIx::HA>.

=over 4

=item initialize ()

This method is called as a static method after database configuration is
done.
At this point, database configuration resides in the I<%DATABASE::conf> hash
that needs to be properly populated. Later revisions of C<DBIx::HA> will
allow the passing of a reference to any configuration hash to I<initialize>.

See a sample %DATABASE::conf in the SYNOPSIS section. That section creates
an entry for the 'test' HA database handle, which is comprised of 3 physical
database handles (prod1, prod2, prod3). 'prod1' is the main handle, while the
other 2 are backup handles.

Add other HA database handles by creating more entries in I<%DATABASE::conf>. 

=item connect ( $dbname )

Static method to connect to the HA handle 'dbname'. There must be a valid
entry for $DATABASE::conf{'dbname'}.
Returns a standard DBI database handle.

=item prepare ( $dbh, $sql )

Overload of I<DBI::prepare()>, with the same inputs and outputs.

=item execute ()

Overload of I<DBI::execute()>, with the same inputs and outputs.

=back

=head1 CLASS METHODS

These private methods are not intended to be called by the user, but are
listed here for reference.

=over 4

=item _init_child ()

=item _readsharedfile ( $dbname )

=item _writesharedfile ( $dbname, $dbstackindex )

=item _getdbname ( $dsn )

=item _isactivedb ( $dsn )

=item _getnextdb ( $dsn )

=item _getApacheDBIidx ()

=item _reconnect ( $dsn, [ $dbh ] )

=item _connect_with_timeout ( $dsn, $username, $auth, \%attrs )

=item _reprepare ( $dsn, $sql )

=item _prepare_with_timeout ( $dsn, $dbh, $sql )

=item _reexecute ( $dsn, $sql, [ $sth ] )

=item _execute_with_timeout ( $dsn, $sth )

=back

=head1 TIPS AND TECHNIQUES

=over 4

=item load-balancing across read-only servers

It is very simple to load-balance across read-only database servers.
Simply randomize or reorder the 'db_stack' entry in your database
configuration on a per-process basis. This will make each process have
its own set of primary and backup servers.
Obviously you should never do that on a read-write environment with hot
spares as you will be writing to the hot spares without writing to the
primary server. Consider C<DBD::Multiplex> for such an application.

=item manually setting the active datasource without downtime

Under mod_perl you can flip all Apache processes to a specific datasource
by simply modifying the file B<DBIxHA_activedb_$dbname> located in the /log
directory in your Apache installation. Assuming that you are using
B<failoverlevel 'application'>, all processes will switch to the datasource you
define in that file as soon as they are ready to prepare or execute a statement.

Another trick is to set the value in the shared file to -1. This will tell the
module that we've reached the end of the stack and no connection should be
attempted, effectively blocking all database calls.

Conversely, if the shared file does contain -1 because all DSNs in the stack
have failed, you can reset it to whatever DSN entry you want without having to
bounce Apache.

=back

=head1 DEPENDENCIES

This modules requires Perl >= 5.6.0, DBI >= 1.49  and Sys::SigAction.
Apache::DBI is recommended when using mod_perl.
If using Apache::DBI, version 0.89 or above is required.
Always load Apache::DBI and Apache before DBIx::HA if you want DBIx::HA to know
of them.

=head1 BUGS

Currently I<%DATABASE::conf> needs to be manually and directly populated.
A proper interface needs to be built for it.

=head1 SEE ALSO

C<DBD::Multiplex> for simultaneous writes to multiple data sources.

C<Apache::DBI> for ping timeouts and caching of database handles.

C<Sys::SigAction> for safe signal handling, particularly with DBI.

=head1 AUTHOR

Henri Asseily <henri@asseily.com>

=head1 COPYRIGHT

Copyright (c) 2003-2006 Henri Asseily <henri@asseily.com>.
All rights reserved. This program is free software; you can redistribute
it and/or modify it under the same terms as Perl itself.

=for html <hr>


=cut