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