From 20075ccf629fa12a28ddb5e5f5b08e6f528d0759 Mon Sep 17 00:00:00 2001
From: Michael Conrad <mconrad@intellitree.com>
Date: Mon, 23 Jan 2017 16:08:29 -0500
Subject: [PATCH] Deliberate rollback support for TxnScopeGuard

When using txn_scope_guard, if you know you need to roll back
the transaction it is nice to be able to avoid the warning
you would otherwise get when it goes out of scope.
---
 lib/DBIx/Class/Storage/TxnScopeGuard.pm | 18 +++++++++++++++++-
 t/storage/txn_scope_guard.t             | 19 ++++++++++++++++++-
 2 files changed, 35 insertions(+), 2 deletions(-)

diff --git a/lib/DBIx/Class/Storage/TxnScopeGuard.pm b/lib/DBIx/Class/Storage/TxnScopeGuard.pm
index f961c4e44..7b1c6b8b0 100644
--- a/lib/DBIx/Class/Storage/TxnScopeGuard.pm
+++ b/lib/DBIx/Class/Storage/TxnScopeGuard.pm
@@ -42,7 +42,7 @@ sub new {
 sub commit {
   my $self = shift;
 
-  $self->{storage}->throw_exception("Refusing to execute multiple commits on scope guard $self")
+  $self->{storage}->throw_exception("Refusing to execute multiple commit/rollbacks on scope guard $self")
     if $self->{inactivated};
 
   # FIXME - this assumption may be premature: a commit may fail and a rollback
@@ -54,6 +54,16 @@ sub commit {
   $self->{storage}->txn_commit;
 }
 
+sub rollback {
+  my $self = shift;
+  
+  $self->{storage}->throw_exception("Refusing to execute multiple commit/rollbacks on scope guard $self")
+    if $self->{inactivated};
+  
+  $self->{inactivated} = 1;
+  $self->{storage}->txn_rollback;
+}
+
 sub DESTROY {
   return if &detected_reinvoked_destructor;
 
@@ -149,6 +159,12 @@ Commit the transaction, and stop guarding the scope. If this method is not
 called and this object goes out of scope (e.g. an exception is thrown) then
 the transaction is rolled back, via L<DBIx::Class::Storage/txn_rollback>
 
+=head2 rollback
+
+Roll back the transaction, and stop guarding the scope. You can use this to
+avoid the warning when the scope guard goes out of scope, for deliberate
+rollbacks.
+
 =cut
 
 =head1 SEE ALSO
diff --git a/t/storage/txn_scope_guard.t b/t/storage/txn_scope_guard.t
index 00d81a46d..91ccb6f54 100644
--- a/t/storage/txn_scope_guard.t
+++ b/t/storage/txn_scope_guard.t
@@ -57,7 +57,24 @@ use DBICTest;
 
     ok(!$artist_rs->find({name => 'Death Cab for Cutie'}), "Artist not created");
 
-  }, 'rollback successful withot exception');
+  }, 'rollback successful without exception');
+  
+  lives_ok (sub {
+    # this weird assignment is to stop perl <= 5.8.9 leaking $schema on nested sub{}s
+    my $s = $schema;
+
+    warnings_are ( sub {
+      my $guard = $schema->txn_scope_guard;
+      $schema->resultset('Artist')->create({
+        name => 'Death Cab for Cutie',
+      });
+      inner($schema, 0);
+      $guard->rollback;
+    }, [], 'Deliberate rollback without warning');
+
+    ok(!$artist_rs->find({name => 'Death Cab for Cutie'}), "Artist not created");
+
+  }, 'rollback successful without exception');
 
   sub outer {
     my ($schema, $fatal) = @_;