view release on metacpan or  search on metacpan

t/52leaks.t  view on Meta::CPAN

  # dbh's are created in XS space, so pull them separately
  for ( grep { defined } map { @{$_->{ChildHandles}} } values %{ {DBI->installed_drivers()} } ) {
    $base_collection->{"DBI handle $_"} = $_;
  }

  populate_weakregistry ($weak_registry, $base_collection->{$_}, "basic $_")
    for keys %$base_collection;
}

# check that "phantom-chaining" works - we never lose track of the original $schema
# and have access to the entire tree without leaking anything
{
  my $phantom;
  for (
    sub { DBICTest->init_schema( sqlite_use_file => 0 ) },
    sub { shift->source('Artist') },
    sub { shift->resultset },
    sub { shift->result_source },
    sub { shift->schema },
    sub { shift->resultset('Artist') },
    sub { shift->find_or_create({ name => 'detachable' }) },
    sub { shift->result_source },
    sub { shift->schema },
    sub { shift->clone },
    sub { shift->resultset('CD') },
    sub { shift->next },
    sub { shift->artist },
    sub { shift->search_related('cds') },
    sub { shift->next },
    sub { shift->search_related('artist') },
    sub { shift->result_source },
    sub { shift->resultset },
    sub { shift->create({ name => 'detached' }) },
    sub { shift->update({ name => 'reattached' }) },
    sub { shift->discard_changes },
    sub { shift->delete },
    sub { shift->insert },
  ) {
    $phantom = populate_weakregistry ( $weak_registry, scalar $_->($phantom) );
  }

  ok( $phantom->in_storage, 'Properly deleted/reinserted' );
  is( $phantom->name, 'reattached', 'Still correct name' );
}

# Naturally we have some exceptions
my $cleared;
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->{$addr};
  }
  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 =~ /^B::Hooks::EndOfScope::PP::_TieHintHashFieldHash/m) {
    # there is one tied lexical which stays alive until GC time
    # https://metacpan.org/source/ETHER/B-Hooks-EndOfScope-0.15/lib/B/Hooks/EndOfScope/PP/FieldHash.pm#L24
    # simply ignore it here, instead of teaching the leaktracer to examine ties
    # the latter is possible yet terrible: https://metacpan.org/source/RIBASUSHI/DBIx-Class-0.082840/t/lib/DBICTest/Util/LeakTracer.pm#L113-117
    delete $weak_registry->{$addr}
      unless $cleared->{bheos_pptiehinthashfieldhash}++;
  }
  elsif ($names =~ /^B::Hooks::EndOfScope::PP::HintHash::__GraveyardTransport/m) {
    # a workaround for perl-level double free: these "leak" by design
    delete $weak_registry->{$addr};
  }
  elsif ($names =~ /^DateTime::TimeZone::UTC/m) {
    # DT is going through a refactor it seems - let it leak zones for now
    delete $weak_registry->{$addr};
  }
  elsif (
#    # if we can look at closed over pieces - we will register it as a global
#    !DBICTest::Util::LeakTracer::CV_TRACING
#      and
    $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}}++;
  }
}

# FIXME !!!
# There is an actual strong circular reference taking place here, but because
# half of it is in XS, so it is a bit harder to track down (it stumps D::FR)
# (our tracker does not yet do it, but it'd be nice)
# The problem is:
#
# $cond_object --> result_source --> schema --> storage --> $dbh --> {CachedKids}
#          ^                                                           /
#           \-------- bound value on prepared/cached STH  <-----------/
#
{
  my @circreffed;

  for my $r (map
    { $_->{weakref} }
    grep
      { $_->{slot_names}{'basic leaky_resultset_cond'} }
      values %$weak_registry
  ) {
    local $TODO = 'Needs Data::Entangled or somesuch - see RT#82942';
    ok(! defined $r, 'Self-referential RS conditions no longer leak!')
      or push @circreffed, $r;
  }

  if (@circreffed) {
    is (scalar @circreffed, 1, 'One resultset expected to leak');

    # this is useless on its own, it is to showcase the circref-diag
    # and eventually test it when it is operational
    local $TODO = 'Needs Data::Entangled or somesuch - see RT#82942';
    while (@circreffed) {
      weaken (my $r = shift @circreffed);