[dbsrgits/DBIx-Class.git] / t / storage / txn.t

use strict;
use warnings;

use Test::More;
use Test::Warn;
use Test::Exception;
use lib qw(t/lib);
use DBICTest;

my $schema = DBICTest->init_schema();

my $code = sub {
  my ($artist, @cd_titles) = @_;

  $artist->create_related('cds', {
    title => $_,
    year => 2006,
  }) foreach (@cd_titles);

  return $artist->cds->all;
};

# Test checking of parameters
{
  throws_ok (sub {
    (ref $schema)->txn_do(sub{});
  }, qr/storage/, "can't call txn_do without storage");

  throws_ok ( sub {
    $schema->txn_do('');
  }, qr/must be a CODE reference/, '$coderef parameter check ok');
}

# Test successful txn_do() - scalar context
{
  is( $schema->storage->{transaction_depth}, 0, 'txn depth starts at 0');

  my @titles = map {'txn_do test CD ' . $_} (1..5);
  my $artist = $schema->resultset('Artist')->find(1);
  my $count_before = $artist->cds->count;
  my $count_after = $schema->txn_do($code, $artist, @titles);
  is($count_after, $count_before+5, 'successful txn added 5 cds');
  is($artist->cds({
    title => "txn_do test CD $_",
  })->first->year, 2006, "new CD $_ year correct") for (1..5);

  is( $schema->storage->{transaction_depth}, 0, 'txn depth has been reset');
}

# Test successful txn_do() - list context
{
  is( $schema->storage->{transaction_depth}, 0, 'txn depth starts at 0');

  my @titles = map {'txn_do test CD ' . $_} (6..10);
  my $artist = $schema->resultset('Artist')->find(1);
  my $count_before = $artist->cds->count;
  my @cds = $schema->txn_do($code, $artist, @titles);
  is(scalar @cds, $count_before+5, 'added 5 CDs and returned in list context');
  is($artist->cds({
    title => "txn_do test CD $_",
  })->first->year, 2006, "new CD $_ year correct") for (6..10);

  is( $schema->storage->{transaction_depth}, 0, 'txn depth has been reset');
}

# Test txn_do() @_ aliasing support
{
  my $res = 'original';
  $schema->storage->txn_do (sub { $_[0] = 'changed' }, $res);
  is ($res, 'changed', "Arguments properly aliased for txn_do");
}

# Test nested successful txn_do()
{
  is( $schema->storage->{transaction_depth}, 0, 'txn depth starts at 0');

  my $nested_code = sub {
    my ($schema, $artist, $code) = @_;

    my @titles1 = map {'nested txn_do test CD ' . $_} (1..5);
    my @titles2 = map {'nested txn_do test CD ' . $_} (6..10);

    $schema->txn_do($code, $artist, @titles1);
    $schema->txn_do($code, $artist, @titles2);
  };

  my $artist = $schema->resultset('Artist')->find(2);
  my $count_before = $artist->cds->count;

  lives_ok (sub {
    $schema->txn_do($nested_code, $schema, $artist, $code);
  }, 'nested txn_do succeeded');

  is($artist->cds({
    title => 'nested txn_do test CD '.$_,
  })->first->year, 2006, qq{nested txn_do CD$_ year ok}) for (1..10);
  is($artist->cds->count, $count_before+10, 'nested txn_do added all CDs');

  is( $schema->storage->{transaction_depth}, 0, 'txn depth has been reset');
}

# test nested txn_begin on fresh connection
{
  my $schema = DBICTest->init_schema(sqlite_use_file => 1, no_deploy => 1);
  $schema->storage->ensure_connected;

  is ($schema->storage->transaction_depth, 0, 'Start outside txn');

  my @pids;
  for my $action (
    sub {
      my $s = shift;
      die "$$ starts in txn!" if $s->storage->transaction_depth != 0;
      $s->txn_do ( sub {
        die "$$ not in txn!" if $s->storage->transaction_depth == 0;
        $s->storage->dbh->do('SELECT 1') } 
      );
      die "$$ did not finish txn!" if $s->storage->transaction_depth != 0;
    },
    sub {
      $_[0]->txn_begin;
      $_[0]->storage->dbh->do('SELECT 1');
      $_[0]->txn_commit
    },
    sub {
      my $guard = $_[0]->txn_scope_guard;
      $_[0]->storage->dbh->do('SELECT 1');
      $guard->commit
    },
  ) {
    push @pids, fork();
    die "Unable to fork: $!\n"
      if ! defined $pids[-1];

    if ($pids[-1]) {
      next;
    }

    $action->($schema);
    exit 0;
  }

  is ($schema->storage->transaction_depth, 0, 'Parent still outside txn');

  for my $pid (@pids) {
    waitpid ($pid, 0);
    ok (! $?, "Child $pid exit ok");
  }
}

