1 package DBICTest::Util::LeakTracer;
7 use Scalar::Util qw(isweak weaken blessed reftype);
8 use DBIx::Class::_Util 'refcount';
9 use Data::Dumper::Concise;
10 use DBICTest::Util 'stacktrace';
13 our @EXPORT_OK = qw(populate_weakregistry assert_empty_weakregistry hrefaddr);
19 sub hrefaddr { sprintf '0x%x', &Scalar::Util::refaddr }
21 # so we don't trigger stringification
24 (defined blessed $_[0]) ? blessed($_[0]) . '=' : '',
30 sub populate_weakregistry {
31 my ($weak_registry, $target, $note) = @_;
33 croak 'Expecting a registry hashref' unless ref $weak_registry eq 'HASH';
34 croak 'Target is not a reference' unless length ref $target;
36 my $refaddr = hrefaddr $target;
38 # a registry could be fed to itself or another registry via recursive sweeps
39 return $target if $reg_of_regs{$refaddr};
41 weaken( $reg_of_regs{ hrefaddr($weak_registry) } = $weak_registry )
42 unless( $reg_of_regs{ hrefaddr($weak_registry) } );
44 # an explicit "garbage collection" pass every time we store a ref
45 # if we do not do this the registry will keep growing appearing
46 # as if the traced program is continuously slowly leaking memory
47 for my $reg (values %reg_of_regs) {
48 (defined $reg->{$_}{weakref}) or delete $reg->{$_}
52 if (! defined $weak_registry->{$refaddr}{weakref}) {
53 $weak_registry->{$refaddr} = {
54 stacktrace => stacktrace(1),
57 weaken( $weak_registry->{$refaddr}{weakref} );
61 my $desc = _describe_ref($target);
62 $weak_registry->{$refaddr}{slot_names}{$desc} = 1;
64 $note =~ s/\s*\Q$desc\E\s*//g;
65 $weak_registry->{$refaddr}{slot_names}{$note} = 1;
71 # Regenerate the slots names on a thread spawn
73 my @individual_regs = grep { scalar keys %{$_||{}} } values %reg_of_regs;
76 for my $reg (@individual_regs) {
77 my @live_slots = grep { defined $_->{weakref} } values %$reg
80 $reg = {}; # get a fresh hashref in the new thread ctx
81 weaken( $reg_of_regs{hrefaddr($reg)} = $reg );
83 for my $slot_info (@live_slots) {
84 my $new_addr = hrefaddr $slot_info->{weakref};
86 # replace all slot names
87 $slot_info->{slot_names} = { map {
89 $name =~ s/\(0x[0-9A-F]+\)/sprintf ('(%s)', $new_addr)/ieg;
91 } keys %{$slot_info->{slot_names}} };
93 $reg->{$new_addr} = $slot_info;
98 sub assert_empty_weakregistry {
99 my ($weak_registry, $quiet) = @_;
101 croak 'Expecting a registry hashref' unless ref $weak_registry eq 'HASH';
103 return unless keys %$weak_registry;
105 my $tb = eval { Test::Builder->new }
106 or croak 'Calling test_weakregistry without a loaded Test::Builder makes no sense';
108 for my $addr (keys %$weak_registry) {
109 $weak_registry->{$addr}{display_name} = join ' | ', (
111 { length $a <=> length $b or $a cmp $b }
112 keys %{$weak_registry->{$addr}{slot_names}}
115 $tb->BAILOUT("!!!! WEAK REGISTRY SLOT $weak_registry->{$addr}{display_name} IS NOT A WEAKREF !!!!")
116 if defined $weak_registry->{$addr}{weakref} and ! isweak( $weak_registry->{$addr}{weakref} );
119 # compile a list of refs stored as CAG class data, so we can skip them
120 # intelligently below
121 my ($classdata_refcounts, $symwalker, $refwalker);
124 return unless length ref $_[0];
126 my $seen = $_[1] || {};
127 return if $seen->{hrefaddr $_[0]}++;
129 $classdata_refcounts->{hrefaddr $_[0]}++;
131 my $type = reftype $_[0];
132 if ($type eq 'HASH') {
133 $refwalker->($_, $seen) for values %{$_[0]};
135 elsif ($type eq 'ARRAY') {
136 $refwalker->($_, $seen) for @{$_[0]};
138 elsif ($type eq 'REF') {
139 $refwalker->($$_, $seen);
145 my $pkg = shift || '::';
147 $refwalker->(${"${pkg}$_"}) for grep { $_ =~ /__cag_(?!pkg_gen__|supers__)/ } keys %$pkg;
149 $symwalker->("${pkg}$_") for grep { $_ =~ /(?<!^main)::$/ } keys %$pkg;
152 # run things twice, some cycles will be broken, introducing new
153 # candidates for pseudo-GC
155 undef $classdata_refcounts;
159 for my $refaddr (keys %$weak_registry) {
161 defined $weak_registry->{$refaddr}{weakref}
163 my $expected_refcnt = $classdata_refcounts->{$refaddr}
165 delete $weak_registry->{$refaddr}
166 if refcount($weak_registry->{$refaddr}{weakref}) == $expected_refcnt;
171 for my $addr (sort { $weak_registry->{$a}{display_name} cmp $weak_registry->{$b}{display_name} } keys %$weak_registry) {
173 next if ! defined $weak_registry->{$addr}{weakref};
176 $tb->ok (0, "Leaked $weak_registry->{$addr}{display_name}");
179 local $Data::Dumper::Maxdepth = 1;
180 sprintf "\n%s (refcnt %d) => %s\n",
181 $weak_registry->{$addr}{display_name},
182 refcount($weak_registry->{$addr}{weakref}),
184 ref($weak_registry->{$addr}{weakref}) eq 'CODE'
186 B::svref_2object($weak_registry->{$addr}{weakref})->XSUB
187 ) ? '__XSUB__' : Dumper( $weak_registry->{$addr}{weakref} )
191 $diag .= Devel::FindRef::track ($weak_registry->{$addr}{weakref}, 20) . "\n"
192 if ( $ENV{TEST_VERBOSE} && eval { require Devel::FindRef });
196 if (my $stack = $weak_registry->{$addr}{stacktrace}) {
197 $diag .= " Reference first seen$stack";
203 if (! $quiet and ! $leaks_found) {
204 $tb->ok(1, sprintf "No leaks found at %s line %d", (caller())[1,2] );
209 if ($INC{'Test/Builder.pm'}) {
210 my $tb = Test::Builder->new;
212 # we check for test passage - a leak may be a part of a TODO
213 if ($leaks_found and !$tb->is_passing) {
216 "\n\n%s\n%s\n\nInstall Devel::FindRef and re-run the test with set "
217 . '$ENV{TEST_VERBOSE} (prove -v) to see a more detailed leak-report'
218 . "\n\n%s\n%s\n\n", ('#' x 16) x 4
219 ) if ( !$ENV{TEST_VERBOSE} or !$INC{'Devel/FindRef.pm'} );
223 $tb->note("Auto checked $refs_traced references for leaks - none detected");