when the position column is part of a unique constraint
* Misc
+ - Centralized leak-checks for all instances of DBICTest::Schema
+ from within any test
- Codebase is now trailing-whitespace-free
- Cleanup of complex resultset update/delete oprations - storage
specific code moved back to ResultSet and replaced by checks
# which might need updating at some future time to be some other
# exception-generating statement:
-sub throwex { $schema->resultset("Artist")->search(1,1,1); }
+my $throw = sub { $schema->resultset("Artist")->search(1,1,1) };
my $ex_regex = qr/Odd number of arguments to search/;
# Basic check, normal exception
-throws_ok { throwex }
- $ex_regex;
+throws_ok \&$throw, $ex_regex;
my $e = $@;
# Now lets rethrow via exception_action
$schema->exception_action(sub { die @_ });
-throws_ok { throwex }
- $ex_regex;
+throws_ok \&$throw, $ex_regex;
#
# This should have never worked!!!
#
# Now lets suppress the error
$schema->exception_action(sub { 1 });
-throws_ok { throwex }
+throws_ok \&$throw,
qr/exception_action handler .+ did \*not\* result in an exception.+original error: $ex_regex/;
# Now lets fall through and let croak take back over
$schema->exception_action(sub { return });
throws_ok {
- warnings_are { throwex }
+ warnings_are \&$throw,
qr/exception_action handler installed .+ returned false instead throwing an exception/;
} $ex_regex;
# again to see if no warning
throws_ok {
- warnings_are { throwex }
+ warnings_are \&$throw,
[];
} $ex_regex;
# Try the exception class
$schema->exception_action(sub { DBICTest::Exception->throw(@_) });
-throws_ok { throwex }
+throws_ok \&$throw,
qr/DBICTest::Exception is handling this: $ex_regex/;
# While we're at it, lets throw a custom exception through Storage::DBI
cmp_ok(DBICTest->resultset('Artist')->count, '>', 0, 'count is valid');
+# cleanup globals so we do not trigger the leaktest
+for ( map { DBICTest->schema->class($_) } DBICTest->schema->sources ) {
+ $_->class_resolver(undef);
+ $_->resultset_instance(undef);
+ $_->result_source_instance(undef);
+}
+{
+ no warnings qw/redefine once/;
+ *DBICTest::schema = sub {};
+}
+
done_testing;
use lib qw(t/lib);
use DBICTest::RunMode;
+use DBICTest::Util qw/populate_weakregistry assert_empty_weakregistry/;
use DBIx::Class;
use B 'svref_2object';
BEGIN {
if DBIx::Class::_ENV_::PEEPEENESS;
}
-use Scalar::Util qw/refaddr reftype weaken/;
-
# this is what holds all weakened refs to be checked for leakage
my $weak_registry = {};
# Skip the heavy-duty leak tracing when just doing an install
unless (DBICTest::RunMode->is_plain) {
- # have our own little stack maker - Carp infloops due to the bless override
- my $trace = sub {
- my $depth = 1;
- my (@stack, @frame);
-
- while (@frame = caller($depth++)) {
- push @stack, [@frame[3,1,2]];
- }
-
- $stack[0][0] = '';
- return join "\tinvoked as ", map { sprintf ("%s at %s line %d\n", @$_ ) } @stack;
- };
-
# redefine the bless override so that we can catch each and every object created
no warnings qw/redefine once/;
no strict qw/refs/;
}
);
- my $slot = (sprintf '%s=%s(0x%x)', # so we don't trigger stringification
- ref $obj,
- reftype $obj,
- refaddr $obj,
- );
-
# weaken immediately to avoid weird side effects
- $weak_registry->{$slot} = { weakref => $obj, strace => $trace->() };
- weaken $weak_registry->{$slot}{weakref};
-
- return $obj;
+ return populate_weakregistry ($weak_registry, $obj );
};
require Try::Tiny;
for my $func (qw/try catch finally/) {
my $orig = \&{"Try::Tiny::$func"};
*{"Try::Tiny::$func"} = sub (&;@) {
-
- my $slot = sprintf ('CODE(0x%x)', refaddr $_[0]);
-
- $weak_registry->{$slot} = { weakref => $_[0], strace => $trace->() };
- weaken $weak_registry->{$slot}{weakref};
-
+ populate_weakregistry( $weak_registry, $_[0] );
goto $orig;
}
}
}
}
- for (keys %$base_collection) {
- $weak_registry->{"basic $_"} = { weakref => $base_collection->{$_} };
- weaken $weak_registry->{"basic $_"}{weakref};
- }
+ populate_weakregistry ($weak_registry, $base_collection->{$_}, "basic $_")
+ for keys %$base_collection;
}
# check that "phantom-chaining" works - we never lose track of the original $schema
sub { shift->delete },
sub { shift->insert },
) {
- $phantom = $_->($phantom);
-
- my $slot = (sprintf 'phantom %s=%s(0x%x)', # so we don't trigger stringification
- ref $phantom,
- reftype $phantom,
- refaddr $phantom,
- );
-
- $weak_registry->{$slot} = $phantom;
- weaken $weak_registry->{$slot};
+ $phantom = populate_weakregistry ( $weak_registry, scalar $_->($phantom) );
}
ok( $phantom->in_storage, 'Properly deleted/reinserted' );
or $r->result_source(undef);
}
-for my $slot (sort keys %$weak_registry) {
-
- ok (! defined $weak_registry->{$slot}{weakref}, "No leaks of $slot") or do {
- my $diag = '';
-
- $diag .= Devel::FindRef::track ($weak_registry->{$slot}{weakref}, 20) . "\n"
- if ( $ENV{TEST_VERBOSE} && eval { require Devel::FindRef });
-
- if (my $stack = $weak_registry->{$slot}{strace}) {
- $diag .= " Reference first seen$stack";
- }
-
- diag $diag if $diag;
- };
-}
+assert_empty_weakregistry ($weak_registry);
# we got so far without a failure - this is a good thing
# now let's try to rerun this script under a "persistent" environment
END {
return unless $schema;
drop_test_schema($schema);
- eapk_drop_all( $schema)
+ eapk_drop_all($schema);
+ undef $schema;
};
# clean up our mess
END {
- eval {
- my $dbh = $schema->storage->dbh;
- $dbh->do("DROP SEQUENCE artist_pk_seq");
- $dbh->do("DROP SEQUENCE cd_seq");
- $dbh->do("DROP SEQUENCE track_seq");
- $dbh->do("DROP TABLE artist");
- $dbh->do("DROP TABLE track");
- $dbh->do("DROP TABLE cd");
+ if ($schema and my $dbh = $schema->storage->dbh) {
+ eval { $dbh->do($_) } for (
+ 'DROP SEQUENCE artist_pk_seq',
+ 'DROP SEQUENCE cd_seq',
+ 'DROP SEQUENCE track_seq',
+ 'DROP TABLE artist',
+ 'DROP TABLE track',
+ 'DROP TABLE cd',
+ );
};
+ undef $schema;
}
# clean up our mess
END {
- my $dbh = eval { $schema->storage->_dbh };
- $dbh->do("DROP TABLE artist") if $dbh;
+ my $dbh = eval { $schema->storage->_dbh };
+ $dbh->do("DROP TABLE artist") if $dbh;
+ undef $schema;
}
# clean up our mess
END {
- my $dbh = eval { $schema->storage->_dbh };
- $dbh->do("DROP TABLE artist") if $dbh;
+ my $dbh = eval { $schema->storage->_dbh };
+ $dbh->do("DROP TABLE artist") if $dbh;
+ undef $schema;
}
eval { $dbh->do("DROP TABLE $_") }
for qw/artist artist_guid money_test books owners/;
}
+ undef $schema;
}
# vim:sw=2 sts=2
eval { $dbh->do("DROP TABLE $_") }
for qw/artist bindtype_test money_test computed_column_test/;
}
+
+ undef $schema;
}
eval { $dbh->do("DROP TABLE $_") }
for qw/artist/;
}
+
+ undef $schema;
}
# vim:sw=2 sts=2
# clean up our mess
END {
- my $dbh = eval { $schema->storage->_dbh };
- $dbh->do("DROP TABLE artist") if $dbh;
+ my $dbh = eval { $schema->storage->_dbh };
+ $dbh->do("DROP TABLE artist") if $dbh;
+ undef $schema;
}
auto_savepoint => 1
});
- my $guard = Scope::Guard->new(\&cleanup);
+ my $guard = Scope::Guard->new(sub{ cleanup($schema) });
my $dbh = $schema->storage->dbh;
done_testing;
sub cleanup {
+ my $schema = shift;
eval { $schema->storage->dbh->do("DROP TABLE $_") }
for qw/artist artist_guid bindtype_test/;
}
use Test::More;
use Test::Exception;
+use Scalar::Util 'weaken';
use DBIx::Class::Optional::Dependencies ();
use lib qw(t/lib);
use DBICTest;
SQL
});
- my $rs = $schema->resultset('Money');
+ my $rs = $schema->resultset('Money');
+ weaken(my $rs_cp = $rs); # nested closure refcounting is an utter mess in perl
my $row;
lives_ok {
# test simple transaction with commit
lives_ok {
$schema->txn_do(sub {
- $rs->create({ amount => 300 });
+ $rs_cp->create({ amount => 300 });
});
} 'simple transaction';
# test rollback
throws_ok {
$schema->txn_do(sub {
- $rs->create({ amount => 700 });
+ $rs_cp->create({ amount => 700 });
die 'mtfnpy';
});
} qr/mtfnpy/, 'simple failed txn';
# a reconnect should trigger on next action
$schema->storage->_get_dbh->disconnect;
+
lives_and {
$wrappers->{$wrapper}->( sub {
- $rs->create({ amount => 900 + $_ }) for 1..3;
+ $rs_cp->create({ amount => 900 + $_ }) for 1..3;
});
is $rs->count, 3;
} "transaction on disconnected handle with $wrapper wrapper";
my $map = [ ['Artist 1', '1002.00'], ['Artist 2', '1003.00'] ];
+ weaken(my $a_rs_cp = $artist_rs);
+
lives_and {
my @results;
-
$wrappers->{$wrapper}->( sub {
- while (my $money = $rs->next) {
- my $artist = $artist_rs->next;
+ while (my $money = $rs_cp->next) {
+ my $artist = $a_rs_cp->next;
push @results, [ $artist->name, $money->amount ];
};
});
$dbh->do("IF OBJECT_ID('cd', 'U') IS NOT NULL DROP TABLE cd");
$dbh->do("IF OBJECT_ID('money_test', 'U') IS NOT NULL DROP TABLE money_test");
}
+
+ undef $schema;
}
});
my $dbh = $schema->storage->dbh;
- my $sg = Scope::Guard->new(\&cleanup);
+ my $sg = Scope::Guard->new(sub { cleanup($schema) });
eval { $dbh->do(q[DROP TABLE "artist"]) };
$dbh->do(<<EOF);
# clean up our mess
sub cleanup {
+ my $schema = shift;
+
my $dbh;
eval {
$schema->storage->disconnect; # to avoid object FOO is in use errors
[ 4, 8 ],
]);
- sub cd_count {
- return $schema->resultset("CD")->count;
- }
- sub tk_count {
- return $schema->resultset("TwoKeys")->count;
- }
-
- is(cd_count(), 8, '8 rows in table cd');
- is(tk_count(), 7, '7 rows in table twokeys');
-
- sub artist1 {
- return $schema->resultset("CD")->search(
- { 'artist.name' => 'Caterwauler McCrae' },
- { join => [qw/artist/]}
- );
- }
- sub artist2 {
- return $schema->resultset("CD")->search(
- { 'artist.name' => 'Random Boy Band' },
- { join => [qw/artist/]}
- );
- }
-
- is( artist1()->count, 3, '3 Caterwauler McCrae CDs' );
- ok( artist1()->delete, 'Successfully deleted 3 CDs' );
- is( artist1()->count, 0, '0 Caterwauler McCrae CDs' );
- is( artist2()->count, 2, '3 Random Boy Band CDs' );
- ok( artist2()->update( { 'artist' => 1 } ) );
- is( artist2()->count, 0, '0 Random Boy Band CDs' );
- is( artist1()->count, 2, '2 Caterwauler McCrae CDs' );
+ my $cd_count = sub { $schema->resultset("CD")->count };
+ my $tk_count = sub { $schema->resultset("TwoKeys")->count };
+
+ is($cd_count->(), 8, '8 rows in table cd');
+ is($tk_count->(), 7, '7 rows in table twokeys');
+
+ my $artist1_rs = $schema->resultset("CD")->search(
+ { 'artist.name' => 'Caterwauler McCrae' },
+ { join => [qw/artist/]}
+ );
+
+ my $artist2_rs = $schema->resultset("CD")->search(
+ { 'artist.name' => 'Random Boy Band' },
+ { join => [qw/artist/]}
+ );
+
+ is( $artist1_rs->count, 3, '3 Caterwauler McCrae CDs' );
+ ok( $artist1_rs->delete, 'Successfully deleted 3 CDs' );
+ is( $artist1_rs->count, 0, '0 Caterwauler McCrae CDs' );
+ is( $artist2_rs->count, 2, '3 Random Boy Band CDs' );
+ ok( $artist2_rs->update( { 'artist' => 1 } ) );
+ is( $artist2_rs->count, 0, '0 Random Boy Band CDs' );
+ is( $artist1_rs->count, 2, '2 Caterwauler McCrae CDs' );
# test update on multi-column-pk
- sub tk1 {
- return $schema->resultset("TwoKeys")->search(
- {
- 'artist.name' => { like => '%Boy Band' },
- 'cd.title' => 'Greatest Hits',
- },
- { join => [qw/artist cd/] }
- );
- }
- sub tk2 {
- return $schema->resultset("TwoKeys")->search(
- { 'artist.name' => 'Caterwauler McCrae' },
- { join => [qw/artist/]}
- );
- }
- is( tk2()->count, 2, 'TwoKeys count == 2' );
- is( tk1()->count, 2, 'TwoKeys count == 2' );
- ok( tk1()->update( { artist => 1 } ) );
- is( tk1()->count, 0, 'TwoKeys count == 0' );
- is( tk2()->count, 4, '2 Caterwauler McCrae CDs' );
- ok( tk2()->delete, 'Successfully deleted 4 CDs' );
- is(cd_count(), 5, '5 rows in table cd');
- is(tk_count(), 3, '3 rows in table twokeys');
+ my $tk1_rs = $schema->resultset("TwoKeys")->search(
+ {
+ 'artist.name' => { like => '%Boy Band' },
+ 'cd.title' => 'Greatest Hits',
+ },
+ { join => [qw/artist cd/] }
+ );
+
+ my $tk2_rs = $schema->resultset("TwoKeys")->search(
+ { 'artist.name' => 'Caterwauler McCrae' },
+ { join => [qw/artist/]}
+ );
+
+ is( $tk2_rs->count, 2, 'TwoKeys count == 2' );
+ is( $tk1_rs->count, 2, 'TwoKeys count == 2' );
+ ok( $tk1_rs->update( { artist => 1 } ) );
+ is( $tk1_rs->count, 0, 'TwoKeys count == 0' );
+ is( $tk2_rs->count, 4, '2 Caterwauler McCrae CDs' );
+ ok( $tk2_rs->delete, 'Successfully deleted 4 CDs' );
+ is($cd_count->(), 5, '5 rows in table cd');
+ is($tk_count->(), 3, '3 rows in table twokeys');
}
done_testing;
{
my $deploy_hook_called = 0;
$custom_deployment_statements_called = 0;
+ my $sqlt_type = $schema->storage->sqlt_type;
# replace the sqlt calback with a custom version ading an index
$schema->source('Track')->sqlt_deploy_callback(sub {
is (
$sqlt_table->schema->translator->producer_type,
- join ('::', 'SQL::Translator::Producer', $schema->storage->sqlt_type),
+ join ('::', 'SQL::Translator::Producer', $sqlt_type),
'Production type passed to translator object',
);
- if ($schema->storage->sqlt_type eq 'SQLite' ) {
+ if ($sqlt_type eq 'SQLite' ) {
$sqlt_table->add_index( name => 'track_title', fields => ['title'] )
or die $sqlt_table->error;
}
# And now to see if txn_do will behave correctly
$schema->txn_do (sub {
+ my $artycp = $arty;
+
$schema->txn_do (sub {
- $arty->name ('Muff');
- $arty->update;
+ $artycp->name ('Muff');
+ $artycp->update;
});
eval {
$schema->txn_do (sub {
- $arty->name ('Moff');
- $arty->update;
- $arty->discard_changes;
- is($arty->name,'Moff','Value updated in nested transaction');
+ $artycp->name ('Moff');
+ $artycp->update;
+ $artycp->discard_changes;
+ is($artycp->name,'Moff','Value updated in nested transaction');
$schema->storage->dbh->do ("GUARANTEED TO PHAIL");
});
};
done_testing;
-END { eval { $schema->storage->dbh->do ("DROP TABLE artist") } if defined $schema }
-
+END {
+ eval { $schema->storage->dbh->do ("DROP TABLE artist") } if defined $schema;
+ undef $schema;
+}
{ rows => 5 }
);
is( $it->count, 1, "complex abstract count ok" );
+
+# cleanup globals so we do not trigger the leaktest
+for ( map { DBICTest->schema->class($_) } DBICTest->schema->sources ) {
+ $_->class_resolver(undef);
+ $_->resultset_instance(undef);
+ $_->result_source_instance(undef);
+}
+{
+ no warnings qw/redefine once/;
+ *DBICTest::schema = sub {};
+}
$schema->_unregister_source('CD');
warnings_like {
+ my $s = $schema;
lives_ok {
- $_->delete for $schema->resultset('Artist')->all;
+ $_->delete for $s->resultset('Artist')->all;
} 'delete on rows with dangling rels lives';
} [
# 12 == 3 artists * failed cascades:
my $cd = $schema->resultset("CD")->find(2);
ok $cd->liner_notes;
-ok keys %{$cd->{_relationship_data}}, "_relationship_data populated";
+
+ok scalar(keys %{$cd->{_relationship_data}}), "_relationship_data populated";
$cd->discard_changes;
ok $cd->liner_notes, 'relationships still valid after discarding changes';
-use Test::More;
use strict;
use warnings;
+use Test::More;
+
use lib qw(t/lib);
use DBICTest;
-plan tests => 4;
-
my $schema = DBICTest->init_schema();
my $ars = $schema->resultset('Artist');
my $cd2pr_count = $cd2pr_rs->count;
$prod_cd->delete_related('cd_to_producer', { producer => $prod } );
is ($cd2pr_rs->count, $cd2pr_count -= 1, 'm2m link deleted succesfully');
+
+ # see 187ec69a for why this is neccessary
+ $prod->result_source(undef);
}
+
+done_testing;
on_connect_call => [ 'datetime_setup' ],
});
- my $sg = Scope::Guard->new(\&cleanup);
+ my $sg = Scope::Guard->new(sub { cleanup($schema) } );
eval { $schema->storage->dbh->do('DROP TABLE "event"') };
$schema->storage->dbh->do(<<'SQL');
# clean up our mess
sub cleanup {
+ my $schema = shift;
my $dbh;
eval {
$schema->storage->disconnect; # to avoid object FOO is in use errors
on_connect_call => [ 'datetime_setup' ],
});
- my $sg = Scope::Guard->new(\&cleanup);
+ my $sg = Scope::Guard->new(sub { cleanup($schema) } );
eval { $schema->storage->dbh->do('DROP TABLE event') };
$schema->storage->dbh->do(<<'SQL');
# clean up our mess
sub cleanup {
+ my $schema = shift;
my $dbh;
eval {
$dbh = $schema->storage->dbh;
}
}
- my $guard = Scope::Guard->new(\&cleanup);
+ my $guard = Scope::Guard->new(sub{ cleanup($schema) });
# $^W because DBD::ADO is a piece of crap
try { local $^W = 0; $schema->storage->dbh->do("DROP TABLE track") };
# clean up our mess
sub cleanup {
+ my $schema = shift;
if (my $dbh = eval { $schema->storage->dbh }) {
$dbh->do('DROP TABLE track');
$dbh->do('DROP TABLE event_small_dt');
# clean up our mess
END {
- if($schema && ($dbh = $schema->storage->dbh)) {
- $dbh->do("DROP TABLE track");
- }
+ if($schema && ($dbh = $schema->storage->dbh)) {
+ $dbh->do("DROP TABLE track");
+ }
+ undef $schema;
}
on_connect_call => 'datetime_setup',
});
- my $sg = Scope::Guard->new(\&cleanup);
+ my $sg = Scope::Guard->new(sub { cleanup($schema) } );
eval { $schema->storage->dbh->do('DROP TABLE event') };
$schema->storage->dbh->do(<<"SQL");
# clean up our mess
sub cleanup {
+ my $schema = shift;
if (my $dbh = $schema->storage->dbh) {
eval { $dbh->do("DROP TABLE $_") } for qw/event/;
}
on_connect_call => 'datetime_setup',
});
- my $guard = Scope::Guard->new(\&cleanup);
+ my $guard = Scope::Guard->new(sub { cleanup($schema) } );
$schema->storage->ensure_connected;
# clean up our mess
sub cleanup {
+ my $schema = shift;
if (my $dbh = eval { $schema->storage->dbh }) {
$dbh->do('DROP TABLE track');
$dbh->do('DROP TABLE event_small_dt');
use warnings;
use DBICTest::RunMode;
use DBICTest::Schema;
+use DBICTest::Util qw/populate_weakregistry assert_empty_weakregistry/;
use Carp;
use Path::Class::File ();
};
}
+my $weak_registry = {};
+
sub init_schema {
my $self = shift;
my %args = @_;
__PACKAGE__->populate_schema( $schema )
if( !$args{no_populate} );
}
+
+ populate_weakregistry ( $weak_registry, $schema->storage )
+ if $INC{'Test/Builder.pm'} and $schema->storage;
+
return $schema;
}
+END {
+ assert_empty_weakregistry($weak_registry, 'quiet');
+}
+
=head2 deploy_schema
DBICTest->deploy_schema( $schema );
package # hide from PAUSE
DBICTest::Schema;
-use base qw/DBIx::Class::Schema/;
+use strict;
+use warnings;
+no warnings 'qw';
-no warnings qw/qw/;
+use base 'DBIx::Class::Schema';
+
+use DBICTest::Util qw/populate_weakregistry assert_empty_weakregistry/;
+use namespace::clean;
__PACKAGE__->mk_group_accessors(simple => 'custom_attr');
$sqlt_schema->drop_table('dummy');
}
+my $weak_registry = {};
+
+sub clone {
+ my $self = shift->next::method(@_);
+ populate_weakregistry ( $weak_registry, $self )
+ if $INC{'Test/Builder.pm'};
+ $self;
+}
+
+END {
+ assert_empty_weakregistry($weak_registry, 'quiet');
+}
+
1;
--- /dev/null
+package DBICTest::Util;
+
+use warnings;
+use strict;
+
+use Carp;
+use Scalar::Util qw/isweak weaken blessed reftype refaddr/;
+
+use base 'Exporter';
+our @EXPORT_OK = qw/stacktrace populate_weakregistry assert_empty_weakregistry/;
+
+sub stacktrace {
+ my $frame = shift;
+ $frame++;
+ my (@stack, @frame);
+
+ while (@frame = caller($frame++)) {
+ push @stack, [@frame[3,1,2]];
+ }
+
+ return undef unless @stack;
+
+ $stack[0][0] = '';
+ return join "\tinvoked as ", map { sprintf ("%s at %s line %d\n", @$_ ) } @stack;
+}
+
+sub populate_weakregistry {
+ my ($reg, $target, $slot) = @_;
+
+
+ croak 'Target is not a reference' unless defined ref $target;
+
+ $slot ||= (sprintf '%s%s(0x%x)', # so we don't trigger stringification
+ (defined blessed $target) ? blessed($target) . '=' : '',
+ reftype $target,
+ refaddr $target,
+ );
+
+ weaken( $reg->{$slot}{weakref} = $target );
+ $reg->{$slot}{stacktrace} = stacktrace(1);
+
+ $target;
+}
+
+my $leaks_found;
+sub assert_empty_weakregistry {
+ my ($weak_registry, $quiet) = @_;
+
+ croak 'Expecting a registry hashref' unless ref $weak_registry eq 'HASH';
+
+ return unless keys %$weak_registry;
+
+ my $tb = eval { Test::Builder->new }
+ or croak 'Calling test_weakregistry without a loaded Test::Builder makes no sense';
+
+ for my $slot (sort keys %$weak_registry) {
+ next if ! defined $weak_registry->{$slot}{weakref};
+ $tb->BAILOUT("!!!! WEAK REGISTRY SLOT $slot IS NOT A WEAKREF !!!!")
+ unless isweak( $weak_registry->{$slot}{weakref} );
+ }
+
+
+ for my $slot (sort keys %$weak_registry) {
+ ! defined $weak_registry->{$slot}{weakref} and next if $quiet;
+
+ $tb->ok (! defined $weak_registry->{$slot}{weakref}, "No leaks of $slot") or do {
+ $leaks_found = 1;
+
+ my $diag = '';
+
+ $diag .= Devel::FindRef::track ($weak_registry->{$slot}{weakref}, 20) . "\n"
+ if ( $ENV{TEST_VERBOSE} && eval { require Devel::FindRef });
+
+ if (my $stack = $weak_registry->{$slot}{stacktrace}) {
+ $diag .= " Reference first seen$stack";
+ }
+
+ $tb->diag($diag) if $diag;
+ };
+ }
+}
+
+END {
+ if ($leaks_found) {
+ my $tb = Test::Builder->new;
+ $tb->diag(sprintf
+ "\n\n%s\n%s\n\nInstall Devel::FindRef and re-run the test with set "
+ . '$ENV{TEST_VERBOSE} (prove -v) to see a more detailed leak-report'
+ . "\n\n%s\n%s\n\n", ('#' x 16) x 4
+ ) if (!$tb->is_passing and (!$ENV{TEST_VERBOSE} or !$INC{'Devel/FindRef.pm'}));
+ }
+}
+
+1;
$schema->resultset('Artist')->populate([ $kurt_cobain ]); # %)
- $a = $schema->resultset('Artist')->find({name => 'Kurt Cobain'});
+ my $artist = $schema->resultset('Artist')->find({name => 'Kurt Cobain'});
- is($a->name, 'Kurt Cobain', 'Artist insertion ok');
- is($a->cds && $a->cds->first && $a->cds->first->title,
+ is($artist->name, 'Kurt Cobain', 'Artist insertion ok');
+ is($artist->cds && $artist->cds->first && $artist->cds->first->title,
'In Utero', 'CD insertion ok');
}, 'populate');
use DBICTest;
use DBIC::SqlMakerTest;
-my $schema = DBICTest->init_schema;
-
-my $rs = $schema->resultset('FourKeys');
-
sub test_order {
TODO: {
+ my $rs = shift;
my $args = shift;
local $TODO = "Not implemented" if $args->{todo};
},
);
-test_order($_) for @tests;
+my $rs = DBICTest->init_schema->resultset('FourKeys');
+test_order($rs, $_) for @tests;
done_testing;
},
};
-for my $ctx (keys $ctx_map) {
+for my $ctx (keys %$ctx_map) {
# start disconnected and then connected
$schema->storage->disconnect;
projects / dbsrgits/DBIx-Class.git / commitdiff