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