use lib qw(t/lib);
use DBICTest::RunMode;
-use DBICTest::Util::LeakTracer qw/populate_weakregistry assert_empty_weakregistry/;
-use Scalar::Util 'refaddr';
+use DBICTest::Util::LeakTracer qw(populate_weakregistry assert_empty_weakregistry visit_refs);
use DBIx::Class;
-use B 'svref_2object';
BEGIN {
plan skip_all => "Your perl version $] appears to leak like a sieve - skipping test"
if DBIx::Class::_ENV_::PEEPEENESS;
%$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
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;
}
# Naturally we have some exceptions
my $cleared;
-for my $slot (keys %$weak_registry) {
- if ($slot =~ /^Test::Builder/) {
+for my $addr (keys %$weak_registry) {
+ my $names = join "\n", keys %{$weak_registry->{$addr}{slot_names}};
+
+ if ($names =~ /^Test::Builder/m) {
# T::B 2.0 has result objects and other fancyness
- delete $weak_registry->{$slot};
- }
- elsif ($slot =~ /^Method::Generate::(?:Accessor|Constructor)/) {
- # Moo keeps globals around, this is normal
- delete $weak_registry->{$slot};
- }
- elsif ($slot =~ /^SQL::Translator::Generator::DDL::SQLite/) {
- # SQLT::Producer::SQLite keeps global generators around for quoted
- # and non-quoted DDL, allow one for each quoting style
- delete $weak_registry->{$slot}
- unless $cleared->{sqlt_ddl_sqlite}->{@{$weak_registry->{$slot}{weakref}->quote_chars}}++;
+ delete $weak_registry->{$addr};
}
- elsif ($slot =~ /^Hash::Merge/) {
+ elsif ($names =~ /^Hash::Merge/m) {
# only clear one object of a specific behavior - more would indicate trouble
- delete $weak_registry->{$slot}
- unless $cleared->{hash_merge_singleton}{$weak_registry->{$slot}{weakref}{behavior}}++;
+ delete $weak_registry->{$addr}
+ unless $cleared->{hash_merge_singleton}{$weak_registry->{$addr}{weakref}{behavior}}++;
}
- elsif ($slot =~ /^DateTime::TimeZone/) {
- # DT is going through a refactor it seems - let it leak zones for now
- delete $weak_registry->{$slot};
- }
-}
-
-# 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
-) {
- # 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};
-}
-
-# 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)};
}
# FIXME !!!
#
{
local $TODO = 'This fails intermittently - see RT#82942';
- if ( my $r = $weak_registry->{'basic leaky_resultset_cond'}{weakref} ) {
+ if ( my $r = ($weak_registry->{'basic leaky_resultset_cond'}||{})->{weakref} ) {
ok(! defined $r, 'Self-referential RS conditions no longer leak!')
or $r->result_source(undef);
}
require IPC::Open2;
for my $type (keys %$persistence_tests) { SKIP: {
- skip "$type module not found", 1
- unless eval "require $type";
+ unless (eval "require $type") {
+ # Don't terminate what we didn't start
+ delete $persistence_tests->{$type}{termcmd};
+ skip "$type module not found", 1;
+ }
my @cmd = @{$persistence_tests->{$type}{cmd}};
unless ($ENV{DBICTEST_IN_PERSISTENT_ENV}) {
close $_ for (*STDIN, *STDOUT, *STDERR);
local $?; # otherwise test will inherit $? of the system()
- system (@{$persistence_tests->{PPerl}{termcmd}});
+ system (@{$persistence_tests->{PPerl}{termcmd}})
+ if $persistence_tests->{PPerl}{termcmd};
}
}
projects / dbsrgits/DBIx-Class.git / blobdiff