line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
# Paranoid::Args -- Command-line argument parsing functions |
2
|
|
|
|
|
|
|
# |
3
|
|
|
|
|
|
|
# $Id: lib/Paranoid/Args.pm, 2.08 2020/12/31 12:10:06 acorliss Exp $ |
4
|
|
|
|
|
|
|
# |
5
|
|
|
|
|
|
|
# This software is free software. Similar to Perl, you can redistribute it |
6
|
|
|
|
|
|
|
# and/or modify it under the terms of either: |
7
|
|
|
|
|
|
|
# |
8
|
|
|
|
|
|
|
# a) the GNU General Public License |
9
|
|
|
|
|
|
|
# as published by the |
10
|
|
|
|
|
|
|
# Free Software Foundation ; either version 1 |
11
|
|
|
|
|
|
|
# , or any later version |
12
|
|
|
|
|
|
|
# , or |
13
|
|
|
|
|
|
|
# b) the Artistic License 2.0 |
14
|
|
|
|
|
|
|
# , |
15
|
|
|
|
|
|
|
# |
16
|
|
|
|
|
|
|
# subject to the following additional term: No trademark rights to |
17
|
|
|
|
|
|
|
# "Paranoid" have been or are conveyed under any of the above licenses. |
18
|
|
|
|
|
|
|
# However, "Paranoid" may be used fairly to describe this unmodified |
19
|
|
|
|
|
|
|
# software, in good faith, but not as a trademark. |
20
|
|
|
|
|
|
|
# |
21
|
|
|
|
|
|
|
# (c) 2005 - 2020, Arthur Corliss (corliss@digitalmages.com) |
22
|
|
|
|
|
|
|
# (tm) 2008 - 2020, Paranoid Inc. (www.paranoid.com) |
23
|
|
|
|
|
|
|
# |
24
|
|
|
|
|
|
|
##################################################################### |
25
|
|
|
|
|
|
|
|
26
|
|
|
|
|
|
|
##################################################################### |
27
|
|
|
|
|
|
|
# |
28
|
|
|
|
|
|
|
# Environment definitions |
29
|
|
|
|
|
|
|
# |
30
|
|
|
|
|
|
|
##################################################################### |
31
|
|
|
|
|
|
|
|
32
|
|
|
|
|
|
|
package Paranoid::Args; |
33
|
|
|
|
|
|
|
|
34
|
2
|
|
|
2
|
|
1245
|
use 5.008; |
|
2
|
|
|
|
|
6
|
|
35
|
|
|
|
|
|
|
|
36
|
2
|
|
|
2
|
|
11
|
use strict; |
|
2
|
|
|
|
|
9
|
|
|
2
|
|
|
|
|
38
|
|
37
|
2
|
|
|
2
|
|
9
|
use warnings; |
|
2
|
|
|
|
|
3
|
|
|
2
|
|
|
|
|
55
|
|
38
|
2
|
|
|
2
|
|
10
|
use vars qw($VERSION @EXPORT @EXPORT_OK %EXPORT_TAGS); |
|
2
|
|
|
|
|
4
|
|
|
2
|
|
|
|
|
115
|
|
39
|
2
|
|
|
2
|
|
11
|
use base qw(Exporter); |
|
2
|
|
|
|
|
4
|
|
|
2
|
|
|
|
|
135
|
|
40
|
2
|
|
|
2
|
|
13
|
use Paranoid; |
|
2
|
|
|
|
|
3
|
|
|
2
|
|
|
|
|
124
|
|
41
|
2
|
|
|
2
|
|
990
|
use Paranoid::Debug qw(:all); |
|
2
|
|
|
|
|
5
|
|
|
2
|
|
|
|
|
639
|
|
42
|
|
|
|
|
|
|
|
43
|
|
|
|
|
|
|
($VERSION) = ( q$Revision: 2.08 $ =~ /(\d+(?:\.\d+)+)/sm ); |
44
|
|
|
|
|
|
|
|
45
|
|
|
|
|
|
|
@EXPORT = qw(parseArgs); |
46
|
|
|
|
|
|
|
@EXPORT_OK = ( @EXPORT, qw(PA_DEBUG PA_VERBOSE PA_HELP PA_VERSION) ); |
47
|
|
|
|
|
|
|
%EXPORT_TAGS = ( |
48
|
|
|
|
|
|
|
all => [@EXPORT_OK], |
49
|
|
|
|
|
|
|
template => [qw(PA_DEBUG PA_VERBOSE PA_HELP PA_VERSION)], |
50
|
|
|
|
|
|
|
); |
51
|
|
|
|
|
|
|
|
52
|
|
|
|
|
|
|
# I know, this really doesn't protect the contents... |
53
|
2
|
|
|
|
|
135
|
use constant PA_DEBUG => { |
54
|
|
|
|
|
|
|
Short => 'D', |
55
|
|
|
|
|
|
|
Long => 'debug', |
56
|
|
|
|
|
|
|
CountShort => 1, |
57
|
2
|
|
|
2
|
|
16
|
}; |
|
2
|
|
|
|
|
4
|
|
58
|
2
|
|
|
|
|
157
|
use constant PA_VERBOSE => { |
59
|
|
|
|
|
|
|
Short => 'v', |
60
|
|
|
|
|
|
|
Long => 'verbose', |
61
|
|
|
|
|
|
|
CountShort => 1, |
62
|
2
|
|
|
2
|
|
20
|
}; |
|
2
|
|
|
|
|
5
|
|
63
|
2
|
|
|
|
|
125
|
use constant PA_HELP => { |
64
|
|
|
|
|
|
|
Short => 'h', |
65
|
|
|
|
|
|
|
Long => 'help', |
66
|
2
|
|
|
2
|
|
12
|
}; |
|
2
|
|
|
|
|
4
|
|
67
|
2
|
|
|
|
|
7175
|
use constant PA_VERSION => { |
68
|
|
|
|
|
|
|
Short => 'V', |
69
|
|
|
|
|
|
|
Long => 'version', |
70
|
2
|
|
|
2
|
|
14
|
}; |
|
2
|
|
|
|
|
2
|
|
71
|
|
|
|
|
|
|
|
72
|
|
|
|
|
|
|
##################################################################### |
73
|
|
|
|
|
|
|
# |
74
|
|
|
|
|
|
|
# Module code follows |
75
|
|
|
|
|
|
|
# |
76
|
|
|
|
|
|
|
##################################################################### |
77
|
|
|
|
|
|
|
|
78
|
|
|
|
|
|
|
{ |
79
|
|
|
|
|
|
|
|
80
|
|
|
|
|
|
|
# Internal boolean flag for noOptions |
81
|
|
|
|
|
|
|
my $noOptions = 0; |
82
|
|
|
|
|
|
|
|
83
|
|
|
|
|
|
|
sub _NOOPTIONS : lvalue { |
84
|
|
|
|
|
|
|
|
85
|
|
|
|
|
|
|
# Purpose: Gets/sets value of boolean flag $noOptions |
86
|
|
|
|
|
|
|
# Returns: Value of $noOptions |
87
|
|
|
|
|
|
|
# Usage: $flag = _NOOPTIONS; |
88
|
|
|
|
|
|
|
# Usage: _NOOPTIONS = 1; |
89
|
|
|
|
|
|
|
|
90
|
70
|
|
|
70
|
|
215
|
$noOptions; |
91
|
|
|
|
|
|
|
} |
92
|
|
|
|
|
|
|
|
93
|
|
|
|
|
|
|
# Internal errors array |
94
|
|
|
|
|
|
|
my @errors; |
95
|
|
|
|
|
|
|
|
96
|
|
|
|
|
|
|
sub _resetErrors { |
97
|
|
|
|
|
|
|
|
98
|
|
|
|
|
|
|
# Purpose: Empties @errors |
99
|
|
|
|
|
|
|
# Returns: True (1) |
100
|
|
|
|
|
|
|
# Usage: resetErrors(); |
101
|
|
|
|
|
|
|
|
102
|
14
|
|
|
14
|
|
20
|
@errors = (); |
103
|
14
|
|
|
|
|
18
|
return 1; |
104
|
|
|
|
|
|
|
} |
105
|
|
|
|
|
|
|
|
106
|
|
|
|
|
|
|
sub _pushErrors { |
107
|
|
|
|
|
|
|
|
108
|
|
|
|
|
|
|
# Purpose: Pushes a new string onto the @errors array |
109
|
|
|
|
|
|
|
# Returns: Same argument as called with |
110
|
|
|
|
|
|
|
# Usage: _pushErrors($message); |
111
|
|
|
|
|
|
|
|
112
|
7
|
|
|
7
|
|
9
|
my $message = shift; |
113
|
7
|
|
|
|
|
15
|
push @errors, $message; |
114
|
7
|
|
|
|
|
9
|
return $message; |
115
|
|
|
|
|
|
|
} |
116
|
|
|
|
|
|
|
|
117
|
|
|
|
|
|
|
sub listErrors { |
118
|
|
|
|
|
|
|
|
119
|
|
|
|
|
|
|
# Purpose: Gets the contents of @errors |
120
|
|
|
|
|
|
|
# Returns: Contents of @errors |
121
|
|
|
|
|
|
|
# Usage: @errors = listErrors(); |
122
|
|
|
|
|
|
|
|
123
|
6
|
|
|
6
|
1
|
13
|
my ( %messages, $n, @indices ); |
124
|
|
|
|
|
|
|
|
125
|
|
|
|
|
|
|
# Filter out redundant messages |
126
|
6
|
|
|
|
|
10
|
$n = 0; |
127
|
6
|
|
|
|
|
12
|
foreach (@errors) { |
128
|
7
|
|
|
|
|
15
|
$messages{$_}++; |
129
|
7
|
100
|
|
|
|
18
|
push @indices, $n if $messages{$_} > 1; |
130
|
7
|
|
|
|
|
15
|
$n++; |
131
|
|
|
|
|
|
|
} |
132
|
6
|
|
|
|
|
15
|
foreach ( sort { $b <=> $a } @indices ) { |
|
0
|
|
|
|
|
0
|
|
133
|
2
|
|
|
|
|
5
|
splice @errors, $_, 1; |
134
|
|
|
|
|
|
|
} |
135
|
|
|
|
|
|
|
|
136
|
6
|
|
|
|
|
21
|
return @errors; |
137
|
|
|
|
|
|
|
} |
138
|
|
|
|
|
|
|
|
139
|
|
|
|
|
|
|
# Internal options hash |
140
|
|
|
|
|
|
|
my %options; |
141
|
|
|
|
|
|
|
|
142
|
|
|
|
|
|
|
sub _getOption { |
143
|
|
|
|
|
|
|
|
144
|
|
|
|
|
|
|
# Purpose: Gets the template associated with passed option |
145
|
|
|
|
|
|
|
# Returns: Reference to template hash or undef should the |
146
|
|
|
|
|
|
|
# requested option not be defined |
147
|
|
|
|
|
|
|
# Usage: $tref = _getOption($option); |
148
|
|
|
|
|
|
|
|
149
|
502
|
|
|
502
|
|
717
|
my $option = shift; |
150
|
|
|
|
|
|
|
|
151
|
502
|
100
|
|
|
|
1170
|
return exists $options{$option} ? $options{$option} : undef; |
152
|
|
|
|
|
|
|
} |
153
|
|
|
|
|
|
|
|
154
|
|
|
|
|
|
|
sub _setOption { |
155
|
|
|
|
|
|
|
|
156
|
|
|
|
|
|
|
# Purpose: Associates the passed option to the passed template in |
157
|
|
|
|
|
|
|
# %options |
158
|
|
|
|
|
|
|
# Returns: True (1) |
159
|
|
|
|
|
|
|
# Usage: _setOption($option, $tref); |
160
|
|
|
|
|
|
|
|
161
|
203
|
|
|
203
|
|
248
|
my $option = shift; |
162
|
203
|
|
|
|
|
233
|
my $tref = shift; |
163
|
|
|
|
|
|
|
|
164
|
203
|
|
|
|
|
330
|
$options{$option} = $tref; |
165
|
|
|
|
|
|
|
|
166
|
203
|
|
|
|
|
318
|
return 1; |
167
|
|
|
|
|
|
|
} |
168
|
|
|
|
|
|
|
|
169
|
|
|
|
|
|
|
sub _optionsKeys { |
170
|
|
|
|
|
|
|
|
171
|
|
|
|
|
|
|
# Purpose: Returns a list of keys from %options |
172
|
|
|
|
|
|
|
# Returns: keys %options |
173
|
|
|
|
|
|
|
# Usage: @keys = _optionsKeys(); |
174
|
|
|
|
|
|
|
|
175
|
14
|
|
|
14
|
|
73
|
return keys %options; |
176
|
|
|
|
|
|
|
} |
177
|
|
|
|
|
|
|
|
178
|
|
|
|
|
|
|
sub _resetOptions { |
179
|
|
|
|
|
|
|
|
180
|
|
|
|
|
|
|
# Purpose: Empties the %options |
181
|
|
|
|
|
|
|
# Returns: True (1) |
182
|
|
|
|
|
|
|
# Usage: _resetOptions(); |
183
|
|
|
|
|
|
|
|
184
|
14
|
|
|
14
|
|
145
|
%options = (); |
185
|
|
|
|
|
|
|
|
186
|
14
|
|
|
|
|
19
|
return 1; |
187
|
|
|
|
|
|
|
} |
188
|
|
|
|
|
|
|
|
189
|
|
|
|
|
|
|
# Internal arguments list |
190
|
|
|
|
|
|
|
my @arguments; |
191
|
|
|
|
|
|
|
|
192
|
|
|
|
|
|
|
sub _getArgRef { |
193
|
|
|
|
|
|
|
|
194
|
|
|
|
|
|
|
# Purpose: Gets a reference the argument array |
195
|
|
|
|
|
|
|
# Returns: Array reference |
196
|
|
|
|
|
|
|
# Usage: $argRef = _getArgRef(); |
197
|
|
|
|
|
|
|
|
198
|
64
|
|
|
64
|
|
98
|
return \@arguments; |
199
|
|
|
|
|
|
|
} |
200
|
|
|
|
|
|
|
|
201
|
|
|
|
|
|
|
sub clearMemory { |
202
|
|
|
|
|
|
|
|
203
|
|
|
|
|
|
|
# Purpose: Empties all internal data structures |
204
|
|
|
|
|
|
|
# Returns: True (1) |
205
|
|
|
|
|
|
|
# Usage: clearMemory(); |
206
|
|
|
|
|
|
|
|
207
|
14
|
|
|
14
|
1
|
27
|
_NOOPTIONS = 0; |
208
|
14
|
|
|
|
|
29
|
_resetErrors(); |
209
|
14
|
|
|
|
|
28
|
_resetOptions(); |
210
|
14
|
|
|
|
|
19
|
@{ _getArgRef() } = (); |
|
14
|
|
|
|
|
22
|
|
211
|
|
|
|
|
|
|
|
212
|
14
|
|
|
|
|
16
|
return 1; |
213
|
|
|
|
|
|
|
} |
214
|
|
|
|
|
|
|
} |
215
|
|
|
|
|
|
|
|
216
|
|
|
|
|
|
|
sub _tLint { |
217
|
|
|
|
|
|
|
|
218
|
|
|
|
|
|
|
# Purpose: Performs basic checks on a given option template for |
219
|
|
|
|
|
|
|
# correctness |
220
|
|
|
|
|
|
|
# Returns: True (1) if all checks pass, False (0) otherwise |
221
|
|
|
|
|
|
|
# Usage: $rv = _tLint($templateRef); |
222
|
|
|
|
|
|
|
|
223
|
108
|
|
|
108
|
|
128
|
my $tref = shift; # Reference to option template hash |
224
|
108
|
|
|
|
|
131
|
my $rv = 1; |
225
|
108
|
|
|
|
|
157
|
my ( $oname, @at ); |
226
|
|
|
|
|
|
|
|
227
|
108
|
|
|
|
|
242
|
pdebug( 'entering w/(%s)', PDLEVEL2, $tref ); |
228
|
108
|
|
|
|
|
242
|
pIn(); |
229
|
|
|
|
|
|
|
|
230
|
|
|
|
|
|
|
# Get the option name for reporting purposes (should have been populated |
231
|
|
|
|
|
|
|
# within parseArgs below) |
232
|
108
|
|
|
|
|
164
|
$oname = $$tref{Name}; |
233
|
|
|
|
|
|
|
|
234
|
|
|
|
|
|
|
# Make sure a short or long option is declared |
235
|
108
|
50
|
|
|
|
207
|
if ( !defined $oname ) { |
236
|
0
|
|
|
|
|
0
|
_pushErrors('No short or long option name declared'); |
237
|
0
|
|
|
|
|
0
|
$rv = 0; |
238
|
|
|
|
|
|
|
} |
239
|
|
|
|
|
|
|
|
240
|
|
|
|
|
|
|
# Make sure the argument template is defined |
241
|
108
|
50
|
|
|
|
174
|
if ($rv) { |
242
|
108
|
50
|
|
|
|
191
|
unless ( defined $$tref{Template} ) { |
243
|
0
|
|
|
|
|
0
|
_pushErrors("$oname option declared without a template"); |
244
|
0
|
|
|
|
|
0
|
$rv = 0; |
245
|
|
|
|
|
|
|
} |
246
|
|
|
|
|
|
|
} |
247
|
|
|
|
|
|
|
|
248
|
|
|
|
|
|
|
# Make sure the template contains only supported characters |
249
|
108
|
50
|
|
|
|
183
|
if ($rv) { |
250
|
108
|
50
|
33
|
|
|
460
|
unless ( defined $$tref{Template} |
251
|
|
|
|
|
|
|
&& $$tref{Template} =~ /^[\$\@]*$/s ) { |
252
|
0
|
|
|
|
|
0
|
_pushErrors( "$oname option declared with an invalid template" |
253
|
|
|
|
|
|
|
. "($$tref{Template})" ); |
254
|
0
|
|
|
|
|
0
|
$rv = 0; |
255
|
|
|
|
|
|
|
} |
256
|
|
|
|
|
|
|
} |
257
|
|
|
|
|
|
|
|
258
|
|
|
|
|
|
|
# Make sure option names are sane |
259
|
108
|
50
|
|
|
|
207
|
if ($rv) { |
260
|
108
|
100
|
|
|
|
190
|
if ( defined $$tref{Short} ) { |
261
|
95
|
50
|
|
|
|
248
|
unless ( $$tref{Short} =~ /^[a-zA-Z0-9]$/s ) { |
262
|
0
|
|
|
|
|
0
|
_pushErrors( |
263
|
|
|
|
|
|
|
"Invalid name for the short option ($$tref{Short})"); |
264
|
0
|
|
|
|
|
0
|
$rv = 0; |
265
|
|
|
|
|
|
|
} |
266
|
|
|
|
|
|
|
} |
267
|
108
|
50
|
|
|
|
182
|
if ( defined $$tref{Long} ) { |
268
|
108
|
50
|
|
|
|
302
|
unless ( $$tref{Long} =~ /^[a-zA-Z0-9-]{2,}$/s ) { |
269
|
0
|
|
|
|
|
0
|
_pushErrors( |
270
|
|
|
|
|
|
|
"Invalid name for the long option ($$tref{Long})"); |
271
|
0
|
|
|
|
|
0
|
$rv = 0; |
272
|
|
|
|
|
|
|
} |
273
|
|
|
|
|
|
|
} |
274
|
|
|
|
|
|
|
} |
275
|
|
|
|
|
|
|
|
276
|
|
|
|
|
|
|
# Make sure '@' is only used once, if at all, and the option isn't |
277
|
|
|
|
|
|
|
# set to allow bundling |
278
|
108
|
50
|
|
|
|
184
|
if ($rv) { |
279
|
108
|
100
|
|
|
|
218
|
if ( $$tref{Template} =~ /\@/sm ) { |
280
|
26
|
|
|
|
|
73
|
@at = ( $$tref{Template} =~ m#(\@)#sg ); |
281
|
26
|
50
|
|
|
|
54
|
if ( @at > 1 ) { |
282
|
0
|
|
|
|
|
0
|
_pushErrors( 'The \'@\' symbol can only be used once in the ' |
283
|
|
|
|
|
|
|
. "template for $oname: $_" ); |
284
|
0
|
|
|
|
|
0
|
$rv = 0; |
285
|
|
|
|
|
|
|
} |
286
|
26
|
50
|
33
|
|
|
64
|
if ( $$tref{CanBundle} and defined $$tref{Short} ) { |
287
|
0
|
|
|
|
|
0
|
_pushErrors( |
288
|
|
|
|
|
|
|
"Option $$tref{Short} must have CanBundle set to false " |
289
|
|
|
|
|
|
|
. 'if the template contains \'@\'' ); |
290
|
0
|
|
|
|
|
0
|
$rv = 0; |
291
|
|
|
|
|
|
|
} |
292
|
|
|
|
|
|
|
} |
293
|
|
|
|
|
|
|
} |
294
|
|
|
|
|
|
|
|
295
|
|
|
|
|
|
|
# Make sure all values in our lists are defined |
296
|
108
|
50
|
|
|
|
175
|
if ($rv) { |
297
|
108
|
50
|
|
|
|
221
|
unless ( ref( $$tref{ExclusiveOf} ) eq 'ARRAY' ) { |
298
|
0
|
|
|
|
|
0
|
_pushErrors( "Option ${oname}'s parameter ExclusiveOf must be an " |
299
|
|
|
|
|
|
|
. 'array reference' ); |
300
|
0
|
|
|
|
|
0
|
$rv = 0; |
301
|
|
|
|
|
|
|
} |
302
|
108
|
50
|
|
|
|
192
|
unless ( ref( $$tref{AccompaniedBy} ) eq 'ARRAY' ) { |
303
|
0
|
|
|
|
|
0
|
_pushErrors( |
304
|
|
|
|
|
|
|
"Option ${oname}'s parameter AccompaniedBy must be an " |
305
|
|
|
|
|
|
|
. 'array reference' ); |
306
|
0
|
|
|
|
|
0
|
$rv = 0; |
307
|
|
|
|
|
|
|
} |
308
|
108
|
50
|
|
|
|
179
|
if ($rv) { |
309
|
108
|
50
|
|
|
|
130
|
if ( grep { !defined } @{ $$tref{ExclusiveOf} } ) { |
|
26
|
|
|
|
|
66
|
|
|
108
|
|
|
|
|
253
|
|
310
|
0
|
|
|
|
|
0
|
_pushErrors( |
311
|
|
|
|
|
|
|
"Option $oname has undefined values in ExclusiveOf"); |
312
|
0
|
|
|
|
|
0
|
$rv = 0; |
313
|
|
|
|
|
|
|
} |
314
|
108
|
50
|
|
|
|
150
|
if ( grep { !defined } @{ $$tref{AccompaniedBy} } ) { |
|
26
|
|
|
|
|
79
|
|
|
108
|
|
|
|
|
214
|
|
315
|
0
|
|
|
|
|
0
|
_pushErrors( |
316
|
|
|
|
|
|
|
"Option $oname has undefined values in ExclusiveOf"); |
317
|
0
|
|
|
|
|
0
|
$rv = 0; |
318
|
|
|
|
|
|
|
} |
319
|
|
|
|
|
|
|
} |
320
|
|
|
|
|
|
|
} |
321
|
|
|
|
|
|
|
|
322
|
|
|
|
|
|
|
# Make sure CountShort is enabled only for those with a template of '' |
323
|
|
|
|
|
|
|
# or '$' |
324
|
108
|
50
|
|
|
|
182
|
if ($rv) { |
325
|
|
|
|
|
|
|
|
326
|
108
|
100
|
|
|
|
189
|
if ( $$tref{CountShort} ) { |
327
|
15
|
50
|
|
|
|
44
|
unless ( $$tref{Template} =~ /^\$?$/sm ) { |
328
|
0
|
|
|
|
|
0
|
_pushErrors( "Option $oname has CountShort set but with an " |
329
|
|
|
|
|
|
|
. 'incompatible template' ); |
330
|
0
|
|
|
|
|
0
|
$rv = 0; |
331
|
|
|
|
|
|
|
} |
332
|
|
|
|
|
|
|
} |
333
|
|
|
|
|
|
|
} |
334
|
|
|
|
|
|
|
|
335
|
108
|
|
|
|
|
245
|
pOut(); |
336
|
108
|
|
|
|
|
269
|
pdebug( 'leaving w/rv: %s', PDLEVEL2, $rv ); |
337
|
|
|
|
|
|
|
|
338
|
108
|
|
|
|
|
305
|
return $rv; |
339
|
|
|
|
|
|
|
} |
340
|
|
|
|
|
|
|
|
341
|
|
|
|
|
|
|
sub _getArgs ($$\@) { |
342
|
|
|
|
|
|
|
|
343
|
|
|
|
|
|
|
# Purpose: Takes passed argument template and extracts the requisite |
344
|
|
|
|
|
|
|
# arguments to satisfy it from the argument list. The |
345
|
|
|
|
|
|
|
# results are stored in the passed option list. |
346
|
|
|
|
|
|
|
# Results: True (1) if successful, False (0) if not |
347
|
|
|
|
|
|
|
# Usage: $rv = _getArgs($option, $argTemplate, @optionArgs); |
348
|
|
|
|
|
|
|
|
349
|
36
|
|
|
36
|
|
56
|
my $option = shift; # Option name |
350
|
36
|
|
|
|
|
47
|
my $argTemplate = shift; # Option argument template |
351
|
36
|
|
|
|
|
41
|
my $lref = shift; # Array reference for retrieved arguments |
352
|
36
|
|
|
|
|
43
|
my $rv = 1; |
353
|
36
|
|
|
|
|
58
|
my $argRef = _getArgRef(); |
354
|
36
|
|
|
|
|
52
|
my @tmp; |
355
|
|
|
|
|
|
|
|
356
|
36
|
|
|
|
|
85
|
pdebug( 'entering w/(%s)(%s)(%s)', |
357
|
|
|
|
|
|
|
PDLEVEL2, $option, $argTemplate, $lref ); |
358
|
36
|
|
|
|
|
77
|
pIn(); |
359
|
|
|
|
|
|
|
|
360
|
|
|
|
|
|
|
# Empty the array |
361
|
36
|
|
|
|
|
57
|
@$lref = (); |
362
|
|
|
|
|
|
|
|
363
|
36
|
|
|
|
|
88
|
pdebug( 'contents of args: %s', PDLEVEL4, @$argRef ); |
364
|
|
|
|
|
|
|
|
365
|
|
|
|
|
|
|
# Start checking the contents of $argTemplate |
366
|
36
|
100
|
|
|
|
96
|
if ( $argTemplate eq '' ) { |
|
|
100
|
|
|
|
|
|
367
|
|
|
|
|
|
|
|
368
|
|
|
|
|
|
|
# Template is '' (boolean option) |
369
|
17
|
|
|
|
|
35
|
@$lref = (1); |
370
|
|
|
|
|
|
|
|
371
|
|
|
|
|
|
|
} elsif ( $argTemplate =~ /\@/s ) { |
372
|
|
|
|
|
|
|
|
373
|
|
|
|
|
|
|
# Template has a '@' in it -- we'll need to |
374
|
|
|
|
|
|
|
# grab as many of the next arguments as possible. |
375
|
|
|
|
|
|
|
|
376
|
|
|
|
|
|
|
# Check the noOptions flags |
377
|
5
|
50
|
|
|
|
47
|
if (_NOOPTIONS) { |
378
|
|
|
|
|
|
|
|
379
|
|
|
|
|
|
|
# True: gobble up everything left |
380
|
0
|
|
|
|
|
0
|
push @$lref, @$argRef; |
381
|
0
|
|
|
|
|
0
|
@$argRef = (); |
382
|
|
|
|
|
|
|
|
383
|
|
|
|
|
|
|
} else { |
384
|
|
|
|
|
|
|
|
385
|
|
|
|
|
|
|
# False: gobble up to the next option-looking thing |
386
|
5
|
|
100
|
|
|
24
|
while ( @$argRef and $$argRef[0] !~ /^--?(?:\w+.*)?$/s ) { |
387
|
18
|
|
|
|
|
61
|
push @$lref, shift @$argRef; |
388
|
|
|
|
|
|
|
} |
389
|
|
|
|
|
|
|
|
390
|
|
|
|
|
|
|
# Now, we check to see if the first remaining argument is '--'. |
391
|
|
|
|
|
|
|
# If it is then we must set noOptions to true and gobble the |
392
|
|
|
|
|
|
|
# rest. |
393
|
5
|
100
|
100
|
|
|
17
|
if ( @$argRef and $$argRef[0] eq '--' ) { |
394
|
1
|
|
|
|
|
2
|
_NOOPTIONS = 1; |
395
|
1
|
|
|
|
|
2
|
shift @$argRef; |
396
|
1
|
|
|
|
|
3
|
push @$lref, @$argRef; |
397
|
1
|
|
|
|
|
3
|
@$argRef = (); |
398
|
|
|
|
|
|
|
} |
399
|
|
|
|
|
|
|
} |
400
|
|
|
|
|
|
|
|
401
|
|
|
|
|
|
|
} else { |
402
|
|
|
|
|
|
|
|
403
|
|
|
|
|
|
|
# The template is not empty and has no '@', so we'll just grab the next |
404
|
|
|
|
|
|
|
# n arguments, n being the length of the template |
405
|
|
|
|
|
|
|
|
406
|
|
|
|
|
|
|
# Check the noOptions flag |
407
|
14
|
50
|
|
|
|
56
|
if (_NOOPTIONS) { |
408
|
|
|
|
|
|
|
|
409
|
|
|
|
|
|
|
# True: grab everything we need |
410
|
0
|
|
0
|
|
|
0
|
while ( @$argRef and @$lref < length $argTemplate ) { |
411
|
0
|
|
|
|
|
0
|
push @$lref, shift @$argRef; |
412
|
|
|
|
|
|
|
} |
413
|
|
|
|
|
|
|
|
414
|
|
|
|
|
|
|
} else { |
415
|
|
|
|
|
|
|
|
416
|
|
|
|
|
|
|
# False: grab as many non-option-looking things as we can |
417
|
14
|
|
100
|
|
|
75
|
while ( @$argRef |
|
|
|
100
|
|
|
|
|
418
|
|
|
|
|
|
|
and $$argRef[0] !~ /^--?(?:\w+.*)$/s |
419
|
|
|
|
|
|
|
and @$lref < length $argTemplate ) { |
420
|
14
|
|
|
|
|
67
|
push @$lref, shift @$argRef; |
421
|
|
|
|
|
|
|
} |
422
|
|
|
|
|
|
|
|
423
|
|
|
|
|
|
|
# Now, we check to see if we still need more arguments and if |
424
|
|
|
|
|
|
|
# the first remaining argument is '--'. If it is then we must |
425
|
|
|
|
|
|
|
# set noOptions to true and gobble what we need. |
426
|
14
|
0
|
33
|
|
|
37
|
if ( @$lref < length $argTemplate |
|
|
|
33
|
|
|
|
|
427
|
|
|
|
|
|
|
and @$argRef |
428
|
|
|
|
|
|
|
and $$argRef[0] eq '--' ) { |
429
|
0
|
|
|
|
|
0
|
_NOOPTIONS = 1; |
430
|
0
|
|
|
|
|
0
|
shift @$argRef; |
431
|
0
|
|
0
|
|
|
0
|
while ( @$argRef and @$lref < length $argTemplate ) { |
432
|
0
|
|
|
|
|
0
|
push @$lref, shift @$argRef; |
433
|
|
|
|
|
|
|
} |
434
|
|
|
|
|
|
|
} |
435
|
|
|
|
|
|
|
} |
436
|
|
|
|
|
|
|
} |
437
|
|
|
|
|
|
|
|
438
|
|
|
|
|
|
|
# Final check: did we get minimum requisite number of arguments? |
439
|
36
|
100
|
|
|
|
70
|
if ( @$lref < length $argTemplate ) { |
440
|
1
|
|
|
|
|
51
|
_pushErrors( |
441
|
|
|
|
|
|
|
pdebug( |
442
|
|
|
|
|
|
|
'Missing the minimum number of arguments for %s', PDLEVEL1, |
443
|
|
|
|
|
|
|
$option |
444
|
|
|
|
|
|
|
) ); |
445
|
1
|
|
|
|
|
1
|
$rv = 0; |
446
|
|
|
|
|
|
|
} else { |
447
|
35
|
|
|
|
|
71
|
pdebug( 'extracted the following arguments: %s', PDLEVEL3, @$lref ); |
448
|
|
|
|
|
|
|
} |
449
|
|
|
|
|
|
|
|
450
|
|
|
|
|
|
|
# sublist '@' portions of multicharacter templates |
451
|
36
|
100
|
100
|
|
|
137
|
if ( $rv and $argTemplate =~ /\@/sm and length $argTemplate > 1 ) { |
|
|
|
66
|
|
|
|
|
452
|
4
|
|
|
|
|
11
|
@tmp = ( [], [], [] ); |
453
|
|
|
|
|
|
|
|
454
|
|
|
|
|
|
|
# First, shift off all preceding '$'s |
455
|
4
|
50
|
|
|
|
14
|
if ( $argTemplate =~ /^(\$+)/s ) { |
456
|
4
|
|
|
|
|
12
|
@{ $tmp[0] } = splice @$lref, 0, length $1; |
|
4
|
|
|
|
|
10
|
|
457
|
|
|
|
|
|
|
} |
458
|
|
|
|
|
|
|
|
459
|
|
|
|
|
|
|
# Next, pop off all trailing '$' |
460
|
4
|
100
|
|
|
|
14
|
if ( $argTemplate =~ /(\$+)\$/s ) { |
461
|
2
|
|
|
|
|
6
|
@{ $tmp[2] } = splice @$lref, -1 * length $1; |
|
2
|
|
|
|
|
5
|
|
462
|
|
|
|
|
|
|
} |
463
|
|
|
|
|
|
|
|
464
|
|
|
|
|
|
|
# Everything left belongs to the '@' |
465
|
4
|
|
|
|
|
8
|
@{ $tmp[1] } = @$lref; |
|
4
|
|
|
|
|
8
|
|
466
|
|
|
|
|
|
|
|
467
|
|
|
|
|
|
|
# Let's put it all together... |
468
|
4
|
|
|
|
|
8
|
@$lref = (); |
469
|
4
|
50
|
|
|
|
7
|
push @$lref, @{ $tmp[0] } if @{ $tmp[0] }; |
|
4
|
|
|
|
|
7
|
|
|
4
|
|
|
|
|
9
|
|
470
|
4
|
|
|
|
|
8
|
push @$lref, $tmp[1]; |
471
|
4
|
100
|
|
|
|
5
|
push @$lref, @{ $tmp[2] } if @{ $tmp[2] }; |
|
2
|
|
|
|
|
3
|
|
|
4
|
|
|
|
|
10
|
|
472
|
|
|
|
|
|
|
|
473
|
4
|
|
|
|
|
9
|
pdebug( 'sublisted arguments into: %s', PDLEVEL3, @$lref ); |
474
|
|
|
|
|
|
|
} |
475
|
|
|
|
|
|
|
|
476
|
36
|
|
|
|
|
81
|
pOut(); |
477
|
36
|
|
|
|
|
76
|
pdebug( 'leaving w/rv: %s', PDLEVEL2, $rv ); |
478
|
|
|
|
|
|
|
|
479
|
36
|
|
|
|
|
82
|
return $rv; |
480
|
|
|
|
|
|
|
} |
481
|
|
|
|
|
|
|
|
482
|
|
|
|
|
|
|
sub _storeArgs ($$\@) { |
483
|
|
|
|
|
|
|
|
484
|
|
|
|
|
|
|
# Purpose: Stores the passed option arguments in the passed option |
485
|
|
|
|
|
|
|
# template's Value, but in accordance with parameters in the |
486
|
|
|
|
|
|
|
# template |
487
|
|
|
|
|
|
|
# Returns: True (1) |
488
|
|
|
|
|
|
|
# Usage: _storeArgs($optionTemplate, $argTemplate, @optionArgs); |
489
|
|
|
|
|
|
|
|
490
|
35
|
|
|
35
|
|
46
|
my $tref = shift; |
491
|
35
|
|
|
|
|
53
|
my $argTemplate = shift; |
492
|
35
|
|
|
|
|
43
|
my $lref = shift; |
493
|
|
|
|
|
|
|
|
494
|
35
|
|
|
|
|
86
|
pdebug( 'entering w/(%s)(%s)(%s)', PDLEVEL2, $tref, $argTemplate, $lref ); |
495
|
35
|
|
|
|
|
79
|
pIn(); |
496
|
|
|
|
|
|
|
|
497
|
35
|
|
|
|
|
85
|
pdebug( 'adding values to %s', PDLEVEL3, $$tref{Name} ); |
498
|
|
|
|
|
|
|
|
499
|
|
|
|
|
|
|
# Increment our usage counter |
500
|
35
|
|
|
|
|
60
|
$$tref{Count}++; |
501
|
|
|
|
|
|
|
|
502
|
|
|
|
|
|
|
# Store arguments according to the template |
503
|
35
|
100
|
|
|
|
76
|
if ( $argTemplate eq '' ) { |
|
|
100
|
|
|
|
|
|
504
|
|
|
|
|
|
|
|
505
|
|
|
|
|
|
|
# Template is '' |
506
|
17
|
100
|
|
|
|
37
|
$$tref{Value} = 0 unless defined $$tref{Value}; |
507
|
17
|
|
|
|
|
21
|
$$tref{Value}++; |
508
|
17
|
|
|
|
|
32
|
pdebug( 'Value is now %s', PDLEVEL3, $$tref{Value} ); |
509
|
|
|
|
|
|
|
|
510
|
|
|
|
|
|
|
} elsif ( $argTemplate eq '$' ) { |
511
|
|
|
|
|
|
|
|
512
|
|
|
|
|
|
|
# Template is '$' |
513
|
14
|
100
|
100
|
|
|
40
|
if ( not $$tref{Multiple} or $$tref{CountShort} ) { |
514
|
|
|
|
|
|
|
|
515
|
|
|
|
|
|
|
# Store the value directly since we |
516
|
|
|
|
|
|
|
# can only be used once |
517
|
12
|
|
|
|
|
21
|
$$tref{Value} = $$lref[0]; |
518
|
12
|
|
|
|
|
24
|
pdebug( 'Value is now %s', PDLEVEL3, $$tref{Value} ); |
519
|
|
|
|
|
|
|
|
520
|
|
|
|
|
|
|
} else { |
521
|
|
|
|
|
|
|
|
522
|
|
|
|
|
|
|
# Store the value as part of a list since |
523
|
|
|
|
|
|
|
# we can be used multiple times |
524
|
|
|
|
|
|
|
$$tref{Value} = [] |
525
|
|
|
|
|
|
|
unless defined $$tref{Value} |
526
|
2
|
100
|
66
|
|
|
12
|
and ref $$tref{Value} eq 'ARRAY'; |
527
|
2
|
|
|
|
|
3
|
push @{ $$tref{Value} }, $$lref[0]; |
|
2
|
|
|
|
|
5
|
|
528
|
2
|
|
|
|
|
3
|
pdebug( 'Value is now %s', PDLEVEL3, @{ $$tref{Value} } ); |
|
2
|
|
|
|
|
8
|
|
529
|
|
|
|
|
|
|
} |
530
|
|
|
|
|
|
|
|
531
|
|
|
|
|
|
|
} else { |
532
|
|
|
|
|
|
|
|
533
|
|
|
|
|
|
|
# Template is anything else |
534
|
4
|
50
|
|
|
|
11
|
if ( not $$tref{Multiple} ) { |
535
|
|
|
|
|
|
|
|
536
|
|
|
|
|
|
|
# Store the values directly in a an array |
537
|
|
|
|
|
|
|
# since we can only be used once |
538
|
4
|
|
|
|
|
9
|
$$tref{Value} = [@$lref]; |
539
|
4
|
|
|
|
|
8
|
pdebug( 'Value is now %s', PDLEVEL3, @{ $$tref{Value} } ); |
|
4
|
|
|
|
|
9
|
|
540
|
|
|
|
|
|
|
|
541
|
|
|
|
|
|
|
} else { |
542
|
|
|
|
|
|
|
|
543
|
|
|
|
|
|
|
# Store the values as an element of an |
544
|
|
|
|
|
|
|
# array since we can be used multiple times |
545
|
|
|
|
|
|
|
$$tref{Value} = [] |
546
|
|
|
|
|
|
|
unless defined $$tref{Value} |
547
|
0
|
0
|
0
|
|
|
0
|
and ref $$tref{Value} eq 'ARRAY'; |
548
|
0
|
|
|
|
|
0
|
push @{ $$tref{Value} }, [@$lref]; |
|
0
|
|
|
|
|
0
|
|
549
|
|
|
|
|
|
|
pdebug( 'Value now has %d sets', |
550
|
0
|
|
|
|
|
0
|
PDLEVEL3, scalar @{ $$tref{Value} } ); |
|
0
|
|
|
|
|
0
|
|
551
|
|
|
|
|
|
|
} |
552
|
|
|
|
|
|
|
} |
553
|
|
|
|
|
|
|
|
554
|
35
|
|
|
|
|
89
|
pOut(); |
555
|
35
|
|
|
|
|
78
|
pdebug( 'leaving w/rv: 1', PDLEVEL2 ); |
556
|
|
|
|
|
|
|
|
557
|
35
|
|
|
|
|
93
|
return 1; |
558
|
|
|
|
|
|
|
} |
559
|
|
|
|
|
|
|
|
560
|
|
|
|
|
|
|
sub parseArgs (\@\%;\@) { |
561
|
|
|
|
|
|
|
|
562
|
|
|
|
|
|
|
# Purpose: Extracts and validates all command-line arguments and options, |
563
|
|
|
|
|
|
|
# storing them in an organized hash for easy retrieval |
564
|
|
|
|
|
|
|
# Returns: True (1) if successful, False (0) if not |
565
|
|
|
|
|
|
|
# Usage: $rv = parseArgs(@templates, %options); |
566
|
|
|
|
|
|
|
# Usage: $rv = parseArgs(@templates, %options, @args); |
567
|
|
|
|
|
|
|
|
568
|
14
|
|
|
14
|
1
|
3405
|
my $tlref = shift; # Templates list ref |
569
|
14
|
|
|
|
|
23
|
my $oref = shift; # Options hash ref |
570
|
14
|
|
|
|
|
16
|
my $paref = shift; # Program argument list ref |
571
|
14
|
|
|
|
|
17
|
my $rv = 1; |
572
|
14
|
|
|
|
|
37
|
my ( $tref, $oname, $argRef, $arg, $argTemplate ); |
573
|
14
|
|
|
|
|
0
|
my ( @tmp, @oargs, $regex ); |
574
|
|
|
|
|
|
|
|
575
|
|
|
|
|
|
|
# Validate arguments |
576
|
14
|
50
|
|
|
|
35
|
$paref = \@ARGV unless defined $paref; |
577
|
|
|
|
|
|
|
|
578
|
14
|
|
|
|
|
43
|
pdebug( 'entering w/(%s)(%s)(%s)', PDLEVEL1, $tlref, $oref, $paref ); |
579
|
14
|
|
|
|
|
34
|
pIn(); |
580
|
|
|
|
|
|
|
|
581
|
|
|
|
|
|
|
# Clear all internal data structures and reset flag |
582
|
14
|
|
|
|
|
29
|
clearMemory(); |
583
|
|
|
|
|
|
|
|
584
|
|
|
|
|
|
|
# Empty the passed options hash |
585
|
14
|
|
|
|
|
33
|
%$oref = (); |
586
|
|
|
|
|
|
|
|
587
|
|
|
|
|
|
|
# Make a copy of the argument list |
588
|
14
|
|
|
|
|
22
|
$argRef = _getArgRef(); |
589
|
14
|
|
|
|
|
37
|
@$argRef = (@$paref); |
590
|
|
|
|
|
|
|
|
591
|
|
|
|
|
|
|
# Assemble %options and lint-check the templates |
592
|
14
|
|
|
|
|
30
|
foreach (@$tlref) { |
593
|
|
|
|
|
|
|
|
594
|
|
|
|
|
|
|
# Make sure the element is a hash reference |
595
|
108
|
50
|
|
|
|
225
|
unless ( ref $_ eq 'HASH' ) { |
596
|
0
|
|
|
|
|
0
|
_pushErrors('Illegal non-hash reference in templates array'); |
597
|
0
|
|
|
|
|
0
|
$rv = 0; |
598
|
0
|
|
|
|
|
0
|
next; |
599
|
|
|
|
|
|
|
} |
600
|
|
|
|
|
|
|
|
601
|
|
|
|
|
|
|
# Establish a base template and copy the contents of the passed hash |
602
|
|
|
|
|
|
|
$tref = { |
603
|
108
|
|
|
|
|
674
|
Short => undef, |
604
|
|
|
|
|
|
|
Long => undef, |
605
|
|
|
|
|
|
|
Template => '', |
606
|
|
|
|
|
|
|
Multiple => 0, |
607
|
|
|
|
|
|
|
ExclusiveOf => [], |
608
|
|
|
|
|
|
|
AccompaniedBy => [], |
609
|
|
|
|
|
|
|
CanBundle => 0, |
610
|
|
|
|
|
|
|
CountShort => 0, |
611
|
|
|
|
|
|
|
Value => undef, |
612
|
|
|
|
|
|
|
%$_, |
613
|
|
|
|
|
|
|
}; |
614
|
|
|
|
|
|
|
|
615
|
|
|
|
|
|
|
# Set AllOptions for error message reporting |
616
|
|
|
|
|
|
|
$$tref{Name} = |
617
|
|
|
|
|
|
|
defined $$tref{Short} |
618
|
|
|
|
|
|
|
&& defined $$tref{Long} ? "-$$tref{Short}/--$$tref{Long}" |
619
|
|
|
|
|
|
|
: defined $$tref{Short} ? "-$$tref{Short}" |
620
|
108
|
50
|
66
|
|
|
580
|
: defined $$tref{Long} ? "--$$tref{Long}" |
|
|
50
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
621
|
|
|
|
|
|
|
: undef; |
622
|
|
|
|
|
|
|
|
623
|
|
|
|
|
|
|
# Initialize our usage counter |
624
|
108
|
|
|
|
|
171
|
$$tref{Count} = 0; |
625
|
|
|
|
|
|
|
|
626
|
|
|
|
|
|
|
# Anything that has CountShort enabled implies Multiple/CanBundle |
627
|
|
|
|
|
|
|
# and a template of '$' |
628
|
108
|
100
|
|
|
|
184
|
if ( $$tref{CountShort} ) { |
629
|
15
|
|
|
|
|
30
|
$$tref{CanBundle} = $$tref{Multiple} = 1; |
630
|
15
|
50
|
|
|
|
33
|
$$tref{Template} = '$' if defined $$tref{Long}; |
631
|
|
|
|
|
|
|
} |
632
|
|
|
|
|
|
|
|
633
|
|
|
|
|
|
|
# Anything that has a Short option and a template of '$' or '' |
634
|
|
|
|
|
|
|
# implies CanBundle |
635
|
|
|
|
|
|
|
$$tref{CanBundle} = 1 |
636
|
108
|
100
|
100
|
|
|
310
|
if defined $$tref{Short} and $$tref{Template} eq ''; |
637
|
|
|
|
|
|
|
|
638
|
|
|
|
|
|
|
# We'll associate both the long and short options to the same hash |
639
|
|
|
|
|
|
|
# to make sure that we count/collect everything appropriately. |
640
|
|
|
|
|
|
|
# |
641
|
|
|
|
|
|
|
# Store the short option |
642
|
108
|
100
|
66
|
|
|
287
|
if ( defined $$tref{Short} and length $$tref{Short} ) { |
643
|
|
|
|
|
|
|
|
644
|
|
|
|
|
|
|
# See if a template is already defined |
645
|
95
|
50
|
|
|
|
172
|
if ( defined _getOption( $$tref{Short} ) ) { |
646
|
|
|
|
|
|
|
|
647
|
|
|
|
|
|
|
# It is -- report the error |
648
|
|
|
|
|
|
|
Paranoid::ERROR = _pushErrors( |
649
|
|
|
|
|
|
|
pdebug( |
650
|
|
|
|
|
|
|
'the %s option has more than one template', |
651
|
0
|
|
|
|
|
0
|
PDLEVEL1, $$tref{Short} ) ); |
652
|
0
|
|
|
|
|
0
|
$rv = 0; |
653
|
|
|
|
|
|
|
|
654
|
|
|
|
|
|
|
} else { |
655
|
|
|
|
|
|
|
|
656
|
|
|
|
|
|
|
# It's not -- go ahead and store it |
657
|
95
|
|
|
|
|
165
|
_setOption( $$tref{Short}, $tref ); |
658
|
|
|
|
|
|
|
} |
659
|
|
|
|
|
|
|
} |
660
|
|
|
|
|
|
|
|
661
|
|
|
|
|
|
|
# Store the long option |
662
|
108
|
50
|
33
|
|
|
322
|
if ( defined $$tref{Long} and length $$tref{Long} ) { |
663
|
|
|
|
|
|
|
|
664
|
|
|
|
|
|
|
# See if a template is already defined |
665
|
108
|
50
|
|
|
|
168
|
if ( defined _getOption( $$tref{Long} ) ) { |
666
|
|
|
|
|
|
|
|
667
|
|
|
|
|
|
|
# It is -- report the error |
668
|
|
|
|
|
|
|
Paranoid::ERROR = _pushErrors( |
669
|
|
|
|
|
|
|
pdebug( |
670
|
|
|
|
|
|
|
'the %s option has more than one template', |
671
|
0
|
|
|
|
|
0
|
PDLEVEL1, $$tref{Long} ) ); |
672
|
0
|
|
|
|
|
0
|
$rv = 0; |
673
|
|
|
|
|
|
|
|
674
|
|
|
|
|
|
|
} else { |
675
|
|
|
|
|
|
|
|
676
|
|
|
|
|
|
|
# It's not -- go ahead and store it |
677
|
108
|
|
|
|
|
167
|
_setOption( $$tref{Long}, $tref ); |
678
|
|
|
|
|
|
|
} |
679
|
|
|
|
|
|
|
} |
680
|
|
|
|
|
|
|
|
681
|
|
|
|
|
|
|
# Do a basic lint-check on the template |
682
|
108
|
50
|
|
|
|
204
|
$rv = 0 unless _tLint($tref); |
683
|
|
|
|
|
|
|
} |
684
|
|
|
|
|
|
|
|
685
|
14
|
50
|
|
|
|
25
|
if ($rv) { |
686
|
|
|
|
|
|
|
|
687
|
14
|
|
|
|
|
26
|
while (@$argRef) { |
688
|
35
|
|
|
|
|
57
|
$arg = shift @$argRef; |
689
|
35
|
50
|
|
|
|
63
|
next unless defined $arg; |
690
|
|
|
|
|
|
|
|
691
|
|
|
|
|
|
|
# Start testing $arg |
692
|
35
|
100
|
66
|
|
|
100
|
if ( $arg eq '--' and not _NOOPTIONS ) { |
|
|
100
|
100
|
|
|
|
|
693
|
|
|
|
|
|
|
|
694
|
|
|
|
|
|
|
# $arg is '--', so set the no options flag |
695
|
1
|
|
|
|
|
3
|
_NOOPTIONS = 1; |
696
|
|
|
|
|
|
|
|
697
|
|
|
|
|
|
|
} elsif ( not _NOOPTIONS and $arg =~ /^--?/s ) { |
698
|
|
|
|
|
|
|
|
699
|
|
|
|
|
|
|
# '--' hasn't been passed yet and this looks |
700
|
|
|
|
|
|
|
# like an option... |
701
|
|
|
|
|
|
|
|
702
|
|
|
|
|
|
|
# Test types of options |
703
|
27
|
100
|
|
|
|
111
|
if ( $arg =~ /^-(\w.*)$/s ) { |
|
|
50
|
|
|
|
|
|
704
|
|
|
|
|
|
|
|
705
|
|
|
|
|
|
|
# With a single '-' it should be a short option. However, |
706
|
|
|
|
|
|
|
# we'll split the option portion, in case there's more |
707
|
|
|
|
|
|
|
# than one character |
708
|
14
|
|
|
|
|
53
|
@tmp = split //s, $1; |
709
|
|
|
|
|
|
|
|
710
|
|
|
|
|
|
|
# If there's more than one character for the option name |
711
|
|
|
|
|
|
|
# it must be either a bunch of bundled options or an |
712
|
|
|
|
|
|
|
# option with a concatenated argument. In case of the |
713
|
|
|
|
|
|
|
# latter (assuming that CanBundle is set to false (a |
714
|
|
|
|
|
|
|
# prerequisite of argument concatenation) and it has a |
715
|
|
|
|
|
|
|
# template of '$' (another prerequisite)) we'll unshift |
716
|
|
|
|
|
|
|
# the rest of the characters back onto the argument list. |
717
|
|
|
|
|
|
|
# |
718
|
|
|
|
|
|
|
# Oh, but first we'll need to get the applicable |
719
|
|
|
|
|
|
|
# option template and then start testing... |
720
|
14
|
|
|
|
|
31
|
$tref = _getOption( $tmp[0] ); |
721
|
14
|
100
|
66
|
|
|
94
|
if ( $#tmp |
|
|
|
66
|
|
|
|
|
|
|
|
66
|
|
|
|
|
722
|
|
|
|
|
|
|
and defined $tref |
723
|
|
|
|
|
|
|
and $$tref{Template} eq '$' |
724
|
|
|
|
|
|
|
and not $$tref{CanBundle} ) { |
725
|
3
|
|
|
|
|
13
|
unshift @$argRef, join '', @tmp[ 1 .. $#tmp ]; |
726
|
3
|
|
|
|
|
7
|
splice @tmp, 1; |
727
|
|
|
|
|
|
|
} |
728
|
|
|
|
|
|
|
|
729
|
|
|
|
|
|
|
# Start processing all remaining short options in @tmp |
730
|
14
|
|
|
|
|
31
|
foreach (@tmp) { |
731
|
|
|
|
|
|
|
|
732
|
|
|
|
|
|
|
# Get the template |
733
|
25
|
|
|
|
|
42
|
$tref = _getOption($_); |
734
|
|
|
|
|
|
|
|
735
|
|
|
|
|
|
|
# Make sure the option is supported |
736
|
25
|
50
|
|
|
|
47
|
if ( defined $tref ) { |
737
|
|
|
|
|
|
|
|
738
|
|
|
|
|
|
|
# Make sure option allows bundling if bundled |
739
|
25
|
100
|
|
|
|
50
|
if ($#tmp) { |
740
|
16
|
50
|
|
|
|
34
|
unless ( $$tref{CanBundle} ) { |
741
|
0
|
|
|
|
|
0
|
_pushErrors( |
742
|
|
|
|
|
|
|
"Option $_ used bundled with " |
743
|
|
|
|
|
|
|
. 'other options' ); |
744
|
0
|
|
|
|
|
0
|
$rv = 0; |
745
|
0
|
|
|
|
|
0
|
next; |
746
|
|
|
|
|
|
|
} |
747
|
|
|
|
|
|
|
} |
748
|
|
|
|
|
|
|
|
749
|
|
|
|
|
|
|
# Get the argument template |
750
|
25
|
|
|
|
|
41
|
$argTemplate = $$tref{Template}; |
751
|
|
|
|
|
|
|
|
752
|
|
|
|
|
|
|
# Override the template if CountShort is true |
753
|
|
|
|
|
|
|
$argTemplate = '' |
754
|
|
|
|
|
|
|
if $argTemplate eq '$' |
755
|
25
|
100
|
100
|
|
|
85
|
and $$tref{CountShort}; |
756
|
|
|
|
|
|
|
|
757
|
|
|
|
|
|
|
# Get any accompanying arguments |
758
|
25
|
50
|
|
|
|
64
|
unless ( _getArgs( "-$_", $argTemplate, @oargs ) ) |
759
|
|
|
|
|
|
|
{ |
760
|
0
|
|
|
|
|
0
|
$rv = 0; |
761
|
0
|
|
|
|
|
0
|
next; |
762
|
|
|
|
|
|
|
} |
763
|
|
|
|
|
|
|
|
764
|
|
|
|
|
|
|
# Check if we've call this more than once |
765
|
25
|
50
|
66
|
|
|
75
|
if ( not $$tref{Multiple} |
766
|
|
|
|
|
|
|
and $$tref{Count} > 0 ) { |
767
|
0
|
|
|
|
|
0
|
_pushErrors( |
768
|
|
|
|
|
|
|
"Option $$tref{Name} is only allowed " |
769
|
|
|
|
|
|
|
. 'to be used once' ); |
770
|
0
|
|
|
|
|
0
|
$rv = 0; |
771
|
0
|
|
|
|
|
0
|
next; |
772
|
|
|
|
|
|
|
} |
773
|
|
|
|
|
|
|
|
774
|
|
|
|
|
|
|
# Store the values |
775
|
25
|
|
|
|
|
60
|
_storeArgs( $tref, $argTemplate, @oargs ); |
776
|
|
|
|
|
|
|
|
777
|
|
|
|
|
|
|
} else { |
778
|
|
|
|
|
|
|
|
779
|
|
|
|
|
|
|
# Warn that this is an unknown option |
780
|
0
|
|
|
|
|
0
|
_pushErrors("Unknown short option used: $_"); |
781
|
0
|
|
|
|
|
0
|
$rv = 0; |
782
|
|
|
|
|
|
|
} |
783
|
|
|
|
|
|
|
} |
784
|
|
|
|
|
|
|
|
785
|
|
|
|
|
|
|
} elsif ( $arg =~ /^--([\w-]+)(?:=(.+))?$/sm ) { |
786
|
|
|
|
|
|
|
|
787
|
|
|
|
|
|
|
# Starts with '--', so must be a long option |
788
|
|
|
|
|
|
|
|
789
|
|
|
|
|
|
|
# Save the extracted option/argument portion |
790
|
13
|
|
|
|
|
44
|
@tmp = ($1); |
791
|
13
|
100
|
66
|
|
|
43
|
push @tmp, $2 if defined $2 and length $2; |
792
|
|
|
|
|
|
|
|
793
|
|
|
|
|
|
|
# If this option had an argument portion we need to |
794
|
|
|
|
|
|
|
# unshift it back onto the argument list *provided* it was |
795
|
|
|
|
|
|
|
# a legal argument, i.e., this option had a template of |
796
|
|
|
|
|
|
|
# '$'. |
797
|
13
|
|
|
|
|
27
|
$tref = _getOption( $tmp[0] ); |
798
|
13
|
100
|
66
|
|
|
33
|
if ( $#tmp and defined $tref ) { |
799
|
|
|
|
|
|
|
|
800
|
|
|
|
|
|
|
# Test for various templates |
801
|
1
|
50
|
|
|
|
5
|
if ( $$tref{Template} eq '$' ) { |
|
|
0
|
|
|
|
|
|
802
|
|
|
|
|
|
|
|
803
|
|
|
|
|
|
|
# Legal invocation -- unshift away |
804
|
1
|
|
|
|
|
3
|
unshift @$argRef, $tmp[1]; |
805
|
|
|
|
|
|
|
|
806
|
|
|
|
|
|
|
} elsif ( $$tref{Template} eq '' ) { |
807
|
|
|
|
|
|
|
|
808
|
|
|
|
|
|
|
# Illegal, no arguments expected |
809
|
0
|
|
|
|
|
0
|
_pushErrors( "--$tmp[0] does not require any " |
810
|
|
|
|
|
|
|
. 'arguments' ); |
811
|
0
|
|
|
|
|
0
|
$rv = 0; |
812
|
0
|
|
|
|
|
0
|
next; |
813
|
|
|
|
|
|
|
|
814
|
|
|
|
|
|
|
} else { |
815
|
|
|
|
|
|
|
|
816
|
|
|
|
|
|
|
# Illegal, can't use concatenated arguments in |
817
|
|
|
|
|
|
|
# more complex templates |
818
|
0
|
|
|
|
|
0
|
_pushErrors( "--$tmp[0] cannot be called like " |
819
|
|
|
|
|
|
|
. 'this when multiple arguments are ' |
820
|
|
|
|
|
|
|
. 'required.' ); |
821
|
|
|
|
|
|
|
} |
822
|
|
|
|
|
|
|
} |
823
|
|
|
|
|
|
|
|
824
|
|
|
|
|
|
|
# Handle known options |
825
|
13
|
100
|
|
|
|
27
|
if ( defined $tref ) { |
826
|
|
|
|
|
|
|
|
827
|
|
|
|
|
|
|
# Get the argument template |
828
|
11
|
|
|
|
|
16
|
$argTemplate = $$tref{Template}; |
829
|
|
|
|
|
|
|
|
830
|
|
|
|
|
|
|
# Snarf extra arguments |
831
|
11
|
100
|
|
|
|
31
|
unless ( |
832
|
|
|
|
|
|
|
_getArgs( "--$tmp[0]", $argTemplate, @oargs ) ) { |
833
|
1
|
|
|
|
|
2
|
$rv = 0; |
834
|
1
|
|
|
|
|
3
|
next; |
835
|
|
|
|
|
|
|
} |
836
|
|
|
|
|
|
|
|
837
|
|
|
|
|
|
|
# Check if we've call this more than once |
838
|
10
|
50
|
66
|
|
|
45
|
if ( not $$tref{Multiple} and $$tref{Count} > 0 ) { |
839
|
0
|
|
|
|
|
0
|
_pushErrors( |
840
|
|
|
|
|
|
|
"Option $$tref{Name} is only allowed to be used once" |
841
|
|
|
|
|
|
|
); |
842
|
0
|
|
|
|
|
0
|
$rv = 0; |
843
|
0
|
|
|
|
|
0
|
next; |
844
|
|
|
|
|
|
|
} |
845
|
|
|
|
|
|
|
|
846
|
|
|
|
|
|
|
# Store the values |
847
|
10
|
|
|
|
|
20
|
_storeArgs( $tref, $argTemplate, @oargs ); |
848
|
|
|
|
|
|
|
|
849
|
|
|
|
|
|
|
} else { |
850
|
|
|
|
|
|
|
|
851
|
|
|
|
|
|
|
# Unknown long option |
852
|
2
|
|
|
|
|
9
|
_pushErrors("Unknown option: --$tmp[0]"); |
853
|
2
|
|
|
|
|
5
|
$rv = 0; |
854
|
|
|
|
|
|
|
} |
855
|
|
|
|
|
|
|
|
856
|
|
|
|
|
|
|
} else { |
857
|
|
|
|
|
|
|
|
858
|
|
|
|
|
|
|
# Unknown option-looking thingy |
859
|
0
|
|
|
|
|
0
|
_pushErrors("Unknown option thingy: $arg"); |
860
|
0
|
|
|
|
|
0
|
$rv = 0; |
861
|
|
|
|
|
|
|
} |
862
|
|
|
|
|
|
|
|
863
|
|
|
|
|
|
|
} else { |
864
|
|
|
|
|
|
|
|
865
|
|
|
|
|
|
|
# Everything else is payload |
866
|
7
|
100
|
|
|
|
15
|
$$oref{PAYLOAD} = [] unless exists $$oref{PAYLOAD}; |
867
|
7
|
|
|
|
|
10
|
push @{ $$oref{PAYLOAD} }, $arg; |
|
7
|
|
|
|
|
16
|
|
868
|
|
|
|
|
|
|
} |
869
|
|
|
|
|
|
|
} |
870
|
|
|
|
|
|
|
} |
871
|
|
|
|
|
|
|
|
872
|
|
|
|
|
|
|
# Make a list of all the arguments that was used |
873
|
14
|
|
|
|
|
23
|
@tmp = (); |
874
|
14
|
|
|
|
|
27
|
foreach ( _optionsKeys() ) { |
875
|
203
|
100
|
|
|
|
236
|
push @tmp, $_ if ${ _getOption($_) }{Count}; |
|
203
|
|
|
|
|
272
|
|
876
|
|
|
|
|
|
|
} |
877
|
|
|
|
|
|
|
|
878
|
|
|
|
|
|
|
# Final sanity check |
879
|
14
|
|
|
|
|
66
|
foreach ( sort @tmp ) { |
880
|
44
|
|
|
|
|
66
|
$tref = _getOption($_); |
881
|
|
|
|
|
|
|
|
882
|
|
|
|
|
|
|
# Make sure nothing was called that is exclusive of |
883
|
|
|
|
|
|
|
# other called options |
884
|
44
|
100
|
|
|
|
54
|
if ( @{ $$tref{ExclusiveOf} } ) { |
|
44
|
|
|
|
|
85
|
|
885
|
2
|
|
|
|
|
9
|
$regex = '(?:' . join( '|', @{ $$tref{ExclusiveOf} } ) . ')'; |
|
2
|
|
|
|
|
8
|
|
886
|
2
|
50
|
|
|
|
40
|
if ( grep /^$regex$/sm, @tmp ) { |
887
|
|
|
|
|
|
|
_pushErrors( |
888
|
|
|
|
|
|
|
"$$tref{Name} cannot be called with the following options: " |
889
|
|
|
|
|
|
|
. join ', ', |
890
|
2
|
|
|
|
|
8
|
@{ $$tref{ExclusiveOf} } ); |
|
2
|
|
|
|
|
9
|
|
891
|
2
|
|
|
|
|
4
|
$rv = 0; |
892
|
|
|
|
|
|
|
} |
893
|
|
|
|
|
|
|
} |
894
|
|
|
|
|
|
|
|
895
|
|
|
|
|
|
|
# Make sure the option was called in conjunction with others |
896
|
44
|
|
|
|
|
57
|
foreach $regex ( @{ $$tref{AccompaniedBy} } ) { |
|
44
|
|
|
|
|
69
|
|
897
|
14
|
100
|
|
|
|
199
|
unless ( grep /^\Q$regex\E$/sm, @tmp ) { |
898
|
|
|
|
|
|
|
_pushErrors( |
899
|
|
|
|
|
|
|
"$$tref{Name} must be called with the following options: " |
900
|
|
|
|
|
|
|
. join ', ', |
901
|
2
|
|
|
|
|
6
|
@{ $$tref{AccompaniedBy} } ); |
|
2
|
|
|
|
|
8
|
|
902
|
2
|
|
|
|
|
4
|
$rv = 0; |
903
|
|
|
|
|
|
|
} |
904
|
|
|
|
|
|
|
} |
905
|
|
|
|
|
|
|
|
906
|
|
|
|
|
|
|
# Copy the values into %$oref |
907
|
44
|
|
|
|
|
95
|
$$oref{$_} = $$tref{Value}; |
908
|
|
|
|
|
|
|
} |
909
|
|
|
|
|
|
|
|
910
|
14
|
|
|
|
|
39
|
pOut(); |
911
|
14
|
|
|
|
|
51
|
pdebug( 'leaving w/rv: %s', PDLEVEL1, $rv ); |
912
|
|
|
|
|
|
|
|
913
|
14
|
|
|
|
|
94
|
return $rv; |
914
|
|
|
|
|
|
|
} |
915
|
|
|
|
|
|
|
|
916
|
|
|
|
|
|
|
1; |
917
|
|
|
|
|
|
|
|
918
|
|
|
|
|
|
|
__END__ |