File Coverage

blib/lib/Devel/MAT/Tool/ListDanglingPtrs.pm
Criterion Covered Total %
statement 20 58 34.4
branch 0 18 0.0
condition 0 3 0.0
subroutine 7 10 70.0
pod 0 2 0.0
total 27 91 29.6


line stmt bran cond sub pod time code
1             # You may distribute under the terms of either the GNU General Public License
2             # or the Artistic License (the same terms as Perl itself)
3             #
4             # (C) Paul Evans, 2022 -- leonerd@leonerd.org.uk
5              
6             package Devel::MAT::Tool::ListDanglingPtrs 0.49;
7              
8 5     5   9630 use v5.14;
  5         19  
9 5     5   29 use warnings;
  5         9  
  5         210  
10 5     5   24 use base qw( Devel::MAT::Tool );
  5         10  
  5         745  
11              
12 5     5   31 use List::Util qw( pairs );
  5         10  
  5         439  
13              
14 5     5   32 use constant CMD => "list-dangling-ptrs";
  5         10  
  5         428  
15 5     5   30 use constant CMD_DESC => "Show pointers in SVs that don't lead anywhere";
  5         16  
  5         537  
16              
17             =head1 NAME
18              
19             C - display a list of SV pointer fields that do not point at known SVs
20              
21             =head1 DESCRIPTION
22              
23             This C tool displays a list of fields from known SVs containing
24             non-NULL addresses, but which do not point to other known SVs. These are so-called
25             "dangling pointers".
26              
27             =cut
28              
29             =head1 COMMANDS
30              
31             =head2 list-dangling-ptrs
32              
33             pmat> list-dangling-ptrs
34             CODE(proto) at 0x55b9d83ae3d8 has no constval SV at addr 0x55b9d83963f0
35             ...
36              
37             Prints a list of fields in SVs which do not point at other valid SVs.
38              
39             =cut
40              
41             my %methodcache;
42             sub methods_of
43             {
44 0     0 0   my ( $pkg ) = @_;
45 0   0       my $methods = $methodcache{$pkg} //= do {
46 5     5   31 no strict 'refs';
  5         11  
  5         3116  
47 0           my @syms = keys %{"${pkg}::"};
  0            
48             [
49 0           ( grep { *{"${pkg}::$_"}{CODE} } @syms ),
  0            
50 0           map { methods_of( $_ ) } @{"${pkg}::ISA"}
  0            
  0            
51             ]
52             };
53 0           return @$methods;
54             }
55              
56             sub run
57             {
58 0     0 0   my $self = shift;
59              
60 0           my $df = $self->df;
61              
62 0           my %roots_at;
63 0           foreach ( pairs $df->roots ) {
64 0           my ( $name, $sv ) = @$_;
65             $sv and
66 0 0         $roots_at{ $sv->addr } = $name;
67             }
68              
69             my $test_ptr = sub {
70 0     0     my $self = shift;
71 0           my ( $sv, $name, $addr ) = @_;
72              
73 0 0         $addr or return;
74 0 0         $roots_at{$addr} and return;
75 0 0         $df->{heap}{$addr} and return;
76              
77 0           Devel::MAT::Cmd->printf( "%s has no %s SV at addr 0x%x\n",
78             Devel::MAT::Cmd->format_sv( $sv ),
79             $name,
80             $addr,
81             );
82 0           };
83              
84 0           foreach my $sv ( $self->df->heap ) {
85             # Quite a bit of cheating here. We'll presume that any _at method gives
86             # a number that should be a raw SV pointer address
87 0           foreach my $meth ( methods_of ref $sv ) {
88 0 0         if( $meth eq "field" ) {
89             # Struct fields might or mightnot be SV pointers. We'll have to ask them
90 0           my $fields = $sv->structtype->fields;
91 0           foreach my $idx ( 0 .. $#$fields ) {
92 0           my $field = $fields->[$idx];
93 0 0         if( $field->type == 0 ) {
94 0           $self->$test_ptr( $sv, "field <${\$field->name}>", $sv->$meth( $idx ) );
  0            
95             }
96             }
97             }
98              
99 0 0         next unless $meth =~ m/^([^_].*)_at$/;
100 0           my $outref = $1;
101              
102 0 0         if( $outref eq "elem" ) {
    0          
103 0           $self->$test_ptr( $sv, "$outref [$_]", $sv->$meth( $_ ) ) for 0 .. $sv->elems-1;
104             }
105             elsif( $outref eq "value" ) {
106 0           $self->$test_ptr( $sv, "$outref {$_}", $sv->$meth( $_ ) ) for $sv->keys;
107             }
108             else {
109 0           $self->$test_ptr( $sv, $outref, $sv->$meth );
110             }
111             }
112             }
113             }
114              
115             =head1 AUTHOR
116              
117             Paul Evans
118              
119             =cut
120              
121             0x55AA;