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, 2016-2018 -- leonerd@leonerd.org.uk |
5
|
|
|
|
|
|
|
|
6
|
|
|
|
|
|
|
package Devel::MAT::Tool 0.49; |
7
|
|
|
|
|
|
|
|
8
|
9
|
|
|
9
|
|
95
|
use v5.14; |
|
9
|
|
|
|
|
29
|
|
9
|
9
|
|
|
9
|
|
44
|
use warnings; |
|
9
|
|
|
|
|
16
|
|
|
9
|
|
|
|
|
225
|
|
10
|
|
|
|
|
|
|
|
11
|
9
|
|
|
9
|
|
49
|
use Syntax::Keyword::Match; |
|
9
|
|
|
|
|
15
|
|
|
9
|
|
|
|
|
59
|
|
12
|
|
|
|
|
|
|
|
13
|
9
|
|
|
9
|
|
449
|
use List::Util qw( any ); |
|
9
|
|
|
|
|
23
|
|
|
9
|
|
|
|
|
594
|
|
14
|
9
|
|
|
9
|
|
3661
|
use Commandable::Invocation; |
|
9
|
|
|
|
|
5755
|
|
|
9
|
|
|
|
|
2487
|
|
15
|
|
|
|
|
|
|
Commandable::Invocation->VERSION( '0.04' ); # ->peek_remaining |
16
|
|
|
|
|
|
|
|
17
|
|
|
|
|
|
|
sub new |
18
|
|
|
|
|
|
|
{ |
19
|
4
|
|
|
4
|
0
|
12
|
my $class = shift; |
20
|
4
|
|
|
|
|
9
|
my ( $pmat, %args ) = @_; |
21
|
|
|
|
|
|
|
|
22
|
|
|
|
|
|
|
my $self = bless { |
23
|
|
|
|
|
|
|
pmat => $pmat, |
24
|
|
|
|
|
|
|
df => $pmat->dumpfile, |
25
|
|
|
|
|
|
|
progress => $args{progress}, |
26
|
4
|
|
|
|
|
19
|
}, $class; |
27
|
|
|
|
|
|
|
|
28
|
4
|
100
|
|
|
|
28
|
$self->init_tool if $self->can( 'init_tool' ); |
29
|
|
|
|
|
|
|
|
30
|
4
|
|
|
|
|
43
|
return $self; |
31
|
|
|
|
|
|
|
} |
32
|
|
|
|
|
|
|
|
33
|
|
|
|
|
|
|
sub pmat |
34
|
|
|
|
|
|
|
{ |
35
|
0
|
|
|
0
|
0
|
0
|
my $self = shift; |
36
|
0
|
|
|
|
|
0
|
return $self->{pmat}; |
37
|
|
|
|
|
|
|
} |
38
|
|
|
|
|
|
|
|
39
|
|
|
|
|
|
|
sub df |
40
|
|
|
|
|
|
|
{ |
41
|
2
|
|
|
2
|
0
|
5
|
my $self = shift; |
42
|
2
|
|
|
|
|
8
|
return $self->{df}; |
43
|
|
|
|
|
|
|
} |
44
|
|
|
|
|
|
|
|
45
|
|
|
|
|
|
|
sub report_progress |
46
|
|
|
|
|
|
|
{ |
47
|
16
|
|
|
16
|
0
|
40
|
my $self = shift; |
48
|
16
|
50
|
|
|
|
90
|
$self->{progress}->( @_ ) if $self->{progress}; |
49
|
|
|
|
|
|
|
} |
50
|
|
|
|
|
|
|
|
51
|
|
|
|
|
|
|
sub get_sv_from_inv |
52
|
|
|
|
|
|
|
{ |
53
|
0
|
|
|
0
|
0
|
|
my $self = shift; |
54
|
0
|
|
|
|
|
|
my ( $inv ) = @_; |
55
|
|
|
|
|
|
|
|
56
|
0
|
|
0
|
|
|
|
my $sv = Devel::MAT::UI->can( "current_sv" ) && Devel::MAT::UI->current_sv; |
57
|
|
|
|
|
|
|
|
58
|
0
|
0
|
|
|
|
|
if( defined( my $addr = $inv->pull_token ) ) { |
59
|
|
|
|
|
|
|
# Acccept any root name symbolically |
60
|
0
|
0
|
|
0
|
|
|
if( any { $addr eq $_ } Devel::MAT::Dumpfile->ROOTS ) { |
|
0
|
0
|
|
|
|
|
|
61
|
0
|
|
|
|
|
|
$sv = $self->df->$addr; |
62
|
|
|
|
|
|
|
} |
63
|
|
|
|
|
|
|
# Accept named symbols |
64
|
|
|
|
|
|
|
elsif( $addr =~ m/^[\$\@\%\&]/ ) { |
65
|
0
|
|
|
|
|
|
$sv = $self->pmat->find_symbol( $addr ); |
66
|
|
|
|
|
|
|
} |
67
|
|
|
|
|
|
|
else { |
68
|
0
|
0
|
|
|
|
|
$addr = do { |
69
|
9
|
|
|
9
|
|
62
|
no warnings 'portable'; |
|
9
|
|
|
|
|
15
|
|
|
9
|
|
|
|
|
748
|
|
70
|
0
|
|
|
|
|
|
hex $addr; |
71
|
|
|
|
|
|
|
} if $addr =~ m/^0x/; |
72
|
|
|
|
|
|
|
|
73
|
9
|
0
|
|
9
|
|
54
|
do { no warnings 'numeric'; $addr eq $addr+0 } or |
|
9
|
|
|
|
|
25
|
|
|
9
|
|
|
|
|
1056
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
74
|
|
|
|
|
|
|
die "Expected numerical SV address\n"; |
75
|
|
|
|
|
|
|
|
76
|
0
|
0
|
|
|
|
|
$sv = $self->df->sv_at( $addr ) or |
77
|
|
|
|
|
|
|
die sprintf "No such SV at address %x\n", $addr; |
78
|
|
|
|
|
|
|
} |
79
|
|
|
|
|
|
|
} |
80
|
|
|
|
|
|
|
|
81
|
0
|
0
|
|
|
|
|
$sv or die "Need an SV address\n"; |
82
|
|
|
|
|
|
|
|
83
|
0
|
|
|
|
|
|
return $sv; |
84
|
|
|
|
|
|
|
} |
85
|
|
|
|
|
|
|
|
86
|
|
|
|
|
|
|
# Some empty defaults |
87
|
9
|
|
|
9
|
|
53
|
use constant CMD_OPTS => (); |
|
9
|
|
|
|
|
17
|
|
|
9
|
|
|
|
|
547
|
|
88
|
9
|
|
|
9
|
|
45
|
use constant CMD_ARGS_SV => 0; |
|
9
|
|
|
|
|
20
|
|
|
9
|
|
|
|
|
456
|
|
89
|
9
|
|
|
9
|
|
59
|
use constant CMD_ARGS => (); |
|
9
|
|
|
|
|
28
|
|
|
9
|
|
|
|
|
5889
|
|
90
|
|
|
|
|
|
|
|
91
|
|
|
|
|
|
|
sub find_subcommand |
92
|
|
|
|
|
|
|
{ |
93
|
0
|
|
|
0
|
0
|
|
my $self = shift; |
94
|
0
|
|
|
|
|
|
my ( $subname ) = @_; |
95
|
|
|
|
|
|
|
|
96
|
|
|
|
|
|
|
# TODO: sanity check |
97
|
|
|
|
|
|
|
|
98
|
|
|
|
|
|
|
return ( ref($self) . "::" . $subname )->new( $self->pmat, |
99
|
|
|
|
|
|
|
progress => $self->{progress}, |
100
|
0
|
|
|
|
|
|
); |
101
|
|
|
|
|
|
|
} |
102
|
|
|
|
|
|
|
|
103
|
|
|
|
|
|
|
sub parse_cmd |
104
|
|
|
|
|
|
|
{ |
105
|
0
|
|
|
0
|
0
|
|
my $self = shift; |
106
|
0
|
|
|
|
|
|
my ( $inv ) = @_; |
107
|
|
|
|
|
|
|
|
108
|
0
|
|
|
|
|
|
my @args; |
109
|
|
|
|
|
|
|
|
110
|
0
|
0
|
|
|
|
|
if( my %optspec = $self->CMD_OPTS ) { |
111
|
0
|
|
|
|
|
|
push @args, $self->get_opts_from_inv( $inv, \%optspec ); |
112
|
|
|
|
|
|
|
} |
113
|
|
|
|
|
|
|
|
114
|
0
|
0
|
|
|
|
|
if( $self->CMD_ARGS_SV ) { |
115
|
0
|
|
|
|
|
|
push @args, $self->get_sv_from_inv( $inv ); |
116
|
|
|
|
|
|
|
} |
117
|
|
|
|
|
|
|
|
118
|
0
|
0
|
|
|
|
|
if( my @argspec = $self->CMD_ARGS ) { |
119
|
0
|
|
|
|
|
|
push @args, $self->get_args_from_inv( $inv, @argspec ); |
120
|
|
|
|
|
|
|
} |
121
|
|
|
|
|
|
|
|
122
|
0
|
|
|
|
|
|
return @args; |
123
|
|
|
|
|
|
|
} |
124
|
|
|
|
|
|
|
|
125
|
|
|
|
|
|
|
sub run_cmd |
126
|
|
|
|
|
|
|
{ |
127
|
0
|
|
|
0
|
0
|
|
my $self = shift; |
128
|
0
|
|
|
|
|
|
my ( $inv ) = @_; |
129
|
|
|
|
|
|
|
|
130
|
0
|
|
|
|
|
|
$self->run( $self->parse_cmd( $inv ) ); |
131
|
|
|
|
|
|
|
} |
132
|
|
|
|
|
|
|
|
133
|
|
|
|
|
|
|
sub get_opts_from_inv |
134
|
|
|
|
|
|
|
{ |
135
|
0
|
|
|
0
|
0
|
|
my $self = shift; |
136
|
0
|
|
|
|
|
|
my ( $inv, $optspec, %args ) = @_; |
137
|
|
|
|
|
|
|
|
138
|
0
|
|
0
|
|
|
|
my $permute = $args{permute} // 1; |
139
|
|
|
|
|
|
|
|
140
|
0
|
|
|
|
|
|
my %opts; |
141
|
|
|
|
|
|
|
my %aliases; |
142
|
|
|
|
|
|
|
|
143
|
0
|
|
|
|
|
|
foreach my $name ( keys %$optspec ) { |
144
|
0
|
|
|
|
|
|
my $spec = $optspec->{$name}; |
145
|
|
|
|
|
|
|
|
146
|
0
|
|
|
|
|
|
$opts{$name} = $spec->{default}; |
147
|
|
|
|
|
|
|
|
148
|
0
|
0
|
|
|
|
|
$aliases{ $spec->{alias} } = $name if defined $spec->{alias}; |
149
|
|
|
|
|
|
|
} |
150
|
|
|
|
|
|
|
|
151
|
0
|
|
|
|
|
|
my @remaining; |
152
|
|
|
|
|
|
|
|
153
|
0
|
|
|
|
|
|
while( defined( my $opt = $inv->pull_token ) ) { |
154
|
0
|
0
|
|
|
|
|
last if $opt eq "--"; |
155
|
|
|
|
|
|
|
|
156
|
0
|
0
|
|
|
|
|
if( $opt =~ m/^--(.*)$/ ) { |
|
|
0
|
|
|
|
|
|
157
|
0
|
|
|
|
|
|
$opt = $1; |
158
|
|
|
|
|
|
|
} |
159
|
|
|
|
|
|
|
elsif( $opt =~ m/^-(.)$/ ) { |
160
|
0
|
0
|
|
|
|
|
$opt = $aliases{$1} or die "No such option '-$1'\n"; |
161
|
|
|
|
|
|
|
} |
162
|
|
|
|
|
|
|
else { |
163
|
0
|
|
|
|
|
|
push @remaining, $opt; |
164
|
|
|
|
|
|
|
|
165
|
0
|
0
|
|
|
|
|
last if !$permute; |
166
|
0
|
|
|
|
|
|
next; |
167
|
|
|
|
|
|
|
} |
168
|
|
|
|
|
|
|
|
169
|
0
|
0
|
|
|
|
|
my $spec = $optspec->{$opt} or die "No such option '--$opt'\n"; |
170
|
|
|
|
|
|
|
|
171
|
0
|
|
|
|
|
|
my $val; |
172
|
|
|
|
|
|
|
match( $spec->{type} // "" : eq ) { |
173
|
|
|
|
|
|
|
case( "" ) { |
174
|
0
|
|
|
|
|
|
$val = 1; |
175
|
|
|
|
|
|
|
} |
176
|
|
|
|
|
|
|
case( "s" ) { |
177
|
0
|
0
|
|
|
|
|
defined( $val = $inv->pull_token ) or |
178
|
|
|
|
|
|
|
die "Option --$opt requires a value\n"; |
179
|
|
|
|
|
|
|
} |
180
|
|
|
|
|
|
|
case( "i" ) { |
181
|
0
|
0
|
|
|
|
|
defined( $val = $inv->pull_token ) or |
182
|
|
|
|
|
|
|
die "Option --$opt requires a value\n"; |
183
|
0
|
0
|
|
|
|
|
$val =~ m/^-?\d+$/ or |
184
|
|
|
|
|
|
|
die "Option --$opt value '$val' is not a number\n"; |
185
|
|
|
|
|
|
|
} |
186
|
|
|
|
|
|
|
case( "x" ) { |
187
|
0
|
0
|
|
|
|
|
defined( $val = $inv->pull_token ) or |
188
|
|
|
|
|
|
|
die "Option --$opt requires a value\n"; |
189
|
0
|
0
|
0
|
|
|
|
$val =~ m/^-?\d+$/ or $val =~ m/^0x[0-9a-f]+$/i or |
190
|
|
|
|
|
|
|
die "Option --$opt value '$val' is not a (hex)number\n"; |
191
|
9
|
|
|
9
|
|
62
|
no warnings 'portable'; |
|
9
|
|
|
|
|
16
|
|
|
9
|
|
|
|
|
2466
|
|
192
|
0
|
0
|
|
|
|
|
$val = hex $val if $val =~ m/^0x/; |
193
|
|
|
|
|
|
|
} |
194
|
0
|
0
|
0
|
|
|
|
default { |
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
195
|
0
|
|
|
|
|
|
die "TODO: unrecognised type $_\n"; |
196
|
|
|
|
|
|
|
} |
197
|
|
|
|
|
|
|
} |
198
|
|
|
|
|
|
|
|
199
|
0
|
|
|
|
|
|
$opts{$opt} = $val; |
200
|
|
|
|
|
|
|
} |
201
|
|
|
|
|
|
|
|
202
|
0
|
|
|
|
|
|
$inv->putback_tokens( @remaining ); |
203
|
|
|
|
|
|
|
|
204
|
0
|
|
|
|
|
|
return \%opts; |
205
|
|
|
|
|
|
|
} |
206
|
|
|
|
|
|
|
|
207
|
|
|
|
|
|
|
sub get_args_from_inv |
208
|
|
|
|
|
|
|
{ |
209
|
0
|
|
|
0
|
0
|
|
my $self = shift; |
210
|
0
|
|
|
|
|
|
my ( $inv, @argspec ) = @_; |
211
|
|
|
|
|
|
|
|
212
|
0
|
|
|
|
|
|
my @args; |
213
|
|
|
|
|
|
|
|
214
|
0
|
|
|
|
|
|
foreach my $argspec ( @argspec ) { |
215
|
0
|
|
|
|
|
|
my $val = $inv->pull_token; |
216
|
|
|
|
|
|
|
defined $val or !$argspec->{required} or |
217
|
0
|
0
|
0
|
|
|
|
die "Expected a value for '$argspec->{name}' argument\n"; |
218
|
0
|
0
|
|
|
|
|
defined $val or last; |
219
|
0
|
|
|
|
|
|
push @args, $val; |
220
|
0
|
0
|
|
|
|
|
if( $argspec->{slurpy} ) { |
221
|
0
|
|
|
|
|
|
push @args, $inv->pull_token while length $inv->peek_remaining; |
222
|
|
|
|
|
|
|
} |
223
|
0
|
0
|
|
|
|
|
redo if $argspec->{repeated}; |
224
|
|
|
|
|
|
|
} |
225
|
|
|
|
|
|
|
|
226
|
0
|
|
|
|
|
|
return @args; |
227
|
|
|
|
|
|
|
} |
228
|
|
|
|
|
|
|
|
229
|
|
|
|
|
|
|
0x55AA; |