t/storage/txn.t

   1 # Test is sufficiently involved to *want* to run with "maximum paranoia"
   2 BEGIN { $ENV{DBICTEST_OLD_MRO_SANITY_CHECK_ASSERTIONS} = 1 }
   3
   4 BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) }
   5
   6 use strict;
   7 use warnings;
   8
   9 use Test::More;
  10 use Test::Warn;
  11 use Test::Exception;
  12 use Errno ();
  13
  14 use DBICTest;
  15
  16 my $code = sub {
  17   my ($artist, @cd_titles) = @_;
  18
  19   $artist->create_related('cds', {
  20     title => $_,
  21     year => 2006,
  22   }) foreach (@cd_titles);
  23
  24   return $artist->cds->all;
  25 };
  26
  27 # Test checking of parameters
  28 {
  29   my $schema = DBICTest->init_schema;
  30
  31   throws_ok (sub {
  32     (ref $schema)->txn_do(sub{});
  33   }, qr/storage/, "can't call txn_do without storage");
  34
  35   throws_ok {
  36     $schema->txn_do('');
  37   } qr/\Qrun() requires a coderef to execute as its first argument/,
  38   '$coderef parameter check ok';
  39 }
  40
  41 # Test successful txn_do() - scalar/list context
  42 for my $want (0,1) {
  43   my $schema = DBICTest->init_schema;
  44
  45   is( $schema->storage->transaction_depth, 0, 'txn depth starts at 0');
  46
  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;
  50
  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   }
  60
  61   is($artist->cds({
  62     title => "txn_do test CD $_",
  63   })->first->year, 2006, "new CD $_ year correct") for (1..5);
  64
  65   is( $schema->storage->transaction_depth, 0, 'txn depth has been reset');
  66 }
  67
  68 # Test txn_do() @_ aliasing support
  69 {
  70   my $schema = DBICTest->init_schema;
  71
  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
  77 # Test nested successful txn_do()
  78 {
  79   my $schema = DBICTest->init_schema;
  80
  81   is( $schema->storage->transaction_depth, 0, 'txn depth starts at 0');
  82
  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
  96   lives_ok (sub {
  97     $schema->txn_do($nested_code, $schema, $artist, $code);
  98   }, 'nested txn_do succeeded');
  99
 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');
 104
 105   is( $schema->storage->transaction_depth, 0, 'txn depth has been reset');
 106 }
 107
 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;
 116   SKIP:
 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;
 123         $s->storage->dbh->do('SELECT 1') }
 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   ) {
 138     my $pid = fork();
 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     }
 146
 147     if ($pid) {
 148       push @pids, $pid;
 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       };
 176       is( $schema->storage->transaction_depth, 0, 'Transaction successfully aborted' );
 177       $schema->txn_do( sub {
 178         ok ($schema->storage->_dbh->do ('SELECT 1'), "Query after exceptions ok ($_)");
 179       });
 180     }
 181
 182     $schema->txn_do ( sub { _test_forking_action ($schema, $pass) } );
 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       };
 198       is( $schema->storage->transaction_depth, 0, 'Transaction successfully aborted' );
 199       $schema->txn_do( sub {
 200         ok ($schema->storage->_dbh->do ('SELECT 1'), "Query after exceptions ok ($_)");
 201       });
 202     }
 203
 204     my $guard = $schema->txn_scope_guard;
 205     my @pids = _test_forking_action ($schema, $pass);
 206     $guard->commit;
 207   }
 208 }
 209
 210 sub _test_forking_action {
 211   my ($schema, $pass) = @_;
 212
 213   my @pids;
 214
 215   SKIP: for my $count (1 .. 5) {
 216
 217     skip 'FIXME: Weird DBI General Protection Faults, skip forking tests (RT#63104)', 5
 218       if $^O eq 'MSWin32';
 219
 220     my $pid = fork();
 221     if( ! defined $pid ) {
 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     }
 227
 228     if ($pid) {
 229       push @pids, $pid;
 230       next;
 231     }
 232
 233     if ($count % 2) {
 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
 251   for my $pid (@pids) {
 252     waitpid ($pid, 0);
 253     ok (! $?, "Child $pid exit ok (pass $pass)");
 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) {
 260     isa_ok ($schema->resultset ('Artist')->find ({ name => "forking action $pid" }), 'DBIx::Class::Row');
 261   }
 262 }
 263
 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
 273 {
 274   my $schema = DBICTest->init_schema;
 275
 276   # Test failed txn_do()
 277   for my $pass (1,2) {
 278
 279     is( $schema->storage->transaction_depth, 0, "txn depth starts at 0 (pass $pass)");
 280
 281     my $artist = $schema->resultset('Artist')->find(3);
 282
 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)");
 286
 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)});
 292
 293     is( $schema->storage->transaction_depth, 0, "txn depth has been reset (pass $pass)");
 294   }
 295
 296
 297   # Test failed txn_do() with failed rollback
 298   {
 299     is( $schema->storage->transaction_depth, 0, 'txn depth starts at 0');
 300
 301     my $artist = $schema->resultset('Artist')->find(3);
 302
 303     # Force txn_rollback() to throw an exception
 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' };
 309
 310     local *DBIx::Class::Storage::DBI::txn_rollback = sub { die 'FAILED' };
 311     Class::C3->reinitialize() if DBIx::Class::_ENV_::OLD_MRO;
 312
 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   }
 335 }
 336
 337 # Test nested failed txn_do()
 338 {
 339   my $schema = DBICTest->init_schema();
 340
 341   is( $schema->storage->transaction_depth, 0, 'txn depth starts at 0');
 342
 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
 354   throws_ok ( sub {
 355     $schema->txn_do($nested_fail_code, $schema, $artist, $code, $fail_code);
 356   }, qr/the sky is falling/, 'nested failed txn_do threw exception');
 357
 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 }
 368
 369
 370 # Grab a new schema to test txn before connect
 371 # also test nested txn exception
 372 {
 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
 379   throws_ok( sub { $schema->txn_rollback }, 'DBIx::Class::Storage::NESTED_ROLLBACK_EXCEPTION', 'got proper nested rollback exception' );
 380 }
 381
 382 # make sure AutoCommit => 0 on external handles behaves correctly with scope_guard
 383 warnings_are {
 384   my $factory = DBICTest->init_schema;
 385   cmp_ok ($factory->resultset('CD')->count, '>', 0, 'Something to delete');
 386   my $dbh = $factory->storage->dbh;
 387   $dbh->{AutoCommit} = 0;
 388
 389   ok (!$dbh->{AutoCommit}, 'AutoCommit is off on $dbh');
 390   my $schema = DBICTest::Schema->connect (sub { $dbh });
 391
 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
 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';
 404
 405 # make sure AutoCommit => 0 on external handles behaves correctly with txn_do
 406 warnings_are {
 407   my $factory = DBICTest->init_schema;
 408   cmp_ok ($factory->resultset('CD')->count, '>', 0, 'Something to delete');
 409   my $dbh = $factory->storage->dbh;
 410   $dbh->{AutoCommit} = 0;
 411
 412   ok (!$dbh->{AutoCommit}, 'AutoCommit is off on $dbh');
 413   my $schema = DBICTest::Schema->connect (sub { $dbh });
 414
 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');
 420
 421   # this will commit the implicitly started txn
 422   $dbh->commit;
 423
 424 } [], 'No warnings on AutoCommit => 0 with txn_do';
 425
 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     })
 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
 459
 460   is @w, 1, 'One matching warning only';
 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';
 472 }
 473
 474 done_testing;