use lib qw(t/lib);
use DBICTest::RunMode;
-use DBICTest::Util::LeakTracer qw/populate_weakregistry assert_empty_weakregistry/;
+use DBICTest::Util::LeakTracer qw(populate_weakregistry assert_empty_weakregistry visit_refs);
use DBIx::Class;
BEGIN {
plan skip_all => "Your perl version $] appears to leak like a sieve - skipping test"
pager => $pager,
);
+ # FIXME - ideally this kind of collector ought to be global, but attempts
+ # with an invasive debugger-based tracer did not quite work out... yet
+ # Manually scan the innards of everything we have in the base collection
+ # we assembled so far (skip the DT madness below) *recursively*
+ #
+ # Only do this when we do have the bits to look inside CVs properly,
+ # without it we are liable to pick up object defaults that are locked
+ # in method closures
+ if (DBICTest::Util::LeakTracer::CV_TRACING) {
+ visit_refs(
+ refs => [ $base_collection ],
+ action => sub {
+ populate_weakregistry ($weak_registry, $_[0]);
+ 1; # true means "keep descending"
+ },
+ );
+ }
+
if ($has_dt) {
my $rs = $base_collection->{icdt_rs} = $schema->resultset('Event');
$base_collection->{"DBI handle $_"} = $_;
}
- SKIP: {
- if ( DBIx::Class::Optional::Dependencies->req_ok_for ('test_leaks') ) {
- my @w;
- local $SIG{__WARN__} = sub { $_[0] =~ /\QUnhandled type: REGEXP/ ? push @w, @_ : warn @_ };
-
- Test::Memory::Cycle::memory_cycle_ok ($base_collection, 'No cycles in the object collection');
-
- if ( $] > 5.011 ) {
- local $TODO = 'Silence warning due to RT56681';
- is (@w, 0, 'No Devel::Cycle emitted warnings');
- }
- }
- else {
- skip 'Circular ref test needs ' . DBIx::Class::Optional::Dependencies->req_missing_for ('test_leaks'), 1;
- }
- }
-
populate_weakregistry ($weak_registry, $base_collection->{$_}, "basic $_")
for keys %$base_collection;
}
# T::B 2.0 has result objects and other fancyness
delete $weak_registry->{$addr};
}
- elsif ($names =~ /^Method::Generate::(?:Accessor|Constructor)/m) {
- # Moo keeps globals around, this is normal
- delete $weak_registry->{$addr};
- }
- elsif ($names =~ /^SQL::Translator::Generator::DDL::SQLite/m) {
- # SQLT::Producer::SQLite keeps global generators around for quoted
- # and non-quoted DDL, allow one for each quoting style
- delete $weak_registry->{$addr}
- unless $cleared->{sqlt_ddl_sqlite}->{@{$weak_registry->{$addr}{weakref}->quote_chars}}++;
- }
elsif ($names =~ /^Hash::Merge/m) {
# only clear one object of a specific behavior - more would indicate trouble
delete $weak_registry->{$addr}
unless $cleared->{hash_merge_singleton}{$weak_registry->{$addr}{weakref}{behavior}}++;
}
- elsif ($names =~ /^DateTime::TimeZone/m) {
- # DT is going through a refactor it seems - let it leak zones for now
- delete $weak_registry->{$addr};
- }
}
# FIXME !!!