1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
|
package DBICTest::Util;
use warnings;
use strict;
use Carp;
use Scalar::Util qw/isweak weaken blessed reftype refaddr/;
use Config;
use base 'Exporter';
our @EXPORT_OK = qw/local_umask stacktrace populate_weakregistry assert_empty_weakregistry/;
sub local_umask {
return unless defined $Config{d_umask};
die 'Calling local_umask() in void context makes no sense'
if ! defined wantarray;
my $old_umask = umask(shift());
die "Setting umask failed: $!" unless defined $old_umask;
return bless \$old_umask, 'DBICTest::Util::UmaskGuard';
}
{
package DBICTest::Util::UmaskGuard;
sub DESTROY {
local ($@, $!);
eval { defined (umask ${$_[0]}) or die };
warn ( "Unable to reset old umask ${$_[0]}: " . ($!||'Unknown error') )
if ($@ || $!);
}
}
sub stacktrace {
my $frame = shift;
$frame++;
my (@stack, @frame);
while (@frame = caller($frame++)) {
push @stack, [@frame[3,1,2]];
}
return undef unless @stack;
$stack[0][0] = '';
return join "\tinvoked as ", map { sprintf ("%s at %s line %d\n", @$_ ) } @stack;
}
my $refs_traced = 0;
sub populate_weakregistry {
my ($reg, $target, $slot) = @_;
croak 'Target is not a reference' unless defined ref $target;
$slot ||= (sprintf '%s%s(0x%x)', # so we don't trigger stringification
(defined blessed $target) ? blessed($target) . '=' : '',
reftype $target,
refaddr $target,
);
if (defined $reg->{$slot}{weakref}) {
if ( refaddr($reg->{$slot}{weakref}) != (refaddr $target) ) {
print STDERR "Bail out! Weak Registry slot collision: $reg->{$slot}{weakref} / $target\n";
exit 255;
}
}
else {
$refs_traced++;
weaken( $reg->{$slot}{weakref} = $target );
$reg->{$slot}{stacktrace} = stacktrace(1);
}
$target;
}
my $leaks_found;
sub assert_empty_weakregistry {
my ($weak_registry, $quiet) = @_;
croak 'Expecting a registry hashref' unless ref $weak_registry eq 'HASH';
return unless keys %$weak_registry;
my $tb = eval { Test::Builder->new }
or croak 'Calling test_weakregistry without a loaded Test::Builder makes no sense';
for my $slot (sort keys %$weak_registry) {
next if ! defined $weak_registry->{$slot}{weakref};
$tb->BAILOUT("!!!! WEAK REGISTRY SLOT $slot IS NOT A WEAKREF !!!!")
unless isweak( $weak_registry->{$slot}{weakref} );
}
for my $slot (sort keys %$weak_registry) {
! defined $weak_registry->{$slot}{weakref} and next if $quiet;
$tb->ok (! defined $weak_registry->{$slot}{weakref}, "No leaks of $slot") or do {
$leaks_found = 1;
my $diag = '';
$diag .= Devel::FindRef::track ($weak_registry->{$slot}{weakref}, 20) . "\n"
if ( $ENV{TEST_VERBOSE} && eval { require Devel::FindRef });
if (my $stack = $weak_registry->{$slot}{stacktrace}) {
$diag .= " Reference first seen$stack";
}
$tb->diag($diag) if $diag;
};
}
}
END {
if ($INC{'Test/Builder.pm'}) {
my $tb = Test::Builder->new;
# we check for test passage - a leak may be a part of a TODO
if ($leaks_found and !$tb->is_passing) {
$tb->diag(sprintf
"\n\n%s\n%s\n\nInstall Devel::FindRef and re-run the test with set "
. '$ENV{TEST_VERBOSE} (prove -v) to see a more detailed leak-report'
. "\n\n%s\n%s\n\n", ('#' x 16) x 4
) if ( !$ENV{TEST_VERBOSE} or !$INC{'Devel/FindRef.pm'} );
}
else {
$tb->note("Auto checked $refs_traced references for leaks - none detected");
}
}
}
1;
|
