| line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
|
1
|
|
|
|
|
|
|
package Getopt::Yath::Option; |
|
2
|
1
|
|
|
1
|
|
5
|
use strict; |
|
|
1
|
|
|
|
|
2
|
|
|
|
1
|
|
|
|
|
29
|
|
|
3
|
1
|
|
|
1
|
|
3
|
use warnings; |
|
|
1
|
|
|
|
|
2
|
|
|
|
1
|
|
|
|
|
67
|
|
|
4
|
|
|
|
|
|
|
|
|
5
|
1
|
|
|
1
|
|
5
|
use Carp qw/croak/; |
|
|
1
|
|
|
|
|
2
|
|
|
|
1
|
|
|
|
|
71
|
|
|
6
|
|
|
|
|
|
|
our @CARP_NOT = ( |
|
7
|
|
|
|
|
|
|
__PACKAGE__, |
|
8
|
|
|
|
|
|
|
'Getopt::Yath', |
|
9
|
|
|
|
|
|
|
'Getopt::Yath::Instance', |
|
10
|
|
|
|
|
|
|
); |
|
11
|
|
|
|
|
|
|
|
|
12
|
1
|
|
|
1
|
|
4
|
use Getopt::Yath::Util qw/mod2file fqmod/; |
|
|
1
|
|
|
|
|
1
|
|
|
|
1
|
|
|
|
|
5
|
|
|
13
|
1
|
|
|
1
|
|
403
|
use Getopt::Yath::Term qw/USE_COLOR color/; |
|
|
1
|
|
|
|
|
4
|
|
|
|
1
|
|
|
|
|
15
|
|
|
14
|
|
|
|
|
|
|
|
|
15
|
|
|
|
|
|
|
our $VERSION = '2.000007'; |
|
16
|
|
|
|
|
|
|
|
|
17
|
1
|
|
|
|
|
9
|
use Getopt::Yath::HashBase qw{ |
|
18
|
|
|
|
|
|
|
|
|
19
|
|
|
|
|
|
|
|
|
20
|
|
|
|
|
|
|
|
|
21
|
|
|
|
|
|
|
|
|
22
|
|
|
|
|
|
|
|
|
23
|
|
|
|
|
|
|
|
|
24
|
|
|
|
|
|
|
|
|
25
|
|
|
|
|
|
|
|
|
26
|
|
|
|
|
|
|
|
|
27
|
|
|
|
|
|
|
|
|
28
|
|
|
|
|
|
|
|
|
29
|
|
|
|
|
|
|
|
|
30
|
|
|
|
|
|
|
|
|
31
|
|
|
|
|
|
|
|
|
32
|
|
|
|
|
|
|
|
|
33
|
|
|
|
|
|
|
|
|
34
|
|
|
|
|
|
|
+trigger |
|
35
|
|
|
|
|
|
|
|
|
36
|
|
|
|
|
|
|
|
|
37
|
|
|
|
|
|
|
|
|
38
|
|
|
|
|
|
|
|
|
39
|
|
|
|
|
|
|
|
|
40
|
|
|
|
|
|
|
|
|
41
|
|
|
|
|
|
|
|
|
42
|
|
|
|
|
|
|
|
|
43
|
|
|
|
|
|
|
|
|
44
|
|
|
|
|
|
|
|
|
45
|
|
|
|
|
|
|
|
|
46
|
|
|
|
|
|
|
+short_examples |
|
47
|
|
|
|
|
|
|
+long_examples |
|
48
|
|
|
|
|
|
|
|
|
49
|
|
|
|
|
|
|
+forms |
|
50
|
|
|
|
|
|
|
|
|
51
|
|
|
|
|
|
|
|
|
52
|
|
|
|
|
|
|
|
|
53
|
|
|
|
|
|
|
|
|
54
|
1
|
|
|
1
|
|
698
|
}; |
|
|
1
|
|
|
|
|
3
|
|
|
55
|
|
|
|
|
|
|
|
|
56
|
0
|
|
|
0
|
0
|
0
|
sub requires_arg { croak "'$_[0]' does not define requires_arg()" } |
|
57
|
0
|
|
|
0
|
0
|
0
|
sub add_value { croak "'$_[0]' does not define add_value()" } |
|
58
|
0
|
|
|
0
|
0
|
0
|
sub is_populated { croak "'$_[0]' does not define is_populated()" } |
|
59
|
0
|
|
|
0
|
0
|
0
|
sub no_arg_value { croak "'$_[0]' does not define no_arg_value()" } |
|
60
|
0
|
|
|
0
|
0
|
0
|
sub get_env_value { croak "'$_[0]' does not define get_env_value()" } |
|
61
|
|
|
|
|
|
|
|
|
62
|
80
|
|
|
80
|
0
|
170
|
sub can_set_env { 0 } |
|
63
|
0
|
|
|
0
|
0
|
0
|
sub requires_autofill { 0 } |
|
64
|
|
|
|
|
|
|
|
|
65
|
25
|
|
|
25
|
0
|
65
|
sub allows_shortval { $_[0]->allows_arg } |
|
66
|
0
|
|
|
0
|
0
|
0
|
sub allows_default { 0 } |
|
67
|
|
|
|
|
|
|
|
|
68
|
16
|
|
|
16
|
0
|
65
|
sub allows_list { 0 } |
|
69
|
|
|
|
|
|
|
|
|
70
|
0
|
|
|
0
|
0
|
0
|
sub allows_arg { $_[0]->requires_arg } |
|
71
|
0
|
|
|
0
|
0
|
0
|
sub allows_autofill { $_[0]->requires_autofill } |
|
72
|
|
|
|
|
|
|
|
|
73
|
7
|
|
|
7
|
0
|
26
|
sub get_autofill_value { shift->_get___value(AUTOFILL(), @_) } |
|
74
|
354
|
|
|
354
|
0
|
679
|
sub get_default_value { shift->_get___value(DEFAULT(), @_) } |
|
75
|
|
|
|
|
|
|
|
|
76
|
|
|
|
475
|
0
|
|
sub init_settings { } |
|
77
|
|
|
|
447
|
0
|
|
sub finalize_settings { } |
|
78
|
|
|
|
|
|
|
|
|
79
|
|
|
|
|
|
|
sub create { |
|
80
|
16
|
|
|
16
|
0
|
47
|
my $class = shift; |
|
81
|
16
|
|
|
|
|
104
|
my %params = @_; |
|
82
|
|
|
|
|
|
|
|
|
83
|
16
|
50
|
|
|
|
47
|
croak "create() cannot be called on an option subclass" unless $class eq __PACKAGE__; |
|
84
|
|
|
|
|
|
|
|
|
85
|
16
|
50
|
|
|
|
60
|
my $type = delete $params{type} or croak "No 'type' specified"; |
|
86
|
|
|
|
|
|
|
|
|
87
|
16
|
|
|
|
|
65
|
my $new_class = fqmod($type, __PACKAGE__); |
|
88
|
16
|
|
|
|
|
32
|
local $Carp::CarpLevel = $Carp::CarpLevel = 1; |
|
89
|
16
|
|
|
|
|
105
|
return $new_class->new(%params); |
|
90
|
|
|
|
|
|
|
} |
|
91
|
|
|
|
|
|
|
|
|
92
|
|
|
|
|
|
|
sub get_initial_value { |
|
93
|
389
|
|
|
389
|
0
|
433
|
my $self = shift; |
|
94
|
|
|
|
|
|
|
|
|
95
|
389
|
|
|
|
|
579
|
my $env = $self->from_env_vars; |
|
96
|
389
|
100
|
|
|
|
441
|
for my $name (@{$env || []}) { |
|
|
389
|
|
|
|
|
882
|
|
|
97
|
19
|
|
|
|
|
29
|
my $env = "$name"; |
|
98
|
19
|
|
|
|
|
68
|
$env =~ s/^(!)//; |
|
99
|
19
|
|
|
|
|
58
|
my $neg = $1; |
|
100
|
|
|
|
|
|
|
|
|
101
|
19
|
100
|
|
|
|
84
|
next unless exists $ENV{$env}; |
|
102
|
9
|
100
|
|
|
|
37
|
return $ENV{$env} unless $neg; |
|
103
|
2
|
100
|
|
|
|
10
|
return $ENV{$env} ? 0 : 1; |
|
104
|
|
|
|
|
|
|
} |
|
105
|
|
|
|
|
|
|
|
|
106
|
380
|
|
|
|
|
733
|
return $self->_get___value(INITIALIZE(), @_); |
|
107
|
|
|
|
|
|
|
} |
|
108
|
|
|
|
|
|
|
|
|
109
|
|
|
|
|
|
|
sub get_clear_value { |
|
110
|
2
|
|
|
2
|
0
|
3
|
my $self = shift; |
|
111
|
|
|
|
|
|
|
|
|
112
|
2
|
|
|
|
|
8
|
return $self->_get___value(CLEAR(), @_); |
|
113
|
|
|
|
|
|
|
} |
|
114
|
|
|
|
|
|
|
|
|
115
|
|
|
|
|
|
|
sub _get___value { |
|
116
|
833
|
|
|
833
|
|
992
|
my $self = shift; |
|
117
|
833
|
|
|
|
|
1258
|
my ($field, @args) = @_; |
|
118
|
|
|
|
|
|
|
|
|
119
|
833
|
50
|
33
|
|
|
1859
|
return undef if $self->{+MAYBE} && $field eq INITIALIZE(); |
|
120
|
|
|
|
|
|
|
|
|
121
|
833
|
100
|
|
|
|
2030
|
return unless exists $self->{$field}; |
|
122
|
294
|
|
|
|
|
489
|
my $val = $self->{$field}; # May be undef, that is fine if specified. |
|
123
|
294
|
100
|
|
|
|
819
|
return $val unless ref($val); |
|
124
|
68
|
50
|
|
|
|
131
|
croak "'$field' values must either be simple scalars (not references) or a code ref that returns the '$field' value" |
|
125
|
|
|
|
|
|
|
unless ref($val) eq 'CODE'; |
|
126
|
68
|
|
|
|
|
189
|
return $self->$val(@args); |
|
127
|
|
|
|
|
|
|
} |
|
128
|
|
|
|
|
|
|
|
|
129
|
|
|
|
|
|
|
sub normalize_value { |
|
130
|
34
|
|
|
34
|
0
|
43
|
my $self = shift; |
|
131
|
34
|
|
|
|
|
61
|
my (@input) = @_; |
|
132
|
|
|
|
|
|
|
|
|
133
|
34
|
50
|
|
|
|
127
|
my $cb = $self->{+NORMALIZE} or return @input; |
|
134
|
0
|
|
|
|
|
0
|
return $cb->(@input); |
|
135
|
|
|
|
|
|
|
} |
|
136
|
|
|
|
|
|
|
|
|
137
|
|
|
|
|
|
|
sub trigger { |
|
138
|
531
|
|
|
531
|
0
|
628
|
my $self = shift; |
|
139
|
531
|
100
|
|
|
|
1121
|
my $cb = $self->{+TRIGGER} or return; |
|
140
|
66
|
|
|
|
|
173
|
$self->$cb(@_); |
|
141
|
|
|
|
|
|
|
} |
|
142
|
|
|
|
|
|
|
|
|
143
|
|
|
|
|
|
|
sub clear_field { |
|
144
|
6
|
|
|
6
|
0
|
9
|
my $self = shift; |
|
145
|
6
|
|
|
|
|
15
|
my ($ref) = @_; |
|
146
|
6
|
|
|
|
|
27
|
return $$ref = $self->get_clear_value(); |
|
147
|
|
|
|
|
|
|
} |
|
148
|
|
|
|
|
|
|
|
|
149
|
|
|
|
|
|
|
sub is_applicable { |
|
150
|
503
|
|
|
503
|
0
|
537
|
my $self = shift; |
|
151
|
503
|
|
|
|
|
654
|
my ($options, $settings) = @_; |
|
152
|
503
|
50
|
|
|
|
1169
|
my $cb = $self->{+APPLICABLE} or return 1; |
|
153
|
0
|
|
|
|
|
0
|
return $self->$cb($options, $settings); |
|
154
|
|
|
|
|
|
|
} |
|
155
|
|
|
|
|
|
|
|
|
156
|
|
|
|
|
|
|
sub long_args { |
|
157
|
0
|
|
|
0
|
0
|
0
|
my $self = shift; |
|
158
|
|
|
|
|
|
|
|
|
159
|
0
|
0
|
|
|
|
0
|
return ($self->{+NAME}, @{$self->{+ALT} || []}); |
|
|
0
|
|
|
|
|
0
|
|
|
160
|
|
|
|
|
|
|
} |
|
161
|
|
|
|
|
|
|
|
|
162
|
|
|
|
|
|
|
sub trace_string { |
|
163
|
0
|
|
|
0
|
0
|
0
|
my $self = shift; |
|
164
|
0
|
0
|
|
|
|
0
|
my $trace = $self->{+TRACE} or return "[UNKNOWN]"; |
|
165
|
0
|
|
|
|
|
0
|
return "$trace->[1] line $trace->[2]"; |
|
166
|
|
|
|
|
|
|
} |
|
167
|
|
|
|
|
|
|
|
|
168
|
|
|
|
|
|
|
sub long_examples { |
|
169
|
28
|
|
|
28
|
0
|
31
|
my $self = shift; |
|
170
|
28
|
50
|
|
|
|
43
|
return @{$self->{+LONG_EXAMPLES}} if $self->{+LONG_EXAMPLES}; |
|
|
0
|
|
|
|
|
0
|
|
|
171
|
28
|
|
|
|
|
41
|
return @{$self->default_long_examples(@_)}; |
|
|
28
|
|
|
|
|
83
|
|
|
172
|
|
|
|
|
|
|
} |
|
173
|
|
|
|
|
|
|
|
|
174
|
|
|
|
|
|
|
sub short_examples { |
|
175
|
16
|
|
|
16
|
0
|
18
|
my $self = shift; |
|
176
|
16
|
50
|
|
|
|
26
|
return @{$self->{+SHORT_EXAMPLES}} if $self->{+SHORT_EXAMPLES}; |
|
|
0
|
|
|
|
|
0
|
|
|
177
|
16
|
|
|
|
|
16
|
return @{$self->default_short_examples(@_)}; |
|
|
16
|
|
|
|
|
42
|
|
|
178
|
|
|
|
|
|
|
} |
|
179
|
|
|
|
|
|
|
|
|
180
|
|
|
|
|
|
|
sub init { |
|
181
|
16
|
|
|
16
|
0
|
25
|
my $self = shift; |
|
182
|
|
|
|
|
|
|
|
|
183
|
|
|
|
|
|
|
croak "A trace is required" |
|
184
|
16
|
50
|
|
|
|
85
|
unless $self->{+TRACE}; |
|
185
|
|
|
|
|
|
|
|
|
186
|
|
|
|
|
|
|
croak "You must provide either 'module' (a module name for dynamic loading) or set 'no_module'" |
|
187
|
16
|
50
|
66
|
|
|
75
|
unless $self->{+MODULE} || $self->{+NO_MODULE}; |
|
188
|
|
|
|
|
|
|
|
|
189
|
|
|
|
|
|
|
croak "You must specify 'title' or both 'field' and 'name'" |
|
190
|
16
|
0
|
0
|
|
|
40
|
unless $self->{+TITLE} || ($self->{+FIELD} && $self->{+NAME}); |
|
|
|
|
33
|
|
|
|
|
|
191
|
|
|
|
|
|
|
|
|
192
|
|
|
|
|
|
|
croak "The 'group' attribute is required" |
|
193
|
16
|
50
|
|
|
|
35
|
unless $self->{+GROUP}; |
|
194
|
|
|
|
|
|
|
|
|
195
|
|
|
|
|
|
|
croak "'set_env_vars' is not supported for this option type" |
|
196
|
16
|
50
|
66
|
|
|
52
|
if $self->{+SET_ENV_VARS} && !$self->can_set_env; |
|
197
|
|
|
|
|
|
|
|
|
198
|
|
|
|
|
|
|
croak "The 'alt' attribute must be an array-ref" |
|
199
|
16
|
50
|
66
|
|
|
52
|
if $self->{+ALT} && ref($self->{+ALT}) ne 'ARRAY'; |
|
200
|
|
|
|
|
|
|
|
|
201
|
|
|
|
|
|
|
croak "The 'alt_no' attribute must be an array-ref" |
|
202
|
16
|
50
|
33
|
|
|
46
|
if $self->{+ALT_NO} && ref($self->{+ALT_NO}) ne 'ARRAY'; |
|
203
|
|
|
|
|
|
|
|
|
204
|
16
|
100
|
33
|
|
|
39
|
$self->{+MODULE} //= $self->{+TRACE}->[0] unless $self->{+NO_MODULE}; |
|
205
|
|
|
|
|
|
|
|
|
206
|
16
|
50
|
|
|
|
39
|
if (my $title = $self->{+TITLE}) { |
|
207
|
16
|
|
33
|
|
|
73
|
$self->{+FIELD} //= $title; |
|
208
|
16
|
|
33
|
|
|
60
|
$self->{+NAME} //= $title; |
|
209
|
|
|
|
|
|
|
} |
|
210
|
|
|
|
|
|
|
|
|
211
|
16
|
|
|
|
|
38
|
$self->{+FIELD} =~ s/-/_/g; |
|
212
|
16
|
|
|
|
|
34
|
$self->{+NAME} =~ s/_/-/g; |
|
213
|
|
|
|
|
|
|
|
|
214
|
16
|
50
|
|
|
|
70
|
unless ($self->allow_underscore_in_alt) { |
|
215
|
16
|
|
100
|
|
|
23
|
for my $alt (@{$self->{+ALT} // []}) { |
|
|
16
|
|
|
|
|
59
|
|
|
216
|
3
|
50
|
|
|
|
11
|
next unless $alt =~ m/_/; |
|
217
|
0
|
|
|
|
|
0
|
croak "alt option form '$alt' contains an underscore, replace it with a '-' or set 'allow_underscore_in_alt' to true"; |
|
218
|
|
|
|
|
|
|
} |
|
219
|
|
|
|
|
|
|
} |
|
220
|
|
|
|
|
|
|
|
|
221
|
|
|
|
|
|
|
croak "'default' is not allowed (did you mean 'initialize'" . ($self->allows_autofill ? " or 'autofill'" : "") . "?)" |
|
222
|
16
|
0
|
66
|
|
|
52
|
if $self->{+DEFAULT} && !$self->allows_default; |
|
|
|
50
|
|
|
|
|
|
|
223
|
|
|
|
|
|
|
|
|
224
|
16
|
100
|
100
|
|
|
46
|
croak "'autofill' is required" if $self->requires_autofill && !$self->{+AUTOFILL}; |
|
225
|
15
|
50
|
66
|
|
|
60
|
croak "'autofill' is not allowed" if $self->{+AUTOFILL} && !$self->allows_autofill; |
|
226
|
|
|
|
|
|
|
|
|
227
|
15
|
|
|
|
|
32
|
for my $field (DEFAULT(), AUTOFILL(), INITIALIZE()) { |
|
228
|
45
|
100
|
|
|
|
115
|
my $val = $self->{$field} or next; |
|
229
|
12
|
100
|
|
|
|
29
|
my $ref = ref($val) or next; |
|
230
|
6
|
50
|
33
|
|
|
24
|
croak "'$field' must be a simple scalar, or a coderef, got a '$ref'" if $ref && $ref ne 'CODE'; |
|
231
|
|
|
|
|
|
|
} |
|
232
|
|
|
|
|
|
|
|
|
233
|
15
|
|
|
|
|
28
|
for my $field (NORMALIZE(), APPLICABLE(), TRIGGER()) { |
|
234
|
45
|
100
|
|
|
|
90
|
my $val = $self->{$field} or next; |
|
235
|
1
|
|
50
|
|
|
3
|
my $ref = ref($val) || 'not a ref'; |
|
236
|
1
|
50
|
|
|
|
3
|
next if $ref eq 'CODE'; |
|
237
|
0
|
|
|
|
|
0
|
croak "'$field' must be undef, or a coderef, got '$ref'"; |
|
238
|
|
|
|
|
|
|
} |
|
239
|
|
|
|
|
|
|
|
|
240
|
15
|
|
50
|
|
|
32
|
$self->{+CATEGORY} //= 'NO CATEGORY - FIX ME'; |
|
241
|
15
|
|
100
|
|
|
49
|
$self->{+DESCRIPTION} //= 'NO DESCRIPTION - FIX ME'; |
|
242
|
|
|
|
|
|
|
|
|
243
|
15
|
|
|
|
|
118
|
for my $key (sort keys %$self) { |
|
244
|
156
|
50
|
|
|
|
417
|
croak "'$key' is not a valid option attribute" unless $self->can(uc($key)); |
|
245
|
|
|
|
|
|
|
} |
|
246
|
|
|
|
|
|
|
|
|
247
|
15
|
|
|
|
|
40
|
return $self; |
|
248
|
|
|
|
|
|
|
} |
|
249
|
|
|
|
|
|
|
|
|
250
|
|
|
|
|
|
|
sub check_value { |
|
251
|
44
|
|
|
44
|
0
|
50
|
my $self = shift; |
|
252
|
44
|
|
|
|
|
69
|
my ($val) = @_; |
|
253
|
|
|
|
|
|
|
|
|
254
|
44
|
50
|
|
|
|
71
|
return unless defined $val; |
|
255
|
|
|
|
|
|
|
|
|
256
|
44
|
50
|
|
|
|
83
|
$val = [$val] unless ref($val) eq 'ARRAY'; |
|
257
|
|
|
|
|
|
|
|
|
258
|
44
|
50
|
|
|
|
147
|
my $av = $self->allowed_values or return; |
|
259
|
0
|
|
|
|
|
0
|
my $r = ref($av); |
|
260
|
|
|
|
|
|
|
|
|
261
|
0
|
|
|
|
|
0
|
my @bad; |
|
262
|
0
|
|
|
|
|
0
|
for my $v (@$val) { |
|
263
|
0
|
|
|
|
|
0
|
my $ok = 1; |
|
264
|
0
|
0
|
|
|
|
0
|
if ($r eq 'CODE') { |
|
|
|
0
|
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
265
|
0
|
|
|
|
|
0
|
$ok = $self->$av($v); |
|
266
|
|
|
|
|
|
|
} |
|
267
|
|
|
|
|
|
|
elsif ($r =~ /Regex/i) { |
|
268
|
0
|
|
|
|
|
0
|
$ok = $v =~ $av; |
|
269
|
|
|
|
|
|
|
} |
|
270
|
|
|
|
|
|
|
elsif($r eq 'ARRAY') { |
|
271
|
0
|
|
|
|
|
0
|
$ok = 0; |
|
272
|
0
|
|
|
|
|
0
|
for my $c (@$av) { |
|
273
|
0
|
0
|
|
|
|
0
|
next unless defined $c; |
|
274
|
1
|
|
|
1
|
|
9
|
no warnings; |
|
|
1
|
|
|
|
|
2
|
|
|
|
1
|
|
|
|
|
1669
|
|
|
275
|
0
|
0
|
0
|
|
|
0
|
$ok = 1 and last if $c eq $v; |
|
276
|
0
|
0
|
0
|
|
|
0
|
$ok = 1 and last if 0+$c && 0+$v && $c == $v; |
|
|
|
|
0
|
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
277
|
|
|
|
|
|
|
} |
|
278
|
|
|
|
|
|
|
} |
|
279
|
|
|
|
|
|
|
else { |
|
280
|
0
|
|
|
|
|
0
|
die "Invalid value check '$av' ($r) defined at " . $self->trace_string . ".\n"; |
|
281
|
|
|
|
|
|
|
} |
|
282
|
0
|
0
|
|
|
|
0
|
next if $ok; |
|
283
|
|
|
|
|
|
|
|
|
284
|
0
|
|
|
|
|
0
|
push @bad => $v; |
|
285
|
|
|
|
|
|
|
} |
|
286
|
|
|
|
|
|
|
|
|
287
|
0
|
|
|
|
|
0
|
return @bad; |
|
288
|
|
|
|
|
|
|
} |
|
289
|
|
|
|
|
|
|
|
|
290
|
|
|
|
|
|
|
sub forms { |
|
291
|
509
|
|
|
509
|
0
|
563
|
my $self = shift; |
|
292
|
509
|
100
|
|
|
|
1519
|
return $self->{+FORMS} if $self->{+FORMS}; |
|
293
|
|
|
|
|
|
|
|
|
294
|
15
|
|
|
|
|
30
|
my $forms = $self->{+FORMS} = {}; |
|
295
|
|
|
|
|
|
|
|
|
296
|
15
|
100
|
|
|
|
49
|
$forms->{'-' . $self->{+SHORT}} = 1 if $self->{+SHORT}; |
|
297
|
|
|
|
|
|
|
|
|
298
|
15
|
|
50
|
|
|
103
|
my $prefix = $self->prefix // ''; |
|
299
|
15
|
50
|
|
|
|
31
|
$prefix .= '-' if length $prefix; |
|
300
|
|
|
|
|
|
|
|
|
301
|
15
|
|
100
|
|
|
41
|
$forms->{$_} = 1 for map { "--${prefix}$_" } @{$self->{+ALT} // []}; |
|
|
3
|
|
|
|
|
14
|
|
|
|
15
|
|
|
|
|
51
|
|
|
302
|
15
|
|
100
|
|
|
30
|
$forms->{$_} = -1 for map { "--no-${prefix}$_" } @{$self->{+ALT} // []}; |
|
|
3
|
|
|
|
|
9
|
|
|
|
15
|
|
|
|
|
52
|
|
|
303
|
15
|
|
50
|
|
|
24
|
$forms->{$_} = -1 for map { "--${prefix}$_" } @{$self->{+ALT_NO} // []}; |
|
|
0
|
|
|
|
|
0
|
|
|
|
15
|
|
|
|
|
41
|
|
|
304
|
|
|
|
|
|
|
|
|
305
|
15
|
|
|
|
|
68
|
my $name = $self->name; |
|
306
|
15
|
|
|
|
|
68
|
$forms->{"--${prefix}${name}"} = 1; |
|
307
|
15
|
|
|
|
|
36
|
$forms->{"--no-${prefix}${name}"} = -1; |
|
308
|
|
|
|
|
|
|
|
|
309
|
15
|
|
|
|
|
56
|
return $forms; |
|
310
|
|
|
|
|
|
|
} |
|
311
|
|
|
|
|
|
|
|
|
312
|
|
|
|
|
|
|
sub _example_append { |
|
313
|
24
|
|
|
24
|
|
22
|
my $self = shift; |
|
314
|
24
|
|
|
|
|
36
|
my ($params, @prefixes) = @_; |
|
315
|
|
|
|
|
|
|
|
|
316
|
24
|
100
|
|
|
|
40
|
return unless $self->allows_list; |
|
317
|
|
|
|
|
|
|
|
|
318
|
8
|
|
100
|
|
|
17
|
my $groups = $params->{groups} // {}; |
|
319
|
|
|
|
|
|
|
|
|
320
|
8
|
|
|
|
|
9
|
my @out; |
|
321
|
|
|
|
|
|
|
|
|
322
|
8
|
|
|
|
|
10
|
for my $prefix (@prefixes) { |
|
323
|
12
|
|
|
|
|
39
|
for my $group (sort keys %$groups) { |
|
324
|
6
|
|
|
|
|
12
|
push @out => "${prefix}${group} ARG1 ARG2 ... $groups->{$group}"; |
|
325
|
|
|
|
|
|
|
} |
|
326
|
|
|
|
|
|
|
} |
|
327
|
|
|
|
|
|
|
|
|
328
|
8
|
|
|
|
|
23
|
return @out; |
|
329
|
|
|
|
|
|
|
} |
|
330
|
|
|
|
|
|
|
|
|
331
|
|
|
|
|
|
|
sub default_long_examples { |
|
332
|
26
|
|
|
26
|
0
|
25
|
my $self = shift; |
|
333
|
26
|
|
|
|
|
43
|
my %params = @_; |
|
334
|
|
|
|
|
|
|
|
|
335
|
26
|
100
|
|
|
|
60
|
return [''] unless $self->allows_arg; |
|
336
|
|
|
|
|
|
|
|
|
337
|
20
|
100
|
|
|
|
37
|
if ($self->requires_arg) { |
|
338
|
12
|
|
|
|
|
25
|
return [' ARG', '=ARG', $self->_example_append(\%params, ' ', '=')]; |
|
339
|
|
|
|
|
|
|
} |
|
340
|
|
|
|
|
|
|
|
|
341
|
8
|
|
|
|
|
20
|
return ['', '=ARG', $self->_example_append(\%params, '=')]; |
|
342
|
|
|
|
|
|
|
} |
|
343
|
|
|
|
|
|
|
|
|
344
|
|
|
|
|
|
|
sub default_short_examples { |
|
345
|
6
|
|
|
6
|
0
|
8
|
my $self = shift; |
|
346
|
6
|
|
|
|
|
13
|
my %params = @_; |
|
347
|
|
|
|
|
|
|
|
|
348
|
6
|
100
|
|
|
|
9
|
return [''] unless $self->allows_arg; |
|
349
|
|
|
|
|
|
|
|
|
350
|
4
|
100
|
|
|
|
7
|
if ($self->requires_arg) { |
|
351
|
2
|
50
|
|
|
|
4
|
return ['ARG', ' ARG', '=ARG', $self->_example_append(\%params, '', ' ', '=')] if $self->allows_shortval; |
|
352
|
0
|
|
|
|
|
0
|
return [' ARG', '=ARG', $self->_example_append(\%params, ' ', '=')]; |
|
353
|
|
|
|
|
|
|
} |
|
354
|
|
|
|
|
|
|
|
|
355
|
2
|
50
|
|
|
|
32
|
return ['', 'ARG', '=ARG', $self->_example_append(\%params, '', '=')] if $self->allows_shortval; |
|
356
|
0
|
|
|
|
|
0
|
return ['', '=ARG', $self->_example_append(\%params, '=')]; |
|
357
|
|
|
|
|
|
|
} |
|
358
|
|
|
|
|
|
|
|
|
359
|
|
|
|
|
|
|
sub doc_forms { |
|
360
|
28
|
|
|
28
|
0
|
32
|
my $self = shift; |
|
361
|
28
|
|
|
|
|
43
|
my %params = @_; |
|
362
|
|
|
|
|
|
|
|
|
363
|
28
|
|
|
|
|
43
|
my $name = $self->{+NAME}; |
|
364
|
28
|
50
|
|
|
|
40
|
my $prefix = $self->{+PREFIX} ? "$self->{+PREFIX}-" : ""; |
|
365
|
|
|
|
|
|
|
|
|
366
|
28
|
|
|
|
|
79
|
my @long_examples = $self->long_examples(%params); |
|
367
|
28
|
|
|
|
|
40
|
my @forms = (map { "--${prefix}${name}${_}" } @long_examples ); |
|
|
65
|
|
|
|
|
165
|
|
|
368
|
|
|
|
|
|
|
|
|
369
|
28
|
100
|
|
|
|
28
|
for my $alt (@{$self->{+ALT} || []}) { |
|
|
28
|
|
|
|
|
68
|
|
|
370
|
6
|
|
|
|
|
9
|
push @forms => (map { "--${prefix}${alt}${_}" } @long_examples); |
|
|
12
|
|
|
|
|
21
|
|
|
371
|
|
|
|
|
|
|
} |
|
372
|
|
|
|
|
|
|
|
|
373
|
28
|
100
|
|
|
|
52
|
if (my $short = $self->{+SHORT}) { |
|
374
|
16
|
|
|
|
|
57
|
my @short_examples = $self->short_examples(%params); |
|
375
|
16
|
|
|
|
|
25
|
push @forms => map { "-${short}${_}" } @short_examples; |
|
|
58
|
|
|
|
|
117
|
|
|
376
|
|
|
|
|
|
|
} |
|
377
|
|
|
|
|
|
|
|
|
378
|
|
|
|
|
|
|
@forms = sort { |
|
379
|
28
|
|
|
|
|
62
|
$a =~ m/^(-+)/; |
|
|
195
|
|
|
|
|
313
|
|
|
380
|
195
|
|
50
|
|
|
305
|
my $al = length($1 // ''); |
|
381
|
195
|
|
|
|
|
244
|
$b =~ m/^(-+)/; |
|
382
|
195
|
|
50
|
|
|
311
|
my $bl = length($1 // ''); |
|
383
|
195
|
50
|
|
|
|
305
|
$al <=> $bl || length($a) <=> length($b); |
|
384
|
|
|
|
|
|
|
} @forms; |
|
385
|
|
|
|
|
|
|
|
|
386
|
28
|
|
|
|
|
30
|
my @no_forms; |
|
387
|
28
|
|
|
|
|
49
|
push @no_forms => "--no-${prefix}${name}"; |
|
388
|
28
|
|
50
|
|
|
30
|
push @no_forms => map { "--$_" } @{$self->{+ALT_NO} // []}; |
|
|
0
|
|
|
|
|
0
|
|
|
|
28
|
|
|
|
|
85
|
|
|
389
|
|
|
|
|
|
|
|
|
390
|
28
|
|
|
|
|
74
|
return \@forms, \@no_forms; |
|
391
|
|
|
|
|
|
|
} |
|
392
|
|
|
|
|
|
|
|
|
393
|
|
|
|
|
|
|
sub cli_docs { |
|
394
|
14
|
|
|
14
|
0
|
17
|
my $self = shift; |
|
395
|
14
|
|
|
|
|
29
|
my %params = @_; |
|
396
|
|
|
|
|
|
|
|
|
397
|
14
|
|
33
|
|
|
27
|
$params{color} //= USE_COLOR && -t STDOUT; |
|
398
|
|
|
|
|
|
|
|
|
399
|
14
|
|
|
|
|
69
|
my ($forms, $no_forms, $other_forms) = $self->doc_forms(%params); |
|
400
|
|
|
|
|
|
|
|
|
401
|
14
|
|
|
|
|
30
|
my @out; |
|
402
|
14
|
50
|
|
|
|
23
|
if ($params{color}) { |
|
403
|
|
|
|
|
|
|
@out = ( |
|
404
|
|
|
|
|
|
|
color('underline white') . $self->{+NAME} . color('reset'), |
|
405
|
0
|
|
0
|
|
|
0
|
(map { color('green') . $_ . color('reset') } @{$forms // []}), |
|
|
0
|
|
|
|
|
0
|
|
|
406
|
0
|
|
0
|
|
|
0
|
(map { color('yellow') . $_ . color('reset') } @{$no_forms // []}), |
|
|
0
|
|
|
|
|
0
|
|
|
407
|
0
|
|
0
|
|
|
0
|
(map { color('cyan') . $_ . color('reset') } @{$other_forms // []}), |
|
|
0
|
|
|
|
|
0
|
|
|
|
0
|
|
|
|
|
0
|
|
|
408
|
|
|
|
|
|
|
); |
|
409
|
|
|
|
|
|
|
} |
|
410
|
|
|
|
|
|
|
else { |
|
411
|
|
|
|
|
|
|
@out = ( |
|
412
|
|
|
|
|
|
|
"[$self->{+NAME}]", |
|
413
|
14
|
|
50
|
|
|
26
|
@{$forms // []}, |
|
414
|
14
|
|
50
|
|
|
22
|
@{$no_forms // []}, |
|
415
|
14
|
|
50
|
|
|
21
|
@{$other_forms // []}, |
|
|
14
|
|
|
|
|
47
|
|
|
416
|
|
|
|
|
|
|
); |
|
417
|
|
|
|
|
|
|
} |
|
418
|
|
|
|
|
|
|
|
|
419
|
14
|
|
|
|
|
39
|
push @out => Getopt::Yath::Term::fit_to_width(" ", $self->{+DESCRIPTION}, prefix => " "); |
|
420
|
|
|
|
|
|
|
|
|
421
|
14
|
100
|
|
|
|
22
|
push @out => "\n" . Getopt::Yath::Term::fit_to_width(" ", "Can also be set with the following environment variables: " . join(", ", @{$self->{+FROM_ENV_VARS}}), prefix => " ") if $self->{+FROM_ENV_VARS}; |
|
|
2
|
|
|
|
|
7
|
|
|
422
|
14
|
100
|
|
|
|
23
|
push @out => "\n" . Getopt::Yath::Term::fit_to_width(" ", "The following environment variables will be cleared after arguments are processed: " . join(", ", @{$self->{+CLEAR_ENV_VARS}}), prefix => " ") if $self->{+CLEAR_ENV_VARS}; |
|
|
2
|
|
|
|
|
6
|
|
|
423
|
14
|
100
|
|
|
|
25
|
push @out => "\n" . Getopt::Yath::Term::fit_to_width(" ", "The following environment variables will be set after arguments are processed: " . join(", ", @{$self->{+SET_ENV_VARS}}), prefix => " ") if $self->{+SET_ENV_VARS}; |
|
|
2
|
|
|
|
|
5
|
|
|
424
|
|
|
|
|
|
|
|
|
425
|
14
|
50
|
|
|
|
59
|
if (my @notes = $self->notes) { |
|
426
|
14
|
|
|
|
|
19
|
my %seen; |
|
427
|
14
|
100
|
|
|
|
21
|
push @out => map { "\n" . Getopt::Yath::Term::fit_to_width(" ", "Note: $_", prefix => " ") } grep { $_ && !$seen{$_}++ } @notes; |
|
|
5
|
|
|
|
|
14
|
|
|
|
19
|
|
|
|
|
51
|
|
|
428
|
|
|
|
|
|
|
} |
|
429
|
|
|
|
|
|
|
|
|
430
|
14
|
|
|
|
|
26
|
for my $field (qw/default autofill/) { |
|
431
|
28
|
|
|
|
|
33
|
my $t = "${field}_text"; |
|
432
|
28
|
|
66
|
|
|
176
|
my $val = $self->$t || $self->$field // next; |
|
|
|
|
100
|
|
|
|
|
|
433
|
12
|
100
|
|
|
|
20
|
next if ref($val); |
|
434
|
6
|
|
|
|
|
16
|
push @out => "\n" . Getopt::Yath::Term::fit_to_width(" ", "$field: $val", prefix => " "); |
|
435
|
|
|
|
|
|
|
} |
|
436
|
|
|
|
|
|
|
|
|
437
|
14
|
50
|
|
|
|
57
|
if (my $avt = $self->allowed_values_text) { |
|
|
|
50
|
|
|
|
|
|
|
438
|
0
|
|
|
|
|
0
|
push @out => "\n" . Getopt::Yath::Term::fit_to_width(" ", "Allowed Values: $avt", prefix => " "); |
|
439
|
|
|
|
|
|
|
} |
|
440
|
|
|
|
|
|
|
elsif (my $vals = $self->allowed_values) { |
|
441
|
0
|
0
|
|
|
|
0
|
push @out => "\n" . Getopt::Yath::Term::fit_to_width(" ", "Allowed Values: " . join(", " => @$vals), prefix => " ") if @$vals; |
|
442
|
|
|
|
|
|
|
} |
|
443
|
|
|
|
|
|
|
|
|
444
|
14
|
|
|
|
|
81
|
return join "\n" => @out; |
|
445
|
|
|
|
|
|
|
} |
|
446
|
|
|
|
|
|
|
|
|
447
|
|
|
|
|
|
|
sub pod_docs { |
|
448
|
14
|
|
|
14
|
0
|
14
|
my $self = shift; |
|
449
|
14
|
|
|
|
|
28
|
my %params = @_; |
|
450
|
|
|
|
|
|
|
|
|
451
|
14
|
|
|
|
|
28
|
my ($forms, $no_forms, $other_forms) = $self->doc_forms(%params); |
|
452
|
|
|
|
|
|
|
|
|
453
|
14
|
|
|
|
|
23
|
my @out = map { "=item $_" } grep { $_ } @$forms, @$no_forms, @$other_forms; |
|
|
87
|
|
|
|
|
115
|
|
|
|
87
|
|
|
|
|
93
|
|
|
454
|
|
|
|
|
|
|
|
|
455
|
14
|
|
|
|
|
41
|
push @out => $self->description; |
|
456
|
|
|
|
|
|
|
|
|
457
|
14
|
100
|
|
|
|
24
|
push @out => "Can also be set with the following environment variables: " . join(", ", map { "C<$_>" } @{$self->{+FROM_ENV_VARS}}) if $self->{+FROM_ENV_VARS}; |
|
|
4
|
|
|
|
|
9
|
|
|
|
2
|
|
|
|
|
4
|
|
|
458
|
14
|
100
|
|
|
|
21
|
push @out => "The following environment variables will be cleared after arguments are processed: " . join(", ", map { "C<$_>" } @{$self->{+CLEAR_ENV_VARS}}) if $self->{+CLEAR_ENV_VARS}; |
|
|
2
|
|
|
|
|
5
|
|
|
|
2
|
|
|
|
|
4
|
|
|
459
|
14
|
100
|
|
|
|
21
|
push @out => "The following environment variables will be set after arguments are processed: " . join(", ", map { "C<$_>" } @{$self->{+SET_ENV_VARS}}) if $self->{+SET_ENV_VARS}; |
|
|
2
|
|
|
|
|
3
|
|
|
|
2
|
|
|
|
|
5
|
|
|
460
|
|
|
|
|
|
|
|
|
461
|
14
|
|
|
|
|
15
|
my %seen; |
|
462
|
14
|
100
|
|
|
|
28
|
push @out => map { "Note: $_" } grep { $_ && !$seen{$_}++ } $self->notes; |
|
|
5
|
|
|
|
|
9
|
|
|
|
19
|
|
|
|
|
43
|
|
|
463
|
|
|
|
|
|
|
|
|
464
|
14
|
|
|
|
|
59
|
return join("\n\n" => @out) . "\n"; |
|
465
|
|
|
|
|
|
|
} |
|
466
|
|
|
|
|
|
|
|
|
467
|
|
|
|
|
|
|
1; |
|
468
|
|
|
|
|
|
|
|
|
469
|
|
|
|
|
|
|
__END__ |