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;
- $slot ||= (sprintf '%s%s(0x%x)', # so we don't trigger stringification
- (defined blessed $target) ? blessed($target) . '=' : '',
- reftype $target,
- refaddr $target,
- );
+ my $refaddr = hrefaddr $target;
- if (defined $weak_registry->{$slot}{weakref}) {
- if ( refaddr($weak_registry->{$slot}{weakref}) != (refaddr $target) ) {
- print STDERR "Bail out! Weak Registry slot collision: $weak_registry->{$slot}{weakref} / $target\n";
- exit 255;
- }
+ # a registry could be fed to itself or another registry via recursive sweeps
+ return $target if $reg_of_regs{$refaddr};
+
+ weaken( $reg_of_regs{ hrefaddr($weak_registry) } = $weak_registry )
+ unless( $reg_of_regs{ hrefaddr($weak_registry) } );
+
+ # an explicit "garbage collection" pass every time we store a ref
+ # if we do not do this the registry will keep growing appearing
+ # as if the traced program is continuously slowly leaking memory
+ for my $reg (values %reg_of_regs) {
+ (defined $reg->{$_}{weakref}) or delete $reg->{$_}
+ for keys %$reg;
}
- else {
+
+ if (! defined $weak_registry->{$refaddr}{weakref}) {
+ $weak_registry->{$refaddr} = {
+ stacktrace => stacktrace(1),
+ weakref => $target,
+ };
+ weaken( $weak_registry->{$refaddr}{weakref} );
$refs_traced++;
- weaken( $weak_registry->{$slot}{weakref} = $target );
- $weak_registry->{$slot}{stacktrace} = stacktrace(1);
- $weak_registry->{$slot}{renumber} = 1 unless $_[2];
}
- 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;
+ }
$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 );
+ weaken( $reg_of_regs{hrefaddr($reg)} = $reg );
- while (@live_slots) {
- my $slot = shift @live_slots;
- my $inst = shift @live_instances;
+ for my $slot_info (@live_slots) {
+ my $new_addr = hrefaddr $slot_info->{weakref};
- $slot =~ s/0x[0-9A-F]+/'0x' . sprintf ('0x%x', refaddr($inst))/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
+ my ($classdata_refcounts, $symwalker, $refwalker);
+
+ $refwalker = sub {
+ return unless length ref $_[0];
- for my $slot (sort keys %$weak_registry) {
- ! defined $weak_registry->{$slot}{weakref} and next if $quiet;
+ my $seen = $_[1] || {};
+ return if $seen->{hrefaddr $_[0]}++;
- $tb->ok (! defined $weak_registry->{$slot}{weakref}, "No leaks of $slot") or do {
- $leaks_found = 1;
+ $classdata_refcounts->{hrefaddr $_[0]}++;
- my $diag = '';
+ my $type = reftype $_[0];
+ if ($type eq 'HASH') {
+ $refwalker->($_, $seen) for values %{$_[0]};
+ }
+ elsif ($type eq 'ARRAY') {
+ $refwalker->($_, $seen) for @{$_[0]};
+ }
+ elsif ($type eq 'REF') {
+ $refwalker->($$_, $seen);
+ }
+ };
- $diag .= Devel::FindRef::track ($weak_registry->{$slot}{weakref}, 20) . "\n"
+ $symwalker = sub {
+ no strict 'refs';
+ my $pkg = shift || '::';
+
+ $refwalker->(${"${pkg}$_"}) for grep { $_ =~ /__cag_(?!pkg_gen__|supers__)/ } keys %$pkg;
+
+ $symwalker->("${pkg}$_") for grep { $_ =~ /(?<!^main)::$/ } keys %$pkg;
+ };
+
+ # run things twice, some cycles will be broken, introducing new
+ # candidates for pseudo-GC
+ for (1,2) {
+ undef $classdata_refcounts;
+
+ $symwalker->();
+
+ for my $refaddr (keys %$weak_registry) {
+ if (
+ defined $weak_registry->{$refaddr}{weakref}
+ and
+ my $expected_refcnt = $classdata_refcounts->{$refaddr}
+ ) {
+ delete $weak_registry->{$refaddr}
+ if refcount($weak_registry->{$refaddr}{weakref}) == $expected_refcnt;
+ }
+ }
+ }
+
+ 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->{$addr}{weakref}, "No leaks of $weak_registry->{$addr}{display_name}") or do {
+ $leaks_found++;
+
+ 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->{$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 / blobdiff