# Test txn_do/scope_guard with forking: outer txn_do
{
  my $schema = DBICTest->init_schema( sqlite_use_file => 1 );

  for my $pass (1..2) {

    # do something trying to destabilize the depth count
    for (1..2) {
      eval {
        my $guard = $schema->txn_scope_guard;
        $schema->txn_do( sub { die } );
      };
      $schema->txn_do( sub {
        ok ($schema->storage->_dbh->do ('SELECT 1'), "Query after exceptions ok ($_)");
      });
    }

    for my $pid ( $schema->txn_do ( sub { _forking_action ($schema) } ) ) {
      waitpid ($pid, 0);
      ok (! $?, "Child $pid exit ok (pass $pass)");
      isa_ok ($schema->resultset ('Artist')->find ({ name => "forking action $pid" }), 'DBIx::Class::Row');
    }
  }
}

# same test with outer guard
{
  my $schema = DBICTest->init_schema( sqlite_use_file => 1 );

  for my $pass (1..2) {

    # do something trying to destabilize the depth count
    for (1..2) {
      eval {
        my $guard = $schema->txn_scope_guard;
        $schema->txn_do( sub { die } );
      };
      $schema->txn_do( sub {
        ok ($schema->storage->_dbh->do ('SELECT 1'), "Query after exceptions ok ($_)");
      });
    }

    my @pids;
    my $guard = $schema->txn_scope_guard;
    _forking_action ($schema);
    $guard->commit;

    for my $pid (@pids) {
      waitpid ($pid, 0);
      ok (! $?, "Child $pid exit ok (pass $pass)");
      isa_ok ($schema->resultset ('Artist')->find ({ name => "forking action $pid" }), 'DBIx::Class::Row');
    }
  }
}

sub _forking_action {
  my $schema = shift;

  my @pids;
  while (@pids < 5) {

    push @pids, fork();
    die "Unable to fork: $!\n"
      if ! defined $pids[-1];

    if ($pids[-1]) {
      next;
    }

    if (@pids % 2) {
      $schema->txn_do (sub {
        my $depth = $schema->storage->transaction_depth;
        die "$$(txn_do)unexpected txn depth $depth!" if $depth != 1;
        $schema->resultset ('Artist')->create ({ name => "forking action $$"});
      });
    }
    else {
      my $guard = $schema->txn_scope_guard;
      my $depth = $schema->storage->transaction_depth;
      die "$$(scope_guard) unexpected txn depth $depth!" if $depth != 1;
      $schema->resultset ('Artist')->create ({ name => "forking action $$"});
      $guard->commit;
    }

    exit 0;
  }

  return @pids;
}

my $fail_code = sub {
  my ($artist) = @_;
  $artist->create_related('cds', {
    title => 'this should not exist',
    year => 2005,
  });
  die "the sky is falling";
};

