X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FDBIx%2FClass%2FStorage.pm;h=d949b01e428c06969605405909e242d3ac0d0686;hb=e50536940adf2ebaef907a0c29ae37fbd5ce95b1;hp=470911b4fb9a837aa8246d3bc573874ab89dad62;hpb=47d7b769c034e04989840b1efc2f5991518cff23;p=dbsrgits%2FDBIx-Class.git diff --git a/lib/DBIx/Class/Storage.pm b/lib/DBIx/Class/Storage.pm index 470911b..d949b01 100644 --- a/lib/DBIx/Class/Storage.pm +++ b/lib/DBIx/Class/Storage.pm @@ -16,6 +16,7 @@ use DBIx::Class::Carp; use DBIx::Class::Storage::BlockRunner; use Scalar::Util qw/blessed weaken/; use DBIx::Class::Storage::TxnScopeGuard; +use DBIx::Class::_Util qw( dbic_internal_try fail_on_internal_call ); use Try::Tiny; use namespace::clean; @@ -24,7 +25,10 @@ __PACKAGE__->mk_group_accessors(component_class => 'cursor_class'); __PACKAGE__->cursor_class('DBIx::Class::Cursor'); -sub cursor { shift->cursor_class(@_); } +sub cursor { + DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call; + shift->cursor_class(@_); +} =head1 NAME @@ -51,7 +55,6 @@ sub new { $self = ref $self if ref $self; my $new = bless( { - transaction_depth => 0, savepoints => [], }, $self); @@ -175,18 +178,16 @@ transaction failure. sub txn_do { my $self = shift; - my $coderef = shift; DBIx::Class::Storage::BlockRunner->new( storage => $self, - run_code => $coderef, - run_args => @_ - ? \@_ # take a ref instead of a copy, to preserve @_ aliasing - : [] # semantics within the coderef, but only if needed - , # (pseudoforking doesn't like this trick much) wrap_txn => 1, - retry_handler => sub { ! ( $_[0]->retried_count or $_[0]->storage->connected ) }, - )->run; + retry_handler => sub { + $_[0]->failed_attempt_count == 1 + and + ! $_[0]->storage->connected + }, + )->run(@_); } =head2 txn_begin @@ -229,6 +230,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}--; @@ -252,8 +254,20 @@ sub txn_rollback { if ($self->transaction_depth == 1) { $self->debugobj->txn_rollback() if $self->debug; - $self->_exec_txn_rollback; $self->{transaction_depth}--; + + # in case things get really hairy - just disconnect + dbic_internal_try { $self->_exec_txn_rollback; 1 } or do { + my $rollback_error = $@; + + # whatever happens, too low down the stack to care + # FIXME - revisit if stackable exceptions become a thing + dbic_internal_try { $self->disconnect }; + + die $rollback_error; + }; + + $self->savepoints([]); } elsif ($self->transaction_depth > 1) { $self->{transaction_depth}--; @@ -273,6 +287,98 @@ sub txn_rollback { } } +# to be called by several internal stacked transaction handler codepaths +# not for external consumption +# *DOES NOT* throw exceptions, instead: +# - returns false on success +# - returns the exception on failed rollback +sub __delicate_rollback { + my $self = shift; + + if ( + ( $self->transaction_depth || 0 ) > 1 + and + # FIXME - the autosvp check here shouldn't be happening, it should be a role-ish thing + # The entire concept needs to be rethought with the storage layer... or something + ! $self->auto_savepoint + and + # the handle seems healthy, and there is nothing for us to do with it + # just go ahead and bow out, without triggering the txn_rollback() "nested exception" + # the unwind will eventually fail somewhere higher up if at all + # FIXME: a ::Storage::DBI-specific method, not a generic ::Storage one + $self->_seems_connected + ) { + # all above checks out - there is nothing to do on the $dbh itself + # just a plain soft-decrease of depth + $self->{transaction_depth}--; + return; + } + + my @args = @_; + my $rbe; + + dbic_internal_try { + $self->txn_rollback; 1 + } + catch { + + $rbe = $_; + + # we were passed an existing exception to augment (think DESTROY stacks etc) + if (@args) { + my ($exception) = @args; + + # append our text - THIS IS A TEMPORARY FIXUP! + # + # If the passed in exception is a reference, or an object we don't know + # how to augment - flattening it is just damn rude + if ( + # FIXME - a better way, not liable to destroy an existing exception needs + # to be created. For the time being perpetuating the sin below in order + # to break the deadlock of which yak is being shaved first + 0 + and + length ref $$exception + and + ( + ! defined blessed $$exception + or + ! $$exception->isa( 'DBIx::Class::Exception' ) + ) + ) { + + ################## + ### FIXME - TODO + ################## + + } + else { + + # SUCH HIDEOUS, MUCH AUGH! (and double WOW on the s/// at the end below) + $rbe =~ s/ at .+? line \d+$//; + + ( + ( + defined blessed $$exception + and + $$exception->isa( 'DBIx::Class::Exception' ) + ) + ? ( + $$exception->{msg} = + "Transaction aborted: $$exception->{msg}. Rollback failed: $rbe" + ) + : ( + $$exception = + "Transaction aborted: $$exception. Rollback failed: $rbe" + ) + ) =~ s/Transaction aborted: (?=Transaction aborted:)//; + } + } + }; + + return $rbe; +} + =head2 svp_begin Arguments: $savepoint_name? @@ -328,12 +434,15 @@ sub svp_release { if (defined $name) { my @stack = @{ $self->savepoints }; - my $svp; + my $svp = ''; - do { $svp = pop @stack } until $svp eq $name; + while( $svp ne $name ) { - $self->throw_exception ("Savepoint '$name' does not exist") - unless $svp; + $self->throw_exception ("Savepoint '$name' does not exist") + unless @stack; + + $svp = pop @stack; + } $self->savepoints(\@stack); # put back what's left } @@ -436,10 +545,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 @@ -473,9 +582,13 @@ sub debugobj { my @pp_args; if ($profile =~ /^\.?\//) { - require Config::Any; - my $cfg = try { + require DBIx::Class::Optional::Dependencies; + if ( my $missing = DBIx::Class::Optional::Dependencies->req_missing_for ('config_file_reader') ) { + $self->throw_exception("Unable to parse TRACE_PROFILE config file '$profile' without $missing"); + } + + my $cfg = dbic_internal_try { Config::Any->load_files({ files => [$profile], use_ext => 1 }); } catch { # sanitize the error message a bit @@ -501,7 +614,7 @@ sub debugobj { # # Yes I am aware this is fragile and TxnScopeGuard needs # a better fix. This is another yak to shave... :( - try { + dbic_internal_try { DBIx::Class::Storage::Debug::PrettyPrint->new(@pp_args); } catch { $self->throw_exception($_); @@ -636,7 +749,6 @@ 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 @@ -646,13 +758,16 @@ Old name for DBIC_TRACE L - reference storage implementation using SQL::Abstract and DBI. -=head1 AUTHOR AND CONTRIBUTORS +=head1 FURTHER QUESTIONS? -See L and L in DBIx::Class +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