package # hide from pause until we figure it all out
DBIx::Class::Storage::BlockRunner;
-use Sub::Quote 'quote_sub';
+use warnings;
+use strict;
+
use DBIx::Class::Exception;
use DBIx::Class::Carp;
use Context::Preserve 'preserve_context';
-use Scalar::Util qw/weaken blessed/;
+use DBIx::Class::_Util qw( is_exception qsub dbic_internal_try );
+use Scalar::Util qw(weaken blessed reftype);
use Try::Tiny;
use Moo;
use namespace::clean;
has retry_handler => (
is => 'ro',
required => 1,
- isa => quote_sub( q|
- (ref $_[0]) eq 'CODE'
+ isa => qsub q{
+ (Scalar::Util::reftype($_[0])||'') eq 'CODE'
or DBIx::Class::Exception->throw('retry_handler must be a CODE reference')
- |),
-);
-
-has run_code => (
- is => 'ro',
- required => 1,
- isa => quote_sub( q|
- (ref $_[0]) eq 'CODE'
- or DBIx::Class::Exception->throw('run_code must be a CODE reference')
- |),
-);
-
-has run_args => (
- is => 'ro',
- isa => quote_sub( q|
- (ref $_[0]) eq 'ARRAY'
- or DBIx::Class::Exception->throw('run_args must be an ARRAY reference')
- |),
- default => quote_sub( '[]' ),
+ },
);
has retry_debug => (
is => 'rw',
- default => quote_sub( '$ENV{DBIC_STORAGE_RETRY_DEBUG}' ),
+ # use a sub - to be evaluated on the spot lazily
+ default => qsub '$ENV{DBIC_STORAGE_RETRY_DEBUG}',
+ lazy => 1,
);
-has max_retried_count => (
+has max_attempts => (
is => 'ro',
- default => quote_sub( '20' ),
+ default => 20,
);
-has retried_count => (
+has failed_attempt_count => (
is => 'ro',
- init_arg => undef,
- writer => '_set_retried_count',
- clearer => '_reset_retried_count',
- default => quote_sub(q{ 0 }),
+ init_arg => undef, # ensures one can't pass the value in
+ writer => '_set_failed_attempt_count',
+ default => 0,
lazy => 1,
- trigger => quote_sub(q{
- DBIx::Class::Exception->throw(sprintf (
- 'Exceeded max_retried_count amount of %d, latest exception: %s',
- $_[0]->max_retried_count, $_[0]->last_exception
- )) if $_[0]->max_retried_count < ($_[1]||0);
- }),
+ trigger => qsub q{
+ $_[0]->throw_exception( sprintf (
+ 'Reached max_attempts amount of %d, latest exception: %s',
+ $_[0]->max_attempts, $_[0]->last_exception
+ )) if $_[0]->max_attempts <= ($_[1]||0);
+ },
);
has exception_stack => (
is => 'ro',
init_arg => undef,
clearer => '_reset_exception_stack',
- default => quote_sub(q{ [] }),
+ default => qsub q{ [] },
lazy => 1,
);
sub last_exception { shift->exception_stack->[-1] }
+sub throw_exception { shift->storage->throw_exception (@_) }
+
sub run {
my $self = shift;
- DBIx::Class::Exception->throw('run() takes no arguments') if @_;
-
$self->_reset_exception_stack;
- $self->_reset_retried_count;
+ $self->_set_failed_attempt_count(0);
+
+ my $cref = shift;
+
+ $self->throw_exception('run() requires a coderef to execute as its first argument')
+ if ( reftype($cref)||'' ) ne 'CODE';
+
my $storage = $self->storage;
- return $self->run_code->( @{$self->run_args} )
- if (! $self->wrap_txn and $storage->{_in_do_block});
+ return $cref->( @_ ) if (
+ $storage->{_in_do_block}
+ and
+ ! $self->wrap_txn
+ );
local $storage->{_in_do_block} = 1 unless $storage->{_in_do_block};
- return $self->_run;
+ return $self->_run($cref, @_);
}
# this is the actual recursing worker
sub _run {
- # warnings here mean I did not anticipate some ueber-complex case
- # fatal warnings are not warranted
- no warnings;
- use warnings;
+ # internal method - we know that both refs are strong-held by the
+ # calling scope of run(), hence safe to weaken everything
+ weaken( my $self = shift );
+ weaken( my $cref = shift );
- my $self = shift;
+ my $args = @_ ? \@_ : [];
# from this point on (defined $txn_init_depth) is an indicator for wrap_txn
# save a bit on method calls
my $run_err = '';
- weaken (my $weakself = $self);
-
return preserve_context {
- try {
+ dbic_internal_try {
if (defined $txn_init_depth) {
- $weakself->storage->txn_begin;
+ $self->storage->txn_begin;
$txn_begin_ok = 1;
}
- $weakself->run_code->( @{$weakself->run_args} );
+ $cref->( @$args );
} catch {
$run_err = $_;
(); # important, affects @_ below
} replace => sub {
my @res = @_;
- my $storage = $weakself->storage;
- my $cur_depth = $storage->transaction_depth;
+ my $storage = $self->storage;
- if (defined $txn_init_depth and $run_err eq '') {
+ if (
+ defined $txn_init_depth
+ and
+ ! is_exception $run_err
+ and
+ defined( my $cur_depth = $storage->transaction_depth )
+ ) {
my $delta_txn = (1 + $txn_init_depth) - $cur_depth;
if ($delta_txn) {
'Unexpected reduction of transaction depth by %d after execution of '
. '%s, skipping txn_commit()',
$delta_txn,
- $weakself->run_code,
+ $cref,
) unless $delta_txn == 1 and $cur_depth == 0;
}
else {
- $run_err = eval { $storage->txn_commit; 1 } ? '' : $@;
+ dbic_internal_try {
+ $storage->txn_commit;
+ 1;
+ }
+ catch {
+ $run_err = $_;
+ };
}
}
# something above threw an error (could be the begin, the code or the commit)
- if ($run_err ne '') {
-
- # attempt a rollback if we did begin in the first place
- if ($txn_begin_ok) {
- # some DBDs go crazy if there is nothing to roll back on, perform a soft-check
- my $rollback_exception = $storage->_seems_connected
- ? (! eval { $storage->txn_rollback; 1 }) ? $@ : ''
- : 'lost connection to storage'
- ;
-
- if ( $rollback_exception and (
- ! defined blessed $rollback_exception
- or
- ! $rollback_exception->isa('DBIx::Class::Storage::NESTED_ROLLBACK_EXCEPTION')
- ) ) {
- $run_err = "Transaction aborted: $run_err. Rollback failed: $rollback_exception";
- }
- }
+ if ( is_exception $run_err ) {
+
+ # Attempt a rollback if we did begin in the first place
+ # Will append rollback error if possible
+ $storage->__delicate_rollback( \$run_err )
+ if $txn_begin_ok;
- push @{ $weakself->exception_stack }, $run_err;
+ push @{ $self->exception_stack }, $run_err;
+
+ # this will throw if max_attempts is reached
+ $self->_set_failed_attempt_count($self->failed_attempt_count + 1);
# init depth of > 0 ( > 1 with AC) implies nesting - no retry attempt queries
$storage->throw_exception($run_err) if (
# FIXME - we assume that $storage->{_dbh_autocommit} is there if
# txn_init_depth is there, but this is a DBI-ism
$txn_init_depth > ( $storage->{_dbh_autocommit} ? 0 : 1 )
- ) or ! $weakself->retry_handler->($weakself)
+ )
+ or
+ ! do {
+ local $self->storage->{_in_do_block_retry_handler} = 1
+ unless $self->storage->{_in_do_block_retry_handler};
+ $self->retry_handler->($self)
+ }
);
- $weakself->_set_retried_count($weakself->retried_count + 1);
-
# we got that far - let's retry
- carp( sprintf 'Retrying %s (run %d) after caught exception: %s',
- $weakself->run_code,
- $weakself->retried_count + 1,
+ carp( sprintf 'Retrying %s (attempt %d) after caught exception: %s',
+ $cref,
+ $self->failed_attempt_count + 1,
$run_err,
- ) if $weakself->retry_debug;
+ ) if $self->retry_debug;
$storage->ensure_connected;
# if txn_depth is > 1 this means something was done to the
- # original $dbh, otherwise we would not get past the preceeding if()
+ # original $dbh, otherwise we would not get past the preceding if()
$storage->throw_exception(sprintf
'Unexpected transaction depth of %d on freshly connected handle',
$storage->transaction_depth,
) if (defined $txn_init_depth and $storage->transaction_depth);
- return $weakself->_run;
+ return $self->_run($cref, @$args);
}
return wantarray ? @res : $res[0];
};
}
-=head1 AUTHOR AND CONTRIBUTORS
+=head1 FURTHER QUESTIONS?
-See L<AUTHOR|DBIx::Class/AUTHOR> and L<CONTRIBUTORS|DBIx::Class/CONTRIBUTORS> in DBIx::Class
+Check the list of L<additional DBIC resources|DBIx::Class/GETTING HELP/SUPPORT>.
-=head1 LICENSE
+=head1 COPYRIGHT AND LICENSE
-You may distribute this code under the same terms as Perl itself.
+This module is free software L<copyright|DBIx::Class/COPYRIGHT AND LICENSE>
+by the L<DBIx::Class (DBIC) authors|DBIx::Class/AUTHORS>. You can
+redistribute it and/or modify it under the same terms as the
+L<DBIx::Class library|DBIx::Class/COPYRIGHT AND LICENSE>.
=cut