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, 2013-2018 -- leonerd@leonerd.org.uk |
5
|
|
|
|
|
|
|
|
6
|
|
|
|
|
|
|
package Devel::MAT::Tool::Reachability 0.50; |
7
|
|
|
|
|
|
|
|
8
|
5
|
|
|
5
|
|
3907
|
use v5.14; |
|
5
|
|
|
|
|
22
|
|
9
|
5
|
|
|
5
|
|
30
|
use warnings; |
|
5
|
|
|
|
|
14
|
|
|
5
|
|
|
|
|
142
|
|
10
|
|
|
|
|
|
|
|
11
|
5
|
|
|
5
|
|
31
|
use constant FOR_UI => 1; |
|
5
|
|
|
|
|
15
|
|
|
5
|
|
|
|
|
261
|
|
12
|
|
|
|
|
|
|
|
13
|
5
|
|
|
5
|
|
55
|
use List::Util qw( pairvalues ); |
|
5
|
|
|
|
|
20
|
|
|
5
|
|
|
|
|
416
|
|
14
|
|
|
|
|
|
|
|
15
|
|
|
|
|
|
|
=head1 NAME |
16
|
|
|
|
|
|
|
|
17
|
|
|
|
|
|
|
C - analyse how SVs are reachable |
18
|
|
|
|
|
|
|
|
19
|
|
|
|
|
|
|
=head1 DESCRIPTION |
20
|
|
|
|
|
|
|
|
21
|
|
|
|
|
|
|
This C tool determines which SVs are reachable via any known roots |
22
|
|
|
|
|
|
|
and which are not. For reachable SVs, they are classified into several broad |
23
|
|
|
|
|
|
|
categories: |
24
|
|
|
|
|
|
|
|
25
|
|
|
|
|
|
|
=over 2 |
26
|
|
|
|
|
|
|
|
27
|
|
|
|
|
|
|
=item * |
28
|
|
|
|
|
|
|
|
29
|
|
|
|
|
|
|
SVs that directly make up the symbol table. |
30
|
|
|
|
|
|
|
|
31
|
|
|
|
|
|
|
=item * |
32
|
|
|
|
|
|
|
|
33
|
|
|
|
|
|
|
SVs that form the padlist of functions or store the names of lexical |
34
|
|
|
|
|
|
|
variables. |
35
|
|
|
|
|
|
|
|
36
|
|
|
|
|
|
|
=item * |
37
|
|
|
|
|
|
|
|
38
|
|
|
|
|
|
|
SVs that hold the value of lexical variables. |
39
|
|
|
|
|
|
|
|
40
|
|
|
|
|
|
|
=item * |
41
|
|
|
|
|
|
|
|
42
|
|
|
|
|
|
|
User data stored in package globals, lexical variables, or referenced |
43
|
|
|
|
|
|
|
recursively via structures stored in them. |
44
|
|
|
|
|
|
|
|
45
|
|
|
|
|
|
|
=item * |
46
|
|
|
|
|
|
|
|
47
|
|
|
|
|
|
|
Miscellaneous other SVs that are used to implement the internals of the |
48
|
|
|
|
|
|
|
interpreter. |
49
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
=back |
51
|
|
|
|
|
|
|
|
52
|
|
|
|
|
|
|
=cut |
53
|
|
|
|
|
|
|
|
54
|
|
|
|
|
|
|
use constant { |
55
|
5
|
|
|
|
|
8518
|
REACH_SYMTAB => 1, |
56
|
|
|
|
|
|
|
REACH_USER => 2, |
57
|
|
|
|
|
|
|
REACH_PADLIST => 3, |
58
|
|
|
|
|
|
|
REACH_LEXICAL => 4, |
59
|
|
|
|
|
|
|
REACH_INTERNAL => 5, |
60
|
5
|
|
|
5
|
|
40
|
}; |
|
5
|
|
|
|
|
10
|
|
61
|
|
|
|
|
|
|
|
62
|
|
|
|
|
|
|
sub new |
63
|
|
|
|
|
|
|
{ |
64
|
1
|
|
|
1
|
0
|
4
|
my $class = shift; |
65
|
1
|
|
|
|
|
4
|
my ( $pmat, %args ) = @_; |
66
|
|
|
|
|
|
|
|
67
|
|
|
|
|
|
|
*Devel::MAT::SV::reachable = sub { |
68
|
2
|
|
|
2
|
|
41
|
my $sv = shift; |
69
|
2
|
|
|
|
|
19
|
return $sv->{tool_reachable}; |
70
|
1
|
|
|
|
|
61
|
}; |
71
|
|
|
|
|
|
|
|
72
|
1
|
|
|
|
|
8
|
$class->mark_reachable( $pmat->dumpfile, progress => $args{progress} ); |
73
|
|
|
|
|
|
|
|
74
|
1
|
|
|
|
|
19
|
return $class; |
75
|
|
|
|
|
|
|
} |
76
|
|
|
|
|
|
|
|
77
|
|
|
|
|
|
|
my @ICONS = ( |
78
|
|
|
|
|
|
|
"none", "symtab", "user", "padlist", "lexical", "internal" |
79
|
|
|
|
|
|
|
); |
80
|
|
|
|
|
|
|
sub _reach2icon |
81
|
|
|
|
|
|
|
{ |
82
|
0
|
|
|
0
|
|
0
|
my ( $sv ) = @_; |
83
|
0
|
|
0
|
|
|
0
|
my $reach = $sv->{tool_reachable} // 0; |
84
|
|
|
|
|
|
|
|
85
|
0
|
|
0
|
|
|
0
|
my $icon = $ICONS[$reach] // die "Unknown reachability value $reach"; |
86
|
0
|
|
|
|
|
0
|
return "reachable-$icon"; |
87
|
|
|
|
|
|
|
} |
88
|
|
|
|
|
|
|
|
89
|
|
|
|
|
|
|
sub init_ui |
90
|
|
|
|
|
|
|
{ |
91
|
0
|
|
|
0
|
0
|
0
|
my $self = shift; |
92
|
0
|
|
|
|
|
0
|
my ( $ui ) = @_; |
93
|
|
|
|
|
|
|
|
94
|
0
|
|
|
|
|
0
|
foreach ( @ICONS ) { |
95
|
0
|
|
|
|
|
0
|
$ui->register_icon( |
96
|
|
|
|
|
|
|
name => "reachable-$_", |
97
|
|
|
|
|
|
|
svg => "icons/reachable-$_.svg" |
98
|
|
|
|
|
|
|
); |
99
|
|
|
|
|
|
|
} |
100
|
|
|
|
|
|
|
|
101
|
0
|
|
|
|
|
0
|
my $column = $ui->provides_svlist_column( |
102
|
|
|
|
|
|
|
title => "R", |
103
|
|
|
|
|
|
|
type => "icon", |
104
|
|
|
|
|
|
|
); |
105
|
|
|
|
|
|
|
|
106
|
0
|
|
|
|
|
0
|
$ui->provides_sv_detail( |
107
|
|
|
|
|
|
|
title => "Reachable", |
108
|
|
|
|
|
|
|
type => "icon", |
109
|
|
|
|
|
|
|
render => \&_reach2icon, |
110
|
|
|
|
|
|
|
); |
111
|
|
|
|
|
|
|
|
112
|
0
|
|
|
|
|
0
|
$ui->set_svlist_column_values( |
113
|
|
|
|
|
|
|
column => $column, |
114
|
|
|
|
|
|
|
from => \&_reach2icon, |
115
|
|
|
|
|
|
|
); |
116
|
|
|
|
|
|
|
} |
117
|
|
|
|
|
|
|
|
118
|
|
|
|
|
|
|
sub mark_reachable |
119
|
|
|
|
|
|
|
{ |
120
|
1
|
|
|
1
|
0
|
3
|
my $self = shift; |
121
|
1
|
|
|
|
|
5
|
my ( $df, %args ) = @_; |
122
|
|
|
|
|
|
|
|
123
|
1
|
|
|
|
|
2
|
my $progress = $args{progress}; |
124
|
|
|
|
|
|
|
|
125
|
1
|
|
|
|
|
2
|
my @user; |
126
|
|
|
|
|
|
|
my @internal; |
127
|
|
|
|
|
|
|
|
128
|
|
|
|
|
|
|
# First, walk the symbol table |
129
|
|
|
|
|
|
|
{ |
130
|
1
|
|
|
|
|
7
|
my @symtab = ( $df->defstash ); |
131
|
1
|
|
|
|
|
4
|
$symtab[0]->{tool_reachable} = REACH_SYMTAB; |
132
|
|
|
|
|
|
|
|
133
|
1
|
|
|
|
|
3
|
my $count = 0; |
134
|
1
|
|
|
|
|
4
|
while( @symtab ) { |
135
|
333
|
|
|
|
|
680
|
my $stash = shift @symtab; |
136
|
333
|
50
|
|
|
|
1597
|
$stash->type =~ m/^(?:STASH|CLASS)$/ or |
137
|
|
|
|
|
|
|
die "ARGH! Encountered non-stash ".$stash->desc_addr; |
138
|
|
|
|
|
|
|
|
139
|
333
|
|
|
|
|
536
|
my @more_symtab; |
140
|
|
|
|
|
|
|
my @more_user; |
141
|
|
|
|
|
|
|
|
142
|
333
|
|
|
|
|
3449
|
foreach my $key ( $stash->keys ) { |
143
|
7806
|
|
|
|
|
14358
|
my $value = $stash->value( $key ); |
144
|
|
|
|
|
|
|
|
145
|
|
|
|
|
|
|
# Keys ending :: signify sub-stashes |
146
|
7806
|
100
|
|
|
|
23472
|
if( $key =~ m/::$/ ) { |
|
|
100
|
|
|
|
|
|
147
|
333
|
|
|
|
|
786
|
push @more_symtab, $value->hash; |
148
|
|
|
|
|
|
|
} |
149
|
|
|
|
|
|
|
# Otherwise it might be a glob |
150
|
|
|
|
|
|
|
elsif( $value->type eq "GLOB" ) { |
151
|
7339
|
|
|
|
|
9742
|
my $gv = $value; |
152
|
7339
|
|
|
|
|
13662
|
$gv->{tool_reachable} = REACH_SYMTAB; |
153
|
|
|
|
|
|
|
|
154
|
7339
|
|
66
|
|
|
13181
|
defined $_ and push @more_user, $_ for |
155
|
|
|
|
|
|
|
$gv->scalar, $gv->array, $gv->hash, $gv->code, $gv->io, $gv->form; |
156
|
|
|
|
|
|
|
} |
157
|
|
|
|
|
|
|
# Otherwise it might be a SCALAR/ARRAY/HASH directly in the STASH |
158
|
|
|
|
|
|
|
else { |
159
|
134
|
|
|
|
|
196
|
push @more_user, $value; |
160
|
|
|
|
|
|
|
} |
161
|
|
|
|
|
|
|
|
162
|
7806
|
|
|
|
|
13327
|
$count++; |
163
|
7806
|
50
|
33
|
|
|
15984
|
$progress->( sprintf "Walking symbol table %d...", $count ) if $progress and $count % 1000 == 0; |
164
|
|
|
|
|
|
|
} |
165
|
|
|
|
|
|
|
|
166
|
|
|
|
|
|
|
!$_->{tool_reachable} and |
167
|
333
|
|
66
|
|
|
1931
|
$_->{tool_reachable} = REACH_SYMTAB, push @symtab, $_ for @more_symtab; |
168
|
|
|
|
|
|
|
|
169
|
|
|
|
|
|
|
!$_->{tool_reachable} and |
170
|
333
|
|
66
|
|
|
9310
|
$_->{tool_reachable} = REACH_USER, push @user, $_ for @more_user; |
171
|
|
|
|
|
|
|
|
172
|
|
|
|
|
|
|
!$_->{tool_reachable} and |
173
|
333
|
|
66
|
|
|
882
|
$_->{tool_reachable} = REACH_INTERNAL, push @internal, $_ for grep { defined } |
|
1665
|
|
|
|
|
4610
|
|
174
|
|
|
|
|
|
|
$stash->backrefs, |
175
|
|
|
|
|
|
|
$stash->mro_linearall, |
176
|
|
|
|
|
|
|
$stash->mro_linearcurrent, |
177
|
|
|
|
|
|
|
$stash->mro_nextmethod, |
178
|
|
|
|
|
|
|
$stash->mro_isa, |
179
|
|
|
|
|
|
|
$stash->magic_svs; |
180
|
|
|
|
|
|
|
|
181
|
333
|
|
|
|
|
594
|
$count++; |
182
|
333
|
50
|
33
|
|
|
1164
|
$progress->( sprintf "Walking symbol table %d...", $count ) if $progress and $count % 1000 == 0; |
183
|
|
|
|
|
|
|
} |
184
|
|
|
|
|
|
|
} |
185
|
|
|
|
|
|
|
|
186
|
|
|
|
|
|
|
# Next the reachable user data, recursively |
187
|
|
|
|
|
|
|
{ |
188
|
1
|
|
|
|
|
3
|
push @user, $df->main_cv; |
|
1
|
|
|
|
|
8
|
|
189
|
1
|
|
|
|
|
4
|
my $count = 0; |
190
|
1
|
|
|
|
|
5
|
while( @user ) { |
191
|
29143
|
50
|
|
|
|
77347
|
my $sv = shift @user or next; |
192
|
|
|
|
|
|
|
|
193
|
29143
|
|
|
|
|
41734
|
my @more_user; |
194
|
|
|
|
|
|
|
my @more_internal; |
195
|
|
|
|
|
|
|
|
196
|
29143
|
|
|
|
|
55837
|
for( $sv->type ) { |
197
|
29143
|
50
|
|
|
|
112587
|
if ( $_ eq "REF" ) { push @more_user, $sv->rv if $sv->rv } |
|
1723
|
100
|
|
|
|
3129
|
|
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
198
|
424
|
|
|
|
|
944
|
elsif( $_ eq "ARRAY" ) { push @more_user, $sv->elems; } |
199
|
536
|
|
|
|
|
1113
|
elsif( $_ eq "HASH" ) { push @more_user, $sv->values; } |
200
|
|
|
|
|
|
|
elsif( $_ eq "GLOB" ) { |
201
|
4
|
|
|
|
|
14
|
my $gv = $sv; |
202
|
4
|
50
|
|
|
|
34
|
next if $gv->{tool_reachable}; # already on symbol table |
203
|
|
|
|
|
|
|
|
204
|
0
|
|
|
|
|
0
|
warn "Found non-SYMTAB GLOB " . $gv->desc_addr . " user reachable\n"; |
205
|
|
|
|
|
|
|
# Hard to know if the GV is being used for GVSV, GVAV, GVHV or GVCV |
206
|
0
|
|
|
|
|
0
|
push @more_user, $gv->scalar, $gv->array, $gv->hash, $gv->code, $gv->egv, $gv->io, $gv->form; |
207
|
|
|
|
|
|
|
} |
208
|
|
|
|
|
|
|
elsif( $_ eq "CODE" ) { |
209
|
5425
|
|
|
|
|
8120
|
my $cv = $sv; |
210
|
|
|
|
|
|
|
|
211
|
5425
|
|
|
|
|
7477
|
my @more_padlist; |
212
|
|
|
|
|
|
|
my @more_lexical; |
213
|
|
|
|
|
|
|
|
214
|
5425
|
|
|
|
|
11104
|
push @more_padlist, $cv->padlist; |
215
|
|
|
|
|
|
|
|
216
|
5425
|
|
|
|
|
11967
|
my $padnames_av = $cv->padnames_av; |
217
|
5425
|
50
|
|
|
|
10319
|
if( $padnames_av ) { |
218
|
0
|
|
|
|
|
0
|
push @more_padlist, $padnames_av, $padnames_av->elems; |
219
|
|
|
|
|
|
|
} |
220
|
|
|
|
|
|
|
|
221
|
5425
|
|
|
|
|
9931
|
foreach my $pad ( $cv->pads ) { |
222
|
2615
|
100
|
|
|
|
5838
|
$pad or next; |
223
|
2614
|
|
|
|
|
4060
|
push @more_padlist, $pad; |
224
|
|
|
|
|
|
|
|
225
|
|
|
|
|
|
|
# PAD slot 0 is always @_ |
226
|
2614
|
100
|
|
|
|
5514
|
if( my $argsav = $pad->elem( 0 ) ) { |
227
|
2479
|
|
|
|
|
3725
|
push @more_internal, $argsav; |
228
|
|
|
|
|
|
|
} |
229
|
|
|
|
|
|
|
|
230
|
2614
|
|
|
|
|
5471
|
foreach my $padix ( 1 .. $pad->elems-1 ) { |
231
|
24056
|
50
|
|
|
|
36803
|
my $padname_sv = $padnames_av ? $padnames_av->elem( $padix ) : undef; |
232
|
24056
|
50
|
33
|
|
|
45391
|
my $padname = $padname_sv && $padname_sv->type eq "SCALAR" ? |
233
|
|
|
|
|
|
|
$padname_sv->pv : undef; |
234
|
|
|
|
|
|
|
|
235
|
24056
|
100
|
|
|
|
44075
|
my $padsv = $pad->elem( $padix ) or next; |
236
|
23427
|
50
|
|
|
|
52507
|
$padsv->immortal and next; |
237
|
|
|
|
|
|
|
|
238
|
23427
|
50
|
33
|
|
|
50766
|
if( $padname and $padname eq "&" ) { |
|
|
50
|
|
|
|
|
|
239
|
|
|
|
|
|
|
# Slots named "&" are closure prototype subs |
240
|
0
|
|
|
|
|
0
|
push @more_user, $padsv; |
241
|
|
|
|
|
|
|
} |
242
|
|
|
|
|
|
|
elsif( $padname ) { |
243
|
|
|
|
|
|
|
# Other named slots are lexical vars |
244
|
0
|
|
|
|
|
0
|
push @more_lexical, $padsv; |
245
|
|
|
|
|
|
|
} |
246
|
|
|
|
|
|
|
else { |
247
|
|
|
|
|
|
|
# Unnamed slots are just part of the padlist |
248
|
23427
|
|
|
|
|
38711
|
push @more_internal, $padsv; |
249
|
|
|
|
|
|
|
} |
250
|
|
|
|
|
|
|
} |
251
|
|
|
|
|
|
|
} |
252
|
|
|
|
|
|
|
|
253
|
5425
|
|
66
|
|
|
10910
|
$_ and push @more_user, $_ for |
254
|
|
|
|
|
|
|
$cv->scope, $cv->constval, $cv->constants, $cv->globrefs; |
255
|
|
|
|
|
|
|
|
256
|
|
|
|
|
|
|
$_ and !$_->{tool_reachable} and |
257
|
5425
|
|
66
|
|
|
22657
|
$_->{tool_reachable} = REACH_PADLIST for @more_padlist; |
|
|
|
100
|
|
|
|
|
258
|
|
|
|
|
|
|
|
259
|
|
|
|
|
|
|
$_ and !$_->{tool_reachable} and |
260
|
5425
|
|
0
|
|
|
12527
|
$_->{tool_reachable} = REACH_LEXICAL, push @user, $_ for @more_lexical; |
|
|
|
0
|
|
|
|
|
261
|
|
|
|
|
|
|
} |
262
|
|
|
|
|
|
|
elsif( $_ eq "LVALUE" ) { |
263
|
0
|
|
|
|
|
0
|
my $lv = $sv; |
264
|
|
|
|
|
|
|
|
265
|
0
|
0
|
|
|
|
0
|
push @more_internal, $lv->target if $lv->target; |
266
|
|
|
|
|
|
|
} |
267
|
|
|
|
|
|
|
elsif( $_ =~ m/^(?:UNDEF|BOOL|SCALAR|IO|REGEXP|FORMAT)$/ ) { } # ignore |
268
|
|
|
|
|
|
|
|
269
|
0
|
|
|
|
|
0
|
else { warn "Not sure what to do with user data item ".$sv->desc_addr."\n"; } |
270
|
|
|
|
|
|
|
} |
271
|
|
|
|
|
|
|
|
272
|
|
|
|
|
|
|
$_ and !$_->{tool_reachable} and !$_->immortal and |
273
|
29143
|
|
66
|
|
|
153081
|
$_->{tool_reachable} = REACH_USER, push @user, $_ for @more_user; |
|
|
|
100
|
|
|
|
|
|
|
|
66
|
|
|
|
|
274
|
|
|
|
|
|
|
|
275
|
|
|
|
|
|
|
$_ and !$_->{tool_reachable} and !$_->immortal and |
276
|
29143
|
|
66
|
|
|
58470
|
$_->{tool_reachable} = REACH_INTERNAL, push @internal, $_ for |
|
|
|
66
|
|
|
|
|
|
|
|
66
|
|
|
|
|
277
|
|
|
|
|
|
|
@more_internal, |
278
|
346
|
|
|
|
|
2294
|
grep { defined } $sv->magic_svs; |
279
|
|
|
|
|
|
|
|
280
|
29143
|
|
|
|
|
39005
|
$count++; |
281
|
29143
|
50
|
33
|
|
|
74968
|
$progress->( sprintf "Marking user reachability %d...", $count ) if $progress and $count % 1000 == 0; |
282
|
|
|
|
|
|
|
} |
283
|
|
|
|
|
|
|
} |
284
|
|
|
|
|
|
|
|
285
|
|
|
|
|
|
|
# Finally internals |
286
|
|
|
|
|
|
|
{ |
287
|
1
|
|
|
|
|
3
|
push @internal, pairvalues $df->roots; |
|
1
|
|
|
|
|
10
|
|
|
1
|
|
|
|
|
8
|
|
288
|
1
|
|
|
|
|
15
|
my $count = 0; |
289
|
1
|
|
|
|
|
6
|
while( @internal ) { |
290
|
26895
|
100
|
|
|
|
56691
|
my $sv = shift @internal or next; |
291
|
26863
|
100
|
|
|
|
67873
|
next if $sv->{tool_reachable}; |
292
|
|
|
|
|
|
|
|
293
|
216
|
|
|
|
|
537
|
$sv->{tool_reachable} = REACH_INTERNAL; |
294
|
|
|
|
|
|
|
|
295
|
216
|
50
|
|
|
|
541
|
push @internal, map { $_->sv ? $_->sv : () } $sv->outrefs; |
|
616
|
|
|
|
|
4282
|
|
296
|
|
|
|
|
|
|
|
297
|
216
|
|
|
|
|
1319
|
$count++; |
298
|
216
|
50
|
33
|
|
|
637
|
$progress->( sprintf "Marking internal reachability %d...", $count ) if $progress and $count % 1000 == 0; |
299
|
|
|
|
|
|
|
} |
300
|
|
|
|
|
|
|
} |
301
|
|
|
|
|
|
|
} |
302
|
|
|
|
|
|
|
|
303
|
|
|
|
|
|
|
=head1 SV METHODS |
304
|
|
|
|
|
|
|
|
305
|
|
|
|
|
|
|
This tool adds the following SV methods. |
306
|
|
|
|
|
|
|
|
307
|
|
|
|
|
|
|
=head2 reachable |
308
|
|
|
|
|
|
|
|
309
|
|
|
|
|
|
|
$r = $sv->reachable |
310
|
|
|
|
|
|
|
|
311
|
|
|
|
|
|
|
Returns true if the SV is reachable from a known root. |
312
|
|
|
|
|
|
|
|
313
|
|
|
|
|
|
|
=cut |
314
|
|
|
|
|
|
|
|
315
|
|
|
|
|
|
|
=head1 AUTHOR |
316
|
|
|
|
|
|
|
|
317
|
|
|
|
|
|
|
Paul Evans |
318
|
|
|
|
|
|
|
|
319
|
|
|
|
|
|
|
=cut |
320
|
|
|
|
|
|
|
|
321
|
|
|
|
|
|
|
0x55AA; |