lib/DBIx/Class/Storage/TxnScopeGuard.pm

   1 package DBIx::Class::Storage::TxnScopeGuard;
   2
   3 use strict;
   4 use warnings;
   5 use Try::Tiny;
   6 use Scalar::Util qw/weaken blessed/;
   7 use DBIx::Class::Exception;
   8 use DBIx::Class::Carp;
   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 ( $rollback_exception and (
 126       ! defined blessed $rollback_exception
 127           or
 128       ! $rollback_exception->isa('DBIx::Class::Storage::NESTED_ROLLBACK_EXCEPTION')
 129     ) ) {
 130       # append our text - THIS IS A TEMPORARY FIXUP!
 131       # a real stackable exception object is in the works
 132       if (ref $exception eq 'DBIx::Class::Exception') {
 133         $exception->{msg} = "Transaction aborted: $exception->{msg} "
 134           ."Rollback failed: ${rollback_exception}";
 135       }
 136       elsif ($exception) {
 137         $exception = "Transaction aborted: ${exception} "
 138           ."Rollback failed: ${rollback_exception}";
 139       }
 140       else {
 141         carp (join ' ',
 142           "********************* ROLLBACK FAILED!!! ********************",
 143           "\nA rollback operation failed after the guard went out of scope.",
 144           'This is potentially a disastrous situation, check your data for',
 145           "consistency: $rollback_exception"
 146         );
 147       }
 148     }
 149   }
 150
 151   $@ = $exception unless IS_BROKEN_PERL;
 152 }
 153
 154 1;
 155
 156 __END__
 157
 158 =head1 NAME
 159
 160 DBIx::Class::Storage::TxnScopeGuard - Scope-based transaction handling
 161
 162 =head1 SYNOPSIS
 163
 164  sub foo {
 165    my ($self, $schema) = @_;
 166
 167    my $guard = $schema->txn_scope_guard;
 168
 169    # Multiple database operations here
 170
 171    $guard->commit;
 172  }
 173
 174 =head1 DESCRIPTION
 175
 176 An object that behaves much like L<Scope::Guard>, but hardcoded to do the
 177 right thing with transactions in DBIx::Class.
 178
 179 =head1 METHODS
 180
 181 =head2 new
 182
 183 Creating an instance of this class will start a new transaction (by
 184 implicitly calling L<DBIx::Class::Storage/txn_begin>. Expects a
 185 L<DBIx::Class::Storage> object as its only argument.
 186
 187 =head2 commit
 188
 189 Commit the transaction, and stop guarding the scope. If this method is not
 190 called and this object goes out of scope (e.g. an exception is thrown) then
 191 the transaction is rolled back, via L<DBIx::Class::Storage/txn_rollback>
 192
 193 =cut
 194
 195 =head1 SEE ALSO
 196
 197 L<DBIx::Class::Schema/txn_scope_guard>.
 198
 199 =head1 AUTHOR
 200
 201 Ash Berlin, 2008.
 202
 203 Inspired by L<Scope::Guard> by chocolateboy.
 204
 205 This module is free software. It may be used, redistributed and/or modified
 206 under the same terms as Perl itself.
 207
 208 =cut