lib/DBIx/Class/Storage/TxnScopeGuard.pm

   1 package DBIx::Class::Storage::TxnScopeGuard;
   2
   3 use strict;
   4 use warnings;
   5 use Carp::Clan qw/^DBIx::Class/;
   6 use Try::Tiny;
   7 use Scalar::Util qw/weaken blessed/;
   8 use DBIx::Class::Exception;
   9 use namespace::clean;
  10
  11 # temporary until we fix the $@ issue in core
  12 # we also need a real appendable, stackable exception object
  13 # (coming soon)
  14 BEGIN {
  15   if ($] >= 5.013001 and $] <= 5.013007) {
  16     *IS_BROKEN_PERL = sub () { 1 };
  17   }
  18   else {
  19     *IS_BROKEN_PERL = sub () { 0 };
  20   }
  21 }
  22
  23 my ($guards_count, $compat_handler, $foreign_handler);
  24
  25 sub new {
  26   my ($class, $storage) = @_;
  27
  28   $storage->txn_begin;
  29   my $guard = bless [ 0, $storage, $storage->_dbh ], ref $class || $class;
  30
  31
  32   # install a callback carefully
  33   if (IS_BROKEN_PERL and !$guards_count) {
  34
  35     # if the thrown exception is a plain string, wrap it in our
  36     # own exception class
  37     # this is actually a pretty cool idea, may very well keep it
  38     # after perl is fixed
  39     $compat_handler ||= bless(
  40       sub {
  41         $@ = (blessed($_[0]) or ref($_[0]))
  42           ? $_[0]
  43           : bless ( { msg => $_[0] }, 'DBIx::Class::Exception')
  44         ;
  45         die;
  46       },
  47       '__TxnScopeGuard__FIXUP__',
  48     );
  49
  50     if ($foreign_handler = $SIG{__DIE__}) {
  51       $SIG{__DIE__} = bless (
  52         sub {
  53           # we trust the foreign handler to do whatever it wants, all we do is set $@
  54           eval { $compat_handler->(@_) };
  55           $foreign_handler->(@_);
  56         },
  57         '__TxnScopeGuard__FIXUP__',
  58       );
  59     }
  60     else {
  61       $SIG{__DIE__} = $compat_handler;
  62     }
  63   }
  64
  65   $guards_count++;
  66
  67   weaken ($guard->[2]);
  68   $guard;
  69 }
  70
  71 sub commit {
  72   my $self = shift;
  73
  74   $self->[1]->txn_commit;
  75   $self->[0] = 1;
  76 }
  77
  78 sub DESTROY {
  79   my ($dismiss, $storage) = @{$_[0]};
  80
  81   $guards_count--;
  82
  83   # don't touch unless it's ours, and there are no more of us left
  84   if (
  85     IS_BROKEN_PERL
  86       and
  87     !$guards_count
  88   ) {
  89
  90     if (ref $SIG{__DIE__} eq '__TxnScopeGuard__FIXUP__') {
  91       # restore what we saved
  92       if ($foreign_handler) {
  93         $SIG{__DIE__} = $foreign_handler;
  94       }
  95       else {
  96         delete $SIG{__DIE__};
  97       }
  98     }
  99
 100     # make sure we do not leak the foreign one in case it exists
 101     undef $foreign_handler;
 102   }
 103
 104   return if $dismiss;
 105
 106   # if our dbh is not ours anymore, the weakref will go undef
 107   $storage->_verify_pid;
 108   return unless $_[0]->[2];
 109
 110   my $exception = $@;
 111
 112   {
 113     local $@;
 114
 115     carp 'A DBIx::Class::Storage::TxnScopeGuard went out of scope without explicit commit or error. Rolling back.'
 116       unless $exception;
 117
 118     my $rollback_exception;
 119     # do minimal connectivity check due to weird shit like
 120     # https://rt.cpan.org/Public/Bug/Display.html?id=62370
 121     try { $storage->_seems_connected && $storage->txn_rollback }
 122     catch { $rollback_exception = shift };
 123
 124     if (defined $rollback_exception && $rollback_exception !~ /DBIx::Class::Storage::NESTED_ROLLBACK_EXCEPTION/) {
 125       # append our text - THIS IS A TEMPORARY FIXUP!
 126       # a real stackable exception object is in the works
 127       if (ref $exception eq 'DBIx::Class::Exception') {
 128         $exception->{msg} = "Transaction aborted: $exception->{msg} "
 129           ."Rollback failed: ${rollback_exception}";
 130       }
 131       elsif ($exception) {
 132         $exception = "Transaction aborted: ${exception} "
 133           ."Rollback failed: ${rollback_exception}";
 134       }
 135       else {
 136         carp (join ' ',
 137           "********************* ROLLBACK FAILED!!! ********************",
 138           "\nA rollback operation failed after the guard went out of scope.",
 139           'This is potentially a disastrous situation, check your data for',
 140           "consistency: $rollback_exception"
 141         );
 142       }
 143     }
 144   }
 145
 146   $@ = $exception unless IS_BROKEN_PERL;
 147 }
 148
 149 1;
 150
 151 __END__
 152
 153 =head1 NAME
 154
 155 DBIx::Class::Storage::TxnScopeGuard - Scope-based transaction handling
 156
 157 =head1 SYNOPSIS
 158
 159  sub foo {
 160    my ($self, $schema) = @_;
 161
 162    my $guard = $schema->txn_scope_guard;
 163
 164    # Multiple database operations here
 165
 166    $guard->commit;
 167  }
 168
 169 =head1 DESCRIPTION
 170
 171 An object that behaves much like L<Scope::Guard>, but hardcoded to do the
 172 right thing with transactions in DBIx::Class.
 173
 174 =head1 METHODS
 175
 176 =head2 new
 177
 178 Creating an instance of this class will start a new transaction (by
 179 implicitly calling L<DBIx::Class::Storage/txn_begin>. Expects a
 180 L<DBIx::Class::Storage> object as its only argument.
 181
 182 =head2 commit
 183
 184 Commit the transaction, and stop guarding the scope. If this method is not
 185 called and this object goes out of scope (e.g. an exception is thrown) then
 186 the transaction is rolled back, via L<DBIx::Class::Storage/txn_rollback>
 187
 188 =cut
 189
 190 =head1 SEE ALSO
 191
 192 L<DBIx::Class::Schema/txn_scope_guard>.
 193
 194 =head1 AUTHOR
 195
 196 Ash Berlin, 2008.
 197
 198 Inspired by L<Scope::Guard> by chocolateboy.
 199
 200 This module is free software. It may be used, redistributed and/or modified
 201 under the same terms as Perl itself.
 202
 203 =cut