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);
18 DBIx::Class::Storage::BlockRunner - Try running a block of code until success with a configurable retry logic
36 # true - retry, false - rethrow, or you can throw your own (not catching)
37 has retry_handler => (
41 (Scalar::Util::reftype($_[0])||'') eq 'CODE'
42 or DBIx::Class::Exception->throw('retry_handler must be a CODE reference')
48 # use a sub - to be evaluated on the spot lazily
49 default => qsub '$ENV{DBIC_STORAGE_RETRY_DEBUG}',
58 has failed_attempt_count => (
60 init_arg => undef, # ensures one can't pass the value in
61 writer => '_set_failed_attempt_count',
65 $_[0]->throw_exception( sprintf (
66 'Reached max_attempts amount of %d, latest exception: %s',
67 $_[0]->max_attempts, $_[0]->last_exception
68 )) if $_[0]->max_attempts <= ($_[1]||0);
72 has exception_stack => (
75 clearer => '_reset_exception_stack',
76 default => qsub q{ [] },
80 sub last_exception { shift->exception_stack->[-1] }
82 sub throw_exception { shift->storage->throw_exception (@_) }
87 $self->_reset_exception_stack;
88 $self->_set_failed_attempt_count(0);
92 $self->throw_exception('run() requires a coderef to execute as its first argument')
93 if ( reftype($cref)||'' ) ne 'CODE';
95 my $storage = $self->storage;
97 return $cref->( @_ ) if (
98 $storage->{_in_do_block}
103 local $storage->{_in_do_block} = 1 unless $storage->{_in_do_block};
105 return $self->_run($cref, @_);
108 # this is the actual recursing worker
110 # internal method - we know that both refs are strong-held by the
111 # calling scope of run(), hence safe to weaken everything
112 weaken( my $self = shift );
113 weaken( my $cref = shift );
115 my $args = @_ ? \@_ : [];
117 # from this point on (defined $txn_init_depth) is an indicator for wrap_txn
118 # save a bit on method calls
119 my $txn_init_depth = $self->wrap_txn ? $self->storage->transaction_depth : undef;
124 return preserve_context {
126 if (defined $txn_init_depth) {
127 $self->storage->txn_begin;
133 (); # important, affects @_ below
138 my $storage = $self->storage;
141 defined $txn_init_depth
143 ! is_exception $run_err
145 defined( my $cur_depth = $storage->transaction_depth )
147 my $delta_txn = (1 + $txn_init_depth) - $cur_depth;
150 # a rollback in a top-level txn_do is valid-ish (seen in the wild and our own tests)
152 'Unexpected reduction of transaction depth by %d after execution of '
153 . '%s, skipping txn_commit()',
156 ) unless $delta_txn == 1 and $cur_depth == 0;
159 $run_err = eval { $storage->txn_commit; 1 } ? '' : $@;
163 # something above threw an error (could be the begin, the code or the commit)
164 if ( is_exception $run_err ) {
166 # Attempt a rollback if we did begin in the first place
167 # Will append rollback error if possible
168 $storage->__delicate_rollback( \$run_err )
171 push @{ $self->exception_stack }, $run_err;
173 # this will throw if max_attempts is reached
174 $self->_set_failed_attempt_count($self->failed_attempt_count + 1);
176 # init depth of > 0 ( > 1 with AC) implies nesting - no retry attempt queries
177 $storage->throw_exception($run_err) if (
179 defined $txn_init_depth
181 # FIXME - we assume that $storage->{_dbh_autocommit} is there if
182 # txn_init_depth is there, but this is a DBI-ism
183 $txn_init_depth > ( $storage->{_dbh_autocommit} ? 0 : 1 )
184 ) or ! $self->retry_handler->($self)
187 # we got that far - let's retry
188 carp( sprintf 'Retrying %s (attempt %d) after caught exception: %s',
190 $self->failed_attempt_count + 1,
192 ) if $self->retry_debug;
194 $storage->ensure_connected;
195 # if txn_depth is > 1 this means something was done to the
196 # original $dbh, otherwise we would not get past the preceding if()
197 $storage->throw_exception(sprintf
198 'Unexpected transaction depth of %d on freshly connected handle',
199 $storage->transaction_depth,
200 ) if (defined $txn_init_depth and $storage->transaction_depth);
202 return $self->_run($cref, @$args);
205 return wantarray ? @res : $res[0];
209 =head1 FURTHER QUESTIONS?
211 Check the list of L<additional DBIC resources|DBIx::Class/GETTING HELP/SUPPORT>.
213 =head1 COPYRIGHT AND LICENSE
215 This module is free software L<copyright|DBIx::Class/COPYRIGHT AND LICENSE>
216 by the L<DBIx::Class (DBIC) authors|DBIx::Class/AUTHORS>. You can
217 redistribute it and/or modify it under the same terms as the
218 L<DBIx::Class library|DBIx::Class/COPYRIGHT AND LICENSE>.