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=0e162cf496ae8d56e9d7f53ca4a2d92ae75262ab;hpb=11544e1d2d3ef6c010616c061563996a3b10df37;p=dbsrgits%2FDBIx-Class.git

diff --git a/lib/DBIx/Class/Storage.pm b/lib/DBIx/Class/Storage.pm
index 0e162cf..d949b01 100644
--- a/lib/DBIx/Class/Storage.pm
+++ b/lib/DBIx/Class/Storage.pm
@@ -13,8 +13,10 @@ use mro 'c3';
 }
 
 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;
 
@@ -23,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
 
@@ -50,7 +55,6 @@ sub new {
   $self = ref $self if ref $self;
 
   my $new = bless( {
-    transaction_depth => 0,
     savepoints => [],
   }, $self);
 
@@ -174,88 +178,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 +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}--;
@@ -321,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}--;
@@ -342,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?
@@ -397,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
   }
@@ -467,8 +507,8 @@ L<DBIx::Class::Storage::TxnScopeGuard>:
 
  my $txn_guard = $storage->txn_scope_guard;
 
- $row->col1("val1");
- $row->update;
+ $result->col1("val1");
+ $result->update;
 
  $txn_guard->commit;
 
@@ -505,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<print> method is used.  Initially
-set to be STDERR - although see information on the
-L<DBIC_TRACE> environment variable.
+An opportunistic proxy to L<< ->debugobj->debugfh(@_)
+|DBIx::Class::Storage::Statistics/debugfh >>
+If the currently set L</debugobj> does not have a L</debugfh> method, caling
+this is a no-op.
 
 =cut
 
@@ -539,10 +579,16 @@ 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;
 
-        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
@@ -550,10 +596,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... :(
+      dbic_internal_try {
+        DBIx::Class::Storage::Debug::PrettyPrint->new(@pp_args);
+      } catch {
+        $self->throw_exception($_);
       }
     }
     else {
@@ -685,7 +749,6 @@ filename the file is read with L<Config::Any> and the results are
 used as the configuration for tracing.  See L<SQL::Abstract::Tree/new>
 for what that structure should look like.
 
-
 =head2 DBIX_CLASS_STORAGE_DBI_DEBUG
 
 Old name for DBIC_TRACE
@@ -695,15 +758,16 @@ Old name for DBIC_TRACE
 L<DBIx::Class::Storage::DBI> - reference storage implementation using
 SQL::Abstract and DBI.
 
-=head1 AUTHORS
-
-Matt S. Trout <mst@shadowcatsystems.co.uk>
+=head1 FURTHER QUESTIONS?
 
-Andy Grundman <andy@hybridized.org>
+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