# Test failed txn_do()
{

  is( $schema->storage->{transaction_depth}, 0, 'txn depth starts at 0');

  my $artist = $schema->resultset('Artist')->find(3);

  throws_ok (sub {
    $schema->txn_do($fail_code, $artist);
  }, qr/the sky is falling/, 'failed txn_do threw an exception');

  my $cd = $artist->cds({
    title => 'this should not exist',
    year => 2005,
  })->first;
  ok(!defined($cd), q{failed txn_do didn't change the cds table});

  is( $schema->storage->{transaction_depth}, 0, 'txn depth has been reset');
}

# do the same transaction again
{
  is( $schema->storage->{transaction_depth}, 0, 'txn depth starts at 0');

  my $artist = $schema->resultset('Artist')->find(3);

  throws_ok (sub {
    $schema->txn_do($fail_code, $artist);
  }, qr/the sky is falling/, 'failed txn_do threw an exception');

  my $cd = $artist->cds({
    title => 'this should not exist',
    year => 2005,
  })->first;
  ok(!defined($cd), q{failed txn_do didn't change the cds table});

  is( $schema->storage->{transaction_depth}, 0, 'txn depth has been reset');
}

# Test failed txn_do() with failed rollback
{
  is( $schema->storage->{transaction_depth}, 0, 'txn depth starts at 0');

  my $artist = $schema->resultset('Artist')->find(3);

  # Force txn_rollback() to throw an exception
  no warnings 'redefine';
  no strict 'refs';

  # die in rollback
  local *{"DBIx::Class::Storage::DBI::SQLite::txn_rollback"} = sub{
    my $storage = shift;
    die 'FAILED';
  };

  throws_ok (
    sub {
      $schema->txn_do($fail_code, $artist);
    },
    qr/the sky is falling.+Rollback failed/s,
    'txn_rollback threw a rollback exception (and included the original exception'
  );

  my $cd = $artist->cds({
    title => 'this should not exist',
    year => 2005,
  })->first;
  isa_ok($cd, 'DBICTest::CD', q{failed txn_do with a failed txn_rollback }.
         q{changed the cds table});
  $cd->delete; # Rollback failed
  $cd = $artist->cds({
    title => 'this should not exist',
    year => 2005,
  })->first;
  ok(!defined($cd), q{deleted the failed txn's cd});
  $schema->storage->_dbh->rollback;

}

# reset schema object (the txn_rollback meddling screws it up)
undef $schema;

# Test nested failed txn_do()
{
  my $schema = DBICTest->init_schema();

  is( $schema->storage->{transaction_depth}, 0, 'txn depth starts at 0');

  my $nested_fail_code = sub {
    my ($schema, $artist, $code1, $code2) = @_;

    my @titles = map {'nested txn_do test CD ' . $_} (1..5);

    $schema->txn_do($code1, $artist, @titles); # successful txn
    $schema->txn_do($code2, $artist);          # failed txn
  };

  my $artist = $schema->resultset('Artist')->find(3);

  throws_ok ( sub {
    $schema->txn_do($nested_fail_code, $schema, $artist, $code, $fail_code);
  }, qr/the sky is falling/, 'nested failed txn_do threw exception');

  ok(!defined($artist->cds({
    title => 'nested txn_do test CD '.$_,
    year => 2006,
  })->first), qq{failed txn_do didn't add first txn's cd $_}) for (1..5);
  my $cd = $artist->cds({
    title => 'this should not exist',
    year => 2005,
  })->first;
  ok(!defined($cd), q{failed txn_do didn't add failed txn's cd});
}

# Grab a new schema to test txn before connect
{
  my $schema = DBICTest->init_schema(no_deploy => 1);
  lives_ok (sub {
    $schema->txn_begin();
    $schema->txn_begin();
  }, 'Pre-connection nested transactions.');

  # although not connected DBI would still warn about rolling back at disconnect
  $schema->txn_rollback;
  $schema->txn_rollback;
}

# Test txn_scope_guard
{
  my $schema = DBICTest->init_schema();

  is($schema->storage->transaction_depth, 0, "Correct transaction depth");
  my $artist_rs = $schema->resultset('Artist');

  my $fn = __FILE__;
  throws_ok {
   my $guard = $schema->txn_scope_guard;

    $artist_rs->create({
      name => 'Death Cab for Cutie',
      made_up_column => 1,
    });

   $guard->commit;
  } qr/No such column made_up_column .*? at .*?$fn line \d+/s, "Error propogated okay";

  ok(!$artist_rs->find({name => 'Death Cab for Cutie'}), "Artist not created");

  my $inner_exception = '';  # set in inner() below
  throws_ok (sub {
    outer($schema, 1);
  }, qr/$inner_exception/, "Nested exceptions propogated");

  ok(!$artist_rs->find({name => 'Death Cab for Cutie'}), "Artist not created");

  lives_ok (sub {

    # this weird assignment is to stop perl <= 5.8.9 leaking $schema on nested sub{}s
    my $s = $schema;

    warnings_exist ( sub {
      # The 0 arg says don't die, just let the scope guard go out of scope
      # forcing a txn_rollback to happen
      outer($s, 0);
    }, qr/A DBIx::Class::Storage::TxnScopeGuard went out of scope without explicit commit or error. Rolling back./, 'Out of scope warning detected');

    ok(!$artist_rs->find({name => 'Death Cab for Cutie'}), "Artist not created");

  }, 'rollback successful withot exception');

  sub outer {
    my ($schema, $fatal) = @_;

    my $guard = $schema->txn_scope_guard;
    $schema->resultset('Artist')->create({
      name => 'Death Cab for Cutie',
    });
    inner($schema, $fatal);
  }

  sub inner {
    my ($schema, $fatal) = @_;

    my $inner_guard = $schema->txn_scope_guard;
    is($schema->storage->transaction_depth, 2, "Correct transaction depth");

    my $artist = $schema->resultset('Artist')->find({ name => 'Death Cab for Cutie' });

    eval {
      $artist->cds->create({
        title => 'Plans',
        year => 2005,
        $fatal ? ( foo => 'bar' ) : ()
      });
    };
    if ($@) {
      # Record what got thrown so we can test it propgates out properly.
      $inner_exception = $@;
      die $@;
    }

    # inner guard should commit without consequences
    $inner_guard->commit;
  }
}

# make sure the guard does not eat exceptions
{
  my $schema = DBICTest->init_schema;

  no strict 'refs';
  no warnings 'redefine';
  local *{DBIx::Class::Storage::DBI::txn_rollback} = sub { die 'die die my darling' };

  throws_ok (sub {
    my $guard = $schema->txn_scope_guard;
    $schema->resultset ('Artist')->create ({ name => 'bohhoo'});

    # this should freak out the guard rollback
    # but it won't work because DBD::SQLite is buggy
    # instead just install a toxic rollback above
    #$schema->storage->_dbh( $schema->storage->_dbh->clone );

    die 'Deliberate exception';
  }, qr/Deliberate exception.+Rollback failed/s);
}

# make sure it warns *big* on failed rollbacks
{
  my $schema = DBICTest->init_schema();

  no strict 'refs';
  no warnings 'redefine';
  local *{DBIx::Class::Storage::DBI::txn_rollback} = sub { die 'die die my darling' };

#The warn from within a DESTROY callback freaks out Test::Warn, do it old-school
=begin
  warnings_exist (
    sub {
      my $guard = $schema->txn_scope_guard;
      $schema->resultset ('Artist')->create ({ name => 'bohhoo'});

      # this should freak out the guard rollback
      # but it won't work because DBD::SQLite is buggy
      # instead just install a toxic rollback above
      #$schema->storage->_dbh( $schema->storage->_dbh->clone );
    },
    [
      qr/A DBIx::Class::Storage::TxnScopeGuard went out of scope without explicit commit or error. Rolling back./,
      qr/\*+ ROLLBACK FAILED\!\!\! \*+/,
    ],
    'proper warnings generated on out-of-scope+rollback failure'
  );
=cut

# delete this once the above works properly (same test)
  my @want = (
    qr/A DBIx::Class::Storage::TxnScopeGuard went out of scope without explicit commit or error. Rolling back./,
    qr/\*+ ROLLBACK FAILED\!\!\! \*+/,
  );

  my @w;
  local $SIG{__WARN__} = sub {
    if (grep {$_[0] =~ $_} (@want)) {
      push @w, $_[0];
    }
    else {
      warn $_[0];
    }
  };
  {
      my $guard = $schema->txn_scope_guard;
      $schema->resultset ('Artist')->create ({ name => 'bohhoo'});
  }

  is (@w, 2, 'Both expected warnings found');
}

# make sure AutoCommit => 0 on external handles behaves correctly with scope_guard
warnings_are {
  my $factory = DBICTest->init_schema (AutoCommit => 0);
  cmp_ok ($factory->resultset('CD')->count, '>', 0, 'Something to delete');
  my $dbh = $factory->storage->dbh;

  ok (!$dbh->{AutoCommit}, 'AutoCommit is off on $dbh');
  my $schema = DBICTest::Schema->connect (sub { $dbh });

  lives_ok ( sub {
    my $guard = $schema->txn_scope_guard;
    $schema->resultset('CD')->delete;
    $guard->commit;
  }, 'No attempt to start a transaction with scope guard');

  is ($schema->resultset('CD')->count, 0, 'Deletion successful in txn');

  # this will commit the implicitly started txn
  $dbh->commit;

} [], 'No warnings on AutoCommit => 0 with txn_guard';

# make sure AutoCommit => 0 on external handles behaves correctly with txn_do
warnings_are {
  my $factory = DBICTest->init_schema (AutoCommit => 0);
  cmp_ok ($factory->resultset('CD')->count, '>', 0, 'Something to delete');
  my $dbh = $factory->storage->dbh;

  ok (!$dbh->{AutoCommit}, 'AutoCommit is off on $dbh');
  my $schema = DBICTest::Schema->connect (sub { $dbh });


  lives_ok ( sub {
    $schema->txn_do (sub { $schema->resultset ('CD')->delete });
  }, 'No attempt to start a atransaction with txn_do');

  is ($schema->resultset('CD')->count, 0, 'Deletion successful');

  # this will commit the implicitly started txn
  $dbh->commit;

} [], 'No warnings on AutoCommit => 0 with txn_do';

done_testing;
Commit	Line	Data
70350518	1	use strict;
d7ded411	2	use warnings;
70350518	3
70350518	4	use Test::More;
d7ded411	5	use Test::Warn;
3b7f3eac	6	use Test::Exception;
70350518	7	use lib qw(t/lib);
	8	use DBICTest;
	9
a47e1233	10	my $schema = DBICTest->init_schema();
70350518	11
a62cf8d4	12	my $code = sub {
a62cf8d4	13	my ($artist, @cd_titles) = @_;
d7ded411	14
a62cf8d4	15	$artist->create_related('cds', {
	16	title => $_,
	17	year => 2006,
	18	}) foreach (@cd_titles);
d7ded411	19
a62cf8d4	20	return $artist->cds->all;
	21	};
	22
171dadd7	23	# Test checking of parameters
171dadd7	24	{
dd7d4b43	25	throws_ok (sub {
171dadd7	26	(ref $schema)->txn_do(sub{});
dd7d4b43	27	}, qr/storage/, "can't call txn_do without storage");
	28
	29	throws_ok ( sub {
171dadd7	30	$schema->txn_do('');
dd7d4b43	31	}, qr/must be a CODE reference/, '$coderef parameter check ok');
171dadd7	32	}
171dadd7	33
a62cf8d4	34	# Test successful txn_do() - scalar context
a62cf8d4	35	{
57c18b65	36	is( $schema->storage->{transaction_depth}, 0, 'txn depth starts at 0');
57c18b65	37
a62cf8d4	38	my @titles = map {'txn_do test CD ' . $_} (1..5);
	39	my $artist = $schema->resultset('Artist')->find(1);
	40	my $count_before = $artist->cds->count;
	41	my $count_after = $schema->txn_do($code, $artist, @titles);
	42	is($count_after, $count_before+5, 'successful txn added 5 cds');
	43	is($artist->cds({
	44	title => "txn_do test CD $_",
	45	})->first->year, 2006, "new CD $_ year correct") for (1..5);
57c18b65	46
57c18b65	47	is( $schema->storage->{transaction_depth}, 0, 'txn depth has been reset');
a62cf8d4	48	}
	49
	50	# Test successful txn_do() - list context
	51	{
57c18b65	52	is( $schema->storage->{transaction_depth}, 0, 'txn depth starts at 0');
57c18b65	53
a62cf8d4	54	my @titles = map {'txn_do test CD ' . $_} (6..10);
	55	my $artist = $schema->resultset('Artist')->find(1);
	56	my $count_before = $artist->cds->count;
	57	my @cds = $schema->txn_do($code, $artist, @titles);
	58	is(scalar @cds, $count_before+5, 'added 5 CDs and returned in list context');
	59	is($artist->cds({
	60	title => "txn_do test CD $_",
	61	})->first->year, 2006, "new CD $_ year correct") for (6..10);
57c18b65	62
57c18b65	63	is( $schema->storage->{transaction_depth}, 0, 'txn depth has been reset');
a62cf8d4	64	}
a62cf8d4	65
38ed54cd	66	# Test txn_do() @_ aliasing support
	67	{
	68	my $res = 'original';
	69	$schema->storage->txn_do (sub { $_[0] = 'changed' }, $res);
	70	is ($res, 'changed', "Arguments properly aliased for txn_do");
	71	}
	72
a62cf8d4	73	# Test nested successful txn_do()
a62cf8d4	74	{
57c18b65	75	is( $schema->storage->{transaction_depth}, 0, 'txn depth starts at 0');
57c18b65	76
a62cf8d4	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
dd7d4b43	90	lives_ok (sub {
a62cf8d4	91	$schema->txn_do($nested_code, $schema, $artist, $code);
dd7d4b43	92	}, 'nested txn_do succeeded');
a62cf8d4	93
a62cf8d4	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');
57c18b65	98
57c18b65	99	is( $schema->storage->{transaction_depth}, 0, 'txn depth has been reset');
a62cf8d4	100	}
a62cf8d4	101
7d216b10	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	for my $action (
	111	sub {
	112	my $s = shift;
	113	die "$$ starts in txn!" if $s->storage->transaction_depth != 0;
	114	$s->txn_do ( sub {
	115	die "$$ not in txn!" if $s->storage->transaction_depth == 0;
	116	$s->storage->dbh->do('SELECT 1') }
	117	);
	118	die "$$ did not finish txn!" if $s->storage->transaction_depth != 0;
	119	},
	120	sub {
	121	$_[0]->txn_begin;
	122	$_[0]->storage->dbh->do('SELECT 1');
	123	$_[0]->txn_commit
	124	},
	125	sub {
	126	my $guard = $_[0]->txn_scope_guard;
	127	$_[0]->storage->dbh->do('SELECT 1');
	128	$guard->commit
	129	},
	130	) {
	131	push @pids, fork();
	132	die "Unable to fork: $!\n"
	133	if ! defined $pids[-1];
	134
	135	if ($pids[-1]) {
	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	for my $pid ( $schema->txn_do ( sub { _forking_action ($schema) } ) ) {
169	waitpid ($pid, 0);
170	ok (! $?, "Child $pid exit ok (pass $pass)");
171	isa_ok ($schema->resultset ('Artist')->find ({ name => "forking action $pid" }), 'DBIx::Class::Row');
172	}
173	}
174	}
175
176	# same test with outer guard
177	{
178	my $schema = DBICTest->init_schema( sqlite_use_file => 1 );
179
180	for my $pass (1..2) {
181
182	# do something trying to destabilize the depth count
183	for (1..2) {
184	eval {
185	my $guard = $schema->txn_scope_guard;
186	$schema->txn_do( sub { die } );
187	};
188	$schema->txn_do( sub {
189	ok ($schema->storage->_dbh->do ('SELECT 1'), "Query after exceptions ok ($_)");
190	});
191	}
192
193	my @pids;
194	my $guard = $schema->txn_scope_guard;
195	_forking_action ($schema);
196	$guard->commit;
197
198	for my $pid (@pids) {
199	waitpid ($pid, 0);
200	ok (! $?, "Child $pid exit ok (pass $pass)");
201	isa_ok ($schema->resultset ('Artist')->find ({ name => "forking action $pid" }), 'DBIx::Class::Row');
202	}
203	}
204	}
205
206	sub _forking_action {
207	my $schema = shift;
208
209	my @pids;
210	while (@pids < 5) {
211
212	push @pids, fork();
213	die "Unable to fork: $!\n"
214	if ! defined $pids[-1];
215
216	if ($pids[-1]) {
217	next;
218	}
219
220	if (@pids % 2) {
221	$schema->txn_do (sub {
222	my $depth = $schema->storage->transaction_depth;
223	die "$$(txn_do)unexpected txn depth $depth!" if $depth != 1;
224	$schema->resultset ('Artist')->create ({ name => "forking action $$"});
225	});
226	}
227	else {
228	my $guard = $schema->txn_scope_guard;
229	my $depth = $schema->storage->transaction_depth;
230	die "$$(scope_guard) unexpected txn depth $depth!" if $depth != 1;
231	$schema->resultset ('Artist')->create ({ name => "forking action $$"});
232	$guard->commit;
233	}
234
235	exit 0;
236	}
237
238	return @pids;
239	}
240
a62cf8d4	241	my $fail_code = sub {
	242	my ($artist) = @_;
	243	$artist->create_related('cds', {
	244	title => 'this should not exist',
	245	year => 2005,
	246	});
	247	die "the sky is falling";
	248	};
	249
	250	# Test failed txn_do()
	251	{
57c18b65	252
	253	is( $schema->storage->{transaction_depth}, 0, 'txn depth starts at 0');
	254
	255	my $artist = $schema->resultset('Artist')->find(3);
	256
dd7d4b43	257	throws_ok (sub {
57c18b65	258	$schema->txn_do($fail_code, $artist);
dd7d4b43	259	}, qr/the sky is falling/, 'failed txn_do threw an exception');
57c18b65	260
57c18b65	261	my $cd = $artist->cds({
	262	title => 'this should not exist',
	263	year => 2005,
	264	})->first;
	265	ok(!defined($cd), q{failed txn_do didn't change the cds table});
	266
	267	is( $schema->storage->{transaction_depth}, 0, 'txn depth has been reset');
	268	}
	269
	270	# do the same transaction again
	271	{
	272	is( $schema->storage->{transaction_depth}, 0, 'txn depth starts at 0');
	273
a62cf8d4	274	my $artist = $schema->resultset('Artist')->find(3);
a62cf8d4	275
dd7d4b43	276	throws_ok (sub {
a62cf8d4	277	$schema->txn_do($fail_code, $artist);
dd7d4b43	278	}, qr/the sky is falling/, 'failed txn_do threw an exception');
a62cf8d4	279
a62cf8d4	280	my $cd = $artist->cds({
	281	title => 'this should not exist',
	282	year => 2005,
	283	})->first;
	284	ok(!defined($cd), q{failed txn_do didn't change the cds table});
57c18b65	285
57c18b65	286	is( $schema->storage->{transaction_depth}, 0, 'txn depth has been reset');
a62cf8d4	287	}
	288
	289	# Test failed txn_do() with failed rollback
	290	{
57c18b65	291	is( $schema->storage->{transaction_depth}, 0, 'txn depth starts at 0');
57c18b65	292
a62cf8d4	293	my $artist = $schema->resultset('Artist')->find(3);
	294
	295	# Force txn_rollback() to throw an exception
	296	no warnings 'redefine';
58d387fe	297	no strict 'refs';
57c18b65	298
fb61e30c	299	# die in rollback
57c18b65	300	local *{"DBIx::Class::Storage::DBI::SQLite::txn_rollback"} = sub{
57c18b65	301	my $storage = shift;
57c18b65	302	die 'FAILED';
57c18b65	303	};
a62cf8d4	304
dd7d4b43	305	throws_ok (
	306	sub {
	307	$schema->txn_do($fail_code, $artist);
	308	},
	309	qr/the sky is falling.+Rollback failed/s,
	310	'txn_rollback threw a rollback exception (and included the original exception'
	311	);
a62cf8d4	312
	313	my $cd = $artist->cds({
	314	title => 'this should not exist',
	315	year => 2005,
	316	})->first;
	317	isa_ok($cd, 'DBICTest::CD', q{failed txn_do with a failed txn_rollback }.
	318	q{changed the cds table});
	319	$cd->delete; # Rollback failed
	320	$cd = $artist->cds({
	321	title => 'this should not exist',
	322	year => 2005,
	323	})->first;
	324	ok(!defined($cd), q{deleted the failed txn's cd});
57c18b65	325	$schema->storage->_dbh->rollback;
d9c17594	326
a62cf8d4	327	}
a62cf8d4	328
fb61e30c	329	# reset schema object (the txn_rollback meddling screws it up)
d9c17594	330	undef $schema;
fb61e30c	331
a62cf8d4	332	# Test nested failed txn_do()
a62cf8d4	333	{
d9c17594	334	my $schema = DBICTest->init_schema();
d9c17594	335
57c18b65	336	is( $schema->storage->{transaction_depth}, 0, 'txn depth starts at 0');
57c18b65	337
a62cf8d4	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
dd7d4b43	349	throws_ok ( sub {
a62cf8d4	350	$schema->txn_do($nested_fail_code, $schema, $artist, $code, $fail_code);
dd7d4b43	351	}, qr/the sky is falling/, 'nested failed txn_do threw exception');
a62cf8d4	352
a62cf8d4	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	}
a62cf8d4	363
291bf95f	364	# Grab a new schema to test txn before connect
291bf95f	365	{
d9c17594	366	my $schema = DBICTest->init_schema(no_deploy => 1);
	367	lives_ok (sub {
	368	$schema->txn_begin();
	369	$schema->txn_begin();
	370	}, 'Pre-connection nested transactions.');
	371
	372	# although not connected DBI would still warn about rolling back at disconnect
	373	$schema->txn_rollback;
	374	$schema->txn_rollback;
291bf95f	375	}
3b7f3eac	376
3b7f3eac	377	# Test txn_scope_guard
3b7f3eac	378	{
3b7f3eac	379	my $schema = DBICTest->init_schema();
	380
	381	is($schema->storage->transaction_depth, 0, "Correct transaction depth");
	382	my $artist_rs = $schema->resultset('Artist');
d9c17594	383
38ed54cd	384	my $fn = __FILE__;
3b7f3eac	385	throws_ok {
	386	my $guard = $schema->txn_scope_guard;
	387
3b7f3eac	388	$artist_rs->create({
	389	name => 'Death Cab for Cutie',
	390	made_up_column => 1,
	391	});
d7ded411	392
3b7f3eac	393	$guard->commit;
38ed54cd	394	} qr/No such column made_up_column .? at .?$fn line \d+/s, "Error propogated okay";
3b7f3eac	395
	396	ok(!$artist_rs->find({name => 'Death Cab for Cutie'}), "Artist not created");
	397
dd7d4b43	398	my $inner_exception = ''; # set in inner() below
dd7d4b43	399	throws_ok (sub {
3b7f3eac	400	outer($schema, 1);
dd7d4b43	401	}, qr/$inner_exception/, "Nested exceptions propogated");
3b7f3eac	402
	403	ok(!$artist_rs->find({name => 'Death Cab for Cutie'}), "Artist not created");
	404
aab0d3b7	405	lives_ok (sub {
d9c17594	406
	407	# this weird assignment is to stop perl <= 5.8.9 leaking $schema on nested sub{}s
	408	my $s = $schema;
	409
d7ded411	410	warnings_exist ( sub {
257a1d3b	411	# The 0 arg says don't die, just let the scope guard go out of scope
d7ded411	412	# forcing a txn_rollback to happen
d9c17594	413	outer($s, 0);
771298cf	414	}, qr/A DBIx::Class::Storage::TxnScopeGuard went out of scope without explicit commit or error. Rolling back./, 'Out of scope warning detected');
d9c17594	415
aab0d3b7	416	ok(!$artist_rs->find({name => 'Death Cab for Cutie'}), "Artist not created");
d9c17594	417
aab0d3b7	418	}, 'rollback successful withot exception');
3b7f3eac	419
3b7f3eac	420	sub outer {
d9c17594	421	my ($schema, $fatal) = @_;
aab0d3b7	422
3b7f3eac	423	my $guard = $schema->txn_scope_guard;
	424	$schema->resultset('Artist')->create({
	425	name => 'Death Cab for Cutie',
	426	});
d9c17594	427	inner($schema, $fatal);
3b7f3eac	428	}
	429
	430	sub inner {
	431	my ($schema, $fatal) = @_;
aab0d3b7	432
	433	my $inner_guard = $schema->txn_scope_guard;
	434	is($schema->storage->transaction_depth, 2, "Correct transaction depth");
3b7f3eac	435
d9c17594	436	my $artist = $schema->resultset('Artist')->find({ name => 'Death Cab for Cutie' });
3b7f3eac	437
3b7f3eac	438	eval {
257a1d3b	439	$artist->cds->create({
3b7f3eac	440	title => 'Plans',
257a1d3b	441	year => 2005,
3b7f3eac	442	$fatal ? ( foo => 'bar' ) : ()
	443	});
	444	};
	445	if ($@) {
	446	# Record what got thrown so we can test it propgates out properly.
	447	$inner_exception = $@;
	448	die $@;
	449	}
	450
aab0d3b7	451	# inner guard should commit without consequences
aab0d3b7	452	$inner_guard->commit;
3b7f3eac	453	}
3b7f3eac	454	}
d7ded411	455
	456	# make sure the guard does not eat exceptions
	457	{
7d216b10	458	my $schema = DBICTest->init_schema;
	459
	460	no strict 'refs';
	461	no warnings 'redefine';
	462	local *{DBIx::Class::Storage::DBI::txn_rollback} = sub { die 'die die my darling' };
	463
d7ded411	464	throws_ok (sub {
	465	my $guard = $schema->txn_scope_guard;
	466	$schema->resultset ('Artist')->create ({ name => 'bohhoo'});
	467
7d216b10	468	# this should freak out the guard rollback
	469	# but it won't work because DBD::SQLite is buggy
	470	# instead just install a toxic rollback above
	471	#$schema->storage->_dbh( $schema->storage->_dbh->clone );
d7ded411	472
	473	die 'Deliberate exception';
	474	}, qr/Deliberate exception.+Rollback failed/s);
	475	}
	476
83f26263	477	# make sure it warns big on failed rollbacks
83f26263	478	{
c6e27318	479	my $schema = DBICTest->init_schema();
c6e27318	480
7d216b10	481	no strict 'refs';
	482	no warnings 'redefine';
	483	local *{DBIx::Class::Storage::DBI::txn_rollback} = sub { die 'die die my darling' };
	484
	485	#The warn from within a DESTROY callback freaks out Test::Warn, do it old-school
36099e8c	486	=begin
	487	warnings_exist (
	488	sub {
771298cf	489	my $guard = $schema->txn_scope_guard;
	490	$schema->resultset ('Artist')->create ({ name => 'bohhoo'});
	491
7d216b10	492	# this should freak out the guard rollback
	493	# but it won't work because DBD::SQLite is buggy
	494	# instead just install a toxic rollback above
	495	#$schema->storage->_dbh( $schema->storage->_dbh->clone );
771298cf	496	},
83f26263	497	[
	498	qr/A DBIx::Class::Storage::TxnScopeGuard went out of scope without explicit commit or error. Rolling back./,
	499	qr/\+ ROLLBACK FAILED\!\!\! \+/,
	500	],
	501	'proper warnings generated on out-of-scope+rollback failure'
	502	);
36099e8c	503	=cut
36099e8c	504
7d216b10	505	# delete this once the above works properly (same test)
36099e8c	506	my @want = (
	507	qr/A DBIx::Class::Storage::TxnScopeGuard went out of scope without explicit commit or error. Rolling back./,
	508	qr/\+ ROLLBACK FAILED\!\!\! \+/,
	509	);
	510
	511	my @w;
	512	local $SIG{__WARN__} = sub {
	513	if (grep {$_[0] =~ $_} (@want)) {
	514	push @w, $_[0];
	515	}
	516	else {
	517	warn $_[0];
	518	}
	519	};
	520	{
	521	my $guard = $schema->txn_scope_guard;
	522	$schema->resultset ('Artist')->create ({ name => 'bohhoo'});
36099e8c	523	}
	524
	525	is (@w, 2, 'Both expected warnings found');
c6e27318	526	}
c6e27318	527
257a1d3b	528	# make sure AutoCommit => 0 on external handles behaves correctly with scope_guard
cf31592c	529	warnings_are {
257a1d3b	530	my $factory = DBICTest->init_schema (AutoCommit => 0);
	531	cmp_ok ($factory->resultset('CD')->count, '>', 0, 'Something to delete');
	532	my $dbh = $factory->storage->dbh;
	533
	534	ok (!$dbh->{AutoCommit}, 'AutoCommit is off on $dbh');
	535	my $schema = DBICTest::Schema->connect (sub { $dbh });
	536
257a1d3b	537	lives_ok ( sub {
	538	my $guard = $schema->txn_scope_guard;
	539	$schema->resultset('CD')->delete;
	540	$guard->commit;
	541	}, 'No attempt to start a transaction with scope guard');
	542
cf31592c	543	is ($schema->resultset('CD')->count, 0, 'Deletion successful in txn');
	544
	545	# this will commit the implicitly started txn
	546	$dbh->commit;
	547
	548	} [], 'No warnings on AutoCommit => 0 with txn_guard';
257a1d3b	549
257a1d3b	550	# make sure AutoCommit => 0 on external handles behaves correctly with txn_do
cf31592c	551	warnings_are {
257a1d3b	552	my $factory = DBICTest->init_schema (AutoCommit => 0);
	553	cmp_ok ($factory->resultset('CD')->count, '>', 0, 'Something to delete');
	554	my $dbh = $factory->storage->dbh;
	555
	556	ok (!$dbh->{AutoCommit}, 'AutoCommit is off on $dbh');
	557	my $schema = DBICTest::Schema->connect (sub { $dbh });
	558
	559
	560	lives_ok ( sub {
	561	$schema->txn_do (sub { $schema->resultset ('CD')->delete });
	562	}, 'No attempt to start a atransaction with txn_do');
	563
	564	is ($schema->resultset('CD')->count, 0, 'Deletion successful');
cf31592c	565
	566	# this will commit the implicitly started txn
	567	$dbh->commit;
	568
	569	} [], 'No warnings on AutoCommit => 0 with txn_do';
257a1d3b	570
d7ded411	571	done_testing;