DBIx::Roles::AutoReconnect - restart DBI calls after reconnecting on failure

     use DBIx::Roles qw(AutoReconnect);

     my $dbh = DBI-> connect(
           "dbi:Pg:dbname=template1",
	   "postgres",
	   "password",
	   {
	   	PrintError => 0,
		ReconnectTimeout => 5,
		ReconnectFailure => sub { warn "oops!" },
	   },
     );

# $Id: AutoReconnect.pm,v 1.4 2005/12/01 18:09:52 dk Exp $

package DBIx::Roles::AutoReconnect;

use strict;
use DBIx::Roles;
use vars qw(%defaults $VERSION);

$VERSION = '1.00';

%defaults = (
	ReconnectTimeout  => 60,
	ReconnectMaxTries => 5,
	ReconnectFailure  => undef,
);

sub initialize
{
	my $self = $_[0];
	return [], \%defaults;
}

sub connect
{
	my ( $self, $conninfo, $dsn, $user, $pass, $attr) = @_;

	@$conninfo = ( $dsn, $user, $pass, $attr );
	
	my ( $super, $private) = $self-> get_super;
	return unless $super;

	my $dbh = db_connect( $self, $conninfo, $super, $private);

	return $dbh;
}

sub db_connect
{
	my ( $self, $conninfo, $ref, @param) = @_;

	my $attr = $self-> {attr};
	my $tries = 0;
	my $downtime = 0;
	my $ret;
	RETRY: while ( 1) {
		{
			my $context = $self-> context;
			eval {
				local $conninfo->[3]->{RaiseError} = 1;
				$ret = $ref->( $self, @param, @$conninfo);
			};
			if ( $@) {
				# restore context if calls are restarted	
				$self-> context( $context);
			} elsif ( $ret) {
				warn "DBIx::Roles::AutoReconnect: successfully reconnected after $tries tries and $downtime sec downtime\n"
					if $tries > 0 and (
						$conninfo->[3]-> {PrintError} or
						not (exists $conninfo->[3]->{PrintError}) # DBI defaults
					);
				last RETRY;
			} else {
				$@ = "DBIx::Roles::AutoReconnect: Cannot connect(): no suitable roles found";
			}
		}
		$attr-> {ReconnectFailure}->() 
			if $attr-> {ReconnectFailure};
		$tries++;
		if ( 
			defined ($attr-> {ReconnectMaxTries}) and 
			$attr-> {ReconnectMaxTries} <= $tries
		) {
			$@ = "DBIx::Roles::AutoReconnect: Tried to connect $attr->{ReconnectMaxTries} time(s), giving up\n"
				unless $@;
			if ( $conninfo-> [3]-> {RaiseError}) {
				die $@;
			} else {
				warn $@ if 
					not (exists $conninfo->[3]->{PrintError}) # DBI defaults
					or $conninfo->[3]->{PrintError};
				return undef;
			}
		}
		if ( $attr-> {ReconnectTimeout} > 0) {
			warn "DBIx::AutoReconnect: sleeping for $attr->{ReconnectTimeout} seconds\n"
				if $conninfo-> [3]->{PrintError};
			sleep $attr-> {ReconnectTimeout};
			$downtime += $attr-> {ReconnectTimeout};
		}
	}

	return $ret;
}

sub dbi_method
{
	my ( $self, $conninfo, $method, @parameters) = @_;

	return $self-> super( $method, @parameters) 
		if $method eq 'connect' or not $self->dbh->{AutoCommit};

	my ( $wantarray, @ret) = ( wantarray);
	my ( $super, $private) = $self-> get_super;
	return unless $super;

	my $tries = 0;
	while ( 1) {
		if ( 
			defined ($self->{attr}-> {ReconnectMaxTries}) and 
			$self->{attr}-> {ReconnectMaxTries} <= $tries
		) {
			if ( $conninfo-> [3]-> {RaiseError}) {
				die "DBIx::Roles::AutoReconnect: Tried to call '$method' $self->{attr}->{ReconnectMaxTries} time(s), giving up\n";
			} else {
				warn "DBIx::Roles::AutoReconnect: Tried to call '$method' $self->{attr}->{ReconnectMaxTries} time(s), giving up\n" if
					not exists ($conninfo->[3]->{PrintError}) # DBI defaults
					or $conninfo->[3]->{PrintError};
				return;
			}
		}
		$tries++;

		unless ( $self-> dbh) {
			$conninfo-> [3]-> {RaiseError} ?
				croak( "DBIx::Roles::AutoReconnect: not connected" ) :
				return;
		}
		# repeatedly call the roles below until they succeed
		{
			local $self-> object-> {RaiseError} = 1;
			my $context = $self-> context;
			eval {
				if ( $wantarray) {
					@ret = $super-> ($self, $private, $method, @parameters);
				} else {
					$ret[0] = $super-> ($self, $private, $method, @parameters);
				}
			};
			return wantarray ? @ret : $ret[0]
				unless $@;
			# restore context if calls are restarted	
			$self-> context( $context);	
		}
		if ( $self-> dbh-> ping) {
			# DB is alive, most probably that was not a DBI-related error 
			if ( $conninfo-> [3]-> {RaiseError}) {
				die $@;
			} else {
				warn $@ if 
					not (exists $conninfo->[3]->{PrintError}) # DBI defaults
					or $conninfo->[3]->{PrintError};
				return;
			}
		} else {
			# without disconnect 
			$self-> dbh( $self-> connect( @$conninfo));
		}
	}
}

sub STORE
{
	my ( $self, $conninfo, $key, $val) = @_;
	if ( $key eq 'ReconnectTimeout' or $key eq 'ReconnectMaxTries') {
		die "Fatal: '$key' must be a positive integer"
			unless $val =~ /^\d+$/;
	} elsif ( $key eq 'ReconnectFailure') {
		die "Fatal: '$key' must be either 'undef' or a CODE reference"
			if not defined($val) or not ref($val) or ref($val) ne 'CODE';
	} elsif ( not exists $self->{defaults}->{$key}) {
		# update $attr for eventual reconnects
		$conninfo->[3]->{$key} = $val;
	}

	
	return $self-> super( $key, $val);
}

1;

__DATA__