line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package App::Easer::V2; |
2
|
17
|
|
|
17
|
|
188133
|
use v5.24; |
|
17
|
|
|
|
|
87
|
|
3
|
17
|
|
|
17
|
|
91
|
use warnings; |
|
17
|
|
|
|
|
52
|
|
|
17
|
|
|
|
|
644
|
|
4
|
17
|
|
|
17
|
|
612
|
use experimental qw< signatures >; |
|
17
|
|
|
|
|
3618
|
|
|
17
|
|
|
|
|
144
|
|
5
|
17
|
|
|
17
|
|
2046
|
no warnings qw< experimental::signatures >; |
|
17
|
|
|
|
|
33
|
|
|
17
|
|
|
|
|
1188
|
|
6
|
|
|
|
|
|
|
{ our $VERSION = '2.006' } |
7
|
17
|
|
|
17
|
|
117
|
use Carp; |
|
17
|
|
|
|
|
34
|
|
|
17
|
|
|
|
|
1051
|
|
8
|
|
|
|
|
|
|
|
9
|
17
|
|
|
17
|
|
1599
|
use parent 'Exporter'; |
|
17
|
|
|
|
|
955
|
|
|
17
|
|
|
|
|
123
|
|
10
|
|
|
|
|
|
|
our @EXPORT_OK = qw< appeaser_api d dd run >; |
11
|
|
|
|
|
|
|
|
12
|
|
|
|
|
|
|
# repeated stuff to ease direct usage and fatpack-like inclusion |
13
|
2
|
|
|
2
|
1
|
2643
|
sub appeaser_api { __PACKAGE__ =~ s{.*::}{}rmxs } |
14
|
0
|
|
|
0
|
1
|
0
|
sub d { warn dd(@_) } |
15
|
|
|
|
|
|
|
|
16
|
0
|
|
|
0
|
1
|
0
|
sub dd (@stuff) { |
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
17
|
17
|
|
|
17
|
|
3203
|
no warnings; |
|
17
|
|
|
|
|
43
|
|
|
17
|
|
|
|
|
5688
|
|
18
|
0
|
|
|
|
|
0
|
require Data::Dumper; |
19
|
0
|
|
|
|
|
0
|
local $Data::Dumper::Indent = 1; |
20
|
0
|
0
|
0
|
|
|
0
|
Data::Dumper::Dumper( |
|
|
0
|
|
|
|
|
|
21
|
|
|
|
|
|
|
@stuff == 0 ? [] |
22
|
|
|
|
|
|
|
: (ref($stuff[0]) || @stuff % 2) ? \@stuff |
23
|
|
|
|
|
|
|
: {@stuff} |
24
|
|
|
|
|
|
|
); |
25
|
|
|
|
|
|
|
} ## end sub dd (@stuff) |
26
|
|
|
|
|
|
|
|
27
|
80
|
|
|
80
|
1
|
350777
|
sub run ($app, @args) { |
|
80
|
|
|
|
|
164
|
|
|
80
|
|
|
|
|
237
|
|
|
80
|
|
|
|
|
121
|
|
28
|
80
|
|
|
|
|
162
|
my $class = 'App::Easer::V2::Command'; |
29
|
80
|
0
|
|
|
|
710
|
my $instance = |
|
|
50
|
|
|
|
|
|
30
|
|
|
|
|
|
|
ref($app) eq 'HASH' ? $class->new($app) |
31
|
|
|
|
|
|
|
: ref($app) eq 'ARRAY' ? $class->instantiate($app->@*) |
32
|
|
|
|
|
|
|
: $class->instantiate($app); |
33
|
80
|
|
|
|
|
287
|
return $instance->run(@args); |
34
|
|
|
|
|
|
|
} ## end sub run |
35
|
|
|
|
|
|
|
|
36
|
8
|
|
|
8
|
|
4631
|
sub import ($package, @args) { |
|
8
|
|
|
|
|
24
|
|
|
8
|
|
|
|
|
14
|
|
|
8
|
|
|
|
|
12
|
|
37
|
8
|
|
|
|
|
21
|
my $target = caller; |
38
|
8
|
|
|
|
|
33
|
my @args_for_exporter; |
39
|
8
|
|
|
|
|
14
|
our %registered; |
40
|
8
|
|
|
|
|
21
|
while (@args) { |
41
|
14
|
|
|
|
|
30
|
my $request = shift @args; |
42
|
14
|
100
|
|
|
|
49
|
if ($request eq '-command') { |
|
|
50
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
43
|
6
|
|
|
|
|
12
|
$registered{$target} = 1; |
44
|
17
|
|
|
17
|
|
160
|
no strict 'refs'; |
|
17
|
|
|
|
|
30
|
|
|
17
|
|
|
|
|
1674
|
|
45
|
6
|
|
|
|
|
8
|
push @{$target . '::ISA'}, 'App::Easer::V2::Command'; |
|
6
|
|
|
|
|
75
|
|
46
|
|
|
|
|
|
|
} |
47
|
|
|
|
|
|
|
elsif ($request eq '-inherit') { |
48
|
17
|
|
|
17
|
|
123
|
no strict 'refs'; |
|
17
|
|
|
|
|
31
|
|
|
17
|
|
|
|
|
2027
|
|
49
|
0
|
|
|
|
|
0
|
push @{$target . '::ISA'}, 'App::Easer::V2::Command'; |
|
0
|
|
|
|
|
0
|
|
50
|
|
|
|
|
|
|
} |
51
|
|
|
|
|
|
|
elsif ($request eq '-register') { |
52
|
0
|
|
|
|
|
0
|
$registered{$target} = 1; |
53
|
|
|
|
|
|
|
} |
54
|
|
|
|
|
|
|
elsif ($request eq '-spec') { |
55
|
4
|
50
|
|
|
|
11
|
Carp::croak "no specification provided" |
56
|
|
|
|
|
|
|
unless @args; |
57
|
4
|
50
|
|
|
|
11
|
Carp::croak "invalid specification provided" |
58
|
|
|
|
|
|
|
unless ref($args[0]) eq 'HASH'; |
59
|
17
|
|
|
17
|
|
110
|
no strict 'refs'; |
|
17
|
|
|
|
|
56
|
|
|
17
|
|
|
|
|
573
|
|
60
|
17
|
|
|
17
|
|
102
|
no warnings 'once'; |
|
17
|
|
|
|
|
82
|
|
|
17
|
|
|
|
|
2719
|
|
61
|
4
|
|
|
|
|
6
|
${$target . '::app_easer_spec'} = shift @args; |
|
4
|
|
|
|
|
21
|
|
62
|
|
|
|
|
|
|
} ## end elsif ($request eq '-spec') |
63
|
4
|
|
|
|
|
10
|
else { push @args_for_exporter, $request } |
64
|
|
|
|
|
|
|
} ## end while (@args) |
65
|
8
|
|
|
|
|
368647
|
$package->export_to_level(1, $package, @args_for_exporter); |
66
|
|
|
|
|
|
|
} ## end sub import |
67
|
|
|
|
|
|
|
|
68
|
|
|
|
|
|
|
package App::Easer::V2::Command; |
69
|
17
|
|
|
17
|
|
123
|
use Scalar::Util 'blessed'; |
|
17
|
|
|
|
|
31
|
|
|
17
|
|
|
|
|
906
|
|
70
|
17
|
|
|
17
|
|
109
|
use List::Util 'any'; |
|
17
|
|
|
|
|
34
|
|
|
17
|
|
|
|
|
1965
|
|
71
|
17
|
|
|
17
|
|
8656
|
use English '-no_match_vars'; |
|
17
|
|
|
|
|
32521
|
|
|
17
|
|
|
|
|
99
|
|
72
|
|
|
|
|
|
|
|
73
|
|
|
|
|
|
|
# some stuff can be managed via a hash reference kept in a "slot", |
74
|
|
|
|
|
|
|
# allowing for overriding should be easy either with re-defining the |
75
|
|
|
|
|
|
|
# "slot" method, or overriding the sub-method relying on it. The name of |
76
|
|
|
|
|
|
|
# the slot is the same as the name of the actual package that $self is |
77
|
|
|
|
|
|
|
# blessed into. |
78
|
5861
|
|
50
|
5861
|
|
7199
|
sub slot ($self) { return $self->{blessed($self)} //= {} } |
|
5861
|
|
|
|
|
7227
|
|
|
5861
|
|
|
|
|
6968
|
|
|
5861
|
|
|
|
|
23569
|
|
79
|
|
|
|
|
|
|
|
80
|
|
|
|
|
|
|
# This is a poor man's way to easily define attributes in a single line |
81
|
|
|
|
|
|
|
# Corinna will be a blessing eventually |
82
|
5861
|
|
|
5861
|
|
33691
|
sub _rwn ($self, $name, @newval) { |
|
5861
|
|
|
|
|
7340
|
|
|
5861
|
|
|
|
|
7772
|
|
|
5861
|
|
|
|
|
7139
|
|
|
5861
|
|
|
|
|
6652
|
|
83
|
5861
|
|
|
|
|
9706
|
my $vref = \$self->slot->{$name}; |
84
|
5861
|
100
|
|
|
|
12901
|
$$vref = $newval[0] if @newval; |
85
|
5861
|
|
|
|
|
16827
|
return $$vref; |
86
|
|
|
|
|
|
|
} |
87
|
|
|
|
|
|
|
|
88
|
2771
|
|
|
2771
|
|
3533
|
sub _rw ($s, @n) { $s->_rwn((caller(1))[3] =~ s{.*::}{}rmxs, @n) } |
|
2771
|
|
|
|
|
3486
|
|
|
2771
|
|
|
|
|
3594
|
|
|
2771
|
|
|
|
|
3596
|
|
|
2771
|
|
|
|
|
17169
|
|
89
|
|
|
|
|
|
|
|
90
|
2171
|
|
|
2171
|
|
2862
|
sub _rwa ($self, @n) { |
|
2171
|
|
|
|
|
2865
|
|
|
2171
|
|
|
|
|
3087
|
|
|
2171
|
|
|
|
|
2732
|
|
91
|
2171
|
|
|
|
|
17101
|
my $aref = $self->_rwn((caller(1))[3] =~ s{.*::}{}rmxs, @n); |
92
|
2171
|
50
|
|
|
|
6390
|
Carp::confess() unless defined $aref; |
93
|
2171
|
|
|
|
|
5374
|
return $aref->@*; |
94
|
|
|
|
|
|
|
} |
95
|
|
|
|
|
|
|
|
96
|
134
|
|
|
134
|
|
184
|
sub _rwad ($self, @n) { |
|
134
|
|
|
|
|
208
|
|
|
134
|
|
|
|
|
174
|
|
|
134
|
|
|
|
|
185
|
|
97
|
134
|
|
50
|
|
|
1081
|
my $aref = $self->_rwn((caller(1))[3] =~ s{.*::}{}rmxs, @n) // []; |
98
|
134
|
50
|
|
|
|
648
|
return wantarray ? $aref->@* : [$aref->@*]; |
99
|
|
|
|
|
|
|
} |
100
|
|
|
|
|
|
|
|
101
|
|
|
|
|
|
|
# these "attributes" would point to stuff that is normally "scalar" and |
102
|
|
|
|
|
|
|
# used as specification overall. It can be overridden but probably it's |
103
|
|
|
|
|
|
|
# just easier to stick in a hash inside the slot. We don't want to put |
104
|
|
|
|
|
|
|
# executables here, though - overriding should be the guiding principle |
105
|
|
|
|
|
|
|
# in this case. |
106
|
134
|
|
|
134
|
|
215
|
sub aliases ($self, @r) { |
|
134
|
|
|
|
|
176
|
|
|
134
|
|
|
|
|
180
|
|
|
134
|
|
|
|
|
160
|
|
107
|
134
|
100
|
|
|
|
294
|
if (my @aliases = $self->_rwad(@r)) { return @aliases } |
|
111
|
|
|
|
|
631
|
|
108
|
23
|
100
|
|
|
|
63
|
if (defined(my $name = $self->_rwn('name'))) { return $name } |
|
22
|
|
|
|
|
74
|
|
109
|
1
|
|
|
|
|
31
|
return; |
110
|
|
|
|
|
|
|
} |
111
|
248
|
|
|
248
|
|
379
|
sub allow_residual_options ($self, @r) { $self->_rw(@r) } |
|
248
|
|
|
|
|
346
|
|
|
248
|
|
|
|
|
344
|
|
|
248
|
|
|
|
|
307
|
|
|
248
|
|
|
|
|
504
|
|
112
|
108
|
|
|
108
|
|
146
|
sub auto_environment ($self, @r) { $self->_rw(@r) } |
|
108
|
|
|
|
|
172
|
|
|
108
|
|
|
|
|
154
|
|
|
108
|
|
|
|
|
136
|
|
|
108
|
|
|
|
|
201
|
|
113
|
155
|
|
|
155
|
|
220
|
sub call_name ($self, @r) { $self->_rw(@r) } |
|
155
|
|
|
|
|
239
|
|
|
155
|
|
|
|
|
232
|
|
|
155
|
|
|
|
|
208
|
|
|
155
|
|
|
|
|
324
|
|
114
|
402
|
|
|
402
|
|
518
|
sub children ($self, @r) { $self->_rwa(@r) } |
|
402
|
|
|
|
|
520
|
|
|
402
|
|
|
|
|
520
|
|
|
402
|
|
|
|
|
526
|
|
|
402
|
|
|
|
|
781
|
|
115
|
804
|
|
|
804
|
|
1226
|
sub children_prefixes ($self, @r) { $self->_rwa(@r) } |
|
804
|
|
|
|
|
1193
|
|
|
804
|
|
|
|
|
1010
|
|
|
804
|
|
|
|
|
1032
|
|
|
804
|
|
|
|
|
1564
|
|
116
|
52
|
|
|
52
|
|
83
|
sub default_child ($self, @r) { $self->_rw(@r) } |
|
52
|
|
|
|
|
81
|
|
|
52
|
|
|
|
|
70
|
|
|
52
|
|
|
|
|
65
|
|
|
52
|
|
|
|
|
88
|
|
117
|
18
|
|
|
18
|
|
40
|
sub description ($self, @r) { $self->_rw(@r) } |
|
18
|
|
|
|
|
31
|
|
|
18
|
|
|
|
|
40
|
|
|
18
|
|
|
|
|
27
|
|
|
18
|
|
|
|
|
47
|
|
118
|
100
|
|
|
100
|
|
114
|
sub environment_prefix ($self, @r) { $self->_rw(@r) } |
|
100
|
|
|
|
|
120
|
|
|
100
|
|
|
|
|
139
|
|
|
100
|
|
|
|
|
120
|
|
|
100
|
|
|
|
|
162
|
|
119
|
79
|
|
|
79
|
|
127
|
sub execution_reason ($self, @r) { $self->_rw(@r) } |
|
79
|
|
|
|
|
122
|
|
|
79
|
|
|
|
|
165
|
|
|
79
|
|
|
|
|
145
|
|
|
79
|
|
|
|
|
164
|
|
120
|
402
|
|
|
402
|
|
568
|
sub force_auto_children ($self, @r) { $self->_rw(@r) } |
|
402
|
|
|
|
|
534
|
|
|
402
|
|
|
|
|
502
|
|
|
402
|
|
|
|
|
510
|
|
|
402
|
|
|
|
|
720
|
|
121
|
4
|
|
|
4
|
|
10
|
sub fallback_to ($self, @r) { $self->_rw(@r) } |
|
4
|
|
|
|
|
9
|
|
|
4
|
|
|
|
|
16
|
|
|
4
|
|
|
|
|
7
|
|
|
4
|
|
|
|
|
11
|
|
122
|
161
|
|
|
161
|
|
263
|
sub hashy_class ($self, @r) { $self->_rw(@r) } |
|
161
|
|
|
|
|
220
|
|
|
161
|
|
|
|
|
201
|
|
|
161
|
|
|
|
|
191
|
|
|
161
|
|
|
|
|
309
|
|
123
|
28
|
|
|
28
|
|
55
|
sub help ($self, @r) { $self->_rw(@r) } |
|
28
|
|
|
|
|
77
|
|
|
28
|
|
|
|
|
43
|
|
|
28
|
|
|
|
|
39
|
|
|
28
|
|
|
|
|
77
|
|
124
|
24
|
|
|
24
|
|
71
|
sub help_channel ($slf, @r) { $slf->_rw(@r) } |
|
24
|
|
|
|
|
71
|
|
|
24
|
|
|
|
|
35
|
|
|
24
|
|
|
|
|
40
|
|
|
24
|
|
|
|
|
50
|
|
125
|
34
|
|
100
|
34
|
|
427
|
sub name ($s, @r) { $s->_rw(@r) // ($s->aliases)[0] // '**no name**' } |
|
34
|
|
100
|
|
|
53
|
|
|
34
|
|
|
|
|
43
|
|
|
34
|
|
|
|
|
46
|
|
|
34
|
|
|
|
|
97
|
|
126
|
148
|
|
|
148
|
|
214
|
sub params_validate ($self, @r) { $self->_rw(@r) } |
|
148
|
|
|
|
|
212
|
|
|
148
|
|
|
|
|
199
|
|
|
148
|
|
|
|
|
213
|
|
|
148
|
|
|
|
|
338
|
|
127
|
527
|
|
|
527
|
|
684
|
sub parent ($self, @r) { $self->_rw(@r) } |
|
527
|
|
|
|
|
713
|
|
|
527
|
|
|
|
|
675
|
|
|
527
|
|
|
|
|
635
|
|
|
527
|
|
|
|
|
991
|
|
128
|
337
|
|
|
337
|
|
653
|
sub residual_args ($self, @r) { $self->_rwa(@r) } |
|
337
|
|
|
|
|
520
|
|
|
337
|
|
|
|
|
448
|
|
|
337
|
|
|
|
|
399
|
|
|
337
|
|
|
|
|
601
|
|
129
|
148
|
|
|
148
|
|
223
|
sub sources ($self, @r) { $self->_rwa(@r) } |
|
148
|
|
|
|
|
208
|
|
|
148
|
|
|
|
|
208
|
|
|
148
|
|
|
|
|
179
|
|
|
148
|
|
|
|
|
360
|
|
130
|
|
|
|
|
|
|
|
131
|
132
|
|
|
132
|
|
174
|
sub supports ($self, $what) { |
|
132
|
|
|
|
|
253
|
|
|
132
|
|
|
|
|
210
|
|
|
132
|
|
|
|
|
195
|
|
132
|
132
|
|
|
146
|
|
674
|
any { $_ eq $what } $self->aliases; |
|
146
|
|
|
|
|
1115
|
|
133
|
|
|
|
|
|
|
} |
134
|
|
|
|
|
|
|
|
135
|
480
|
|
|
480
|
|
657
|
sub options ($self, @r) { |
|
480
|
|
|
|
|
664
|
|
|
480
|
|
|
|
|
587
|
|
|
480
|
|
|
|
|
600
|
|
136
|
480
|
|
|
|
|
949
|
return map { $self->resolve_options($_) } $self->_rwa(@r); |
|
969
|
|
|
|
|
1756
|
|
137
|
|
|
|
|
|
|
} |
138
|
|
|
|
|
|
|
|
139
|
969
|
|
|
969
|
|
1170
|
sub resolve_options ($self, $spec) { |
|
969
|
|
|
|
|
1266
|
|
|
969
|
|
|
|
|
1157
|
|
|
969
|
|
|
|
|
1122
|
|
140
|
969
|
100
|
|
|
|
2660
|
return $spec if ref($spec) eq 'HASH'; |
141
|
18
|
50
|
|
|
|
52
|
$spec = [inherit_options => $spec] unless ref $spec; |
142
|
18
|
50
|
|
|
|
43
|
Carp::confess("invalid spec $spec") unless ref($spec) eq 'ARRAY'; |
143
|
18
|
|
|
|
|
40
|
my ($method_name, @names) = $spec->@*; |
144
|
18
|
50
|
|
|
|
58
|
my $method = $self->can($method_name) |
145
|
|
|
|
|
|
|
or Carp::confess("cannot find method $method_name in $self"); |
146
|
18
|
|
|
|
|
37
|
return $self->$method(@names); |
147
|
|
|
|
|
|
|
} ## end sub resolve_options |
148
|
|
|
|
|
|
|
|
149
|
18
|
|
|
18
|
|
22
|
sub inherit_options ($self, @names) { |
|
18
|
|
|
|
|
23
|
|
|
18
|
|
|
|
|
58
|
|
|
18
|
|
|
|
|
24
|
|
150
|
18
|
|
|
|
|
30
|
my %got; |
151
|
|
|
|
|
|
|
map { |
152
|
18
|
|
|
|
|
31
|
my @options; |
|
18
|
|
|
|
|
23
|
|
153
|
18
|
50
|
|
|
|
39
|
if ($_ eq '+parent') { |
154
|
18
|
|
100
|
|
|
37
|
@options = grep { $_->{transmit} // 0 } $self->parent->options; |
|
108
|
|
|
|
|
238
|
|
155
|
|
|
|
|
|
|
} |
156
|
|
|
|
|
|
|
else { |
157
|
0
|
|
|
|
|
0
|
my $namerx = qr{\A(?:$_)\z}; |
158
|
0
|
|
|
|
|
0
|
my $ancestor = $self->parent; |
159
|
0
|
|
|
|
|
0
|
while ($ancestor) { |
160
|
|
|
|
|
|
|
push @options, my @pass = # FIXME something's strange here |
161
|
|
|
|
|
|
|
grep { |
162
|
0
|
|
|
|
|
0
|
my $name = $self->name_for_option($_); |
|
0
|
|
|
|
|
0
|
|
163
|
|
|
|
|
|
|
(!$_->{transmit_exact}) |
164
|
|
|
|
|
|
|
&& $name =~ m{$namerx} |
165
|
0
|
0
|
0
|
|
|
0
|
&& !$got{$name}; |
166
|
|
|
|
|
|
|
} $ancestor->options; |
167
|
0
|
|
|
|
|
0
|
$ancestor = $ancestor->parent; |
168
|
|
|
|
|
|
|
} ## end while ($ancestor) |
169
|
|
|
|
|
|
|
} ## end else [ if ($_ eq '+parent') ] |
170
|
18
|
|
|
|
|
35
|
map { +{transmit => 1, $_->%*, inherited => 1} } @options; |
|
90
|
|
|
|
|
354
|
|
171
|
|
|
|
|
|
|
} @names; |
172
|
|
|
|
|
|
|
} ## end sub inherit_options |
173
|
|
|
|
|
|
|
|
174
|
277
|
|
|
277
|
|
441
|
sub new ($pkg, @args) { |
|
277
|
|
|
|
|
417
|
|
|
277
|
|
|
|
|
740
|
|
|
277
|
|
|
|
|
413
|
|
175
|
17
|
|
|
17
|
|
35171
|
my $pkg_spec = do { no strict 'refs'; ${$pkg . '::app_easer_spec'} }; |
|
17
|
|
|
|
|
296
|
|
|
17
|
|
|
|
|
137518
|
|
|
277
|
|
|
|
|
363
|
|
|
277
|
|
|
|
|
352
|
|
|
277
|
|
|
|
|
1149
|
|
176
|
277
|
100
|
100
|
|
|
4612
|
my $slot = { |
|
|
|
66
|
|
|
|
|
177
|
|
|
|
|
|
|
aliases => [], |
178
|
|
|
|
|
|
|
allow_residual_options => 0, |
179
|
|
|
|
|
|
|
auto_environment => 0, |
180
|
|
|
|
|
|
|
children => [], |
181
|
|
|
|
|
|
|
children_prefixes => [$pkg . '::Cmd'], |
182
|
|
|
|
|
|
|
default_child => 'help', |
183
|
|
|
|
|
|
|
environment_prefix => '', |
184
|
|
|
|
|
|
|
fallback_to => undef, |
185
|
|
|
|
|
|
|
force_auto_children => undef, |
186
|
|
|
|
|
|
|
hashy_class => __PACKAGE__, |
187
|
|
|
|
|
|
|
help_channel => '-STDOUT:encoding(UTF-8)', |
188
|
|
|
|
|
|
|
options => [], |
189
|
|
|
|
|
|
|
params_validate => undef, |
190
|
|
|
|
|
|
|
sources => [qw< +CmdLine +Environment +Parent=70 +Default=100 >], |
191
|
|
|
|
|
|
|
($pkg_spec // {})->%*, |
192
|
|
|
|
|
|
|
(@args && ref $args[0] ? $args[0]->%* : @args), |
193
|
|
|
|
|
|
|
}; |
194
|
277
|
|
|
|
|
1035
|
my $self = bless {$pkg => $slot}, $pkg; |
195
|
277
|
|
|
|
|
677
|
return $self; |
196
|
|
|
|
|
|
|
} ## end sub new |
197
|
|
|
|
|
|
|
|
198
|
612
|
|
|
612
|
|
937
|
sub merge_hashes ($self, @hrefs) { |
|
612
|
|
|
|
|
814
|
|
|
612
|
|
|
|
|
876
|
|
|
612
|
|
|
|
|
715
|
|
199
|
612
|
|
|
|
|
871
|
my (%retval, %is_overridable); |
200
|
612
|
|
|
|
|
1088
|
for my $href (@hrefs) { |
201
|
1585
|
|
|
|
|
3341
|
for my $src_key (keys $href->%*) { |
202
|
953
|
|
|
|
|
1268
|
my $dst_key = $src_key; |
203
|
953
|
|
|
|
|
1125
|
my $this_overridable = 0; |
204
|
|
|
|
|
|
|
$retval{$dst_key} = $href->{$src_key} |
205
|
953
|
100
|
66
|
|
|
3331
|
if $is_overridable{$dst_key} || !exists($retval{$dst_key}); |
206
|
953
|
50
|
|
|
|
2299
|
$is_overridable{$dst_key} = 0 unless $this_overridable; |
207
|
|
|
|
|
|
|
} ## end for my $src_key (keys $href...) |
208
|
|
|
|
|
|
|
} ## end for my $href (@hrefs) |
209
|
612
|
|
|
|
|
1549
|
return \%retval; |
210
|
|
|
|
|
|
|
} ## end sub merge_hashes |
211
|
|
|
|
|
|
|
|
212
|
|
|
|
|
|
|
# collect options values from $args (= [...]) & other sources |
213
|
|
|
|
|
|
|
# sets own configuration and residual_args |
214
|
|
|
|
|
|
|
# acts based on what is provided by method options() |
215
|
148
|
|
|
148
|
|
215
|
sub collect ($self, @args) { |
|
148
|
|
|
|
|
239
|
|
|
148
|
|
|
|
|
270
|
|
|
148
|
|
|
|
|
195
|
|
216
|
148
|
|
|
|
|
241
|
my @sequence; # stuff collected from Sources, w/ context |
217
|
|
|
|
|
|
|
my @slices; # ditto, no context |
218
|
148
|
|
|
|
|
253
|
my $config = {}; # merged configuration |
219
|
148
|
|
|
|
|
205
|
my @residual_args; # what is left from the @args at the end |
220
|
|
|
|
|
|
|
|
221
|
148
|
|
|
|
|
262
|
my $last_priority = 0; |
222
|
148
|
|
|
|
|
397
|
for my $source ($self->sources) { |
223
|
612
|
100
|
|
|
|
1605
|
my ($src, @opts) = ref($source) eq 'ARRAY' ? $source->@* : $source; |
224
|
612
|
100
|
100
|
|
|
1644
|
my $meta = (@opts && ref $opts[0]) ? shift @opts : {}; |
225
|
612
|
|
|
|
|
1020
|
my $locator = $src; |
226
|
612
|
100
|
|
|
|
1177
|
if (! ref($src)) { |
227
|
610
|
|
|
|
|
1819
|
($src, my $priority) = split m{=}mxs, $src; |
228
|
610
|
100
|
|
|
|
1545
|
$meta->{priority} = $priority if defined $priority; |
229
|
610
|
|
|
|
|
2354
|
$locator = $src =~ s{\A \+}{source_}rmxs; |
230
|
|
|
|
|
|
|
} |
231
|
612
|
50
|
|
|
|
1559
|
my $sub = $self->ref_to_sub($locator) |
232
|
|
|
|
|
|
|
or die "unhandled source for $locator\n"; |
233
|
612
|
|
|
|
|
1674
|
my ($slice, $residuals) = $sub->($self, \@opts, \@args); |
234
|
612
|
100
|
|
|
|
13763
|
push @residual_args, $residuals->@* if defined $residuals; |
235
|
612
|
|
66
|
|
|
2041
|
$last_priority = my $priority = $meta->{priority} //= $last_priority + 10; |
236
|
612
|
|
|
|
|
1626
|
push @sequence, [$priority, $src, \@opts, $locator, $slice]; |
237
|
612
|
|
|
|
|
1585
|
for (my $i = $#sequence; $i > 0; --$i) { |
238
|
504
|
100
|
|
|
|
1704
|
last if $sequence[$i - 1][0] <= $sequence[$i][0]; |
239
|
41
|
|
|
|
|
134
|
@sequence[$i - 1, $i] = @sequence[$i, $i - 1]; |
240
|
|
|
|
|
|
|
} |
241
|
612
|
|
|
|
|
1110
|
$config = $self->merge_hashes(map {$_->[-1]} @sequence); |
|
1585
|
|
|
|
|
2997
|
|
242
|
612
|
|
|
|
|
1983
|
$self->_rwn(config => {merged => $config, sequence => \@sequence}); |
243
|
|
|
|
|
|
|
} ## end for my $source ($self->...) |
244
|
|
|
|
|
|
|
|
245
|
|
|
|
|
|
|
# save and return |
246
|
148
|
|
|
|
|
555
|
$self->residual_args(\@residual_args); |
247
|
148
|
|
|
|
|
344
|
return $self; |
248
|
|
|
|
|
|
|
} ## end sub collect |
249
|
|
|
|
|
|
|
|
250
|
148
|
|
|
148
|
|
237
|
sub getopt_config ($self, @n) { |
|
148
|
|
|
|
|
193
|
|
|
148
|
|
|
|
|
214
|
|
|
148
|
|
|
|
|
198
|
|
251
|
148
|
|
|
|
|
283
|
my $value = $self->_rw(@n); |
252
|
148
|
50
|
|
|
|
430
|
if (!defined $value) { |
253
|
148
|
|
|
|
|
378
|
my @r = qw< gnu_getopt >; |
254
|
148
|
100
|
|
|
|
424
|
push @r, qw< require_order pass_through > if $self->list_children; |
255
|
148
|
50
|
|
|
|
462
|
push @r, qw< pass_through > if $self->allow_residual_options; |
256
|
148
|
|
|
|
|
387
|
$value = $self->_rw(\@r); |
257
|
|
|
|
|
|
|
} ## end if (!defined $value) |
258
|
148
|
|
|
|
|
757
|
return $value->@*; |
259
|
|
|
|
|
|
|
} ## end sub getopt_config |
260
|
|
|
|
|
|
|
|
261
|
148
|
|
|
148
|
|
229
|
sub source_CmdLine ($self, $ignore, $args) { |
|
148
|
|
|
|
|
216
|
|
|
148
|
|
|
|
|
188
|
|
|
148
|
|
|
|
|
226
|
|
|
148
|
|
|
|
|
194
|
|
262
|
148
|
|
|
|
|
503
|
my @args = $args->@*; |
263
|
|
|
|
|
|
|
|
264
|
148
|
|
|
|
|
10350
|
require Getopt::Long; |
265
|
148
|
|
|
|
|
131123
|
Getopt::Long::Configure('default', $self->getopt_config); |
266
|
|
|
|
|
|
|
|
267
|
148
|
|
|
|
|
10209
|
my %option_for; |
268
|
|
|
|
|
|
|
my @specs = map { |
269
|
300
|
|
|
|
|
466
|
my $go = $_->{getopt}; |
270
|
|
|
|
|
|
|
ref($go) eq 'ARRAY' |
271
|
0
|
|
|
0
|
|
0
|
? ($go->[0] => sub { $go->[1]->(\%option_for, @_) }) |
272
|
300
|
50
|
|
|
|
707
|
: $go; |
273
|
|
|
|
|
|
|
} |
274
|
148
|
|
|
|
|
468
|
grep { exists $_->{getopt} } $self->options; |
|
300
|
|
|
|
|
715
|
|
275
|
148
|
50
|
|
|
|
552
|
Getopt::Long::GetOptionsFromArray(\@args, \%option_for, @specs) |
276
|
|
|
|
|
|
|
or die "bailing out\n"; |
277
|
|
|
|
|
|
|
|
278
|
|
|
|
|
|
|
# Check if we want to forbid the residual @args to start with a '-' |
279
|
148
|
|
|
|
|
39178
|
my $strict = !$self->allow_residual_options; |
280
|
148
|
50
|
66
|
|
|
871
|
if ($strict && @args && $args[0] =~ m{\A -}mxs) { |
|
|
|
66
|
|
|
|
|
281
|
0
|
|
|
|
|
0
|
Getopt::Long::Configure('default', 'gnu_getopt'); |
282
|
0
|
|
|
|
|
0
|
Getopt::Long::GetOptionsFromArray(\@args, {}); |
283
|
0
|
|
|
|
|
0
|
die "bailing out\n"; |
284
|
|
|
|
|
|
|
} |
285
|
|
|
|
|
|
|
|
286
|
148
|
|
|
|
|
547
|
return (\%option_for, \@args); |
287
|
|
|
|
|
|
|
} ## end sub source_CmdLine |
288
|
|
|
|
|
|
|
|
289
|
293
|
|
|
293
|
|
381
|
sub name_for_option ($self, $o) { |
|
293
|
|
|
|
|
368
|
|
|
293
|
|
|
|
|
373
|
|
|
293
|
|
|
|
|
378
|
|
290
|
293
|
50
|
|
|
|
661
|
return $o->{name} if defined $o->{name}; |
291
|
293
|
50
|
33
|
|
|
2532
|
return $1 if defined $o->{getopt} && $o->{getopt} =~ m{\A(\w+)}mxs; |
292
|
|
|
|
|
|
|
return lc $o->{environment} |
293
|
0
|
0
|
0
|
|
|
0
|
if defined $o->{environment} && $o->{environment} ne '1'; |
294
|
0
|
|
|
|
|
0
|
return '~~~'; |
295
|
|
|
|
|
|
|
} ## end sub name_for_option |
296
|
|
|
|
|
|
|
|
297
|
148
|
|
|
148
|
|
230
|
sub source_Default ($self, @ignore) { |
|
148
|
|
|
|
|
228
|
|
|
148
|
|
|
|
|
228
|
|
|
148
|
|
|
|
|
193
|
|
298
|
|
|
|
|
|
|
return { |
299
|
128
|
|
|
|
|
288
|
map { $self->name_for_option($_) => $_->{default} } |
300
|
270
|
|
|
|
|
542
|
grep { exists $_->{default} } |
301
|
148
|
|
|
|
|
324
|
grep { !$_->{inherited} } $self->options |
|
300
|
|
|
|
|
636
|
|
302
|
|
|
|
|
|
|
}; |
303
|
|
|
|
|
|
|
} ## end sub source_Default |
304
|
|
|
|
|
|
|
|
305
|
3
|
|
|
3
|
|
7
|
sub source_FromTrail ($self, $trail, @ignore) { |
|
3
|
|
|
|
|
3
|
|
|
3
|
|
|
|
|
6
|
|
|
3
|
|
|
|
|
6
|
|
|
3
|
|
|
|
|
6
|
|
306
|
3
|
|
|
|
|
7
|
my $conf = $self->config_hash; |
307
|
3
|
|
|
|
|
9
|
for my $key ($trail->@*) { |
308
|
9
|
50
|
|
|
|
21
|
return {} unless defined $conf->{$key}; |
309
|
9
|
|
|
|
|
13
|
$conf = $conf->{$key}; |
310
|
9
|
50
|
|
|
|
24
|
die "invalid trail $trail->@* for configuration gathering" |
311
|
|
|
|
|
|
|
unless ref($conf) eq 'HASH'; |
312
|
|
|
|
|
|
|
} ## end for my $key ($keys->@*) |
313
|
3
|
|
|
|
|
8
|
return $conf; |
314
|
|
|
|
|
|
|
} |
315
|
|
|
|
|
|
|
|
316
|
303
|
|
|
303
|
|
438
|
sub environment_variable_name ($self, $ospec) { |
|
303
|
|
|
|
|
414
|
|
|
303
|
|
|
|
|
394
|
|
|
303
|
|
|
|
|
360
|
|
317
|
|
|
|
|
|
|
my $env = |
318
|
|
|
|
|
|
|
exists $ospec->{environment} ? $ospec->{environment} |
319
|
303
|
100
|
|
|
|
761
|
: $self->auto_environment ? 1 |
|
|
100
|
|
|
|
|
|
320
|
|
|
|
|
|
|
: undef; |
321
|
303
|
100
|
100
|
|
|
1112
|
return $env unless ($env // '') eq '1'; |
322
|
|
|
|
|
|
|
|
323
|
|
|
|
|
|
|
# get prefixes all the way up to the first command |
324
|
92
|
|
|
|
|
122
|
my @prefixes; |
325
|
92
|
|
|
|
|
192
|
for (my $instance = $self; $instance; $instance = $instance->parent) { |
326
|
100
|
|
50
|
|
|
183
|
unshift @prefixes, $instance->environment_prefix // ''; |
327
|
|
|
|
|
|
|
} |
328
|
|
|
|
|
|
|
|
329
|
92
|
|
|
|
|
214
|
return uc(join '', @prefixes, $self->name_for_option($ospec)); |
330
|
|
|
|
|
|
|
} ## end sub environment_variable_name |
331
|
|
|
|
|
|
|
|
332
|
148
|
|
|
148
|
|
200
|
sub source_Environment ($self, @ignore) { |
|
148
|
|
|
|
|
212
|
|
|
148
|
|
|
|
|
237
|
|
|
148
|
|
|
|
|
232
|
|
333
|
|
|
|
|
|
|
return { |
334
|
|
|
|
|
|
|
map { |
335
|
270
|
|
|
|
|
571
|
my $en = $self->environment_variable_name($_); |
336
|
|
|
|
|
|
|
defined($en) |
337
|
|
|
|
|
|
|
&& exists($ENV{$en}) |
338
|
270
|
100
|
100
|
|
|
1287
|
? ($self->name_for_option($_) => $ENV{$en}) |
339
|
|
|
|
|
|
|
: (); |
340
|
148
|
|
|
|
|
322
|
} grep { !$_->{inherited} } $self->options |
|
300
|
|
|
|
|
639
|
|
341
|
|
|
|
|
|
|
}; |
342
|
|
|
|
|
|
|
} ## end sub source_Environment |
343
|
|
|
|
|
|
|
|
344
|
16
|
|
|
16
|
|
23
|
sub source_JsonFileFromConfig ($self, $key, @ignore) { |
|
16
|
|
|
|
|
35
|
|
|
16
|
|
|
|
|
22
|
|
|
16
|
|
|
|
|
24
|
|
|
16
|
|
|
|
|
25
|
|
345
|
16
|
|
50
|
|
|
60
|
$key = $key->[0] // 'config'; |
346
|
16
|
100
|
|
|
|
42
|
defined(my $filename = $self->config($key)) or return {}; |
347
|
9
|
|
|
|
|
1652
|
require JSON::PP; |
348
|
9
|
|
|
|
|
30395
|
return JSON::PP::decode_json($self->slurp($filename)); |
349
|
|
|
|
|
|
|
} ## end sub source_JsonFileFromConfig |
350
|
|
|
|
|
|
|
|
351
|
9
|
|
|
9
|
|
18
|
sub slurp ($self, $file, $mode = '<:encoding(UTF-8)') { |
|
9
|
|
|
|
|
18
|
|
|
9
|
|
|
|
|
17
|
|
|
9
|
|
|
|
|
15
|
|
|
9
|
|
|
|
|
18
|
|
352
|
9
|
50
|
|
|
|
420
|
open my $fh, $mode, $file or die "open('$file'): $!\n"; |
353
|
9
|
|
|
|
|
24596
|
local $/; |
354
|
9
|
|
|
|
|
389
|
return <$fh>; |
355
|
|
|
|
|
|
|
} |
356
|
|
|
|
|
|
|
|
357
|
0
|
|
|
0
|
|
0
|
sub source_JsonFiles ($self, $candidates, @ignore) { |
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
358
|
0
|
|
|
|
|
0
|
require JSON::PP; |
359
|
|
|
|
|
|
|
return $self->merge_hashes( |
360
|
0
|
|
|
|
|
0
|
map { JSON::PP::decode_json($self->slurp($_)) } |
361
|
0
|
|
|
|
|
0
|
grep { -e $_ } $candidates->@* |
|
0
|
|
|
|
|
0
|
|
362
|
|
|
|
|
|
|
); |
363
|
|
|
|
|
|
|
} ## end sub source_JsonFiles |
364
|
|
|
|
|
|
|
|
365
|
146
|
|
|
146
|
|
217
|
sub source_Parent ($self, @ignore) { |
|
146
|
|
|
|
|
253
|
|
|
146
|
|
|
|
|
246
|
|
|
146
|
|
|
|
|
233
|
|
366
|
146
|
100
|
|
|
|
318
|
my $parent = $self->parent or return {}; |
367
|
68
|
|
|
|
|
228
|
return $parent->config_hash(0); |
368
|
|
|
|
|
|
|
} |
369
|
|
|
|
|
|
|
|
370
|
|
|
|
|
|
|
|
371
|
|
|
|
|
|
|
# get the assembled config for the command. It supports the optional |
372
|
|
|
|
|
|
|
# additional boolean parameter $blame to get back a more structured |
373
|
|
|
|
|
|
|
# version where it's clear where each option comes from, to allow for |
374
|
|
|
|
|
|
|
# further injection of parameters from elsewhere. |
375
|
150
|
|
|
150
|
|
393
|
sub config_hash ($self, $blame = 0) { |
|
150
|
|
|
|
|
220
|
|
|
150
|
|
|
|
|
313
|
|
|
150
|
|
|
|
|
181
|
|
376
|
150
|
|
50
|
|
|
274
|
my $config = $self->_rwn('config') // {}; |
377
|
150
|
50
|
|
|
|
326
|
return $config if $blame; |
378
|
150
|
|
50
|
|
|
842
|
return $config->{merged} // {}; |
379
|
|
|
|
|
|
|
} |
380
|
|
|
|
|
|
|
|
381
|
|
|
|
|
|
|
# get one or more specific configurtion values |
382
|
32
|
|
|
32
|
|
117
|
sub config ($self, @keys) { |
|
32
|
|
|
|
|
44
|
|
|
32
|
|
|
|
|
51
|
|
|
32
|
|
|
|
|
42
|
|
383
|
32
|
|
|
|
|
80
|
my $hash = $self->config_hash(0); |
384
|
32
|
50
|
|
|
|
159
|
return $hash->{$keys[0]} if @keys == 1; |
385
|
0
|
|
|
|
|
0
|
return $hash->@{@keys}; |
386
|
|
|
|
|
|
|
} |
387
|
|
|
|
|
|
|
|
388
|
0
|
|
|
0
|
|
0
|
sub set_config ($self, $key, @value) { |
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
389
|
0
|
|
|
|
|
0
|
my $hash = $self->config_hash(0); |
390
|
0
|
|
|
|
|
0
|
delete $hash->{$key}; |
391
|
0
|
0
|
|
|
|
0
|
$hash->{$key} = $value[0] if @value; |
392
|
0
|
|
|
|
|
0
|
return $self; |
393
|
|
|
|
|
|
|
} ## end sub set_config |
394
|
|
|
|
|
|
|
|
395
|
|
|
|
|
|
|
# commit collected options values, called after collect ends |
396
|
148
|
|
|
148
|
|
206
|
sub commit ($self, @n) { |
|
148
|
|
|
|
|
234
|
|
|
148
|
|
|
|
|
195
|
|
|
148
|
|
|
|
|
186
|
|
397
|
148
|
|
|
|
|
287
|
my $commit = $self->_rw(@n); |
398
|
148
|
50
|
|
|
|
366
|
return $commit if @n; |
399
|
148
|
50
|
|
|
|
362
|
return unless $commit; |
400
|
0
|
|
|
|
|
0
|
return $self->ref_to_sub($commit)->($self); |
401
|
|
|
|
|
|
|
} ## end sub commit |
402
|
|
|
|
|
|
|
|
403
|
|
|
|
|
|
|
# validate collected options values, called after commit ends. |
404
|
148
|
|
|
148
|
|
201
|
sub validate ($self, @n) { |
|
148
|
|
|
|
|
210
|
|
|
148
|
|
|
|
|
208
|
|
|
148
|
|
|
|
|
183
|
|
405
|
|
|
|
|
|
|
|
406
|
|
|
|
|
|
|
# Support the "accessor" interface for using a validation sub |
407
|
148
|
|
|
|
|
274
|
my $validator = $self->_rw(@n); |
408
|
148
|
50
|
|
|
|
363
|
return $validator if @n; |
409
|
|
|
|
|
|
|
|
410
|
|
|
|
|
|
|
# If set, it MUST be a validation sub reference. Otherwise, try the |
411
|
|
|
|
|
|
|
# params_validate/Params::Validate path. |
412
|
148
|
50
|
|
|
|
504
|
if ($validator) { |
|
|
50
|
|
|
|
|
|
413
|
0
|
0
|
|
|
|
0
|
die "validator can only be a CODE reference\n" |
414
|
|
|
|
|
|
|
unless ref $validator eq 'CODE'; |
415
|
0
|
|
|
|
|
0
|
$validator->($self); |
416
|
|
|
|
|
|
|
} |
417
|
|
|
|
|
|
|
elsif (my $params_validate = $self->params_validate) { |
418
|
0
|
|
|
|
|
0
|
require Params::Validate; |
419
|
0
|
0
|
0
|
|
|
0
|
if (my $config_validator = $params_validate->{config} // undef) { |
420
|
0
|
|
|
|
|
0
|
my @array = $self->config_hash; |
421
|
0
|
|
|
|
|
0
|
Params::Validate::validate(\@array, $config_validator); |
422
|
|
|
|
|
|
|
} |
423
|
0
|
0
|
0
|
|
|
0
|
if (my $args_validator = $params_validate->{args} // undef) { |
424
|
0
|
|
|
|
|
0
|
my @array = $self->residual_args; |
425
|
0
|
|
|
|
|
0
|
Params::Validate::validate_pos(\@array, $args_validator->@*); |
426
|
|
|
|
|
|
|
} |
427
|
|
|
|
|
|
|
} |
428
|
|
|
|
|
|
|
else {} # no validation needed |
429
|
|
|
|
|
|
|
|
430
|
148
|
|
|
|
|
268
|
return $self; |
431
|
|
|
|
|
|
|
} ## end sub validate ($self) |
432
|
|
|
|
|
|
|
|
433
|
81
|
|
|
81
|
|
117
|
sub find_matching_child ($self, $command) { |
|
81
|
|
|
|
|
124
|
|
|
81
|
|
|
|
|
137
|
|
|
81
|
|
|
|
|
98
|
|
434
|
81
|
50
|
|
|
|
212
|
return unless defined $command; |
435
|
81
|
|
|
|
|
189
|
for my $candidate ($self->list_children) { |
436
|
132
|
|
|
|
|
369
|
my ($child) = $self->inflate_children($candidate); |
437
|
132
|
100
|
|
|
|
441
|
return $child if $child->supports($command); |
438
|
|
|
|
|
|
|
} |
439
|
4
|
|
|
|
|
28
|
return; |
440
|
|
|
|
|
|
|
} ## end sub find_matching_child |
441
|
|
|
|
|
|
|
|
442
|
26
|
|
|
26
|
|
54
|
sub _inflate_default_child ($self) { |
|
26
|
|
|
|
|
48
|
|
|
26
|
|
|
|
|
35
|
|
443
|
26
|
50
|
|
|
|
60
|
defined(my $default = $self->default_child) |
444
|
|
|
|
|
|
|
or die "undefined default child\n"; |
445
|
26
|
100
|
|
|
|
176
|
return undef if $default eq '-self'; |
446
|
4
|
50
|
|
|
|
14
|
my $child = $self->find_matching_child($default) |
447
|
|
|
|
|
|
|
or die "no child matching the default $default\n"; |
448
|
4
|
|
|
|
|
25
|
return $child; |
449
|
|
|
|
|
|
|
} ## end sub inflate_default_child ($self) |
450
|
|
|
|
|
|
|
|
451
|
|
|
|
|
|
|
# look for a child to hand execution over. Returns an child instance or |
452
|
|
|
|
|
|
|
# undef (which means that the $self is in charge of executing |
453
|
|
|
|
|
|
|
# something). This implements the most sensible default, deviations will |
454
|
|
|
|
|
|
|
# have to be coded explicitly. |
455
|
|
|
|
|
|
|
# Return values: |
456
|
|
|
|
|
|
|
# - (undef, '-leaf') if no child exists |
457
|
|
|
|
|
|
|
# - ($instance, @args) if a child is found with $args[0] |
458
|
|
|
|
|
|
|
# - ($instance, '-default') if the default child is returned |
459
|
|
|
|
|
|
|
# - (undef, '-fallback') in case $self is the fallback |
460
|
|
|
|
|
|
|
# - ($instance, '-fallback', @args) in case the fallback is returned |
461
|
148
|
|
|
148
|
|
210
|
sub find_child ($self) { |
|
148
|
|
|
|
|
259
|
|
|
148
|
|
|
|
|
183
|
|
462
|
148
|
100
|
|
|
|
294
|
my @candidates = $self->list_children or return (undef, '-leaf'); |
463
|
91
|
|
|
|
|
240
|
my @residuals = $self->residual_args; |
464
|
91
|
100
|
|
|
|
287
|
if (@residuals) { |
|
|
50
|
|
|
|
|
|
465
|
65
|
100
|
|
|
|
222
|
if (my $child = $self->find_matching_child($residuals[0])) { |
466
|
61
|
|
|
|
|
283
|
return ($child, @residuals); |
467
|
|
|
|
|
|
|
} # otherwise... see what the fallback is about |
468
|
|
|
|
|
|
|
} |
469
|
|
|
|
|
|
|
elsif (defined(my $default = $self->default_child)) { |
470
|
26
|
|
|
|
|
152
|
return ($self->_inflate_default_child, '-default'); |
471
|
|
|
|
|
|
|
} |
472
|
|
|
|
|
|
|
|
473
|
|
|
|
|
|
|
# try the fallback... |
474
|
4
|
|
|
|
|
33
|
my $fallback = $self->fallback; |
475
|
4
|
50
|
|
|
|
18
|
if (defined $fallback) { |
476
|
0
|
0
|
|
|
|
0
|
return (undef, '-fallback') if $fallback eq '-self'; |
477
|
0
|
0
|
|
|
|
0
|
return ($self->_inflate_default_child, '-default') |
478
|
|
|
|
|
|
|
if $fallback eq '-default'; |
479
|
0
|
0
|
|
|
|
0
|
if (my $child = $self->find_matching_child($fallback)) { |
480
|
0
|
|
|
|
|
0
|
return ($child, -fallback => @residuals); |
481
|
|
|
|
|
|
|
} |
482
|
|
|
|
|
|
|
} ## end if (defined $fallback) |
483
|
|
|
|
|
|
|
|
484
|
|
|
|
|
|
|
# no fallback at this point... it's an error, build a message and die! |
485
|
|
|
|
|
|
|
# FIXME this can be improved |
486
|
4
|
|
|
|
|
78
|
die "cannot find sub-command '$residuals[0]'\n"; |
487
|
|
|
|
|
|
|
} ## end sub find_child ($self) |
488
|
|
|
|
|
|
|
|
489
|
|
|
|
|
|
|
# get the list of children. This only gives back a list of "hints" that |
490
|
|
|
|
|
|
|
# can be turned into instances via inflate_children. In this case, it's |
491
|
|
|
|
|
|
|
# module names |
492
|
402
|
|
|
402
|
|
600
|
sub list_children ($self) { |
|
402
|
|
|
|
|
578
|
|
|
402
|
|
|
|
|
474
|
|
493
|
402
|
|
|
|
|
881
|
my @children = $self->children; |
494
|
402
|
|
|
|
|
1876
|
require File::Spec; |
495
|
|
|
|
|
|
|
my @expanded_inc = map { |
496
|
402
|
|
|
|
|
862
|
my ($v, $dirs) = File::Spec->splitpath($_, 'no-file'); |
|
3707
|
|
|
|
|
14311
|
|
497
|
3707
|
|
|
|
|
18880
|
[$v, File::Spec->splitdir($dirs)]; |
498
|
|
|
|
|
|
|
} @INC; |
499
|
402
|
|
|
|
|
725
|
my %seen; |
500
|
|
|
|
|
|
|
push @children, map { |
501
|
402
|
|
|
|
|
1048
|
my @parts = split m{::}mxs, $_ . 'x'; |
|
402
|
|
|
|
|
1498
|
|
502
|
402
|
|
|
|
|
1058
|
substr(my $bprefix = pop @parts, -1, 1, ''); |
503
|
|
|
|
|
|
|
map { |
504
|
402
|
|
|
|
|
665
|
my ($v, @dirs) = $_->@*; |
|
3707
|
|
|
|
|
12327
|
|
505
|
3707
|
|
|
|
|
25962
|
my $dirs = File::Spec->catdir(@dirs, @parts); |
506
|
3707
|
50
|
|
|
|
65201
|
if (opendir my $dh, File::Spec->catpath($v, $dirs, '')) { |
507
|
0
|
|
|
|
|
0
|
grep { !$seen{$_}++ } |
508
|
|
|
|
|
|
|
map { |
509
|
0
|
|
|
|
|
0
|
substr(my $lastpart = $_, -3, 3, ''); |
510
|
0
|
|
|
|
|
0
|
join '::', @parts, $lastpart; |
511
|
|
|
|
|
|
|
} grep { |
512
|
0
|
|
|
|
|
0
|
my $path = File::Spec->catpath($v, $dirs, $_); |
513
|
0
|
0
|
0
|
|
|
0
|
(-e $path && !-d $path) |
|
|
|
0
|
|
|
|
|
514
|
|
|
|
|
|
|
&& substr($_, 0, length($bprefix)) eq $bprefix |
515
|
|
|
|
|
|
|
&& substr($_, -3, 3) eq '.pm' |
516
|
0
|
|
|
|
|
0
|
} sort { $a cmp $b } readdir $dh; |
|
0
|
|
|
|
|
0
|
|
517
|
|
|
|
|
|
|
} ## end if (opendir my $dh, File::Spec...) |
518
|
3707
|
|
|
|
|
18582
|
else { () } |
519
|
|
|
|
|
|
|
} @expanded_inc; |
520
|
|
|
|
|
|
|
} $self->children_prefixes; |
521
|
|
|
|
|
|
|
push @children, map { |
522
|
402
|
|
|
|
|
1244
|
my $prefix = $_; |
|
402
|
|
|
|
|
655
|
|
523
|
44
|
|
|
|
|
196
|
grep { !$seen{$_}++ } |
524
|
|
|
|
|
|
|
grep { |
525
|
402
|
|
|
|
|
996
|
my $this_prefix = substr $_, 0, length $prefix; |
|
423
|
|
|
|
|
734
|
|
526
|
423
|
|
|
|
|
941
|
$this_prefix eq $prefix; |
527
|
|
|
|
|
|
|
} keys %App::Easer::V2::registered; |
528
|
|
|
|
|
|
|
} $self->children_prefixes; |
529
|
402
|
100
|
100
|
|
|
1115
|
push @children, $self->auto_children |
530
|
|
|
|
|
|
|
if $self->force_auto_children // @children; |
531
|
402
|
|
|
|
|
3605
|
return @children; |
532
|
|
|
|
|
|
|
} ## end sub list_children ($self) |
533
|
|
|
|
|
|
|
|
534
|
844
|
|
|
844
|
|
1014
|
sub _auto_child ($self, $name, $inflate = 0) { |
|
844
|
|
|
|
|
1177
|
|
|
844
|
|
|
|
|
1051
|
|
|
844
|
|
|
|
|
1031
|
|
|
844
|
|
|
|
|
986
|
|
535
|
844
|
|
|
|
|
2083
|
my $child = __PACKAGE__ . '::' . ucfirst(lc($name)); |
536
|
844
|
100
|
|
|
|
1508
|
($child) = $self->inflate_children($child) if $inflate; |
537
|
844
|
|
|
|
|
1879
|
return $child; |
538
|
|
|
|
|
|
|
} |
539
|
|
|
|
|
|
|
|
540
|
|
|
|
|
|
|
# returns either class names or inflated objects |
541
|
280
|
|
|
280
|
|
408
|
sub auto_children ($self, $inflate = 0) { |
|
280
|
|
|
|
|
392
|
|
|
280
|
|
|
|
|
414
|
|
|
280
|
|
|
|
|
363
|
|
542
|
280
|
|
|
|
|
523
|
map { $self->_auto_child($_, $inflate) } qw< help commands tree >; |
|
840
|
|
|
|
|
1480
|
|
543
|
|
|
|
|
|
|
} |
544
|
|
|
|
|
|
|
|
545
|
1
|
|
|
1
|
|
12
|
sub auto_commands ($self) { return $self->_auto_child('commands', 1) } |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
4
|
|
546
|
|
|
|
|
|
|
|
547
|
3
|
|
|
3
|
|
12
|
sub auto_help ($self) { return $self->_auto_child('help', 1) } |
|
3
|
|
|
|
|
6
|
|
|
3
|
|
|
|
|
4
|
|
|
3
|
|
|
|
|
10
|
|
548
|
|
|
|
|
|
|
|
549
|
0
|
|
|
0
|
|
0
|
sub auto_tree ($self) { return $self->_auto_child('tree', 1) } |
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
550
|
|
|
|
|
|
|
|
551
|
1
|
|
|
1
|
|
9
|
sub run_help ($self) { return $self->auto_help->run($self->name) } |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
3
|
|
|
1
|
|
|
|
|
4
|
|
552
|
1
|
|
|
1
|
|
45
|
sub full_help_text ($s) { return $s->auto_help->collect_help_for($s) } |
|
1
|
|
|
|
|
3
|
|
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
5
|
|
553
|
|
|
|
|
|
|
|
554
|
0
|
|
|
0
|
|
0
|
sub load_module ($sop, $module) { |
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
555
|
0
|
|
|
|
|
0
|
my $file = "$module.pm" =~ s{::}{/}grmxs; |
556
|
0
|
0
|
|
|
|
0
|
eval { require $file } or Carp::confess("module<$module>: $EVAL_ERROR"); |
|
0
|
|
|
|
|
0
|
|
557
|
0
|
|
|
|
|
0
|
return $module; |
558
|
|
|
|
|
|
|
} |
559
|
|
|
|
|
|
|
|
560
|
|
|
|
|
|
|
# Gets a specification like "Foo::Bar::baz" and returns a reference to |
561
|
|
|
|
|
|
|
# sub "baz" in "Foo::Bar". If no package name is set, returns a |
562
|
|
|
|
|
|
|
# reference to a sub in the package of $self. FIXME document properly |
563
|
655
|
|
|
655
|
|
898
|
sub ref_to_sub ($self, $spec) { |
|
655
|
|
|
|
|
890
|
|
|
655
|
|
|
|
|
932
|
|
|
655
|
|
|
|
|
829
|
|
564
|
655
|
50
|
|
|
|
1211
|
Carp::confess("undefined specification in ref_to_sub") |
565
|
|
|
|
|
|
|
unless defined $spec; |
566
|
655
|
100
|
|
|
|
1326
|
return $spec if ref($spec) eq 'CODE'; |
567
|
610
|
50
|
|
|
|
3360
|
my ($class, $function) = |
568
|
|
|
|
|
|
|
ref($spec) eq 'ARRAY' |
569
|
|
|
|
|
|
|
? $spec->@* |
570
|
|
|
|
|
|
|
: $spec =~ m{\A (?: (.*) :: )? (.*) \z}mxs; |
571
|
610
|
100
|
100
|
|
|
4378
|
return $self->can($function) unless length($class // ''); |
572
|
1
|
50
|
|
|
|
12
|
$self->load_module($class) unless $class->can($function); |
573
|
1
|
|
|
|
|
5
|
return $class->can($function); |
574
|
|
|
|
|
|
|
} ## end sub ref_to_sub |
575
|
|
|
|
|
|
|
|
576
|
197
|
|
|
197
|
|
310
|
sub instantiate ($sop, $class, @args) { |
|
197
|
|
|
|
|
266
|
|
|
197
|
|
|
|
|
266
|
|
|
197
|
|
|
|
|
249
|
|
|
197
|
|
|
|
|
265
|
|
577
|
197
|
50
|
|
|
|
1727
|
$sop->load_module($class) unless $class->can('new'); |
578
|
197
|
|
|
|
|
506
|
return $class->new(@args); |
579
|
|
|
|
|
|
|
} |
580
|
|
|
|
|
|
|
|
581
|
|
|
|
|
|
|
# transform one or more children "hints" into instances. |
582
|
161
|
|
|
161
|
|
224
|
sub inflate_children ($self, @hints) { |
|
161
|
|
|
|
|
232
|
|
|
161
|
|
|
|
|
239
|
|
|
161
|
|
|
|
|
205
|
|
583
|
161
|
|
|
|
|
326
|
my $hashy = $self->hashy_class; |
584
|
|
|
|
|
|
|
map { |
585
|
197
|
|
|
|
|
296
|
my $child = $_; |
586
|
197
|
50
|
|
|
|
492
|
if (!blessed($child)) { # actually inflate it |
587
|
197
|
100
|
|
|
|
706
|
$child = |
|
|
100
|
|
|
|
|
|
588
|
|
|
|
|
|
|
ref($child) eq 'ARRAY' ? $self->instantiate($child->@*) |
589
|
|
|
|
|
|
|
: ref($child) eq 'HASH' ? $self->instantiate($hashy, $child) |
590
|
|
|
|
|
|
|
: $self->instantiate($child); |
591
|
|
|
|
|
|
|
} ## end if (!blessed($child)) |
592
|
197
|
|
|
|
|
648
|
$child->parent($self); |
593
|
197
|
|
|
|
|
826
|
$child; |
594
|
161
|
|
|
|
|
381
|
} grep { defined $_ } @hints; |
|
197
|
|
|
|
|
447
|
|
595
|
|
|
|
|
|
|
} ## end sub inflate_children |
596
|
|
|
|
|
|
|
|
597
|
|
|
|
|
|
|
# fallback mechanism when finding a child, relies on fallback_to. |
598
|
4
|
|
|
4
|
|
8
|
sub fallback ($self) { |
|
4
|
|
|
|
|
10
|
|
|
4
|
|
|
|
|
5
|
|
599
|
4
|
|
|
|
|
14
|
my $fto = $self->fallback_to; |
600
|
4
|
50
|
33
|
|
|
41
|
return $fto if !defined($fto) || $fto !~ m{\A(?: 0 | [1-9]\d* )\z}; |
601
|
0
|
|
|
|
|
0
|
my @children = $self->list_children; |
602
|
0
|
0
|
|
|
|
0
|
return $children[$fto] if $fto <= $#children; |
603
|
0
|
|
|
|
|
0
|
return undef; |
604
|
|
|
|
|
|
|
} ## end sub fallback ($self) |
605
|
|
|
|
|
|
|
|
606
|
|
|
|
|
|
|
# execute what's set as the execute sub in the slot |
607
|
43
|
|
|
43
|
|
65
|
sub execute ($self) { |
|
43
|
|
|
|
|
66
|
|
|
43
|
|
|
|
|
55
|
|
608
|
43
|
50
|
|
|
|
82
|
my $spec = $self->_rw or die "nothing to search for execution\n"; |
609
|
43
|
50
|
|
|
|
139
|
my $sub = $self->ref_to_sub($spec) or die "nothing to execute\n"; |
610
|
43
|
|
|
|
|
148
|
return $sub->($self); |
611
|
|
|
|
|
|
|
} |
612
|
|
|
|
|
|
|
|
613
|
148
|
|
|
148
|
|
218
|
sub run ($self, $name, @args) { |
|
148
|
|
|
|
|
240
|
|
|
148
|
|
|
|
|
238
|
|
|
148
|
|
|
|
|
241
|
|
|
148
|
|
|
|
|
187
|
|
614
|
148
|
|
|
|
|
546
|
$self->call_name($name); |
615
|
148
|
|
|
|
|
696
|
$self->collect(@args); |
616
|
148
|
|
|
|
|
464
|
$self->commit; |
617
|
148
|
|
|
|
|
467
|
$self->validate; |
618
|
148
|
|
|
|
|
435
|
my ($child, @child_args) = $self->find_child; |
619
|
144
|
100
|
|
|
|
575
|
return $child->run(@child_args) if defined $child; |
620
|
79
|
|
|
|
|
386
|
$self->execution_reason($child_args[0]); |
621
|
79
|
|
|
|
|
385
|
return $self->execute; |
622
|
|
|
|
|
|
|
} ## end sub run |
623
|
|
|
|
|
|
|
|
624
|
|
|
|
|
|
|
package App::Easer::V2::Command::Commands; |
625
|
|
|
|
|
|
|
push our @ISA, 'App::Easer::V2::Command'; |
626
|
27
|
|
|
27
|
|
61
|
sub aliases { 'commands' } |
627
|
14
|
|
|
14
|
|
43
|
sub allow_residual_options { 0 } |
628
|
0
|
|
|
0
|
|
0
|
sub description { 'Print list of supported sub-commands' } |
629
|
17
|
|
|
17
|
|
47
|
sub help { 'list sub-commands' } |
630
|
0
|
|
|
0
|
|
0
|
sub name { 'commands' } |
631
|
|
|
|
|
|
|
|
632
|
48
|
|
|
48
|
|
107
|
sub target ($self) { |
|
48
|
|
|
|
|
69
|
|
|
48
|
|
|
|
|
62
|
|
633
|
48
|
|
|
|
|
118
|
my ($subc, @rest) = $self->residual_args; |
634
|
48
|
50
|
|
|
|
131
|
die "this command does not support many arguments\n" if @rest; |
635
|
48
|
|
|
|
|
158
|
my $target = $self->parent; |
636
|
48
|
100
|
|
|
|
165
|
$target = $target->find_matching_child($subc) if defined $subc; |
637
|
48
|
50
|
|
|
|
146
|
die "cannot find sub-command '$subc'\n" unless defined $target; |
638
|
48
|
|
|
|
|
234
|
return $target; |
639
|
|
|
|
|
|
|
} ## end sub target ($self) |
640
|
|
|
|
|
|
|
|
641
|
25
|
|
|
25
|
|
55
|
sub list_commands_for ($self, $target = undef) { |
|
25
|
|
|
|
|
49
|
|
|
25
|
|
|
|
|
45
|
|
|
25
|
|
|
|
|
35
|
|
642
|
25
|
|
33
|
|
|
72
|
$target //= $self->target; |
643
|
25
|
|
|
|
|
52
|
my @lines; |
644
|
25
|
|
|
|
|
76
|
for my $command ($target->inflate_children($target->list_children)) { |
645
|
61
|
|
50
|
|
|
258
|
my $help = $command->help // '(**missing help**)'; |
646
|
61
|
|
|
|
|
173
|
my @aliases = $command->aliases; |
647
|
61
|
50
|
|
|
|
134
|
next unless @aliases; |
648
|
61
|
|
|
|
|
234
|
push @lines, sprintf '%15s: %s', shift(@aliases), $help; |
649
|
61
|
100
|
|
|
|
186
|
push @lines, sprintf '%15s (also as: %s)', '', join ', ', @aliases |
650
|
|
|
|
|
|
|
if @aliases; |
651
|
|
|
|
|
|
|
} ## end for my $command ($target...) |
652
|
25
|
100
|
|
|
|
382
|
return unless @lines; |
653
|
17
|
|
|
|
|
128
|
return join "\n", @lines; |
654
|
|
|
|
|
|
|
} ## end sub list_commands_for |
655
|
|
|
|
|
|
|
|
656
|
24
|
|
|
24
|
|
44
|
sub help_channel ($self) { $self->target->help_channel } |
|
24
|
|
|
|
|
42
|
|
|
24
|
|
|
|
|
39
|
|
|
24
|
|
|
|
|
59
|
|
657
|
|
|
|
|
|
|
|
658
|
24
|
|
|
24
|
|
46
|
sub _build_printout_facility ($self) { |
|
24
|
|
|
|
|
53
|
|
|
24
|
|
|
|
|
35
|
|
659
|
24
|
|
|
|
|
114
|
my $channel = $self->help_channel; |
660
|
24
|
|
|
|
|
109
|
my $refch = ref $channel; |
661
|
|
|
|
|
|
|
|
662
|
24
|
50
|
|
|
|
94
|
return $channel if $refch eq 'CODE'; |
663
|
|
|
|
|
|
|
|
664
|
24
|
|
|
|
|
38
|
my $fh; |
665
|
24
|
50
|
|
|
|
121
|
if ($refch eq 'GLOB') { |
|
|
50
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
666
|
0
|
|
|
|
|
0
|
$fh = $channel; |
667
|
|
|
|
|
|
|
} |
668
|
|
|
|
|
|
|
elsif ($refch eq 'SCALAR') { |
669
|
0
|
0
|
|
|
|
0
|
open $fh, '>', $channel or die "open(): $!\n"; |
670
|
|
|
|
|
|
|
} |
671
|
|
|
|
|
|
|
elsif ($refch) { |
672
|
0
|
|
|
|
|
0
|
die 'invalid channel'; |
673
|
|
|
|
|
|
|
} |
674
|
|
|
|
|
|
|
else { |
675
|
24
|
|
|
|
|
119
|
($channel, my $binmode) = split m{:}mxs, $channel, 2; |
676
|
24
|
50
|
33
|
|
|
133
|
if ($channel eq '-' || lc($channel) eq '-stdout') { |
|
|
0
|
|
|
|
|
|
677
|
24
|
|
|
|
|
61
|
$fh = \*STDOUT; |
678
|
|
|
|
|
|
|
} |
679
|
|
|
|
|
|
|
elsif (lc($channel) eq '-stderr') { |
680
|
0
|
|
|
|
|
0
|
$fh = \*STDERR; |
681
|
|
|
|
|
|
|
} |
682
|
|
|
|
|
|
|
else { |
683
|
0
|
0
|
|
|
|
0
|
open $fh, '>', $channel or die "open('$channel'): $!\n"; |
684
|
|
|
|
|
|
|
} |
685
|
24
|
50
|
50
|
11
|
|
776
|
binmode $fh, $binmode if length($binmode // ''); |
|
11
|
|
|
|
|
78
|
|
|
11
|
|
|
|
|
29
|
|
|
11
|
|
|
|
|
95
|
|
686
|
|
|
|
|
|
|
} |
687
|
|
|
|
|
|
|
|
688
|
24
|
|
|
24
|
|
41
|
return sub ($cmd, @stuff) { |
|
24
|
|
|
|
|
41
|
|
|
24
|
|
|
|
|
45
|
|
|
24
|
|
|
|
|
56
|
|
689
|
24
|
|
|
|
|
46
|
print {$fh} @stuff; |
|
24
|
|
|
|
|
1482
|
|
690
|
24
|
|
|
|
|
180
|
return $cmd; |
691
|
|
|
|
|
|
|
} |
692
|
24
|
|
|
|
|
113203
|
} |
693
|
|
|
|
|
|
|
|
694
|
24
|
|
|
24
|
|
46
|
sub printout ($self, @stuff) { |
|
24
|
|
|
|
|
37
|
|
|
24
|
|
|
|
|
50
|
|
|
24
|
|
|
|
|
50
|
|
695
|
24
|
|
|
|
|
57
|
my $pof = $self->_rw; |
696
|
24
|
50
|
|
|
|
168
|
$self->_rw($pof = $self->_build_printout_facility) unless $pof; |
697
|
24
|
|
|
|
|
111
|
$pof->($self, @stuff); |
698
|
|
|
|
|
|
|
} |
699
|
|
|
|
|
|
|
|
700
|
7
|
|
|
7
|
|
26
|
sub execute ($self) { |
|
7
|
|
|
|
|
17
|
|
|
7
|
|
|
|
|
14
|
|
701
|
7
|
|
|
|
|
24
|
my $target = $self->target; |
702
|
7
|
|
33
|
|
|
36
|
my $name = $target->call_name // $target->name; |
703
|
7
|
100
|
|
|
|
52
|
if (defined(my $commands = $self->list_commands_for($target))) { |
704
|
6
|
|
|
|
|
50
|
$self->printout("sub-commands for $name\n", $commands, "\n"); |
705
|
|
|
|
|
|
|
} |
706
|
|
|
|
|
|
|
else { |
707
|
1
|
|
|
|
|
10
|
$self->printout("no sub-commands for $name\n"); |
708
|
|
|
|
|
|
|
} |
709
|
|
|
|
|
|
|
} ## end sub execute ($self) |
710
|
|
|
|
|
|
|
|
711
|
|
|
|
|
|
|
package App::Easer::V2::Command::Help; |
712
|
|
|
|
|
|
|
push our @ISA, 'App::Easer::V2::Command::Commands'; |
713
|
42
|
|
|
42
|
|
189
|
sub aliases { 'help' } |
714
|
34
|
|
|
34
|
|
108
|
sub allow_residual_options { 0 } |
715
|
0
|
|
|
0
|
|
0
|
sub description { 'Print help for (sub)command' } |
716
|
17
|
|
|
17
|
|
62
|
sub help { 'print a help command' } |
717
|
0
|
|
|
0
|
|
0
|
sub name { 'help' } |
718
|
|
|
|
|
|
|
|
719
|
33
|
|
|
33
|
|
59
|
sub __commandline_help ($getopt) { |
|
33
|
|
|
|
|
55
|
|
|
33
|
|
|
|
|
48
|
|
720
|
33
|
|
|
|
|
43
|
my @retval; |
721
|
|
|
|
|
|
|
|
722
|
33
|
|
|
|
|
67
|
my ($mode, $type, $desttype, $min, $max, $default); |
723
|
33
|
100
|
|
|
|
314
|
if (substr($getopt, -1, 1) eq '!') { |
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
724
|
14
|
|
|
|
|
47
|
$type = 'bool-negatable'; |
725
|
14
|
|
|
|
|
38
|
substr $getopt, -1, 1, ''; |
726
|
14
|
|
|
|
|
47
|
push @retval, 'boolean (can be negated)'; |
727
|
|
|
|
|
|
|
} |
728
|
|
|
|
|
|
|
elsif ($getopt =~ s<:\+ ([@%])? \z><>mxs) { |
729
|
1
|
|
|
|
|
2
|
$mode = 'optional'; |
730
|
1
|
|
|
|
|
3
|
$type = 'i'; |
731
|
1
|
|
|
|
|
2
|
$default = 'increment'; |
732
|
1
|
|
|
|
|
2
|
$desttype = $1; |
733
|
1
|
|
|
|
|
2
|
my $line = "integer, value is optional, defaults to incrementing current value"; |
734
|
1
|
50
|
33
|
|
|
4
|
$line .= ", list valued" if defined($desttype) && $desttype eq '@'; |
735
|
1
|
|
|
|
|
2
|
push @retval, $line; |
736
|
|
|
|
|
|
|
} ## end elsif ($getopt =~ s<:+ ([@%])? \z><>mxs) |
737
|
|
|
|
|
|
|
elsif (substr($getopt, -1, 1) eq '+') { |
738
|
1
|
|
|
|
|
3
|
$mode = 'increment'; |
739
|
1
|
|
|
|
|
2
|
substr $getopt, -1, 1, ''; |
740
|
1
|
|
|
|
|
2
|
push @retval, |
741
|
|
|
|
|
|
|
'incremental integer (adds 1 every time it is provided)'; |
742
|
|
|
|
|
|
|
} ## end elsif (substr($getopt, -1...)) |
743
|
|
|
|
|
|
|
elsif ( |
744
|
|
|
|
|
|
|
$getopt =~ s<( |
745
|
|
|
|
|
|
|
[:=]) # 1 mode |
746
|
|
|
|
|
|
|
([siof]) # 2 type |
747
|
|
|
|
|
|
|
([@%])? # 3 desttype |
748
|
|
|
|
|
|
|
(?: |
749
|
|
|
|
|
|
|
\{ |
750
|
|
|
|
|
|
|
(\d*)? # 4 min |
751
|
|
|
|
|
|
|
,? |
752
|
|
|
|
|
|
|
(\d*)? # 5 max |
753
|
|
|
|
|
|
|
\} |
754
|
|
|
|
|
|
|
)? \z><>mxs |
755
|
|
|
|
|
|
|
) |
756
|
|
|
|
|
|
|
{ |
757
|
15
|
100
|
|
|
|
66
|
$mode = $1 eq '=' ? 'required' : 'optional'; |
758
|
15
|
|
|
|
|
36
|
$type = $2; |
759
|
15
|
|
|
|
|
36
|
$desttype = $3; |
760
|
15
|
|
|
|
|
43
|
$min = $4; |
761
|
15
|
|
|
|
|
30
|
$max = $5; |
762
|
15
|
50
|
|
|
|
62
|
if (defined $min) { |
763
|
0
|
0
|
|
|
|
0
|
$mode = $min ? 'optional' : 'required'; |
764
|
|
|
|
|
|
|
} |
765
|
|
|
|
|
|
|
$type = { |
766
|
|
|
|
|
|
|
s => 'string', |
767
|
|
|
|
|
|
|
i => 'integer', |
768
|
|
|
|
|
|
|
o => 'perl-extended-integer', |
769
|
|
|
|
|
|
|
f => 'float', |
770
|
15
|
|
|
|
|
98
|
}->{$type}; |
771
|
15
|
|
|
|
|
67
|
my $line = "$type, value is $mode"; |
772
|
15
|
50
|
33
|
|
|
61
|
$line .= ", at least $min times" if defined($min) && $min > 1; |
773
|
15
|
50
|
33
|
|
|
62
|
$line .= ", no more than $max times" |
774
|
|
|
|
|
|
|
if defined($max) && length($max); |
775
|
15
|
100
|
66
|
|
|
59
|
$line .= ", list valued" if defined($desttype) && $desttype eq '@'; |
776
|
15
|
|
|
|
|
38
|
push @retval, $line; |
777
|
|
|
|
|
|
|
} ## end elsif ($getopt =~ s<( ) ) |
778
|
|
|
|
|
|
|
elsif ($getopt =~ s<: (\d+) ([@%])? \z><>mxs) { |
779
|
1
|
|
|
|
|
3
|
$mode = 'optional'; |
780
|
1
|
|
|
|
|
2
|
$type = 'i'; |
781
|
1
|
|
|
|
|
3
|
$default = $1; |
782
|
1
|
|
|
|
|
2
|
$desttype = $2; |
783
|
1
|
|
|
|
|
3
|
my $line = "integer, value is optional, defaults to $default"; |
784
|
1
|
50
|
33
|
|
|
14
|
$line .= ", list valued" if defined($desttype) && $desttype eq '@'; |
785
|
1
|
|
|
|
|
4
|
push @retval, $line; |
786
|
|
|
|
|
|
|
} ## end elsif ($getopt =~ s<: (\d+) ([@%])? \z><>mxs) |
787
|
|
|
|
|
|
|
else { # boolean, non-negatable |
788
|
1
|
|
|
|
|
2
|
$type = 'bool'; |
789
|
1
|
|
|
|
|
3
|
push @retval, 'boolean'; |
790
|
|
|
|
|
|
|
} |
791
|
|
|
|
|
|
|
|
792
|
33
|
|
|
|
|
145
|
my @alternatives = split /\|/, $getopt; |
793
|
33
|
100
|
100
|
|
|
296
|
if ($type eq 'bool-negatable') { |
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
794
|
|
|
|
|
|
|
push @retval, map { |
795
|
14
|
100
|
|
|
|
44
|
if (length($_) == 1) { "-$_" } |
|
26
|
|
|
|
|
68
|
|
|
12
|
|
|
|
|
43
|
|
796
|
14
|
|
|
|
|
63
|
else { "--$_ | --no-$_" } |
797
|
|
|
|
|
|
|
} @alternatives; |
798
|
|
|
|
|
|
|
} ## end if ($type eq 'bool') |
799
|
|
|
|
|
|
|
elsif ($type eq 'bool' || $mode eq 'increment') { |
800
|
|
|
|
|
|
|
push @retval, map { |
801
|
2
|
100
|
|
|
|
7
|
if (length($_) == 1) { "-$_" } |
|
3
|
|
|
|
|
8
|
|
|
1
|
|
|
|
|
4
|
|
802
|
2
|
|
|
|
|
18
|
else { "--$_" } |
803
|
|
|
|
|
|
|
} @alternatives; |
804
|
|
|
|
|
|
|
} ## end if ($type eq 'bool') |
805
|
|
|
|
|
|
|
elsif ($mode eq 'optional') { |
806
|
|
|
|
|
|
|
push @retval, map { |
807
|
3
|
50
|
|
|
|
5
|
if (length($_) == 1) { "-$_ []" } |
|
3
|
|
|
|
|
9
|
|
|
0
|
|
|
|
|
0
|
|
808
|
3
|
|
|
|
|
24
|
else { "--$_ []" } |
809
|
|
|
|
|
|
|
} @alternatives; |
810
|
|
|
|
|
|
|
} ## end elsif ($mode eq 'optional') |
811
|
|
|
|
|
|
|
else { |
812
|
|
|
|
|
|
|
push @retval, map { |
813
|
14
|
100
|
|
|
|
38
|
if (length($_) == 1) { "-$_ " } |
|
27
|
|
|
|
|
63
|
|
|
13
|
|
|
|
|
41
|
|
814
|
14
|
|
|
|
|
58
|
else { "--$_ " } |
815
|
|
|
|
|
|
|
} @alternatives; |
816
|
|
|
|
|
|
|
} ## end else [ if ($type eq 'bool') ] |
817
|
|
|
|
|
|
|
|
818
|
33
|
|
|
|
|
132
|
return @retval; |
819
|
|
|
|
|
|
|
} ## end sub __commandline_help ($getopt) |
820
|
|
|
|
|
|
|
|
821
|
17
|
|
|
17
|
|
91
|
sub execute ($self) { |
|
17
|
|
|
|
|
62
|
|
|
17
|
|
|
|
|
35
|
|
822
|
17
|
|
|
|
|
115
|
$self->printout($self->collect_help_for($self->target)); |
823
|
17
|
|
|
|
|
562
|
return 0; |
824
|
|
|
|
|
|
|
} |
825
|
|
|
|
|
|
|
|
826
|
18
|
|
|
18
|
|
41
|
sub collect_help_for ($self, $target = undef) { |
|
18
|
|
|
|
|
82
|
|
|
18
|
|
|
|
|
43
|
|
|
18
|
|
|
|
|
33
|
|
827
|
18
|
|
33
|
|
|
81
|
$target //= $self->target; |
828
|
18
|
|
|
|
|
33
|
my @stuff; |
829
|
|
|
|
|
|
|
|
830
|
18
|
|
|
|
|
67
|
push @stuff, $target->help, "\n\n"; |
831
|
|
|
|
|
|
|
|
832
|
18
|
50
|
|
|
|
104
|
if (defined(my $description = $target->description)) { |
833
|
18
|
|
|
|
|
199
|
$description =~ s{\A\s+|\s+\z}{}gmxs; # trim |
834
|
18
|
|
|
|
|
103
|
$description =~ s{^}{ }gmxs; # add some indentation |
835
|
18
|
|
|
|
|
72
|
push @stuff, "Description:\n$description\n\n"; |
836
|
|
|
|
|
|
|
} |
837
|
|
|
|
|
|
|
|
838
|
|
|
|
|
|
|
# Print this only for sub-commands, not for the root |
839
|
18
|
100
|
|
|
|
60
|
push @stuff, sprintf "Can be called as: %s\n\n", join ', ', |
840
|
|
|
|
|
|
|
$target->aliases |
841
|
|
|
|
|
|
|
if $target->parent; |
842
|
|
|
|
|
|
|
|
843
|
18
|
100
|
|
|
|
84
|
if (my @options = $target->options) { |
844
|
16
|
|
|
|
|
50
|
push @stuff, "Options:\n"; |
845
|
16
|
|
|
|
|
48
|
my $n = 0; # count the option |
846
|
16
|
|
|
|
|
49
|
for my $opt (@options) { |
847
|
33
|
100
|
|
|
|
141
|
push @stuff, "\n" if $n++; # from second line on |
848
|
|
|
|
|
|
|
|
849
|
|
|
|
|
|
|
push @stuff, sprintf "%15s: %s\n", $target->name_for_option($opt), |
850
|
33
|
|
100
|
|
|
108
|
$opt->{help} // ''; |
851
|
|
|
|
|
|
|
|
852
|
33
|
50
|
|
|
|
120
|
if (exists $opt->{getopt}) { |
853
|
33
|
|
|
|
|
96
|
my @lines = __commandline_help($opt->{getopt}); |
854
|
33
|
|
|
|
|
160
|
push @stuff, sprintf "%15s command-line: %s\n", '', |
855
|
|
|
|
|
|
|
shift(@lines); |
856
|
|
|
|
|
|
|
push @stuff, |
857
|
33
|
|
|
|
|
70
|
map { sprintf "%15s %s\n", '', $_ } @lines; |
|
59
|
|
|
|
|
206
|
|
858
|
|
|
|
|
|
|
} ## end if (exists $opt->{getopt...}) |
859
|
|
|
|
|
|
|
|
860
|
33
|
100
|
|
|
|
136
|
if (defined(my $env = $self->environment_variable_name($opt))) { |
861
|
13
|
|
|
|
|
86
|
push @stuff, sprintf "%15s environment: %s\n", '', $env; |
862
|
|
|
|
|
|
|
} |
863
|
|
|
|
|
|
|
|
864
|
|
|
|
|
|
|
push @stuff, sprintf "%15s default: %s\n", '', |
865
|
|
|
|
|
|
|
$opt->{default} // '*undef*' |
866
|
33
|
100
|
50
|
|
|
170
|
if exists $opt->{default}; |
867
|
|
|
|
|
|
|
} ## end for my $opt (@options) |
868
|
|
|
|
|
|
|
|
869
|
16
|
|
|
|
|
47
|
push @stuff, "\n"; |
870
|
|
|
|
|
|
|
} ## end if (my @options = $target...) |
871
|
|
|
|
|
|
|
else { |
872
|
2
|
|
|
|
|
14
|
push @stuff, "This command has no option\n"; |
873
|
|
|
|
|
|
|
} |
874
|
|
|
|
|
|
|
|
875
|
18
|
100
|
|
|
|
107
|
if (defined(my $commands = $self->list_commands_for($target))) { |
876
|
11
|
|
|
|
|
47
|
push @stuff, "Sub-commands:\n", $commands, "\n"; |
877
|
|
|
|
|
|
|
} |
878
|
|
|
|
|
|
|
else { |
879
|
7
|
|
|
|
|
20
|
push @stuff, "No sub-commands\n"; |
880
|
|
|
|
|
|
|
} |
881
|
|
|
|
|
|
|
|
882
|
18
|
|
|
|
|
267
|
return join '', @stuff; |
883
|
|
|
|
|
|
|
} ## end sub execute ($self) |
884
|
|
|
|
|
|
|
|
885
|
|
|
|
|
|
|
package App::Easer::V2::Command::Tree; |
886
|
|
|
|
|
|
|
push our @ISA, 'App::Easer::V2::Command::Commands'; |
887
|
21
|
|
|
21
|
|
65
|
sub aliases { 'tree' } |
888
|
0
|
|
|
0
|
|
0
|
sub description { 'Print tree of supported sub-commands' } |
889
|
17
|
|
|
17
|
|
39
|
sub help { 'print sub-commands in a tree' } |
890
|
0
|
|
|
0
|
|
0
|
sub name { 'tree' } |
891
|
|
|
|
|
|
|
|
892
|
|
|
|
|
|
|
sub options { |
893
|
|
|
|
|
|
|
return ( |
894
|
|
|
|
|
|
|
{ |
895
|
0
|
|
|
0
|
|
0
|
getopt => 'include_auto|include-auto|I!', |
896
|
|
|
|
|
|
|
default => 0, |
897
|
|
|
|
|
|
|
environment => 1, |
898
|
|
|
|
|
|
|
}, |
899
|
|
|
|
|
|
|
); |
900
|
|
|
|
|
|
|
} ## end sub options |
901
|
|
|
|
|
|
|
|
902
|
0
|
|
|
0
|
|
0
|
sub list_commands_for ($self, $target) { |
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
903
|
0
|
0
|
|
|
|
0
|
my $exclude_auto = $self->config('include_auto') ? 0 : 1; |
904
|
0
|
|
|
|
|
0
|
my @lines; |
905
|
0
|
|
|
|
|
0
|
for my $command ($target->inflate_children($target->list_children)) { |
906
|
0
|
0
|
|
|
|
0
|
my ($name) = $command->aliases or next; |
907
|
|
|
|
|
|
|
next |
908
|
0
|
0
|
0
|
|
|
0
|
if $name =~ m{\A(?: help | commands | tree)\z}mxs && $exclude_auto; |
909
|
0
|
|
0
|
|
|
0
|
my $help = $command->help // '(**missing help**)'; |
910
|
0
|
|
|
|
|
0
|
push @lines, sprintf '- %s (%s)', $name, $help; |
911
|
0
|
0
|
|
|
|
0
|
if (defined(my $subtree = $self->list_commands_for($command))) { |
912
|
0
|
|
|
|
|
0
|
push @lines, $subtree =~ s{^}{ }rgmxs; |
913
|
|
|
|
|
|
|
} |
914
|
|
|
|
|
|
|
} ## end for my $command ($target...) |
915
|
0
|
0
|
|
|
|
0
|
return unless @lines; |
916
|
0
|
|
|
|
|
0
|
return join "\n", @lines; |
917
|
|
|
|
|
|
|
} ## end sub list_commands_for |
918
|
|
|
|
|
|
|
|
919
|
|
|
|
|
|
|
1; |