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