X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FDBIx%2FClass%2FStorage.pm;h=049230af6419f049c322af64ee6916d635181553;hb=757891ed5c4132d95e339212a5f66a2ee9fe4503;hp=251c407b0f9506a17819d9c3ddc12045f135ccc5;hpb=90d7422fc60a3bad71cc67dc20106ef68046664e;p=dbsrgits%2FDBIx-Class.git diff --git a/lib/DBIx/Class/Storage.pm b/lib/DBIx/Class/Storage.pm index 251c407..049230a 100644 --- a/lib/DBIx/Class/Storage.pm +++ b/lib/DBIx/Class/Storage.pm @@ -13,6 +13,7 @@ use mro 'c3'; } use DBIx::Class::Carp; +use DBIx::Class::Storage::BlockRunner; use Scalar::Util qw/blessed weaken/; use DBIx::Class::Storage::TxnScopeGuard; use Try::Tiny; @@ -174,88 +175,16 @@ transaction failure. sub txn_do { my $self = shift; - my $coderef = shift; - ref $coderef eq 'CODE' or $self->throw_exception - ('$coderef must be a CODE reference'); - - my $abort_txn = sub { - my ($self, $exception) = @_; - - my $rollback_exception = try { $self->txn_rollback; undef } catch { shift }; - - if ( $rollback_exception and ( - ! defined blessed $rollback_exception - or - ! $rollback_exception->isa('DBIx::Class::Storage::NESTED_ROLLBACK_EXCEPTION') - ) ) { - $self->throw_exception( - "Transaction aborted: ${exception}. " - . "Rollback failed: ${rollback_exception}" - ); - } - $self->throw_exception($exception); - }; - - # take a ref instead of a copy, to preserve coderef @_ aliasing semantics - my $args = \@_; - - # do not turn on until a succesful txn_begin - my $attempt_commit = 0; - - my $txn_init_depth = $self->transaction_depth; - - try { - $self->txn_begin; - $attempt_commit = 1; - $coderef->(@$args) - } - catch { - $attempt_commit = 0; - - # init depth of > 0 implies nesting or non-autocommit (either way no retry) - if($txn_init_depth or $self->connected ) { - $abort_txn->($self, $_); - } - else { - carp "Retrying txn_do($coderef) after catching disconnected exception: $_" - if $ENV{DBIC_STORAGE_RETRY_DEBUG}; - - $self->_populate_dbh; - - # if txn_depth is > 1 this means something was done to the - # original $dbh, otherwise we would not get past the if() above - $self->throw_exception(sprintf - 'Unexpected transaction depth of %d on freshly connected handle', - $self->transaction_depth, - ) if $self->transaction_depth; - - $self->txn_begin; - $attempt_commit = 1; - - try { - $coderef->(@$args) - } - catch { - $attempt_commit = 0; - $abort_txn->($self, $_) - }; - }; - } - finally { - if ($attempt_commit) { - my $delta_txn = (1 + $txn_init_depth) - $self->transaction_depth; - - if ($delta_txn) { - # a rollback in a top-level txn_do is valid-ish (seen in the wild and our own tests) - carp "Unexpected reduction of transaction depth by $delta_txn after execution of $coderef, skipping txn_do's commit" - unless $delta_txn == 1 and $self->transaction_depth == 0; - } - else { - $self->txn_commit; - } - } - }; + DBIx::Class::Storage::BlockRunner->new( + storage => $self, + wrap_txn => 1, + retry_handler => sub { + $_[0]->failed_attempt_count == 1 + and + ! $_[0]->storage->connected + }, + )->run(@_); } =head2 txn_begin @@ -298,6 +227,7 @@ sub txn_commit { $self->debugobj->txn_commit() if $self->debug; $self->_exec_txn_commit; $self->{transaction_depth}--; + $self->savepoints([]); } elsif($self->transaction_depth > 1) { $self->{transaction_depth}--; @@ -323,6 +253,7 @@ sub txn_rollback { $self->debugobj->txn_rollback() if $self->debug; $self->_exec_txn_rollback; $self->{transaction_depth}--; + $self->savepoints([]); } elsif ($self->transaction_depth > 1) { $self->{transaction_depth}--; @@ -460,8 +391,6 @@ sub svp_rollback { $exec->($self, $name); } -=for comment - =head2 txn_scope_guard An alternative way of transaction handling based on @@ -469,8 +398,8 @@ L: my $txn_guard = $storage->txn_scope_guard; - $row->col1("val1"); - $row->update; + $result->col1("val1"); + $result->update; $txn_guard->commit; @@ -507,10 +436,10 @@ shell environment. =head2 debugfh -Set or retrieve the filehandle used for trace/debug output. This should be -an IO::Handle compatible object (only the C method is used. Initially -set to be STDERR - although see information on the -L environment variable. +An opportunistic proxy to L<< ->debugobj->debugfh(@_) +|DBIx::Class::Storage::Statistics/debugfh >> +If the currently set L does not have a L method, caling +this is a no-op. =cut @@ -541,6 +470,8 @@ sub debugobj { $self->{debugobj} ||= do { if (my $profile = $ENV{DBIC_TRACE_PROFILE}) { require DBIx::Class::Storage::Debug::PrettyPrint; + my @pp_args; + if ($profile =~ /^\.?\//) { require Config::Any; @@ -552,10 +483,28 @@ sub debugobj { $self->throw_exception("Failure processing \$ENV{DBIC_TRACE_PROFILE}: $_"); }; - DBIx::Class::Storage::Debug::PrettyPrint->new(values %{$cfg->[0]}); + @pp_args = values %{$cfg->[0]}; } else { - DBIx::Class::Storage::Debug::PrettyPrint->new({ profile => $profile }); + @pp_args = { profile => $profile }; + } + + # FIXME - FRAGILE + # Hash::Merge is a sorry piece of shit and tramples all over $@ + # *without* throwing an exception + # This is a rather serious problem in the debug codepath + # Insulate the condition here with a try{} until a review of + # DBIx::Class::Storage::Debug::PrettyPrint takes place + # we do rethrow the error unconditionally, the only reason + # to try{} is to preserve the precise state of $@ (down + # to the scalar (if there is one) address level) + # + # Yes I am aware this is fragile and TxnScopeGuard needs + # a better fix. This is another yak to shave... :( + try { + DBIx::Class::Storage::Debug::PrettyPrint->new(@pp_args); + } catch { + $self->throw_exception($_); } } else { @@ -680,14 +629,13 @@ re-connect on your schema. =head2 DBIC_TRACE_PROFILE -If C is set, L +If C is set, L will be used to format the output from C. The value it is set to is the C that it will be used. If the value is a filename the file is read with L and the results are used as the configuration for tracing. See L for what that structure should look like. - =head2 DBIX_CLASS_STORAGE_DBI_DEBUG Old name for DBIC_TRACE @@ -697,15 +645,16 @@ Old name for DBIC_TRACE L - reference storage implementation using SQL::Abstract and DBI. -=head1 AUTHORS - -Matt S. Trout +=head1 FURTHER QUESTIONS? -Andy Grundman +Check the list of L. -=head1 LICENSE +=head1 COPYRIGHT AND LICENSE -You may distribute this code under the same terms as Perl itself. +This module is free software L +by the L. You can +redistribute it and/or modify it under the same terms as the +L. =cut