Commit | Line | Data |
12e7015a |
1 | # Test is sufficiently involved to *want* to run with "maximum paranoia" |
2 | BEGIN { $ENV{DBICTEST_OLD_MRO_SANITY_CHECK_ASSERTIONS} = 1 } |
3 | |
c0329273 |
4 | BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } |
5 | |
70350518 |
6 | use strict; |
d7ded411 |
7 | use warnings; |
70350518 |
8 | |
9 | use Test::More; |
d7ded411 |
10 | use Test::Warn; |
3b7f3eac |
11 | use Test::Exception; |
e48635f7 |
12 | use Errno (); |
c0329273 |
13 | |
70350518 |
14 | use DBICTest; |
15 | |
a62cf8d4 |
16 | my $code = sub { |
17 | my ($artist, @cd_titles) = @_; |
d7ded411 |
18 | |
a62cf8d4 |
19 | $artist->create_related('cds', { |
20 | title => $_, |
21 | year => 2006, |
22 | }) foreach (@cd_titles); |
d7ded411 |
23 | |
0e7a447e |
24 | return $artist->cds->all; |
a62cf8d4 |
25 | }; |
26 | |
171dadd7 |
27 | # Test checking of parameters |
28 | { |
471a5fdd |
29 | my $schema = DBICTest->init_schema; |
30 | |
dd7d4b43 |
31 | throws_ok (sub { |
171dadd7 |
32 | (ref $schema)->txn_do(sub{}); |
dd7d4b43 |
33 | }, qr/storage/, "can't call txn_do without storage"); |
34 | |
7d534e68 |
35 | throws_ok { |
171dadd7 |
36 | $schema->txn_do(''); |
7d534e68 |
37 | } qr/\Qrun() requires a coderef to execute as its first argument/, |
38 | '$coderef parameter check ok'; |
171dadd7 |
39 | } |
40 | |
471a5fdd |
41 | # Test successful txn_do() - scalar/list context |
42 | for my $want (0,1) { |
43 | my $schema = DBICTest->init_schema; |
44 | |
b74b15b0 |
45 | is( $schema->storage->transaction_depth, 0, 'txn depth starts at 0'); |
57c18b65 |
46 | |
a62cf8d4 |
47 | my @titles = map {'txn_do test CD ' . $_} (1..5); |
48 | my $artist = $schema->resultset('Artist')->find(1); |
49 | my $count_before = $artist->cds->count; |
a62cf8d4 |
50 | |
471a5fdd |
51 | my @res; |
52 | if ($want) { |
53 | @res = $schema->txn_do($code, $artist, @titles); |
54 | is(scalar @res, $count_before+5, 'successful txn added 5 cds'); |
55 | } |
56 | else { |
57 | $res[0] = $schema->txn_do($code, $artist, @titles); |
58 | is($res[0], $count_before+5, 'successful txn added 5 cds'); |
59 | } |
57c18b65 |
60 | |
a62cf8d4 |
61 | is($artist->cds({ |
62 | title => "txn_do test CD $_", |
471a5fdd |
63 | })->first->year, 2006, "new CD $_ year correct") for (1..5); |
57c18b65 |
64 | |
b74b15b0 |
65 | is( $schema->storage->transaction_depth, 0, 'txn depth has been reset'); |
a62cf8d4 |
66 | } |
67 | |
38ed54cd |
68 | # Test txn_do() @_ aliasing support |
69 | { |
471a5fdd |
70 | my $schema = DBICTest->init_schema; |
71 | |
38ed54cd |
72 | my $res = 'original'; |
73 | $schema->storage->txn_do (sub { $_[0] = 'changed' }, $res); |
74 | is ($res, 'changed', "Arguments properly aliased for txn_do"); |
75 | } |
76 | |
a62cf8d4 |
77 | # Test nested successful txn_do() |
78 | { |
471a5fdd |
79 | my $schema = DBICTest->init_schema; |
80 | |
b74b15b0 |
81 | is( $schema->storage->transaction_depth, 0, 'txn depth starts at 0'); |
57c18b65 |
82 | |
a62cf8d4 |
83 | my $nested_code = sub { |
84 | my ($schema, $artist, $code) = @_; |
85 | |
86 | my @titles1 = map {'nested txn_do test CD ' . $_} (1..5); |
87 | my @titles2 = map {'nested txn_do test CD ' . $_} (6..10); |
88 | |
89 | $schema->txn_do($code, $artist, @titles1); |
90 | $schema->txn_do($code, $artist, @titles2); |
91 | }; |
92 | |
93 | my $artist = $schema->resultset('Artist')->find(2); |
94 | my $count_before = $artist->cds->count; |
95 | |
dd7d4b43 |
96 | lives_ok (sub { |
a62cf8d4 |
97 | $schema->txn_do($nested_code, $schema, $artist, $code); |
dd7d4b43 |
98 | }, 'nested txn_do succeeded'); |
a62cf8d4 |
99 | |
a62cf8d4 |
100 | is($artist->cds({ |
101 | title => 'nested txn_do test CD '.$_, |
102 | })->first->year, 2006, qq{nested txn_do CD$_ year ok}) for (1..10); |
103 | is($artist->cds->count, $count_before+10, 'nested txn_do added all CDs'); |
57c18b65 |
104 | |
b74b15b0 |
105 | is( $schema->storage->transaction_depth, 0, 'txn depth has been reset'); |
a62cf8d4 |
106 | } |
107 | |
7d216b10 |
108 | # test nested txn_begin on fresh connection |
109 | { |
110 | my $schema = DBICTest->init_schema(sqlite_use_file => 1, no_deploy => 1); |
111 | $schema->storage->ensure_connected; |
112 | |
113 | is ($schema->storage->transaction_depth, 0, 'Start outside txn'); |
114 | |
115 | my @pids; |
c5915b45 |
116 | SKIP: |
7d216b10 |
117 | for my $action ( |
118 | sub { |
119 | my $s = shift; |
120 | die "$$ starts in txn!" if $s->storage->transaction_depth != 0; |
121 | $s->txn_do ( sub { |
122 | die "$$ not in txn!" if $s->storage->transaction_depth == 0; |
8273e845 |
123 | $s->storage->dbh->do('SELECT 1') } |
7d216b10 |
124 | ); |
125 | die "$$ did not finish txn!" if $s->storage->transaction_depth != 0; |
126 | }, |
127 | sub { |
128 | $_[0]->txn_begin; |
129 | $_[0]->storage->dbh->do('SELECT 1'); |
130 | $_[0]->txn_commit |
131 | }, |
132 | sub { |
133 | my $guard = $_[0]->txn_scope_guard; |
134 | $_[0]->storage->dbh->do('SELECT 1'); |
135 | $guard->commit |
136 | }, |
137 | ) { |
ec6415a9 |
138 | my $pid = fork(); |
c5915b45 |
139 | |
140 | if( ! defined $pid ) { |
141 | skip "EAGAIN encountered, your system is likely bogged down: skipping forking test", 1 |
142 | if $! == Errno::EAGAIN(); |
143 | |
144 | die "Unable to fork: $!" |
145 | } |
7d216b10 |
146 | |
ec6415a9 |
147 | if ($pid) { |
148 | push @pids, $pid; |
7d216b10 |
149 | next; |
150 | } |
151 | |
152 | $action->($schema); |
153 | exit 0; |
154 | } |
155 | |
156 | is ($schema->storage->transaction_depth, 0, 'Parent still outside txn'); |
157 | |
158 | for my $pid (@pids) { |
159 | waitpid ($pid, 0); |
160 | ok (! $?, "Child $pid exit ok"); |
161 | } |
162 | } |
163 | |
164 | # Test txn_do/scope_guard with forking: outer txn_do |
165 | { |
166 | my $schema = DBICTest->init_schema( sqlite_use_file => 1 ); |
167 | |
168 | for my $pass (1..2) { |
169 | |
170 | # do something trying to destabilize the depth count |
171 | for (1..2) { |
172 | eval { |
173 | my $guard = $schema->txn_scope_guard; |
174 | $schema->txn_do( sub { die } ); |
175 | }; |
90d7422f |
176 | is( $schema->storage->transaction_depth, 0, 'Transaction successfully aborted' ); |
7d216b10 |
177 | $schema->txn_do( sub { |
178 | ok ($schema->storage->_dbh->do ('SELECT 1'), "Query after exceptions ok ($_)"); |
179 | }); |
180 | } |
181 | |
ec6415a9 |
182 | $schema->txn_do ( sub { _test_forking_action ($schema, $pass) } ); |
7d216b10 |
183 | } |
184 | } |
185 | |
186 | # same test with outer guard |
187 | { |
188 | my $schema = DBICTest->init_schema( sqlite_use_file => 1 ); |
189 | |
190 | for my $pass (1..2) { |
191 | |
192 | # do something trying to destabilize the depth count |
193 | for (1..2) { |
194 | eval { |
195 | my $guard = $schema->txn_scope_guard; |
196 | $schema->txn_do( sub { die } ); |
197 | }; |
90d7422f |
198 | is( $schema->storage->transaction_depth, 0, 'Transaction successfully aborted' ); |
7d216b10 |
199 | $schema->txn_do( sub { |
200 | ok ($schema->storage->_dbh->do ('SELECT 1'), "Query after exceptions ok ($_)"); |
201 | }); |
202 | } |
203 | |
7d216b10 |
204 | my $guard = $schema->txn_scope_guard; |
ec6415a9 |
205 | my @pids = _test_forking_action ($schema, $pass); |
7d216b10 |
206 | $guard->commit; |
7d216b10 |
207 | } |
208 | } |
209 | |
ec6415a9 |
210 | sub _test_forking_action { |
211 | my ($schema, $pass) = @_; |
7d216b10 |
212 | |
213 | my @pids; |
7d216b10 |
214 | |
ec6415a9 |
215 | SKIP: for my $count (1 .. 5) { |
216 | |
3cff955a |
217 | skip 'FIXME: Weird DBI General Protection Faults, skip forking tests (RT#63104)', 5 |
ec6415a9 |
218 | if $^O eq 'MSWin32'; |
219 | |
220 | my $pid = fork(); |
c5915b45 |
221 | if( ! defined $pid ) { |
c5915b45 |
222 | skip "EAGAIN encountered, your system is likely bogged down: skipping forking test", 1 |
223 | if $! == Errno::EAGAIN(); |
224 | |
225 | die "Unable to fork: $!" |
226 | } |
7d216b10 |
227 | |
ec6415a9 |
228 | if ($pid) { |
229 | push @pids, $pid; |
7d216b10 |
230 | next; |
231 | } |
232 | |
ec6415a9 |
233 | if ($count % 2) { |
7d216b10 |
234 | $schema->txn_do (sub { |
235 | my $depth = $schema->storage->transaction_depth; |
236 | die "$$(txn_do)unexpected txn depth $depth!" if $depth != 1; |
237 | $schema->resultset ('Artist')->create ({ name => "forking action $$"}); |
238 | }); |
239 | } |
240 | else { |
241 | my $guard = $schema->txn_scope_guard; |
242 | my $depth = $schema->storage->transaction_depth; |
243 | die "$$(scope_guard) unexpected txn depth $depth!" if $depth != 1; |
244 | $schema->resultset ('Artist')->create ({ name => "forking action $$"}); |
245 | $guard->commit; |
246 | } |
247 | |
248 | exit 0; |
249 | } |
250 | |
ec6415a9 |
251 | for my $pid (@pids) { |
252 | waitpid ($pid, 0); |
253 | ok (! $?, "Child $pid exit ok (pass $pass)"); |
02050e77 |
254 | } |
255 | |
256 | # it is important to reap all children before checking the final db-state |
257 | # otherwise a deadlock may occur between the transactions running in the |
258 | # children and the query of the parent |
259 | for my $pid (@pids) { |
ec6415a9 |
260 | isa_ok ($schema->resultset ('Artist')->find ({ name => "forking action $pid" }), 'DBIx::Class::Row'); |
261 | } |
7d216b10 |
262 | } |
263 | |
a62cf8d4 |
264 | my $fail_code = sub { |
265 | my ($artist) = @_; |
266 | $artist->create_related('cds', { |
267 | title => 'this should not exist', |
268 | year => 2005, |
269 | }); |
270 | die "the sky is falling"; |
271 | }; |
272 | |
a62cf8d4 |
273 | { |
471a5fdd |
274 | my $schema = DBICTest->init_schema; |
57c18b65 |
275 | |
471a5fdd |
276 | # Test failed txn_do() |
277 | for my $pass (1,2) { |
57c18b65 |
278 | |
b74b15b0 |
279 | is( $schema->storage->transaction_depth, 0, "txn depth starts at 0 (pass $pass)"); |
a62cf8d4 |
280 | |
471a5fdd |
281 | my $artist = $schema->resultset('Artist')->find(3); |
a62cf8d4 |
282 | |
471a5fdd |
283 | throws_ok (sub { |
284 | $schema->txn_do($fail_code, $artist); |
285 | }, qr/the sky is falling/, "failed txn_do threw an exception (pass $pass)"); |
57c18b65 |
286 | |
471a5fdd |
287 | my $cd = $artist->cds({ |
288 | title => 'this should not exist', |
289 | year => 2005, |
290 | })->first; |
291 | ok(!defined($cd), qq{failed txn_do didn't change the cds table (pass $pass)}); |
a62cf8d4 |
292 | |
b74b15b0 |
293 | is( $schema->storage->transaction_depth, 0, "txn depth has been reset (pass $pass)"); |
471a5fdd |
294 | } |
57c18b65 |
295 | |
a62cf8d4 |
296 | |
471a5fdd |
297 | # Test failed txn_do() with failed rollback |
298 | { |
b74b15b0 |
299 | is( $schema->storage->transaction_depth, 0, 'txn depth starts at 0'); |
57c18b65 |
300 | |
471a5fdd |
301 | my $artist = $schema->resultset('Artist')->find(3); |
a62cf8d4 |
302 | |
471a5fdd |
303 | # Force txn_rollback() to throw an exception |
90d7422f |
304 | no warnings qw/once redefine/; |
305 | |
306 | # this should logically work just fine - but it does not, |
307 | # only direct override of the existing method dtrt |
308 | #local *DBIx::Class::Storage::DBI::SQLite::txn_rollback = sub { die 'FAILED' }; |
a62cf8d4 |
309 | |
90d7422f |
310 | local *DBIx::Class::Storage::DBI::txn_rollback = sub { die 'FAILED' }; |
311 | Class::C3->reinitialize() if DBIx::Class::_ENV_::OLD_MRO; |
d9c17594 |
312 | |
471a5fdd |
313 | throws_ok ( |
314 | sub { |
315 | $schema->txn_do($fail_code, $artist); |
316 | }, |
317 | qr/the sky is falling.+Rollback failed/s, |
318 | 'txn_rollback threw a rollback exception (and included the original exception' |
319 | ); |
320 | |
321 | my $cd = $artist->cds({ |
322 | title => 'this should not exist', |
323 | year => 2005, |
324 | })->first; |
325 | isa_ok($cd, 'DBICTest::CD', q{failed txn_do with a failed txn_rollback }. |
326 | q{changed the cds table}); |
327 | $cd->delete; # Rollback failed |
328 | $cd = $artist->cds({ |
329 | title => 'this should not exist', |
330 | year => 2005, |
331 | })->first; |
332 | ok(!defined($cd), q{deleted the failed txn's cd}); |
333 | $schema->storage->_dbh->rollback; |
334 | } |
a62cf8d4 |
335 | } |
336 | |
337 | # Test nested failed txn_do() |
338 | { |
d9c17594 |
339 | my $schema = DBICTest->init_schema(); |
340 | |
b74b15b0 |
341 | is( $schema->storage->transaction_depth, 0, 'txn depth starts at 0'); |
57c18b65 |
342 | |
a62cf8d4 |
343 | my $nested_fail_code = sub { |
344 | my ($schema, $artist, $code1, $code2) = @_; |
345 | |
346 | my @titles = map {'nested txn_do test CD ' . $_} (1..5); |
347 | |
348 | $schema->txn_do($code1, $artist, @titles); # successful txn |
349 | $schema->txn_do($code2, $artist); # failed txn |
350 | }; |
351 | |
352 | my $artist = $schema->resultset('Artist')->find(3); |
353 | |
dd7d4b43 |
354 | throws_ok ( sub { |
a62cf8d4 |
355 | $schema->txn_do($nested_fail_code, $schema, $artist, $code, $fail_code); |
dd7d4b43 |
356 | }, qr/the sky is falling/, 'nested failed txn_do threw exception'); |
a62cf8d4 |
357 | |
a62cf8d4 |
358 | ok(!defined($artist->cds({ |
359 | title => 'nested txn_do test CD '.$_, |
360 | year => 2006, |
361 | })->first), qq{failed txn_do didn't add first txn's cd $_}) for (1..5); |
362 | my $cd = $artist->cds({ |
363 | title => 'this should not exist', |
364 | year => 2005, |
365 | })->first; |
366 | ok(!defined($cd), q{failed txn_do didn't add failed txn's cd}); |
367 | } |
a62cf8d4 |
368 | |
90d7422f |
369 | |
291bf95f |
370 | # Grab a new schema to test txn before connect |
90d7422f |
371 | # also test nested txn exception |
291bf95f |
372 | { |
d9c17594 |
373 | my $schema = DBICTest->init_schema(no_deploy => 1); |
374 | lives_ok (sub { |
375 | $schema->txn_begin(); |
376 | $schema->txn_begin(); |
377 | }, 'Pre-connection nested transactions.'); |
378 | |
90d7422f |
379 | throws_ok( sub { $schema->txn_rollback }, 'DBIx::Class::Storage::NESTED_ROLLBACK_EXCEPTION', 'got proper nested rollback exception' ); |
291bf95f |
380 | } |
3b7f3eac |
381 | |
257a1d3b |
382 | # make sure AutoCommit => 0 on external handles behaves correctly with scope_guard |
cf31592c |
383 | warnings_are { |
6c925c72 |
384 | my $factory = DBICTest->init_schema; |
257a1d3b |
385 | cmp_ok ($factory->resultset('CD')->count, '>', 0, 'Something to delete'); |
386 | my $dbh = $factory->storage->dbh; |
6c925c72 |
387 | $dbh->{AutoCommit} = 0; |
257a1d3b |
388 | |
389 | ok (!$dbh->{AutoCommit}, 'AutoCommit is off on $dbh'); |
390 | my $schema = DBICTest::Schema->connect (sub { $dbh }); |
391 | |
257a1d3b |
392 | lives_ok ( sub { |
393 | my $guard = $schema->txn_scope_guard; |
394 | $schema->resultset('CD')->delete; |
395 | $guard->commit; |
396 | }, 'No attempt to start a transaction with scope guard'); |
397 | |
cf31592c |
398 | is ($schema->resultset('CD')->count, 0, 'Deletion successful in txn'); |
399 | |
400 | # this will commit the implicitly started txn |
401 | $dbh->commit; |
402 | |
403 | } [], 'No warnings on AutoCommit => 0 with txn_guard'; |
257a1d3b |
404 | |
405 | # make sure AutoCommit => 0 on external handles behaves correctly with txn_do |
cf31592c |
406 | warnings_are { |
6c925c72 |
407 | my $factory = DBICTest->init_schema; |
257a1d3b |
408 | cmp_ok ($factory->resultset('CD')->count, '>', 0, 'Something to delete'); |
409 | my $dbh = $factory->storage->dbh; |
6c925c72 |
410 | $dbh->{AutoCommit} = 0; |
257a1d3b |
411 | |
412 | ok (!$dbh->{AutoCommit}, 'AutoCommit is off on $dbh'); |
413 | my $schema = DBICTest::Schema->connect (sub { $dbh }); |
414 | |
257a1d3b |
415 | lives_ok ( sub { |
416 | $schema->txn_do (sub { $schema->resultset ('CD')->delete }); |
417 | }, 'No attempt to start a atransaction with txn_do'); |
418 | |
419 | is ($schema->resultset('CD')->count, 0, 'Deletion successful'); |
cf31592c |
420 | |
421 | # this will commit the implicitly started txn |
422 | $dbh->commit; |
423 | |
424 | } [], 'No warnings on AutoCommit => 0 with txn_do'; |
257a1d3b |
425 | |
9bea2000 |
426 | |
427 | # make sure we are not fucking up the stacktrace on broken overloads |
428 | { |
429 | package DBICTest::BrokenOverload; |
430 | |
431 | use overload '""' => sub { $_[0] }; |
432 | } |
433 | |
434 | { |
435 | my @w; |
436 | local $SIG{__WARN__} = sub { |
437 | $_[0] =~ /\QExternal exception class DBICTest::BrokenOverload implements partial (broken) overloading preventing its instances from being used in simple (\E\$x eq \$y\Q) comparisons/ |
438 | ? push @w, @_ |
439 | : warn @_ |
440 | }; |
441 | |
442 | my $s = DBICTest->init_schema(no_deploy => 1); |
443 | $s->stacktrace(0); |
444 | my $g = $s->storage->txn_scope_guard; |
445 | my $broken_exception = bless {}, 'DBICTest::BrokenOverload'; |
446 | |
447 | # FIXME - investigate what confuses the regex engine below |
448 | |
449 | # do not reformat - line-num part of the test |
450 | my $ln = __LINE__ + 6; |
451 | throws_ok { |
452 | $s->txn_do( sub { |
453 | $s->txn_do( sub { |
454 | $s->storage->_dbh->disconnect; |
455 | die $broken_exception |
456 | }); |
457 | }) |
84efb6d7 |
458 | } qr/\QTransaction aborted: $broken_exception. Rollback failed: DBIx::Class::Storage::DBI::txn_rollback(): lost connection to storage at @{[__FILE__]} line $ln\E\n/; # FIXME wtf - ...\E$/m doesn't work here |
9bea2000 |
459 | |
460 | is @w, 1, 'One matching warning only'; |
e240b8ba |
461 | |
462 | # try the same broken exception object, but have exception_action inject it |
463 | $s->exception_action(sub { die $broken_exception }); |
464 | eval { |
465 | $s->txn_do( sub { |
466 | die "some string masked away"; |
467 | }); |
468 | }; |
469 | isa_ok $@, 'DBICTest::BrokenOverload', 'Deficient exception properly propagated'; |
470 | |
471 | is @w, 2, 'The warning was emitted a second time'; |
9bea2000 |
472 | } |
473 | |
d7ded411 |
474 | done_testing; |