1 package DBICTest::Util;
7 use Scalar::Util qw/isweak weaken blessed reftype refaddr/;
11 our @EXPORT_OK = qw/local_umask stacktrace populate_weakregistry assert_empty_weakregistry/;
14 return unless defined $Config{d_umask};
16 die 'Calling local_umask() in void context makes no sense'
17 if ! defined wantarray;
19 my $old_umask = umask(shift());
20 die "Setting umask failed: $!" unless defined $old_umask;
22 return bless \$old_umask, 'DBICTest::Util::UmaskGuard';
25 package DBICTest::Util::UmaskGuard;
28 eval { defined (umask ${$_[0]}) or die };
29 warn ( "Unable to reset old umask ${$_[0]}: " . ($!||'Unknown error') )
40 while (@frame = caller($frame++)) {
41 push @stack, [@frame[3,1,2]];
44 return undef unless @stack;
47 return join "\tinvoked as ", map { sprintf ("%s at %s line %d\n", @$_ ) } @stack;
51 sub populate_weakregistry {
52 my ($reg, $target, $slot) = @_;
54 croak 'Target is not a reference' unless defined ref $target;
56 $slot ||= (sprintf '%s%s(0x%x)', # so we don't trigger stringification
57 (defined blessed $target) ? blessed($target) . '=' : '',
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";
70 weaken( $reg->{$slot}{weakref} = $target );
71 $reg->{$slot}{stacktrace} = stacktrace(1);
78 sub assert_empty_weakregistry {
79 my ($weak_registry, $quiet) = @_;
81 croak 'Expecting a registry hashref' unless ref $weak_registry eq 'HASH';
83 return unless keys %$weak_registry;
85 my $tb = eval { Test::Builder->new }
86 or croak 'Calling test_weakregistry without a loaded Test::Builder makes no sense';
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} );
95 for my $slot (sort keys %$weak_registry) {
96 ! defined $weak_registry->{$slot}{weakref} and next if $quiet;
98 $tb->ok (! defined $weak_registry->{$slot}{weakref}, "No leaks of $slot") or do {
103 $diag .= Devel::FindRef::track ($weak_registry->{$slot}{weakref}, 20) . "\n"
104 if ( $ENV{TEST_VERBOSE} && eval { require Devel::FindRef });
106 if (my $stack = $weak_registry->{$slot}{stacktrace}) {
107 $diag .= " Reference first seen$stack";
110 $tb->diag($diag) if $diag;
116 if ($INC{'Test/Builder.pm'}) {
117 my $tb = Test::Builder->new;
119 # we check for test passage - a leak may be a part of a TODO
120 if ($leaks_found and !$tb->is_passing) {
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'} );
130 $tb->note("Auto checked $refs_traced references for leaks - none detected");