1 package DBICTest::Util::LeakTracer;
7 use Scalar::Util qw/isweak weaken blessed reftype refaddr/;
8 use DBICTest::Util 'stacktrace';
11 our @EXPORT_OK = qw/populate_weakregistry assert_empty_weakregistry/;
17 sub populate_weakregistry {
18 my ($weak_registry, $target, $slot) = @_;
20 croak 'Expecting a registry hashref' unless ref $weak_registry eq 'HASH';
21 croak 'Target is not a reference' unless length ref $target;
23 $slot ||= (sprintf '%s%s(0x%x)', # so we don't trigger stringification
24 (defined blessed $target) ? blessed($target) . '=' : '',
29 if (defined $weak_registry->{$slot}{weakref}) {
30 if ( refaddr($weak_registry->{$slot}{weakref}) != (refaddr $target) ) {
31 print STDERR "Bail out! Weak Registry slot collision: $weak_registry->{$slot}{weakref} / $target\n";
37 weaken( $weak_registry->{$slot}{weakref} = $target );
38 $weak_registry->{$slot}{stacktrace} = stacktrace(1);
39 $weak_registry->{$slot}{renumber} = 1 unless $_[2];
42 weaken( $reg_of_regs{ refaddr($weak_registry) } = $weak_registry )
43 unless( $reg_of_regs{ refaddr($weak_registry) } );
48 # Renumber everything we auto-named on a thread spawn
50 my @individual_regs = grep { scalar keys %{$_||{}} } values %reg_of_regs;
53 for my $reg (@individual_regs) {
54 my @live_slots = grep { defined $reg->{$_}{weakref} } keys %$reg
57 my @live_instances = @{$reg}{@live_slots};
59 $reg = {}; # get a fresh hashref in the new thread ctx
60 weaken( $reg_of_regs{refaddr($reg)} = $reg );
63 my $slot = shift @live_slots;
64 my $inst = shift @live_instances;
66 $slot =~ s/0x[0-9A-F]+/'0x' . sprintf ('0x%x', refaddr($inst))/ieg
69 $reg->{$slot} = $inst;
74 sub assert_empty_weakregistry {
75 my ($weak_registry, $quiet) = @_;
77 croak 'Expecting a registry hashref' unless ref $weak_registry eq 'HASH';
79 return unless keys %$weak_registry;
81 my $tb = eval { Test::Builder->new }
82 or croak 'Calling test_weakregistry without a loaded Test::Builder makes no sense';
84 for my $slot (sort keys %$weak_registry) {
85 next if ! defined $weak_registry->{$slot}{weakref};
86 $tb->BAILOUT("!!!! WEAK REGISTRY SLOT $slot IS NOT A WEAKREF !!!!")
87 unless isweak( $weak_registry->{$slot}{weakref} );
91 for my $slot (sort keys %$weak_registry) {
92 ! defined $weak_registry->{$slot}{weakref} and next if $quiet;
94 $tb->ok (! defined $weak_registry->{$slot}{weakref}, "No leaks of $slot") or do {
99 $diag .= Devel::FindRef::track ($weak_registry->{$slot}{weakref}, 20) . "\n"
100 if ( $ENV{TEST_VERBOSE} && eval { require Devel::FindRef });
102 if (my $stack = $weak_registry->{$slot}{stacktrace}) {
103 $diag .= " Reference first seen$stack";
106 $tb->diag($diag) if $diag;
112 if ($INC{'Test/Builder.pm'}) {
113 my $tb = Test::Builder->new;
115 # we check for test passage - a leak may be a part of a TODO
116 if ($leaks_found and !$tb->is_passing) {
119 "\n\n%s\n%s\n\nInstall Devel::FindRef and re-run the test with set "
120 . '$ENV{TEST_VERBOSE} (prove -v) to see a more detailed leak-report'
121 . "\n\n%s\n%s\n\n", ('#' x 16) x 4
122 ) if ( !$ENV{TEST_VERBOSE} or !$INC{'Devel/FindRef.pm'} );
126 $tb->note("Auto checked $refs_traced references for leaks - none detected");