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