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

# Test is sufficiently involved to *want* to run with "maximum paranoia"
BEGIN { $ENV{DBICTEST_OLD_MRO_SANITY_CHECK_ASSERTIONS} = 1 }

BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) }

use strict;
use warnings;

use Test::More;
use Test::Warn;
use Test::Exception;
use Errno ();

use DBICTest;

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
{
  my $schema = DBICTest->init_schema;

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

  throws_ok {
    $schema->txn_do('');
  } qr/\Qrun() requires a coderef to execute as its first argument/,
  '$coderef parameter check ok';
}

# Test successful txn_do() - scalar/list context
for my $want (0,1) {
  my $schema = DBICTest->init_schema;

  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 @res;
  if ($want) {
    @res = $schema->txn_do($code, $artist, @titles);
    is(scalar @res, $count_before+5, 'successful txn added 5 cds');
  }
  else {
    $res[0] = $schema->txn_do($code, $artist, @titles);
    is($res[0], $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 txn_do() @_ aliasing support
{
  my $schema = DBICTest->init_schema;

  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()
{
  my $schema = DBICTest->init_schema;

  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;
  SKIP:
  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
    },
  ) {
    my $pid = fork();

    if( ! defined $pid ) {
      skip "EAGAIN encountered, your system is likely bogged down: skipping forking test", 1
        if $! == Errno::EAGAIN();

      die "Unable to fork: $!"
    }

    if ($pid) {
      push @pids, $pid;
      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 } );
      };
      is( $schema->storage->transaction_depth, 0, 'Transaction successfully aborted' );
      $schema->txn_do( sub {
        ok ($schema->storage->_dbh->do ('SELECT 1'), "Query after exceptions ok ($_)");
      });
    }

    $schema->txn_do ( sub { _test_forking_action ($schema, $pass) } );
  }
}

# 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 } );
      };
      is( $schema->storage->transaction_depth, 0, 'Transaction successfully aborted' );
      $schema->txn_do( sub {
        ok ($schema->storage->_dbh->do ('SELECT 1'), "Query after exceptions ok ($_)");
      });
    }

    my $guard = $schema->txn_scope_guard;
    my @pids = _test_forking_action ($schema, $pass);
    $guard->commit;
  }
}

sub _test_forking_action {
  my ($schema, $pass) = @_;

  my @pids;

  SKIP: for my $count (1 .. 5) {

    skip 'FIXME: Weird DBI General Protection Faults, skip forking tests (RT#63104)', 5
      if $^O eq 'MSWin32';

    my $pid = fork();
    if( ! defined $pid ) {
      skip "EAGAIN encountered, your system is likely bogged down: skipping forking test", 1
        if $! == Errno::EAGAIN();

      die "Unable to fork: $!"
    }

    if ($pid) {
      push @pids, $pid;
      next;
    }

    if ($count % 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;
  }

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

  # it is important to reap all children before checking the final db-state
  # otherwise a deadlock may occur between the transactions running in the
  # children and the query of the parent
  for my $pid (@pids) {
    isa_ok ($schema->resultset ('Artist')->find ({ name => "forking action $pid" }), 'DBIx::Class::Row');
  }
}

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

{
  my $schema = DBICTest->init_schema;

  # Test failed txn_do()
  for my $pass (1,2) {

    is( $schema->storage->transaction_depth, 0, "txn depth starts at 0 (pass $pass)");

    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 (pass $pass)");

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

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


  # 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 qw/once redefine/;

    # this should logically work just fine - but it does not,
    # only direct override of the existing method dtrt
    #local *DBIx::Class::Storage::DBI::SQLite::txn_rollback = sub { die 'FAILED' };

    local *DBIx::Class::Storage::DBI::txn_rollback = sub { die 'FAILED' };
    Class::C3->reinitialize() if DBIx::Class::_ENV_::OLD_MRO;

    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;
  }
}

# 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
# also test nested txn exception
{
  my $schema = DBICTest->init_schema(no_deploy => 1);
  lives_ok (sub {
    $schema->txn_begin();
    $schema->txn_begin();
  }, 'Pre-connection nested transactions.');

  throws_ok( sub { $schema->txn_rollback }, 'DBIx::Class::Storage::NESTED_ROLLBACK_EXCEPTION', 'got proper nested rollback exception' );
}

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

  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;
  cmp_ok ($factory->resultset('CD')->count, '>', 0, 'Something to delete');
  my $dbh = $factory->storage->dbh;
  $dbh->{AutoCommit} = 0;

  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';


# make sure we are not fucking up the stacktrace on broken overloads
{
  package DBICTest::BrokenOverload;

  use overload '""' => sub { $_[0] };
}

{
  my @w;
  local $SIG{__WARN__} = sub {
    $_[0] =~ /\QExternal exception class DBICTest::BrokenOverload implements partial (broken) overloading preventing its instances from being used in simple (\E\$x eq \$y\Q) comparisons/
      ? push @w, @_
      : warn @_
  };

  my $s = DBICTest->init_schema(no_deploy => 1);
  $s->stacktrace(0);
  my $g = $s->storage->txn_scope_guard;
  my $broken_exception = bless {}, 'DBICTest::BrokenOverload';

  # FIXME - investigate what confuses the regex engine below

  # do not reformat - line-num part of the test
  my $ln = __LINE__ + 6;
  throws_ok {
    $s->txn_do( sub {
      $s->txn_do( sub {
        $s->storage->_dbh->disconnect;
        die $broken_exception
      });
    })
  } 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

  is @w, 1, 'One matching warning only';

  # try the same broken exception object, but have exception_action inject it
  $s->exception_action(sub { die $broken_exception });
  eval {
    $s->txn_do( sub {
      die "some string masked away";
    });
  };
  isa_ok $@, 'DBICTest::BrokenOverload', 'Deficient exception properly propagated';

  is @w, 2, 'The warning was emitted a second time';
}

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