view release on metacpan or  search on metacpan

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

# work around brain damage in PPerl (yes, it has to be a global)
$SIG{__WARN__} = sub {
  warn @_ unless $_[0] =~ /\QUse of "goto" to jump into a construct is deprecated/
} if ($ENV{DBIO_TEST_IN_PERSISTENT_ENV});

# the persistent environments run with this flag first to see if
# we will run at all (e.g. it will fail if $^X doesn't match)
exit 0 if $ENV{DBIO_TEST_PERSISTENT_ENV_BAIL_EARLY};

# Do the override as early as possible so that CORE::bless doesn't get compiled away
# We will replace $bless_override only if we are in author mode
my $bless_override;
BEGIN {
  $bless_override = sub {
    CORE::bless( $_[0], (@_ > 1) ? $_[1] : caller() );
  };
  *CORE::GLOBAL::bless = sub { goto $bless_override };
}

use strict;
use warnings;
use Test::More;

use DBIO::Test;
use DBIO::Test::Util::LeakTracer qw(populate_weakregistry assert_empty_weakregistry visit_refs);
use Scalar::Util qw(weaken blessed reftype);
use DBIO::Util qw(hrefaddr peepeeness sigwarn_silencer modver_gt_or_eq modver_gt_or_eq_and_lt);
BEGIN {
  plan skip_all => "Your perl version $] appears to leak like a sieve - skipping test"
    if peepeeness;
}


my $TB = Test::More->builder;
if ($ENV{DBIO_TEST_IN_PERSISTENT_ENV}) {
  # without this explicit close TB warns in END after a ->reset
  close ($TB->$_) for qw(output failure_output todo_output);

  # newer TB does not auto-reopen handles
  if ( modver_gt_or_eq( 'Test::More', '1.200' ) ) {
    open ($TB->$_, '>&', *STDERR)
      for qw( failure_output todo_output );
    open ($TB->output, '>&', *STDOUT);
  }

  # so done_testing can work on every persistent pass
  $TB->reset;
}

# this is what holds all weakened refs to be checked for leakage
my $weak_registry = {};

# whether or to invoke IC::DT
my $has_dt;

# Skip the heavy-duty leak tracing when just doing an install
unless (DBIO::Test->is_plain) {

  # redefine the bless override so that we can catch each and every object created
  no warnings qw/redefine once/;
  no strict qw/refs/;

  $bless_override = sub {

    my $obj = CORE::bless(
      $_[0], (@_ > 1) ? $_[1] : do {
        my ($class, $fn, $line) = caller();
        fail ("bless() of $_[0] into $class without explicit class specification at $fn line $line")
          if $class =~ /^ (?: DBIx\:\:Class | DBIO::Test ) /x;
        $class;
      }
    );

    # unicode is tricky, and now we happen to invoke it early via a
    # regex in connection()
    return $obj if (ref $obj) =~ /^utf8/;

    # Test Builder is now making a new object for every pass/fail (que bloat?)
    # and as such we can't really store any of its objects (since it will
    # re-populate the registry while checking it, ewwww!)
    return $obj if (ref $obj) =~ /^TB2::|^Test::Stream/;

    # populate immediately to avoid weird side effects
    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 (&;@) {
      populate_weakregistry( $weak_registry, $_[0] );
      goto $orig;
    }
  }

  # Some modules are known to install singletons on-load
  # Load them and empty the registry

  # this loads the DT armada
  $has_dt = DBIO::Optional::Dependencies->req_ok_for('test_dt_sqlite');

  require Errno;
  require DBI;
  require DBD::SQLite;
  require FileHandle;
  require Moo;

  %$weak_registry = ();
}

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

  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/DBIO-0.082840/t/lib/DBIOTest/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
#    !DBIO::Test::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);

      populate_weakregistry( (my $mini_registry = {}), $r );
      assert_empty_weakregistry( $mini_registry );

      $r->result_source(undef);
    }
  }
}

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
# this is ugly and dirty but we do not yet have a Test::Embedded or
# similar

my $persistence_tests;
SKIP: {
  skip 'Test already in a persistent loop', 1
    if $ENV{DBIO_TEST_IN_PERSISTENT_ENV};

  skip 'Main test failed - skipping persistent env tests', 1
    unless $TB->is_passing;

  skip "Test::Builder\@@{[ Test::Builder->VERSION ]} known to break persistence tests", 1
    if modver_gt_or_eq_and_lt( 'Test::More', '1.200', '1.301001_099' );

  local $ENV{DBIO_TEST_IN_PERSISTENT_ENV} = 1;

  $persistence_tests = {
    PPerl => {
      cmd => [qw/pperl --prefork=1/, __FILE__],
    },
    'CGI::SpeedyCGI' => {
      cmd => [qw/speedy -- -t5/, __FILE__],
    },
  };

  # scgi is smart and will auto-reap after -t amount of seconds
  # pperl needs an actual killer :(
  $persistence_tests->{PPerl}{termcmd} = [
    $persistence_tests->{PPerl}{cmd}[0],
    '--kill',
    @{$persistence_tests->{PPerl}{cmd}}[ 1 .. $#{$persistence_tests->{PPerl}{cmd}} ],
  ];

  # set up -I
  require Config;
  $ENV{PERL5LIB} = join ($Config::Config{path_sep}, @INC);

  # adjust PATH for -T
  if (length $ENV{PATH}) {
    ( $ENV{PATH} ) = join ( $Config::Config{path_sep},
      map { length($_) ? File::Spec->rel2abs($_) : () }
        split /\Q$Config::Config{path_sep}/, $ENV{PATH}
    ) =~ /\A(.+)\z/;
  }

  for my $type (keys %$persistence_tests) { SKIP: {
    unless (eval "require $type") {