Fix multiple savepointing transactions on DBD::SQLite

[dbsrgits/DBIx-Class.git] / lib / DBIx / Class / Storage.pm

diff --git a/lib/DBIx/Class/Storage.pm b/lib/DBIx/Class/Storage.pm
index 6b88d28..ad1770e 100644 (file)
--- a/lib/DBIx/Class/Storage.pm
+++ b/lib/DBIx/Class/Storage.pm
@@ -175,18 +175,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 +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}--;
@@ -254,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}--;
@@ -398,8 +398,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;
 
@@ -437,7 +437,7 @@ 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
+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.
 
@@ -470,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;
 
@@ -481,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 {