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; |
56 | my @live_instances = @{$reg}{@live_slots}; |
57 | |
58 | %$reg = (); |
59 | weaken( $reg_of_regs{refaddr($reg)} = $reg ); |
60 | |
61 | while (@live_slots) { |
62 | my $slot = shift @live_slots; |
63 | my $inst = shift @live_instances; |
64 | |
65 | $slot =~ s/0x[0-9A-F]+/'0x' . sprintf ('0x%x', refaddr($inst))/ieg |
66 | if $inst->{renumber}; |
67 | |
68 | $reg->{$slot} = $inst; |
69 | } |
70 | } |
71 | } |
72 | |
73 | sub assert_empty_weakregistry { |
74 | my ($weak_registry, $quiet) = @_; |
75 | |
76 | croak 'Expecting a registry hashref' unless ref $weak_registry eq 'HASH'; |
77 | |
78 | return unless keys %$weak_registry; |
79 | |
80 | my $tb = eval { Test::Builder->new } |
81 | or croak 'Calling test_weakregistry without a loaded Test::Builder makes no sense'; |
82 | |
83 | for my $slot (sort keys %$weak_registry) { |
84 | next if ! defined $weak_registry->{$slot}{weakref}; |
85 | $tb->BAILOUT("!!!! WEAK REGISTRY SLOT $slot IS NOT A WEAKREF !!!!") |
86 | unless isweak( $weak_registry->{$slot}{weakref} ); |
87 | } |
88 | |
89 | |
90 | for my $slot (sort keys %$weak_registry) { |
91 | ! defined $weak_registry->{$slot}{weakref} and next if $quiet; |
92 | |
93 | $tb->ok (! defined $weak_registry->{$slot}{weakref}, "No leaks of $slot") or do { |
94 | $leaks_found = 1; |
95 | |
96 | my $diag = ''; |
97 | |
98 | $diag .= Devel::FindRef::track ($weak_registry->{$slot}{weakref}, 20) . "\n" |
99 | if ( $ENV{TEST_VERBOSE} && eval { require Devel::FindRef }); |
100 | |
101 | if (my $stack = $weak_registry->{$slot}{stacktrace}) { |
102 | $diag .= " Reference first seen$stack"; |
103 | } |
104 | |
105 | $tb->diag($diag) if $diag; |
106 | }; |
107 | } |
108 | } |
109 | |
110 | END { |
111 | if ($INC{'Test/Builder.pm'}) { |
112 | my $tb = Test::Builder->new; |
113 | |
114 | # we check for test passage - a leak may be a part of a TODO |
115 | if ($leaks_found and !$tb->is_passing) { |
116 | |
117 | $tb->diag(sprintf |
118 | "\n\n%s\n%s\n\nInstall Devel::FindRef and re-run the test with set " |
119 | . '$ENV{TEST_VERBOSE} (prove -v) to see a more detailed leak-report' |
120 | . "\n\n%s\n%s\n\n", ('#' x 16) x 4 |
121 | ) if ( !$ENV{TEST_VERBOSE} or !$INC{'Devel/FindRef.pm'} ); |
122 | |
123 | } |
124 | else { |
125 | $tb->note("Auto checked $refs_traced references for leaks - none detected"); |
126 | } |
127 | } |
128 | } |
129 | |
130 | 1; |