use lib qw(t/lib);
use DBICTest::RunMode;
use DBICTest::Util::LeakTracer qw/populate_weakregistry assert_empty_weakregistry/;
-use Scalar::Util 'refaddr';
use DBIx::Class;
BEGIN {
plan skip_all => "Your perl version $] appears to leak like a sieve - skipping test"
# 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};
+ delete $weak_registry->{$addr};
}
- elsif ($slot =~ /^Method::Generate::(?:Accessor|Constructor)/) {
+ elsif ($names =~ /^Method::Generate::(?:Accessor|Constructor)/m) {
# Moo keeps globals around, this is normal
- delete $weak_registry->{$slot};
+ delete $weak_registry->{$addr};
}
- elsif ($slot =~ /^SQL::Translator::Generator::DDL::SQLite/) {
+ 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->{$slot}
- unless $cleared->{sqlt_ddl_sqlite}->{@{$weak_registry->{$slot}{weakref}->quote_chars}}++;
+ delete $weak_registry->{$addr}
+ unless $cleared->{sqlt_ddl_sqlite}->{@{$weak_registry->{$addr}{weakref}->quote_chars}}++;
}
- 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/) {
+ elsif ($names =~ /^DateTime::TimeZone/m) {
# DT is going through a refactor it seems - let it leak zones for now
- delete $weak_registry->{$slot};
+ delete $weak_registry->{$addr};
}
}
#
{
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);
}
use strict;
use Carp;
-use Scalar::Util qw/isweak weaken blessed reftype refaddr/;
+use Scalar::Util qw(isweak weaken blessed reftype);
use DBIx::Class::_Util 'refcount';
+use Data::Dumper::Concise;
use DBICTest::Util 'stacktrace';
use base 'Exporter';
-our @EXPORT_OK = qw/populate_weakregistry assert_empty_weakregistry/;
+our @EXPORT_OK = qw(populate_weakregistry assert_empty_weakregistry hrefaddr);
my $refs_traced = 0;
-my $leaks_found;
+my $leaks_found = 0;
my %reg_of_regs;
+sub hrefaddr { sprintf '0x%x', &Scalar::Util::refaddr }
+
+# so we don't trigger stringification
+sub _describe_ref {
+ sprintf '%s%s(%s)',
+ (defined blessed $_[0]) ? blessed($_[0]) . '=' : '',
+ reftype $_[0],
+ hrefaddr $_[0],
+ ;
+}
+
sub populate_weakregistry {
- my ($weak_registry, $target, $slot) = @_;
+ my ($weak_registry, $target, $note) = @_;
croak 'Expecting a registry hashref' unless ref $weak_registry eq 'HASH';
croak 'Target is not a reference' unless length ref $target;
- my $refaddr = refaddr $target;
+ my $refaddr = hrefaddr $target;
- $slot ||= (sprintf '%s%s(0x%x)', # so we don't trigger stringification
- (defined blessed $target) ? blessed($target) . '=' : '',
- reftype $target,
- $refaddr,
- );
+ # a registry could be fed to itself or another registry via recursive sweeps
+ return $target if $reg_of_regs{$refaddr};
- if (defined $weak_registry->{$slot}{weakref}) {
- if ( $weak_registry->{$slot}{refaddr} != $refaddr ) {
- print STDERR "Bail out! Weak Registry slot collision $slot: $weak_registry->{$slot}{weakref} / $target\n";
- exit 255;
- }
- }
- else {
- $weak_registry->{$slot} = {
+ if (! defined $weak_registry->{$refaddr}{weakref}) {
+ $weak_registry->{$refaddr} = {
stacktrace => stacktrace(1),
- refaddr => $refaddr,
- renumber => $_[2] ? 0 : 1,
+ weakref => $target,
};
- weaken( $weak_registry->{$slot}{weakref} = $target );
+ weaken( $weak_registry->{$refaddr}{weakref} );
$refs_traced++;
}
- weaken( $reg_of_regs{ refaddr($weak_registry) } = $weak_registry )
- unless( $reg_of_regs{ refaddr($weak_registry) } );
+ my $desc = _describe_ref($target);
+ $weak_registry->{$refaddr}{slot_names}{$desc} = 1;
+ if ($note) {
+ $note =~ s/\s*\Q$desc\E\s*//g;
+ $weak_registry->{$refaddr}{slot_names}{$note} = 1;
+ }
+
+ weaken( $reg_of_regs{ hrefaddr($weak_registry) } = $weak_registry )
+ unless( $reg_of_regs{ hrefaddr($weak_registry) } );
$target;
}
-# Renumber everything we auto-named on a thread spawn
+# Regenerate the slots names on a thread spawn
sub CLONE {
my @individual_regs = grep { scalar keys %{$_||{}} } values %reg_of_regs;
%reg_of_regs = ();
for my $reg (@individual_regs) {
- my @live_slots = grep { defined $reg->{$_}{weakref} } keys %$reg
+ my @live_slots = grep { defined $_->{weakref} } values %$reg
or next;
- my @live_instances = @{$reg}{@live_slots};
-
$reg = {}; # get a fresh hashref in the new thread ctx
- weaken( $reg_of_regs{refaddr($reg)} = $reg );
-
- while (@live_slots) {
- my $slot = shift @live_slots;
- my $inst = shift @live_instances;
+ weaken( $reg_of_regs{hrefaddr($reg)} = $reg );
- my $refaddr = $inst->{refaddr} = refaddr($inst);
+ for my $slot_info (@live_slots) {
+ my $new_addr = hrefaddr $slot_info->{weakref};
- $slot =~ s/0x[0-9A-F]+/'0x' . sprintf ('0x%x', $refaddr)/ieg
- if $inst->{renumber};
+ # replace all slot names
+ $slot_info->{slot_names} = { map {
+ my $name = $_;
+ $name =~ s/\(0x[0-9A-F]+\)/sprintf ('(%s)', $new_addr)/ieg;
+ ($name => 1);
+ } keys %{$slot_info->{slot_names}} };
- $reg->{$slot} = $inst;
+ $reg->{$new_addr} = $slot_info;
}
}
}
my $tb = eval { Test::Builder->new }
or croak 'Calling test_weakregistry without a loaded Test::Builder makes no sense';
- for my $slot (sort keys %$weak_registry) {
- next if ! defined $weak_registry->{$slot}{weakref};
- $tb->BAILOUT("!!!! WEAK REGISTRY SLOT $slot IS NOT A WEAKREF !!!!")
- unless isweak( $weak_registry->{$slot}{weakref} );
- }
+ for my $addr (keys %$weak_registry) {
+ $weak_registry->{$addr}{display_name} = join ' | ', (
+ sort
+ { length $a <=> length $b or $a cmp $b }
+ keys %{$weak_registry->{$addr}{slot_names}}
+ );
+ $tb->BAILOUT("!!!! WEAK REGISTRY SLOT $weak_registry->{$addr}{display_name} IS NOT A WEAKREF !!!!")
+ if defined $weak_registry->{$addr}{weakref} and ! isweak( $weak_registry->{$addr}{weakref} );
+ }
# compile a list of refs stored as CAG class data, so we can skip them
# intelligently below
return unless length ref $_[0];
my $seen = $_[1] || {};
- return if $seen->{refaddr $_[0]}++;
+ return if $seen->{hrefaddr $_[0]}++;
- $classdata_refcounts->{refaddr $_[0]}++;
+ $classdata_refcounts->{hrefaddr $_[0]}++;
my $type = reftype $_[0];
if ($type eq 'HASH') {
$symwalker->();
- for my $slot (keys %$weak_registry) {
+ for my $refaddr (keys %$weak_registry) {
if (
- defined $weak_registry->{$slot}{weakref}
+ defined $weak_registry->{$refaddr}{weakref}
and
- my $expected_refcnt = $classdata_refcounts->{$weak_registry->{$slot}{refaddr}}
+ my $expected_refcnt = $classdata_refcounts->{$refaddr}
) {
- delete $weak_registry->{$slot}
- if refcount($weak_registry->{$slot}{weakref}) == $expected_refcnt;
+ delete $weak_registry->{$refaddr}
+ if refcount($weak_registry->{$refaddr}{weakref}) == $expected_refcnt;
}
}
}
- for my $slot (sort keys %$weak_registry) {
- ! defined $weak_registry->{$slot}{weakref} and next if $quiet;
+ for my $addr (sort { $weak_registry->{$a}{display_name} cmp $weak_registry->{$b}{display_name} } keys %$weak_registry) {
+
+ ! defined $weak_registry->{$addr}{weakref} and next if $quiet;
- $tb->ok (! defined $weak_registry->{$slot}{weakref}, "No leaks of $slot") or do {
- $leaks_found = 1;
+ $tb->ok (! defined $weak_registry->{$addr}{weakref}, "No leaks of $weak_registry->{$addr}{display_name}") or do {
+ $leaks_found++;
- my $diag = '';
+ my $diag = do {
+ local $Data::Dumper::Maxdepth = 1;
+ sprintf "\n%s (refcnt %d) => %s\n",
+ $weak_registry->{$addr}{display_name},
+ refcount($weak_registry->{$addr}{weakref}),
+ (
+ ref($weak_registry->{$addr}{weakref}) eq 'CODE'
+ and
+ B::svref_2object($weak_registry->{$addr}{weakref})->XSUB
+ ) ? '__XSUB__' : Dumper( $weak_registry->{$addr}{weakref} )
+ ;
+ };
- $diag .= Devel::FindRef::track ($weak_registry->{$slot}{weakref}, 20) . "\n"
+ $diag .= Devel::FindRef::track ($weak_registry->{$addr}{weakref}, 20) . "\n"
if ( $ENV{TEST_VERBOSE} && eval { require Devel::FindRef });
- if (my $stack = $weak_registry->{$slot}{stacktrace}) {
+ $diag =~ s/^/ /mg;
+
+ if (my $stack = $weak_registry->{$addr}{stacktrace}) {
$diag .= " Reference first seen$stack";
}
- $tb->diag($diag) if $diag;
+ $tb->diag($diag);
};
}
}
projects / dbsrgits/DBIx-Class.git / commitdiff