use lib qw(t/lib);
use DBICTest;
-my $schema = DBICTest->init_schema();
-
-plan tests => 10;
-
# Test various uses of passing an object to find, create, and update on a single
# rel accessor
{
+ my $schema = DBICTest->init_schema();
my $artist = $schema->resultset("Artist")->find(1);
my $cd = $schema->resultset("CD")->find_or_create({
is($track->get_column('cd'), $another_cd->cdid, 'track matches another CD after update');
}
-$schema = DBICTest->init_schema();
{
+ my $schema = DBICTest->init_schema();
my $artist = $schema->resultset('Artist')->create({ artistid => 666, name => 'bad religion' });
my $cd = $schema->resultset('CD')->create({ cdid => 187, artist => 1, title => 'how could hell be any worse?', year => 1982, genreid => undef });
ok(!defined($cd->genre), 'genre accessor returns undef');
}
-$schema = DBICTest->init_schema();
-
{
+ my $schema = DBICTest->init_schema();
my $artist = $schema->resultset('Artist')->create({ artistid => 666, name => 'bad religion' });
my $genre = $schema->resultset('Genre')->create({ genreid => 88, name => 'disco' });
my $cd = $schema->resultset('CD')->create({ cdid => 187, artist => 1, title => 'how could hell be any worse?', year => 1982 });
dies_ok { $cd->genre } 'genre accessor throws without column';
}
+done_testing;
# set a *DBI* disconnect callback, to make sure the physical SQLite
# file is still there (i.e. the test does not attempt to delete
# an open database, which fails on Win32)
- if (-e $db_file and my $orig_inode = (stat($db_file))[1] ) {
-
- my $failed_once;
- my $connected = 1;
- my $cb = sub {
- return if $failed_once;
-
- my $event = shift;
- if ($event eq 'connect') {
- # this is necessary in case we are disconnected and connected again, all within the same $dbh object
- $connected = 1;
- return;
- }
- elsif ($event eq 'disconnect') {
- $connected = 0;
- }
- elsif ($event eq 'DESTROY' and ! $connected ) {
- return;
- }
-
- my $fail_reason;
- if (! -e $db_file) {
- $fail_reason = 'is missing';
- }
- else {
- my $cur_inode = (stat($db_file))[1];
-
- $fail_reason ||= sprintf 'was recreated (inode %s vs %s)', ($orig_inode, $cur_inode)
- if $orig_inode != $cur_inode;
- }
-
- if ($fail_reason) {
- $failed_once++;
-
- require Test::Builder;
- my $t = Test::Builder->new;
- local $Test::Builder::Level = $Test::Builder::Level + 1;
-
- $t->ok (0,
- "$db_file $fail_reason before $event of DBI handle - a strong indicator that "
- . 'the SQLite file was tampered with while still being open. This action would '
- . 'fail massively if running under Win32, hence DBICTest makes sure it fails '
- . 'on any OS :)'
- );
- }
-
- return; # this empty return is a DBI requirement
- };
+ if (my $guard_cb = __mk_disconnect_guard($db_file)) {
$dbh->{Callbacks} = {
- connect => sub { $cb->('connect') },
- disconnect => sub { $cb->('disconnect') },
- DESTROY => sub { $cb->('DESTROY') },
+ connect => sub { $guard_cb->('connect') },
+ disconnect => sub { $guard_cb->('disconnect') },
+ DESTROY => sub { $guard_cb->('DESTROY') },
};
}
},
});
}
+sub __mk_disconnect_guard {
+ my $db_file = shift;
+ return unless -f $db_file;
+
+ my $orig_inode = (stat($db_file))[1]
+ or return;
+
+ my $clan_connect_caller = '*UNKNOWN*';
+ my $i;
+ while ( my ($pack, $file, $line) = caller(++$i) ) {
+ next if $file eq __FILE__;
+ next if $pack =~ /^DBIx::Class|^Try::Tiny/;
+ $clan_connect_caller = "$file line $line";
+ }
+
+ my $failed_once = 0;
+ my $connected = 1;
+
+ return sub {
+ return if $failed_once;
+
+ my $event = shift;
+ if ($event eq 'connect') {
+ # this is necessary in case we are disconnected and connected again, all within the same $dbh object
+ $connected = 1;
+ return;
+ }
+ elsif ($event eq 'disconnect') {
+ $connected = 0;
+ }
+ elsif ($event eq 'DESTROY' and ! $connected ) {
+ return;
+ }
+
+ my $fail_reason;
+ if (! -e $db_file) {
+ $fail_reason = 'is missing';
+ }
+ else {
+ my $cur_inode = (stat($db_file))[1];
+
+ if ($orig_inode != $cur_inode) {
+ # pack/unpack to match the unsigned longs returned by `stat`
+ $fail_reason = sprintf 'was recreated (initially inode %s, now %s)', (
+ map { unpack ('L', pack ('l', $_) ) } ($orig_inode, $cur_inode )
+ );
+ }
+ }
+
+ if ($fail_reason) {
+ $failed_once++;
+
+ require Test::Builder;
+ my $t = Test::Builder->new;
+ local $Test::Builder::Level = $Test::Builder::Level + 3;
+ $t->ok (0,
+ "$db_file originally created at $clan_connect_caller $fail_reason before $event "
+ . 'of DBI handle - a strong indicator that the database file was tampered with while '
+ . 'still being open. This action would fail massively if running under Win32, hence '
+ . 'we make sure it fails on any OS :)'
+ );
+ }
+
+ return; # this empty return is a DBI requirement
+ };
+}
+
sub init_schema {
my $self = shift;
my %args = @_;
admin => 1
};
-ok( my $schema = My::Schema->connection('dbi:SQLite:dbname=:memory:') );
+ok( my $schema = My::Schema->connection(DBICTest->_database) );
ok(
$schema->storage->dbh->do(
use Test::More;
use lib qw(t/lib);
+use DBICTest;
use DBICTest::Schema;
use DBIC::SqlMakerTest;
);
}
}
-
-my $s = DBICTest::Schema->connect ('dbi:SQLite::memory:');
+my $s = DBICTest::Schema->connect (DBICTest->_database);
$s->storage->sql_maker_class ('DBICTest::SQLMaker::CustomDialect');
my $rs = $s->resultset ('CD');
})->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)
-$schema = DBICTest->init_schema();
+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 {
# Grab a new schema to test txn before connect
{
- my $schema2 = DBICTest->init_schema(no_deploy => 1);
- lives_ok (sub {
- $schema2->txn_begin();
- $schema2->txn_begin();
- }, 'Pre-connection nested transactions.');
-
- # although not connected DBI would still warn about rolling back at disconnect
- $schema2->txn_rollback;
- $schema2->txn_rollback;
- $schema2->storage->disconnect;
+ 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;
}
-$schema->storage->disconnect;
# Test txn_scope_guard
{
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,
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($schema, 0);
+ 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) = @_;
+ my ($schema, $fatal) = @_;
my $guard = $schema->txn_scope_guard;
$schema->resultset('Artist')->create({
name => 'Death Cab for Cutie',
});
- inner(@_);
+ inner($schema, $fatal);
}
sub inner {
my $inner_guard = $schema->txn_scope_guard;
is($schema->storage->transaction_depth, 2, "Correct transaction depth");
- my $artist = $artist_rs->find({ name => 'Death Cab for Cutie' });
+ my $artist = $schema->resultset('Artist')->find({ name => 'Death Cab for Cutie' });
eval {
$artist->cds->create({
projects / dbsrgits/DBIx-Class.git / commitdiff