use lib qw(t/lib);
use DBICTest::RunMode;
+use DBIx::Class;
+use B 'svref_2object';
BEGIN {
plan skip_all => "Your perl version $] appears to leak like a sieve - skipping test"
- if DBICTest::RunMode->peepeeness;
+ if DBIx::Class::_ENV_::PEEPEENESS;
}
use Scalar::Util qw/refaddr reftype weaken/;
-use Carp qw/longmess/;
-use Try::Tiny;
-
-my $have_test_cycle;
-BEGIN {
- require DBIx::Class::Optional::Dependencies;
- $have_test_cycle = DBIx::Class::Optional::Dependencies->req_ok_for ('test_leaks')
- and import Test::Memory::Cycle;
-}
# 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) {
- # Some modules are known to install singletons on-load
- # Load them before we swap out $bless_override
- require DBI;
- require DBD::SQLite;
- require Errno;
- require Class::Struct;
- require FileHandle;
- require Hash::Merge;
- require Storable;
- # this loads the DT armada as well
- $has_dt = DBIx::Class::Optional::Dependencies->req_ok_for('test_dt_sqlite');
+ # 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/;
- # redefine the bless override so that we can catch each and every object created
$bless_override = sub {
my $obj = CORE::bless(
);
# weaken immediately to avoid weird side effects
- $weak_registry->{$slot} = { weakref => $obj, strace => longmess() };
+ $weak_registry->{$slot} = { weakref => $obj, strace => $trace->() };
weaken $weak_registry->{$slot}{weakref};
return $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 => longmess() };
+ $weak_registry->{$slot} = { weakref => $_[0], strace => $trace->() };
weaken $weak_registry->{$slot}{weakref};
goto $orig;
}
}
+
+ # Some modules are known to install singletons on-load
+ # Load them and empty the registry
+
+ # this loads the DT armada
+ $has_dt = DBIx::Class::Optional::Dependencies->req_ok_for('test_dt_sqlite');
+
+ require Errno;
+ require DBI;
+ require DBD::SQLite;
+ require FileHandle;
+
+ %$weak_registry = ();
}
+my @compose_ns_classes;
{
use_ok ('DBICTest');
my $rs = $schema->resultset ('Artist');
my $storage = $schema->storage;
+ @compose_ns_classes = map { "DBICTest::${_}" } keys %{$schema->source_registrations};
+
ok ($storage->connected, 'we are connected');
my $row_obj = $rs->search({}, { rows => 1})->next; # so that commits/rollbacks work
result_source_handle => $rs->result_source->handle,
- fresh_pager => $rs->page(5)->pager,
- pager => $pager,
pager_explicit_count => $pager_explicit_count,
};
+ require Storable;
%$base_collection = (
%$base_collection,
refrozen => Storable::dclone( $base_collection ),
storage => $storage,
sql_maker => $storage->sql_maker,
dbh => $storage->_dbh,
+ fresh_pager => $rs->page(5)->pager,
+ pager => $pager,
);
if ($has_dt) {
my @dummy = $rs->all;
}
- memory_cycle_ok ($base_collection, 'No cycles in the object collection')
- if $have_test_cycle;
+ # dbh's are created in XS space, so pull them separately
+ for ( grep { defined } map { @{$_->{ChildHandles}} } values %{ {DBI->installed_drivers()} } ) {
+ $base_collection->{"DBI handle $_"} = $_;
+ }
+
+ if ( DBIx::Class::Optional::Dependencies->req_ok_for ('test_leaks') ) {
+ Test::Memory::Cycle::memory_cycle_ok ($base_collection, 'No cycles in the object collection')
+ }
for (keys %$base_collection) {
$weak_registry->{"basic $_"} = { weakref => $base_collection->{$_} };
reftype $phantom,
refaddr $phantom,
);
+
$weak_registry->{$slot} = $phantom;
weaken $weak_registry->{$slot};
}
delete $weak_registry->{$slot}
unless $cleared->{hash_merge_singleton}{$weak_registry->{$slot}{weakref}{behavior}}++;
}
- elsif ($slot =~ /^__TxnScopeGuard__FIXUP__/) {
+ elsif (DBIx::Class::_ENV_::INVISIBLE_DOLLAR_AT and $slot =~ /^__TxnScopeGuard__FIXUP__/) {
delete $weak_registry->{$slot}
- if $] > 5.013001 and $] < 5.013008;
+ }
+ elsif ($slot =~ /^DateTime::TimeZone/) {
+ # DT is going through a refactor it seems - let it leak zones for now
+ delete $weak_registry->{$slot};
}
}
-
-# FIXME
-# For reasons I can not yet fully understand the table() god-method (located in
-# ::ResultSourceProxy::Table) attaches an actual source instance to each class
-# as virtually *immortal* class-data.
-# For now just ignore these instances manually but there got to be a saner way
-for ( map { $_->result_source_instance } (
+# every result class has a result source instance as classdata
+# make sure these are all present and distinct before ignoring
+# (distinct means only 1 reference)
+for my $rs_class (
'DBICTest::BaseResult',
+ @compose_ns_classes,
map { DBICTest::Schema->class ($_) } DBICTest::Schema->sources
-)) {
- delete $weak_registry->{$_};
+) {
+ # need to store the SVref and examine it separately, to push the rsrc instance off the pad
+ my $SV = svref_2object($rs_class->result_source_instance);
+ is( $SV->REFCNT, 1, "Source instance of $rs_class referenced exactly once" );
+
+ # ignore it
+ delete $weak_registry->{$rs_class->result_source_instance};
}
-# FIXME
-# same problem goes for the schema - its classdata contains live result source
-# objects, which to add insult to the injury are *different* instances from the
-# ones we ignored above
-for ( values %{DBICTest::Schema->source_registrations || {}} ) {
- delete $weak_registry->{$_};
+# Schema classes also hold sources, but these are clones, since
+# each source contains the schema (or schema class name in this case)
+# Hence the clone so that the same source can be registered with
+# multiple schemas
+for my $moniker ( keys %{DBICTest::Schema->source_registrations || {}} ) {
+
+ my $SV = svref_2object(DBICTest::Schema->source($moniker));
+ is( $SV->REFCNT, 1, "Source instance registered under DBICTest::Schema as $moniker referenced exactly once" );
+
+ delete $weak_registry->{DBICTest::Schema->source($moniker)};
}
for my $slot (sort keys %$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
# this is ugly and dirty but we do not yet have a Test::Embedded or