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;