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