1 package # hide from pause until we figure it all out
2 DBIx::Class::Storage::BlockRunner;
7 use DBIx::Class::Exception;
9 use Context::Preserve 'preserve_context';
10 use DBIx::Class::_Util qw(is_exception qsub);
11 use Scalar::Util qw(weaken blessed reftype);
14 # DO NOT edit away without talking to riba first, he will just put it back
15 # BEGIN pre-Moo2 import block
17 my $initial_fatal_bits = (${^WARNING_BITS}||'') & $warnings::DeadBits{all};
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
26 require Method::Generate::Accessor;
27 require Method::Generate::Constructor;
30 ${^WARNING_BITS} &= ( $initial_fatal_bits | ~ $warnings::DeadBits{all} );
32 # END pre-Moo2 import block
38 DBIx::Class::Storage::BlockRunner - Try running a block of code until success with a configurable retry logic
56 # true - retry, false - rethrow, or you can throw your own (not catching)
57 has retry_handler => (
61 (Scalar::Util::reftype($_[0])||'') eq 'CODE'
62 or DBIx::Class::Exception->throw('retry_handler must be a CODE reference')
68 # use a sub - to be evaluated on the spot lazily
69 default => qsub '$ENV{DBIC_STORAGE_RETRY_DEBUG}',
78 has failed_attempt_count => (
80 init_arg => undef, # ensures one can't pass the value in
81 writer => '_set_failed_attempt_count',
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);
92 has exception_stack => (
95 clearer => '_reset_exception_stack',
96 default => qsub q{ [] },
100 sub last_exception { shift->exception_stack->[-1] }
102 sub throw_exception { shift->storage->throw_exception (@_) }
107 $self->_reset_exception_stack;
108 $self->_set_failed_attempt_count(0);
112 $self->throw_exception('run() requires a coderef to execute as its first argument')
113 if ( reftype($cref)||'' ) ne 'CODE';
115 my $storage = $self->storage;
117 return $cref->( @_ ) if (
118 $storage->{_in_do_block}
123 local $storage->{_in_do_block} = 1 unless $storage->{_in_do_block};
125 return $self->_run($cref, @_);
128 # this is the actual recursing worker
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 );
135 my $args = @_ ? \@_ : [];
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;
144 return preserve_context {
146 if (defined $txn_init_depth) {
147 $self->storage->txn_begin;
153 (); # important, affects @_ below
158 my $storage = $self->storage;
159 my $cur_depth = $storage->transaction_depth;
161 if (defined $txn_init_depth and ! is_exception $run_err) {
162 my $delta_txn = (1 + $txn_init_depth) - $cur_depth;
165 # a rollback in a top-level txn_do is valid-ish (seen in the wild and our own tests)
167 'Unexpected reduction of transaction depth by %d after execution of '
168 . '%s, skipping txn_commit()',
171 ) unless $delta_txn == 1 and $cur_depth == 0;
174 $run_err = eval { $storage->txn_commit; 1 } ? '' : $@;
178 # something above threw an error (could be the begin, the code or the commit)
179 if ( is_exception $run_err ) {
181 # attempt a rollback if we did begin in the first place
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'
189 if ( $rollback_exception and (
190 ! defined blessed $rollback_exception
192 ! $rollback_exception->isa('DBIx::Class::Storage::NESTED_ROLLBACK_EXCEPTION')
194 $run_err = "Transaction aborted: $run_err. Rollback failed: $rollback_exception";
198 push @{ $self->exception_stack }, $run_err;
200 # this will throw if max_attempts is reached
201 $self->_set_failed_attempt_count($self->failed_attempt_count + 1);
203 # init depth of > 0 ( > 1 with AC) implies nesting - no retry attempt queries
204 $storage->throw_exception($run_err) if (
206 defined $txn_init_depth
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)
214 # we got that far - let's retry
215 carp( sprintf 'Retrying %s (attempt %d) after caught exception: %s',
217 $self->failed_attempt_count + 1,
219 ) if $self->retry_debug;
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);
229 return $self->_run($cref, @$args);
232 return wantarray ? @res : $res[0];
236 =head1 AUTHOR AND CONTRIBUTORS
238 See L<AUTHOR|DBIx::Class/AUTHOR> and L<CONTRIBUTORS|DBIx::Class/CONTRIBUTORS> in DBIx::Class
242 You may distribute this code under the same terms as Perl itself.