view release on metacpan or  search on metacpan

lib/DBIx/Connector/Retry.pm  view on Meta::CPAN

package DBIx::Connector::Retry;

our $AUTHORITY = 'cpan:GSG';
# ABSTRACT: DBIx::Connector with block retry support
use version;
our $VERSION = 'v0.900.3'; # VERSION

use strict;
use warnings;

use Moo;

extends 'DBIx::Connector', 'Moo::Object';

use Scalar::Util           qw( weaken );
use Types::Standard        qw( Str Bool HashRef CodeRef Dict Tuple Optional Maybe );
use Types::Common::Numeric qw( PositiveInt );

use namespace::clean;  # don't export the above

#pod =encoding utf8
#pod
#pod =head1 SYNOPSIS
#pod
#pod     my $conn = DBIx::Connector::Retry->new(
#pod         connect_info  => [ 'dbi:Driver:database=foobar', $user, $pass, \%args ],
#pod         retry_debug   => 1,
#pod         max_attempts  => 5,
#pod     );
#pod
#pod     # Keep retrying/reconnecting on errors
#pod     my ($count) = $conn->run(ping => sub {
#pod         $_->do('UPDATE foobar SET updated = 1 WHERE active = ?', undef, 'on');
#pod         $_->selectrow_array('SELECT COUNT(*) FROM foobar WHERE updated = 1');
#pod     });
#pod
#pod     # Add a simple retry_handler for a manual timeout
#pod     my $start_time = time;
#pod     $conn->retry_handler(sub { time <= $start_time + 60 });
#pod
#pod     my ($count) = $conn->txn(fixup => sub {
#pod         $_->selectrow_array('SELECT COUNT(*) FROM barbaz');
#pod     });
#pod     $conn->clear_retry_handler;
#pod
#pod     # Plus everything else in DBIx::Connector
#pod
#pod =head1 DESCRIPTION
#pod
#pod DBIx::Connector::Retry is a Moo-based subclass of L<DBIx::Connector> that will retry on
#pod failures.  Most of the interface was modeled after L<DBIx::Class::Storage::BlockRunner>
#pod and adapted for use in DBIx::Connector.
#pod
#pod =head1 ATTRIBUTES
#pod
#pod =head2 connect_info
#pod
#pod An arrayref that contains all of the connection details normally found in the L<DBI> or
#pod L<DBIx::Connector> call.  This data can be changed, but won't take effect until the next
#pod C<$dbh> re-connection cycle.
#pod
#pod Obviously, this is required.
#pod
#pod =cut

has connect_info => (
    is       => 'rw',
    # Yes, DBI->connect() is still technically-valid syntax
    isa      => Tuple[ Maybe[Str], Maybe[Str], Maybe[Str], Optional[HashRef] ],
    required => 1,
);

#pod =head2 mode
#pod
#pod This is just like L<DBIx::Connector/mode> except that it can be set from within the

lib/DBIx/Connector/Retry.pm  view on Meta::CPAN

#pod     );
#pod
#pod As this is a L<Moo> class, it uses the standard Moo constructor.  The L</connect_info>
#pod should be specified as its own key.  The L<DBI>/L<DBIx::Connector> syntax is available,
#pod but only as a nicety for compatibility.
#pod
#pod =cut

around BUILDARGS => sub {
    my ($orig, $class, @args) = @_;

    # Old-style DBI/DBIx::Connector parameters.  Try to fix it up.
    if (@args && $args[0] && !ref $args[0] && $args[0] =~ /^dbi:/) {
        my @connect_info = splice(@args, 0, 3);                                       # DBI DSN, UN, PW
        push @connect_info, shift @args if $args[0] && (ref $args[0]||'') eq 'HASH';  # DBI \%attr, if it exists

        if ( @args && $args[0] && (my $ref = ref $args[0]) ) {
            if    ($ref eq 'ARRAY') {
                push @{$args[0]}, ( connect_info => \@connect_info );
                @args = @{$args[0]};  # Moo::Object::BUILDARGS doesn't actually support lone ARRAYREFs
            }
            elsif ($ref eq 'HASH') {
                $args[0]{connect_info} = \@connect_info;
            }
            else {
                # Mimicing Moo::Object::BUILDARGS here
                Carp::croak(join ' ',
                    "The new() method for $class cannot parse the strange argument list.",
                    "Please switch to a standard Moo constructor, instead of the DBI syntax.",
                );
            }
        }
        else {
            # either the key within a list or we're out of arguments
            push @args, ( connect_info => \@connect_info );
        }
    }

    return $class->$orig(@args);
};

sub BUILD {
    my ($self, $args) = @_;

    my @connect_args = @{ $self->connect_info };

    # Add in the keys that DBIx::Connector expects.  For the purposes of future
    # expandability of DBIx::Connector, we do this by getting a new base Connector
    # object, and inject those properties into our own object.

    my $base_obj = DBIx::Connector->new(@connect_args);
    %$self = (
        %$base_obj,
        %$self,  # $self's existing attributes take priority
    );

    # DBIx::Connector stores connection details in a coderef (for some reason).  Instead
    # of just dumping the same arguments as another copy, we'll tie it directly to the
    # attr.  If connect_info ever changes, it will grab the latest version.
    $self->{_args} = sub { @{ $self->connect_info } };
    weaken $self;  # circular closure ref
}

#pod =head1 MODIFIED METHODS
#pod
#pod =head2 run / txn
#pod
#pod     my @result = $conn->run($mode => $coderef);
#pod     my $result = $conn->run($mode => $coderef);
#pod     $conn->run($mode => $coderef);
#pod
#pod     my @result = $conn->txn($mode => $coderef);
#pod     my $result = $conn->txn($mode => $coderef);
#pod     $conn->txn($mode => $coderef);
#pod
#pod Both L<run|DBIx::Connector/run> and L<txn|DBIx::Connector/txn> are modified to run inside
#pod a retry loop.  If the original Connector action dies, the exception is caught, and if
#pod L</retry_handler> and L</max_attempts> allows it, the action is retried.  The database
#pod handle may be reset by the Connector action, according to its connection mode.
#pod
#pod See L</CAVEATS> for important behaviors/limitations.
#pod
#pod =cut

foreach my $method (qw< run txn >) {
    around $method => sub {
        my $orig = shift;
        my $self = shift;
        my $mode = ref $_[0] eq 'CODE' ? $self->{_mode} : shift;
        my $cref = shift;

        my $wantarray = wantarray;

        return $self->_retry_loop($orig, $method, $mode, $cref, $wantarray);
    };
}

sub _retry_loop {
    my ($self, $orig, $method, $mode, $cref, $wantarray) = @_;

    # For the purposes of nesting, these variables should be localized.
    local $self->{exception_stack}      = [];
    local $self->{failed_attempt_count} = 0;
    local $self->{execute_method}       = $method;

    # If we already started in a transaction, that implies nesting, so don't
    # retry the query.  We can't guarantee that the statements before the block
    # run will be committed, and are assuming that the connection will break.
    #
    # We cannot rely on checking the database connection via ping, because some
    # DBDs (like mysql) will try to reconnect to the DB if the first ping check
    # fails, and a reconnection auto-rollbacks all transactions, locks, etc.
    if ($self->in_txn) {
        unless (defined $wantarray) { return        $self->$orig($mode, $cref)  }
        elsif          ($wantarray) { return       ($self->$orig($mode, $cref)) }
        else                        { return scalar $self->$orig($mode, $cref)  }
    }

    # Mode is localized within $orig, but we should localize it again ourselves, in case
    # it's changed on-the-fly.
    local $self->{_mode} = $mode;