Commit | Line | Data |
471a5fdd |
1 | use strict; |
2 | use warnings; |
3 | |
4 | use Test::More; |
5 | use Test::Warn; |
6 | use Test::Exception; |
7 | use lib qw(t/lib); |
8 | use DBICTest; |
9 | |
10 | # Test txn_scope_guard |
11 | { |
12 | my $schema = DBICTest->init_schema(); |
13 | |
14 | is($schema->storage->transaction_depth, 0, "Correct transaction depth"); |
15 | my $artist_rs = $schema->resultset('Artist'); |
16 | |
17 | my $fn = __FILE__; |
18 | throws_ok { |
19 | my $guard = $schema->txn_scope_guard; |
20 | |
21 | $artist_rs->create({ |
22 | name => 'Death Cab for Cutie', |
23 | made_up_column => 1, |
24 | }); |
25 | |
26 | $guard->commit; |
e705f529 |
27 | } qr/No such column 'made_up_column' .*? at .*?\Q$fn\E line \d+/s, "Error propogated okay"; |
471a5fdd |
28 | |
29 | ok(!$artist_rs->find({name => 'Death Cab for Cutie'}), "Artist not created"); |
30 | |
31 | my $inner_exception = ''; # set in inner() below |
32 | throws_ok (sub { |
33 | outer($schema, 1); |
34 | }, qr/$inner_exception/, "Nested exceptions propogated"); |
35 | |
36 | ok(!$artist_rs->find({name => 'Death Cab for Cutie'}), "Artist not created"); |
37 | |
38 | lives_ok (sub { |
39 | |
40 | # this weird assignment is to stop perl <= 5.8.9 leaking $schema on nested sub{}s |
41 | my $s = $schema; |
42 | |
43 | warnings_exist ( sub { |
44 | # The 0 arg says don't die, just let the scope guard go out of scope |
45 | # forcing a txn_rollback to happen |
46 | outer($s, 0); |
47 | }, qr/A DBIx::Class::Storage::TxnScopeGuard went out of scope without explicit commit or error. Rolling back./, 'Out of scope warning detected'); |
48 | |
49 | ok(!$artist_rs->find({name => 'Death Cab for Cutie'}), "Artist not created"); |
50 | |
51 | }, 'rollback successful withot exception'); |
52 | |
53 | sub outer { |
54 | my ($schema, $fatal) = @_; |
55 | |
56 | my $guard = $schema->txn_scope_guard; |
57 | $schema->resultset('Artist')->create({ |
58 | name => 'Death Cab for Cutie', |
59 | }); |
60 | inner($schema, $fatal); |
61 | } |
62 | |
63 | sub inner { |
64 | my ($schema, $fatal) = @_; |
65 | |
66 | my $inner_guard = $schema->txn_scope_guard; |
67 | is($schema->storage->transaction_depth, 2, "Correct transaction depth"); |
68 | |
69 | my $artist = $schema->resultset('Artist')->find({ name => 'Death Cab for Cutie' }); |
70 | |
71 | eval { |
72 | $artist->cds->create({ |
73 | title => 'Plans', |
74 | year => 2005, |
75 | $fatal ? ( foo => 'bar' ) : () |
76 | }); |
77 | }; |
78 | if ($@) { |
79 | # Record what got thrown so we can test it propgates out properly. |
80 | $inner_exception = $@; |
81 | die $@; |
82 | } |
83 | |
84 | # inner guard should commit without consequences |
85 | $inner_guard->commit; |
86 | } |
87 | } |
88 | |
89 | # make sure the guard does not eat exceptions |
90 | { |
91 | my $schema = DBICTest->init_schema; |
92 | |
93 | no strict 'refs'; |
94 | no warnings 'redefine'; |
87bf71d5 |
95 | |
471a5fdd |
96 | local *{DBIx::Class::Storage::DBI::txn_rollback} = sub { die 'die die my darling' }; |
87bf71d5 |
97 | Class::C3->reinitialize() if DBIx::Class::_ENV_::OLD_MRO; |
471a5fdd |
98 | |
99 | throws_ok (sub { |
100 | my $guard = $schema->txn_scope_guard; |
101 | $schema->resultset ('Artist')->create ({ name => 'bohhoo'}); |
102 | |
103 | # this should freak out the guard rollback |
104 | # but it won't work because DBD::SQLite is buggy |
105 | # instead just install a toxic rollback above |
106 | #$schema->storage->_dbh( $schema->storage->_dbh->clone ); |
107 | |
108 | die 'Deliberate exception'; |
e69b5335 |
109 | }, ($] >= 5.013008 ) |
110 | ? qr/Deliberate exception/s # temporary until we get the generic exception wrapper rolling |
111 | : qr/Deliberate exception.+Rollback failed/s |
112 | ); |
471a5fdd |
113 | |
114 | # just to mask off warning since we could not disconnect above |
115 | $schema->storage->_dbh->disconnect; |
116 | } |
117 | |
118 | # make sure it warns *big* on failed rollbacks |
f62c5724 |
119 | # test with and without a poisoned $@ |
6e102c8f |
120 | for my $pre_poison (0,1) { |
121 | for my $post_poison (0,1) { |
f62c5724 |
122 | |
6e102c8f |
123 | my $schema = DBICTest->init_schema(no_populate => 1); |
471a5fdd |
124 | |
125 | no strict 'refs'; |
126 | no warnings 'redefine'; |
127 | local *{DBIx::Class::Storage::DBI::txn_rollback} = sub { die 'die die my darling' }; |
87bf71d5 |
128 | Class::C3->reinitialize() if DBIx::Class::_ENV_::OLD_MRO; |
471a5fdd |
129 | |
130 | #The warn from within a DESTROY callback freaks out Test::Warn, do it old-school |
131 | =begin |
132 | warnings_exist ( |
133 | sub { |
134 | my $guard = $schema->txn_scope_guard; |
135 | $schema->resultset ('Artist')->create ({ name => 'bohhoo'}); |
136 | |
137 | # this should freak out the guard rollback |
138 | # but it won't work because DBD::SQLite is buggy |
139 | # instead just install a toxic rollback above |
140 | #$schema->storage->_dbh( $schema->storage->_dbh->clone ); |
141 | }, |
142 | [ |
143 | qr/A DBIx::Class::Storage::TxnScopeGuard went out of scope without explicit commit or error. Rolling back./, |
144 | qr/\*+ ROLLBACK FAILED\!\!\! \*+/, |
145 | ], |
146 | 'proper warnings generated on out-of-scope+rollback failure' |
147 | ); |
148 | =cut |
149 | |
150 | # delete this once the above works properly (same test) |
151 | my @want = ( |
152 | qr/A DBIx::Class::Storage::TxnScopeGuard went out of scope without explicit commit or error. Rolling back./, |
153 | qr/\*+ ROLLBACK FAILED\!\!\! \*+/, |
154 | ); |
155 | |
156 | my @w; |
157 | local $SIG{__WARN__} = sub { |
158 | if (grep {$_[0] =~ $_} (@want)) { |
159 | push @w, $_[0]; |
160 | } |
161 | else { |
162 | warn $_[0]; |
163 | } |
164 | }; |
6e102c8f |
165 | |
471a5fdd |
166 | { |
6e102c8f |
167 | eval { die 'pre-GIFT!' if $pre_poison }; |
168 | my $guard = $schema->txn_scope_guard; |
169 | eval { die 'post-GIFT!' if $post_poison }; |
170 | $schema->resultset ('Artist')->create ({ name => 'bohhoo'}); |
471a5fdd |
171 | } |
172 | |
6e102c8f |
173 | local $TODO = 'Do not know how to deal with trapped exceptions occuring after guard instantiation...' |
174 | if ( $post_poison and ( |
175 | # take no chances on installation |
176 | ( DBICTest::RunMode->is_plain and ($ENV{TRAVIS}||'') ne 'true' ) |
177 | or |
178 | # this always fails |
179 | ! $pre_poison |
180 | or |
f2f65c95 |
181 | # I do not understand why but on <= 5.8.8 and on 5.10.0 "$pre_poison && $post_poison" passes... |
182 | ($] > 5.008008 and $] < 5.010000 ) or $] > 5.010000 |
6e102c8f |
183 | )); |
184 | |
185 | is (@w, 2, "Both expected warnings found - \$\@ pre-poison: $pre_poison, post-poison: $post_poison" ); |
471a5fdd |
186 | |
187 | # just to mask off warning since we could not disconnect above |
188 | $schema->storage->_dbh->disconnect; |
6e102c8f |
189 | }} |
471a5fdd |
190 | |
153a6b38 |
191 | # add a TODO to catch when Text::Balanced is finally fixed |
192 | # https://rt.cpan.org/Public/Bug/Display.html?id=74994 |
193 | # |
194 | # while it doesn't matter much for DBIC itself, this particular bug |
195 | # is a *BANE*, and DBIC is to bump its dep as soon as possible |
196 | { |
197 | |
198 | require Text::Balanced; |
199 | |
841efcb3 |
200 | my @w; |
201 | local $SIG{__WARN__} = sub { |
202 | $_[0] =~ /External exception object .+? \Qimplements partial (broken) overloading/ |
203 | ? push @w, @_ |
204 | : warn @_ |
205 | }; |
153a6b38 |
206 | |
841efcb3 |
207 | lives_ok { |
208 | # this is what poisons $@ |
209 | Text::Balanced::extract_bracketed( '(foo', '()' ); |
153a6b38 |
210 | |
841efcb3 |
211 | my $s = DBICTest::Schema->connect('dbi:SQLite::memory:'); |
212 | my $g = $s->txn_scope_guard; |
213 | $g->commit; |
214 | } 'Broken Text::Balanced is not screwing up txn_guard'; |
153a6b38 |
215 | |
841efcb3 |
216 | local $TODO = 'RT#74994 *STILL* not fixed'; |
217 | is(scalar @w, 0, 'no warnings \o/'); |
153a6b38 |
218 | } |
219 | |
471a5fdd |
220 | done_testing; |