Cleanup/improve the leaktest a bit
[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 ( sub {
30     $schema->txn_do('');
31   }, qr/must be a CODE reference/, '$coderef parameter check ok');
32 }
33
34 # Test successful txn_do() - scalar/list context
35 for my $want (0,1) {
36   my $schema = DBICTest->init_schema;
37
38   is( $schema->storage->{transaction_depth}, 0, 'txn depth starts at 0');
39
40   my @titles = map {'txn_do test CD ' . $_} (1..5);
41   my $artist = $schema->resultset('Artist')->find(1);
42   my $count_before = $artist->cds->count;
43
44   my @res;
45   if ($want) {
46     @res = $schema->txn_do($code, $artist, @titles);
47     is(scalar @res, $count_before+5, 'successful txn added 5 cds');
48   }
49   else {
50     $res[0] = $schema->txn_do($code, $artist, @titles);
51     is($res[0], $count_before+5, 'successful txn added 5 cds');
52   }
53
54   is($artist->cds({
55     title => "txn_do test CD $_",
56   })->first->year, 2006, "new CD $_ year correct") for (1..5);
57
58   is( $schema->storage->{transaction_depth}, 0, 'txn depth has been reset');
59 }
60
61 # Test txn_do() @_ aliasing support
62 {
63   my $schema = DBICTest->init_schema;
64
65   my $res = 'original';
66   $schema->storage->txn_do (sub { $_[0] = 'changed' }, $res);
67   is ($res, 'changed', "Arguments properly aliased for txn_do");
68 }
69
70 # Test nested successful txn_do()
71 {
72   my $schema = DBICTest->init_schema;
73
74   is( $schema->storage->{transaction_depth}, 0, 'txn depth starts at 0');
75
76   my $nested_code = sub {
77     my ($schema, $artist, $code) = @_;
78
79     my @titles1 = map {'nested txn_do test CD ' . $_} (1..5);
80     my @titles2 = map {'nested txn_do test CD ' . $_} (6..10);
81
82     $schema->txn_do($code, $artist, @titles1);
83     $schema->txn_do($code, $artist, @titles2);
84   };
85
86   my $artist = $schema->resultset('Artist')->find(2);
87   my $count_before = $artist->cds->count;
88
89   lives_ok (sub {
90     $schema->txn_do($nested_code, $schema, $artist, $code);
91   }, 'nested txn_do succeeded');
92
93   is($artist->cds({
94     title => 'nested txn_do test CD '.$_,
95   })->first->year, 2006, qq{nested txn_do CD$_ year ok}) for (1..10);
96   is($artist->cds->count, $count_before+10, 'nested txn_do added all CDs');
97
98   is( $schema->storage->{transaction_depth}, 0, 'txn depth has been reset');
99 }
100
101 # test nested txn_begin on fresh connection
102 {
103   my $schema = DBICTest->init_schema(sqlite_use_file => 1, no_deploy => 1);
104   $schema->storage->ensure_connected;
105
106   is ($schema->storage->transaction_depth, 0, 'Start outside txn');
107
108   my @pids;
109   for my $action (
110     sub {
111       my $s = shift;
112       die "$$ starts in txn!" if $s->storage->transaction_depth != 0;
113       $s->txn_do ( sub {
114         die "$$ not in txn!" if $s->storage->transaction_depth == 0;
115         $s->storage->dbh->do('SELECT 1') } 
116       );
117       die "$$ did not finish txn!" if $s->storage->transaction_depth != 0;
118     },
119     sub {
120       $_[0]->txn_begin;
121       $_[0]->storage->dbh->do('SELECT 1');
122       $_[0]->txn_commit
123     },
124     sub {
125       my $guard = $_[0]->txn_scope_guard;
126       $_[0]->storage->dbh->do('SELECT 1');
127       $guard->commit
128     },
129   ) {
130     my $pid = fork();
131     die "Unable to fork: $!\n"
132       if ! defined $pid;
133
134     if ($pid) {
135       push @pids, $pid;
136       next;
137     }
138
139     $action->($schema);
140     exit 0;
141   }
142
143   is ($schema->storage->transaction_depth, 0, 'Parent still outside txn');
144
145   for my $pid (@pids) {
146     waitpid ($pid, 0);
147     ok (! $?, "Child $pid exit ok");
148   }
149 }
150
151 # Test txn_do/scope_guard with forking: outer txn_do
152 {
153   my $schema = DBICTest->init_schema( sqlite_use_file => 1 );
154
155   for my $pass (1..2) {
156
157     # do something trying to destabilize the depth count
158     for (1..2) {
159       eval {
160         my $guard = $schema->txn_scope_guard;
161         $schema->txn_do( sub { die } );
162       };
163       $schema->txn_do( sub {
164         ok ($schema->storage->_dbh->do ('SELECT 1'), "Query after exceptions ok ($_)");
165       });
166     }
167
168     $schema->txn_do ( sub { _test_forking_action ($schema, $pass) } );
169
170   }
171 }
172
173 # same test with outer guard
174 {
175   my $schema = DBICTest->init_schema( sqlite_use_file => 1 );
176
177   for my $pass (1..2) {
178
179     # do something trying to destabilize the depth count
180     for (1..2) {
181       eval {
182         my $guard = $schema->txn_scope_guard;
183         $schema->txn_do( sub { die } );
184       };
185       $schema->txn_do( sub {
186         ok ($schema->storage->_dbh->do ('SELECT 1'), "Query after exceptions ok ($_)");
187       });
188     }
189
190     my $guard = $schema->txn_scope_guard;
191     my @pids = _test_forking_action ($schema, $pass);
192     $guard->commit;
193   }
194 }
195
196 sub _test_forking_action {
197   my ($schema, $pass) = @_;
198
199   my @pids;
200
201   SKIP: for my $count (1 .. 5) {
202
203     skip 'Weird DBI General Protection Faults, skip forking tests (RT#63104)', 5
204       if $^O eq 'MSWin32';
205
206     my $pid = fork();
207     die "Unable to fork: $!\n"
208       if ! defined $pid;
209
210     if ($pid) {
211       push @pids, $pid;
212       next;
213     }
214
215     if ($count % 2) {
216       $schema->txn_do (sub {
217         my $depth = $schema->storage->transaction_depth;
218         die "$$(txn_do)unexpected txn depth $depth!" if $depth != 1;
219         $schema->resultset ('Artist')->create ({ name => "forking action $$"});
220       });
221     }
222     else {
223       my $guard = $schema->txn_scope_guard;
224       my $depth = $schema->storage->transaction_depth;
225       die "$$(scope_guard) unexpected txn depth $depth!" if $depth != 1;
226       $schema->resultset ('Artist')->create ({ name => "forking action $$"});
227       $guard->commit;
228     }
229
230     exit 0;
231   }
232
233   for my $pid (@pids) {
234     waitpid ($pid, 0);
235     ok (! $?, "Child $pid exit ok (pass $pass)");
236   }
237
238   # it is important to reap all children before checking the final db-state
239   # otherwise a deadlock may occur between the transactions running in the
240   # children and the query of the parent
241   for my $pid (@pids) {
242     isa_ok ($schema->resultset ('Artist')->find ({ name => "forking action $pid" }), 'DBIx::Class::Row');
243   }
244 }
245
246 my $fail_code = sub {
247   my ($artist) = @_;
248   $artist->create_related('cds', {
249     title => 'this should not exist',
250     year => 2005,
251   });
252   die "the sky is falling";
253 };
254
255 {
256   my $schema = DBICTest->init_schema;
257
258   # Test failed txn_do()
259   for my $pass (1,2) {
260
261     is( $schema->storage->{transaction_depth}, 0, "txn depth starts at 0 (pass $pass)");
262
263     my $artist = $schema->resultset('Artist')->find(3);
264
265     throws_ok (sub {
266       $schema->txn_do($fail_code, $artist);
267     }, qr/the sky is falling/, "failed txn_do threw an exception (pass $pass)");
268
269     my $cd = $artist->cds({
270       title => 'this should not exist',
271       year => 2005,
272     })->first;
273     ok(!defined($cd), qq{failed txn_do didn't change the cds table (pass $pass)});
274
275     is( $schema->storage->{transaction_depth}, 0, "txn depth has been reset (pass $pass)");
276   }
277
278
279   # Test failed txn_do() with failed rollback
280   {
281     is( $schema->storage->{transaction_depth}, 0, 'txn depth starts at 0');
282
283     my $artist = $schema->resultset('Artist')->find(3);
284
285     # Force txn_rollback() to throw an exception
286     no warnings 'redefine';
287     no strict 'refs';
288
289     # die in rollback
290     local *{"DBIx::Class::Storage::DBI::SQLite::txn_rollback"} = sub{
291       my $storage = shift;
292       die 'FAILED';
293     };
294
295     throws_ok (
296       sub {
297         $schema->txn_do($fail_code, $artist);
298       },
299       qr/the sky is falling.+Rollback failed/s,
300       'txn_rollback threw a rollback exception (and included the original exception'
301     );
302
303     my $cd = $artist->cds({
304       title => 'this should not exist',
305       year => 2005,
306     })->first;
307     isa_ok($cd, 'DBICTest::CD', q{failed txn_do with a failed txn_rollback }.
308            q{changed the cds table});
309     $cd->delete; # Rollback failed
310     $cd = $artist->cds({
311       title => 'this should not exist',
312       year => 2005,
313     })->first;
314     ok(!defined($cd), q{deleted the failed txn's cd});
315     $schema->storage->_dbh->rollback;
316   }
317 }
318
319 # Test nested failed txn_do()
320 {
321   my $schema = DBICTest->init_schema();
322
323   is( $schema->storage->{transaction_depth}, 0, 'txn depth starts at 0');
324
325   my $nested_fail_code = sub {
326     my ($schema, $artist, $code1, $code2) = @_;
327
328     my @titles = map {'nested txn_do test CD ' . $_} (1..5);
329
330     $schema->txn_do($code1, $artist, @titles); # successful txn
331     $schema->txn_do($code2, $artist);          # failed txn
332   };
333
334   my $artist = $schema->resultset('Artist')->find(3);
335
336   throws_ok ( sub {
337     $schema->txn_do($nested_fail_code, $schema, $artist, $code, $fail_code);
338   }, qr/the sky is falling/, 'nested failed txn_do threw exception');
339
340   ok(!defined($artist->cds({
341     title => 'nested txn_do test CD '.$_,
342     year => 2006,
343   })->first), qq{failed txn_do didn't add first txn's cd $_}) for (1..5);
344   my $cd = $artist->cds({
345     title => 'this should not exist',
346     year => 2005,
347   })->first;
348   ok(!defined($cd), q{failed txn_do didn't add failed txn's cd});
349 }
350
351 # Grab a new schema to test txn before connect
352 {
353   my $schema = DBICTest->init_schema(no_deploy => 1);
354   lives_ok (sub {
355     $schema->txn_begin();
356     $schema->txn_begin();
357   }, 'Pre-connection nested transactions.');
358
359   # although not connected DBI would still warn about rolling back at disconnect
360   $schema->txn_rollback;
361   $schema->txn_rollback;
362 }
363
364 # make sure AutoCommit => 0 on external handles behaves correctly with scope_guard
365 warnings_are {
366   my $factory = DBICTest->init_schema;
367   cmp_ok ($factory->resultset('CD')->count, '>', 0, 'Something to delete');
368   my $dbh = $factory->storage->dbh;
369   $dbh->{AutoCommit} = 0;
370
371   ok (!$dbh->{AutoCommit}, 'AutoCommit is off on $dbh');
372   my $schema = DBICTest::Schema->connect (sub { $dbh });
373
374   lives_ok ( sub {
375     my $guard = $schema->txn_scope_guard;
376     $schema->resultset('CD')->delete;
377     $guard->commit;
378   }, 'No attempt to start a transaction with scope guard');
379
380   is ($schema->resultset('CD')->count, 0, 'Deletion successful in txn');
381
382   # this will commit the implicitly started txn
383   $dbh->commit;
384
385 } [], 'No warnings on AutoCommit => 0 with txn_guard';
386
387 # make sure AutoCommit => 0 on external handles behaves correctly with txn_do
388 warnings_are {
389   my $factory = DBICTest->init_schema;
390   cmp_ok ($factory->resultset('CD')->count, '>', 0, 'Something to delete');
391   my $dbh = $factory->storage->dbh;
392   $dbh->{AutoCommit} = 0;
393
394   ok (!$dbh->{AutoCommit}, 'AutoCommit is off on $dbh');
395   my $schema = DBICTest::Schema->connect (sub { $dbh });
396
397   lives_ok ( sub {
398     $schema->txn_do (sub { $schema->resultset ('CD')->delete });
399   }, 'No attempt to start a atransaction with txn_do');
400
401   is ($schema->resultset('CD')->count, 0, 'Deletion successful');
402
403   # this will commit the implicitly started txn
404   $dbh->commit;
405
406 } [], 'No warnings on AutoCommit => 0 with txn_do';
407
408 done_testing;