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