lib/DBIx/Class/Storage/BlockRunner.pm

   1 package # hide from pause until we figure it all out
   2   DBIx::Class::Storage::BlockRunner;
   3
   4 use warnings;
   5 use strict;
   6
   7 use DBIx::Class::Exception;
   8 use DBIx::Class::Carp;
   9 use Context::Preserve 'preserve_context';
  10 use DBIx::Class::_Util qw(is_exception qsub);
  11 use Scalar::Util qw(weaken blessed reftype);
  12 use Try::Tiny;
  13
  14 # DO NOT edit away without talking to riba first, he will just put it back
  15 # BEGIN pre-Moo2 import block
  16 BEGIN {
  17   my $initial_fatal_bits = (${^WARNING_BITS}||'') & $warnings::DeadBits{all};
  18
  19   local $ENV{PERL_STRICTURES_EXTRA} = 0;
  20   # load all of these now, so that lazy-loading does not escape
  21   # the current PERL_STRICTURES_EXTRA setting
  22   require Sub::Quote;
  23   require Sub::Defer;
  24   require Moo;
  25   require Moo::Object;
  26   require Method::Generate::Accessor;
  27   require Method::Generate::Constructor;
  28
  29   Moo->import;
  30   ${^WARNING_BITS} &= ( $initial_fatal_bits | ~ $warnings::DeadBits{all} );
  31 }
  32 # END pre-Moo2 import block
  33
  34 use namespace::clean;
  35
  36 =head1 NAME
  37
  38 DBIx::Class::Storage::BlockRunner - Try running a block of code until success with a configurable retry logic
  39
  40 =head1 DESCRIPTION
  41
  42 =head1 METHODS
  43
  44 =cut
  45
  46 has storage => (
  47   is => 'ro',
  48   required => 1,
  49 );
  50
  51 has wrap_txn => (
  52   is => 'ro',
  53   required => 1,
  54 );
  55
  56 # true - retry, false - rethrow, or you can throw your own (not catching)
  57 has retry_handler => (
  58   is => 'ro',
  59   required => 1,
  60   isa => qsub q{
  61     (Scalar::Util::reftype($_[0])||'') eq 'CODE'
  62       or DBIx::Class::Exception->throw('retry_handler must be a CODE reference')
  63   },
  64 );
  65
  66 has retry_debug => (
  67   is => 'rw',
  68   # use a sub - to be evaluated on the spot lazily
  69   default => qsub '$ENV{DBIC_STORAGE_RETRY_DEBUG}',
  70   lazy => 1,
  71 );
  72
  73 has max_attempts => (
  74   is => 'ro',
  75   default => 20,
  76 );
  77
  78 has failed_attempt_count => (
  79   is => 'ro',
  80   init_arg => undef,  # ensures one can't pass the value in
  81   writer => '_set_failed_attempt_count',
  82   default => 0,
  83   lazy => 1,
  84   trigger => qsub q{
  85     $_[0]->throw_exception( sprintf (
  86       'Reached max_attempts amount of %d, latest exception: %s',
  87       $_[0]->max_attempts, $_[0]->last_exception
  88     )) if $_[0]->max_attempts <= ($_[1]||0);
  89   },
  90 );
  91
  92 has exception_stack => (
  93   is => 'ro',
  94   init_arg => undef,
  95   clearer => '_reset_exception_stack',
  96   default => qsub q{ [] },
  97   lazy => 1,
  98 );
  99
 100 sub last_exception { shift->exception_stack->[-1] }
 101
 102 sub throw_exception { shift->storage->throw_exception (@_) }
 103
 104 sub run {
 105   my $self = shift;
 106
 107   $self->_reset_exception_stack;
 108   $self->_set_failed_attempt_count(0);
 109
 110   my $cref = shift;
 111
 112   $self->throw_exception('run() requires a coderef to execute as its first argument')
 113     if ( reftype($cref)||'' ) ne 'CODE';
 114
 115   my $storage = $self->storage;
 116
 117   return $cref->( @_ ) if (
 118     $storage->{_in_do_block}
 119       and
 120     ! $self->wrap_txn
 121   );
 122
 123   local $storage->{_in_do_block} = 1 unless $storage->{_in_do_block};
 124
 125   return $self->_run($cref, @_);
 126 }
 127
 128 # this is the actual recursing worker
 129 sub _run {
 130   # internal method - we know that both refs are strong-held by the
 131   # calling scope of run(), hence safe to weaken everything
 132   weaken( my $self = shift );
 133   weaken( my $cref = shift );
 134
 135   my $args = @_ ? \@_ : [];
 136
 137   # from this point on (defined $txn_init_depth) is an indicator for wrap_txn
 138   # save a bit on method calls
 139   my $txn_init_depth = $self->wrap_txn ? $self->storage->transaction_depth : undef;
 140   my $txn_begin_ok;
 141
 142   my $run_err = '';
 143
 144   return preserve_context {
 145     try {
 146       if (defined $txn_init_depth) {
 147         $self->storage->txn_begin;
 148         $txn_begin_ok = 1;
 149       }
 150       $cref->( @$args );
 151     } catch {
 152       $run_err = $_;
 153       (); # important, affects @_ below
 154     };
 155   } replace => sub {
 156     my @res = @_;
 157
 158     my $storage = $self->storage;
 159     my $cur_depth = $storage->transaction_depth;
 160
 161     if (defined $txn_init_depth and ! is_exception $run_err) {
 162       my $delta_txn = (1 + $txn_init_depth) - $cur_depth;
 163
 164       if ($delta_txn) {
 165         # a rollback in a top-level txn_do is valid-ish (seen in the wild and our own tests)
 166         carp (sprintf
 167           'Unexpected reduction of transaction depth by %d after execution of '
 168         . '%s, skipping txn_commit()',
 169           $delta_txn,
 170           $cref,
 171         ) unless $delta_txn == 1 and $cur_depth == 0;
 172       }
 173       else {
 174         $run_err = eval { $storage->txn_commit; 1 } ? '' : $@;
 175       }
 176     }
 177
 178     # something above threw an error (could be the begin, the code or the commit)
 179     if ( is_exception $run_err ) {
 180
 181       # attempt a rollback if we did begin in the first place
 182       if ($txn_begin_ok) {
 183         # some DBDs go crazy if there is nothing to roll back on, perform a soft-check
 184         my $rollback_exception = $storage->_seems_connected
 185           ? (! eval { $storage->txn_rollback; 1 }) ? $@ : ''
 186           : 'lost connection to storage'
 187         ;
 188
 189         if ( $rollback_exception and (
 190           ! defined blessed $rollback_exception
 191             or
 192           ! $rollback_exception->isa('DBIx::Class::Storage::NESTED_ROLLBACK_EXCEPTION')
 193         ) ) {
 194           $run_err = "Transaction aborted: $run_err. Rollback failed: $rollback_exception";
 195         }
 196       }
 197
 198       push @{ $self->exception_stack }, $run_err;
 199
 200       # this will throw if max_attempts is reached
 201       $self->_set_failed_attempt_count($self->failed_attempt_count + 1);
 202
 203       # init depth of > 0 ( > 1 with AC) implies nesting - no retry attempt queries
 204       $storage->throw_exception($run_err) if (
 205         (
 206           defined $txn_init_depth
 207             and
 208           # FIXME - we assume that $storage->{_dbh_autocommit} is there if
 209           # txn_init_depth is there, but this is a DBI-ism
 210           $txn_init_depth > ( $storage->{_dbh_autocommit} ? 0 : 1 )
 211         ) or ! $self->retry_handler->($self)
 212       );
 213
 214       # we got that far - let's retry
 215       carp( sprintf 'Retrying %s (attempt %d) after caught exception: %s',
 216         $cref,
 217         $self->failed_attempt_count + 1,
 218         $run_err,
 219       ) if $self->retry_debug;
 220
 221       $storage->ensure_connected;
 222       # if txn_depth is > 1 this means something was done to the
 223       # original $dbh, otherwise we would not get past the preceding if()
 224       $storage->throw_exception(sprintf
 225         'Unexpected transaction depth of %d on freshly connected handle',
 226         $storage->transaction_depth,
 227       ) if (defined $txn_init_depth and $storage->transaction_depth);
 228
 229       return $self->_run($cref, @$args);
 230     }
 231
 232     return wantarray ? @res : $res[0];
 233   };
 234 }
 235
 236 =head1 FURTHER QUESTIONS?
 237
 238 Check the list of L<additional DBIC resources|DBIx::Class/GETTING HELP/SUPPORT>.
 239
 240 =head1 COPYRIGHT AND LICENSE
 241
 242 This module is free software L<copyright|DBIx::Class/COPYRIGHT AND LICENSE>
 243 by the L<DBIx::Class (DBIC) authors|DBIx::Class/AUTHORS>. You can
 244 redistribute it and/or modify it under the same terms as the
 245 L<DBIx::Class library|DBIx::Class/COPYRIGHT AND LICENSE>.
 246
 247 =cut
 248
 249 1;