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 | |
27 | sub populate_weakregistry { |
28 | my ($reg, $target, $slot) = @_; |
29 | |
30 | |
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 | |
39 | weaken( $reg->{$slot}{weakref} = $target ); |
40 | $reg->{$slot}{stacktrace} = stacktrace(1); |
41 | |
42 | $target; |
43 | } |
44 | |
45 | my $leaks_found; |
46 | sub assert_empty_weakregistry { |
47 | my ($weak_registry, $quiet) = @_; |
48 | |
49 | croak 'Expecting a registry hashref' unless ref $weak_registry eq 'HASH'; |
50 | |
51 | return unless keys %$weak_registry; |
52 | |
53 | my $tb = eval { Test::Builder->new } |
54 | or croak 'Calling test_weakregistry without a loaded Test::Builder makes no sense'; |
55 | |
56 | for my $slot (sort keys %$weak_registry) { |
57 | next if ! defined $weak_registry->{$slot}{weakref}; |
58 | $tb->BAILOUT("!!!! WEAK REGISTRY SLOT $slot IS NOT A WEAKREF !!!!") |
59 | unless isweak( $weak_registry->{$slot}{weakref} ); |
60 | } |
61 | |
62 | |
63 | for my $slot (sort keys %$weak_registry) { |
64 | ! defined $weak_registry->{$slot}{weakref} and next if $quiet; |
65 | |
66 | $tb->ok (! defined $weak_registry->{$slot}{weakref}, "No leaks of $slot") or do { |
67 | $leaks_found = 1; |
68 | |
69 | my $diag = ''; |
70 | |
71 | $diag .= Devel::FindRef::track ($weak_registry->{$slot}{weakref}, 20) . "\n" |
72 | if ( $ENV{TEST_VERBOSE} && eval { require Devel::FindRef }); |
73 | |
74 | if (my $stack = $weak_registry->{$slot}{stacktrace}) { |
75 | $diag .= " Reference first seen$stack"; |
76 | } |
77 | |
78 | $tb->diag($diag) if $diag; |
79 | }; |
80 | } |
81 | } |
82 | |
83 | END { |
84 | if ($leaks_found) { |
85 | my $tb = Test::Builder->new; |
86 | $tb->diag(sprintf |
87 | "\n\n%s\n%s\n\nInstall Devel::FindRef and re-run the test with set " |
88 | . '$ENV{TEST_VERBOSE} (prove -v) to see a more detailed leak-report' |
89 | . "\n\n%s\n%s\n\n", ('#' x 16) x 4 |
90 | ) if (!$tb->is_passing and (!$ENV{TEST_VERBOSE} or !$INC{'Devel/FindRef.pm'})); |
91 | } |
92 | } |
93 | |
94 | 1; |