1 package DBICTest::Util::LeakTracer;
7 use Scalar::Util qw/isweak weaken blessed reftype refaddr/;
8 use DBIx::Class::_Util 'refcount';
9 use DBICTest::Util 'stacktrace';
12 our @EXPORT_OK = qw/populate_weakregistry assert_empty_weakregistry/;
18 sub populate_weakregistry {
19 my ($weak_registry, $target, $slot) = @_;
21 croak 'Expecting a registry hashref' unless ref $weak_registry eq 'HASH';
22 croak 'Target is not a reference' unless length ref $target;
24 my $refaddr = refaddr $target;
26 $slot ||= (sprintf '%s%s(0x%x)', # so we don't trigger stringification
27 (defined blessed $target) ? blessed($target) . '=' : '',
32 if (defined $weak_registry->{$slot}{weakref}) {
33 if ( $weak_registry->{$slot}{refaddr} != $refaddr ) {
34 print STDERR "Bail out! Weak Registry slot collision $slot: $weak_registry->{$slot}{weakref} / $target\n";
39 $weak_registry->{$slot} = {
40 stacktrace => stacktrace(1),
42 renumber => $_[2] ? 0 : 1,
44 weaken( $weak_registry->{$slot}{weakref} = $target );
48 weaken( $reg_of_regs{ refaddr($weak_registry) } = $weak_registry )
49 unless( $reg_of_regs{ refaddr($weak_registry) } );
54 # Renumber everything we auto-named on a thread spawn
56 my @individual_regs = grep { scalar keys %{$_||{}} } values %reg_of_regs;
59 for my $reg (@individual_regs) {
60 my @live_slots = grep { defined $reg->{$_}{weakref} } keys %$reg
63 my @live_instances = @{$reg}{@live_slots};
65 $reg = {}; # get a fresh hashref in the new thread ctx
66 weaken( $reg_of_regs{refaddr($reg)} = $reg );
69 my $slot = shift @live_slots;
70 my $inst = shift @live_instances;
72 my $refaddr = $inst->{refaddr} = refaddr($inst);
74 $slot =~ s/0x[0-9A-F]+/'0x' . sprintf ('0x%x', $refaddr)/ieg
77 $reg->{$slot} = $inst;
82 sub assert_empty_weakregistry {
83 my ($weak_registry, $quiet) = @_;
85 croak 'Expecting a registry hashref' unless ref $weak_registry eq 'HASH';
87 return unless keys %$weak_registry;
89 my $tb = eval { Test::Builder->new }
90 or croak 'Calling test_weakregistry without a loaded Test::Builder makes no sense';
92 for my $slot (sort keys %$weak_registry) {
93 next if ! defined $weak_registry->{$slot}{weakref};
94 $tb->BAILOUT("!!!! WEAK REGISTRY SLOT $slot IS NOT A WEAKREF !!!!")
95 unless isweak( $weak_registry->{$slot}{weakref} );
99 # compile a list of refs stored as CAG class data, so we can skip them
100 # intelligently below
101 my ($classdata_refcounts, $symwalker, $refwalker);
104 return unless length ref $_[0];
106 my $seen = $_[1] || {};
107 return if $seen->{refaddr $_[0]}++;
109 $classdata_refcounts->{refaddr $_[0]}++;
111 my $type = reftype $_[0];
112 if ($type eq 'HASH') {
113 $refwalker->($_, $seen) for values %{$_[0]};
115 elsif ($type eq 'ARRAY') {
116 $refwalker->($_, $seen) for @{$_[0]};
118 elsif ($type eq 'REF') {
119 $refwalker->($$_, $seen);
125 my $pkg = shift || '::';
127 $refwalker->(${"${pkg}$_"}) for grep { $_ =~ /__cag_(?!pkg_gen__|supers__)/ } keys %$pkg;
129 $symwalker->("${pkg}$_") for grep { $_ =~ /(?<!^main)::$/ } keys %$pkg;
132 # run things twice, some cycles will be broken, introducing new
133 # candidates for pseudo-GC
135 undef $classdata_refcounts;
139 for my $slot (keys %$weak_registry) {
141 defined $weak_registry->{$slot}{weakref}
143 my $expected_refcnt = $classdata_refcounts->{$weak_registry->{$slot}{refaddr}}
145 delete $weak_registry->{$slot}
146 if refcount($weak_registry->{$slot}{weakref}) == $expected_refcnt;
151 for my $slot (sort keys %$weak_registry) {
152 ! defined $weak_registry->{$slot}{weakref} and next if $quiet;
154 $tb->ok (! defined $weak_registry->{$slot}{weakref}, "No leaks of $slot") or do {
159 $diag .= Devel::FindRef::track ($weak_registry->{$slot}{weakref}, 20) . "\n"
160 if ( $ENV{TEST_VERBOSE} && eval { require Devel::FindRef });
162 if (my $stack = $weak_registry->{$slot}{stacktrace}) {
163 $diag .= " Reference first seen$stack";
166 $tb->diag($diag) if $diag;
172 if ($INC{'Test/Builder.pm'}) {
173 my $tb = Test::Builder->new;
175 # we check for test passage - a leak may be a part of a TODO
176 if ($leaks_found and !$tb->is_passing) {
179 "\n\n%s\n%s\n\nInstall Devel::FindRef and re-run the test with set "
180 . '$ENV{TEST_VERBOSE} (prove -v) to see a more detailed leak-report'
181 . "\n\n%s\n%s\n\n", ('#' x 16) x 4
182 ) if ( !$ENV{TEST_VERBOSE} or !$INC{'Devel/FindRef.pm'} );
186 $tb->note("Auto checked $refs_traced references for leaks - none detected");