Commit | Line | Data |
218b7c12 |
1 | package DBICTest::Util::LeakTracer; |
2 | |
3 | use warnings; |
4 | use strict; |
5 | |
6 | use Carp; |
7 | use Scalar::Util qw/isweak weaken blessed reftype refaddr/; |
8 | use DBICTest::Util 'stacktrace'; |
9 | |
10 | use base 'Exporter'; |
11 | our @EXPORT_OK = qw/populate_weakregistry assert_empty_weakregistry/; |
12 | |
13 | my $refs_traced = 0; |
14 | my $leaks_found; |
15 | my %reg_of_regs; |
16 | |
17 | sub populate_weakregistry { |
18 | my ($weak_registry, $target, $slot) = @_; |
19 | |
20 | croak 'Expecting a registry hashref' unless ref $weak_registry eq 'HASH'; |
21 | croak 'Target is not a reference' unless length ref $target; |
22 | |
23 | $slot ||= (sprintf '%s%s(0x%x)', # so we don't trigger stringification |
24 | (defined blessed $target) ? blessed($target) . '=' : '', |
25 | reftype $target, |
26 | refaddr $target, |
27 | ); |
28 | |
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"; |
32 | exit 255; |
33 | } |
34 | } |
35 | else { |
36 | $refs_traced++; |
37 | weaken( $weak_registry->{$slot}{weakref} = $target ); |
38 | $weak_registry->{$slot}{stacktrace} = stacktrace(1); |
39 | $weak_registry->{$slot}{renumber} = 1 unless $_[2]; |
40 | } |
41 | |
42 | weaken( $reg_of_regs{ refaddr($weak_registry) } = $weak_registry ) |
43 | unless( $reg_of_regs{ refaddr($weak_registry) } ); |
44 | |
45 | $target; |
46 | } |
47 | |
48 | # Renumber everything we auto-named on a thread spawn |
49 | sub CLONE { |
50 | my @individual_regs = grep { scalar keys %{$_||{}} } values %reg_of_regs; |
51 | %reg_of_regs = (); |
52 | |
53 | for my $reg (@individual_regs) { |
54 | my @live_slots = grep { defined $reg->{$_}{weakref} } keys %$reg |
55 | or next; |
cf8fa286 |
56 | |
218b7c12 |
57 | my @live_instances = @{$reg}{@live_slots}; |
58 | |
cf8fa286 |
59 | $reg = {}; # get a fresh hashref in the new thread ctx |
218b7c12 |
60 | weaken( $reg_of_regs{refaddr($reg)} = $reg ); |
61 | |
62 | while (@live_slots) { |
63 | my $slot = shift @live_slots; |
64 | my $inst = shift @live_instances; |
65 | |
66 | $slot =~ s/0x[0-9A-F]+/'0x' . sprintf ('0x%x', refaddr($inst))/ieg |
67 | if $inst->{renumber}; |
68 | |
69 | $reg->{$slot} = $inst; |
70 | } |
71 | } |
72 | } |
73 | |
74 | sub assert_empty_weakregistry { |
75 | my ($weak_registry, $quiet) = @_; |
76 | |
77 | croak 'Expecting a registry hashref' unless ref $weak_registry eq 'HASH'; |
78 | |
79 | return unless keys %$weak_registry; |
80 | |
81 | my $tb = eval { Test::Builder->new } |
82 | or croak 'Calling test_weakregistry without a loaded Test::Builder makes no sense'; |
83 | |
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} ); |
88 | } |
89 | |
90 | |
91 | for my $slot (sort keys %$weak_registry) { |
92 | ! defined $weak_registry->{$slot}{weakref} and next if $quiet; |
93 | |
94 | $tb->ok (! defined $weak_registry->{$slot}{weakref}, "No leaks of $slot") or do { |
95 | $leaks_found = 1; |
96 | |
97 | my $diag = ''; |
98 | |
99 | $diag .= Devel::FindRef::track ($weak_registry->{$slot}{weakref}, 20) . "\n" |
100 | if ( $ENV{TEST_VERBOSE} && eval { require Devel::FindRef }); |
101 | |
102 | if (my $stack = $weak_registry->{$slot}{stacktrace}) { |
103 | $diag .= " Reference first seen$stack"; |
104 | } |
105 | |
106 | $tb->diag($diag) if $diag; |
107 | }; |
108 | } |
109 | } |
110 | |
111 | END { |
112 | if ($INC{'Test/Builder.pm'}) { |
113 | my $tb = Test::Builder->new; |
114 | |
115 | # we check for test passage - a leak may be a part of a TODO |
116 | if ($leaks_found and !$tb->is_passing) { |
117 | |
118 | $tb->diag(sprintf |
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'} ); |
123 | |
124 | } |
125 | else { |
126 | $tb->note("Auto checked $refs_traced references for leaks - none detected"); |
127 | } |
128 | } |
129 | } |
130 | |
131 | 1; |