1 package # hide from pause until we figure it all out
2 DBIx::Class::Storage::BlockRunner;
7 # DO NOT edit away without talking to riba first, he will just put it back
8 # BEGIN pre-Moo2 import block
10 my $initial_fatal_bits = (${^WARNING_BITS}||'') & $warnings::DeadBits{all};
11 local $ENV{PERL_STRICTURES_EXTRA} = 0;
12 require Moo; Moo->import;
13 ${^WARNING_BITS} &= ( $initial_fatal_bits | ~ $warnings::DeadBits{all} );
15 # END pre-Moo2 import block
17 use DBIx::Class::Exception;
18 use DBIx::Class::Carp;
19 use Context::Preserve 'preserve_context';
20 use DBIx::Class::_Util qw(is_exception qsub);
21 use Scalar::Util qw(weaken blessed reftype);
28 DBIx::Class::Storage::BlockRunner - Try running a block of code until success with a configurable retry logic
46 # true - retry, false - rethrow, or you can throw your own (not catching)
47 has retry_handler => (
51 (Scalar::Util::reftype($_[0])||'') eq 'CODE'
52 or DBIx::Class::Exception->throw('retry_handler must be a CODE reference')
58 # use a sub - to be evaluated on the spot lazily
59 default => qsub '$ENV{DBIC_STORAGE_RETRY_DEBUG}',
68 has failed_attempt_count => (
70 init_arg => undef, # ensures one can't pass the value in
71 writer => '_set_failed_attempt_count',
75 $_[0]->throw_exception( sprintf (
76 'Reached max_attempts amount of %d, latest exception: %s',
77 $_[0]->max_attempts, $_[0]->last_exception
78 )) if $_[0]->max_attempts <= ($_[1]||0);
82 has exception_stack => (
85 clearer => '_reset_exception_stack',
86 default => qsub q{ [] },
90 sub last_exception { shift->exception_stack->[-1] }
92 sub throw_exception { shift->storage->throw_exception (@_) }
97 $self->_reset_exception_stack;
98 $self->_set_failed_attempt_count(0);
102 $self->throw_exception('run() requires a coderef to execute as its first argument')
103 if ( reftype($cref)||'' ) ne 'CODE';
105 my $storage = $self->storage;
107 return $cref->( @_ ) if (
108 $storage->{_in_do_block}
113 local $storage->{_in_do_block} = 1 unless $storage->{_in_do_block};
115 return $self->_run($cref, @_);
118 # this is the actual recursing worker
120 # internal method - we know that both refs are strong-held by the
121 # calling scope of run(), hence safe to weaken everything
122 weaken( my $self = shift );
123 weaken( my $cref = shift );
125 my $args = @_ ? \@_ : [];
127 # from this point on (defined $txn_init_depth) is an indicator for wrap_txn
128 # save a bit on method calls
129 my $txn_init_depth = $self->wrap_txn ? $self->storage->transaction_depth : undef;
134 return preserve_context {
136 if (defined $txn_init_depth) {
137 $self->storage->txn_begin;
143 (); # important, affects @_ below
148 my $storage = $self->storage;
149 my $cur_depth = $storage->transaction_depth;
151 if (defined $txn_init_depth and ! is_exception $run_err) {
152 my $delta_txn = (1 + $txn_init_depth) - $cur_depth;
155 # a rollback in a top-level txn_do is valid-ish (seen in the wild and our own tests)
157 'Unexpected reduction of transaction depth by %d after execution of '
158 . '%s, skipping txn_commit()',
161 ) unless $delta_txn == 1 and $cur_depth == 0;
164 $run_err = eval { $storage->txn_commit; 1 } ? '' : $@;
168 # something above threw an error (could be the begin, the code or the commit)
169 if ( is_exception $run_err ) {
171 # attempt a rollback if we did begin in the first place
173 # some DBDs go crazy if there is nothing to roll back on, perform a soft-check
174 my $rollback_exception = $storage->_seems_connected
175 ? (! eval { $storage->txn_rollback; 1 }) ? $@ : ''
176 : 'lost connection to storage'
179 if ( $rollback_exception and (
180 ! defined blessed $rollback_exception
182 ! $rollback_exception->isa('DBIx::Class::Storage::NESTED_ROLLBACK_EXCEPTION')
184 $run_err = "Transaction aborted: $run_err. Rollback failed: $rollback_exception";
188 push @{ $self->exception_stack }, $run_err;
190 # this will throw if max_attempts is reached
191 $self->_set_failed_attempt_count($self->failed_attempt_count + 1);
193 # init depth of > 0 ( > 1 with AC) implies nesting - no retry attempt queries
194 $storage->throw_exception($run_err) if (
196 defined $txn_init_depth
198 # FIXME - we assume that $storage->{_dbh_autocommit} is there if
199 # txn_init_depth is there, but this is a DBI-ism
200 $txn_init_depth > ( $storage->{_dbh_autocommit} ? 0 : 1 )
201 ) or ! $self->retry_handler->($self)
204 # we got that far - let's retry
205 carp( sprintf 'Retrying %s (attempt %d) after caught exception: %s',
207 $self->failed_attempt_count + 1,
209 ) if $self->retry_debug;
211 $storage->ensure_connected;
212 # if txn_depth is > 1 this means something was done to the
213 # original $dbh, otherwise we would not get past the preceding if()
214 $storage->throw_exception(sprintf
215 'Unexpected transaction depth of %d on freshly connected handle',
216 $storage->transaction_depth,
217 ) if (defined $txn_init_depth and $storage->transaction_depth);
219 return $self->_run($cref, @$args);
222 return wantarray ? @res : $res[0];
226 =head1 AUTHOR AND CONTRIBUTORS
228 See L<AUTHOR|DBIx::Class/AUTHOR> and L<CONTRIBUTORS|DBIx::Class/CONTRIBUTORS> in DBIx::Class
232 You may distribute this code under the same terms as Perl itself.