1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
|
# newgetopt.pl -- new options parsing
# SCCS Status : @(#)@ newgetopt.pl 1.13
# Author : Johan Vromans
# Created On : Tue Sep 11 15:00:12 1990
# Last Modified By: Johan Vromans
# Last Modified On: Tue Jun 2 11:24:03 1992
# Update Count : 75
# Status : Okay
# This package implements a new getopt function. This function adheres
# to the new syntax (long option names, no bundling).
#
# Arguments to the function are:
#
# - a list of possible options. These should designate valid perl
# identifiers, optionally followed by an argument specifier ("="
# for mandatory arguments or ":" for optional arguments) and an
# argument type specifier: "n" or "i" for integer numbers, "f" for
# real (fix) numbers or "s" for strings.
# If an "@" sign is appended, the option is treated as an array.
# Value(s) are not set, but pushed.
#
# - if the first option of the list consists of non-alphanumeric
# characters only, it is interpreted as a generic option starter.
# Everything starting with one of the characters from the starter
# will be considered an option.
# Likewise, a double occurrence (e.g. "--") signals end of
# the options list.
# The default value for the starter is "-", "--" or "+".
#
# Upon return, the option variables, prefixed with "opt_", are defined
# and set to the respective option arguments, if any.
# Options that do not take an argument are set to 1. Note that an
# option with an optional argument will be defined, but set to '' if
# no actual argument has been supplied.
# A return status of 0 (false) indicates that the function detected
# one or more errors.
#
# Special care is taken to give a correct treatment to optional arguments.
#
# E.g. if option "one:i" (i.e. takes an optional integer argument),
# then the following situations are handled:
#
# -one -two -> $opt_one = '', -two is next option
# -one -2 -> $opt_one = -2
#
# Also, assume "foo=s" and "bar:s" :
#
# -bar -xxx -> $opt_bar = '', '-xxx' is next option
# -foo -bar -> $opt_foo = '-bar'
# -foo -- -> $opt_foo = '--'
#
# HISTORY
# 2-Jun-1992 Johan Vromans
# Do not use //o to allow multiple NGetOpt calls with different delimeters.
# Prevent typeless option from using previous $array state.
# Prevent empty option from being eaten as a (negative) number.
# 25-May-1992 Johan Vromans
# Add array options. "foo=s@" will return an array @opt_foo that
# contains all values that were supplied. E.g. "-foo one -foo -two" will
# return @opt_foo = ("one", "-two");
# Correct bug in handling options that allow for a argument when followed
# by another option.
# 4-May-1992 Johan Vromans
# Add $ignorecase to match options in either case.
# Allow '' option.
# 19-Mar-1992 Johan Vromans
# Allow require from packages.
# NGetOpt is now defined in the package that requires it.
# @ARGV and $opt_... are taken from the package that calls it.
# Use standard (?) option prefixes: -, -- and +.
# 20-Sep-1990 Johan Vromans
# Set options w/o argument to 1.
# Correct the dreadful semicolon/require bug.
{ package newgetopt;
$debug = 0; # for debugging
$ignorecase = 1; # ignore case when matching options
}
sub NGetOpt {
@newgetopt'optionlist = @_;
*newgetopt'ARGV = *ARGV;
package newgetopt;
local ($[) = 0;
local ($genprefix) = "(--|-|\\+)";
local ($argend) = "--";
local ($error) = 0;
local ($opt, $optx, $arg, $type, $mand, %opctl);
local ($pkg) = (caller)[0];
print STDERR "NGetOpt 1.13 -- called from $pkg\n" if $debug;
# See if the first element of the optionlist contains option
# starter characters.
if ( $optionlist[0] =~ /^\W+$/ ) {
$genprefix = shift (@optionlist);
# Turn into regexp.
$genprefix =~ s/(\W)/\\\1/g;
$genprefix = "[" . $genprefix . "]";
undef $argend;
}
# Verify correctness of optionlist.
%opctl = ();
foreach $opt ( @optionlist ) {
$opt =~ tr/A-Z/a-z/ if $ignorecase;
if ( $opt !~ /^(\w*)([=:][infse]@?)?$/ ) {
print STDERR ("Error in option spec: \"", $opt, "\"\n");
$error++;
next;
}
$opctl{$1} = defined $2 ? $2 : "";
}
return 0 if $error;
if ( $debug ) {
local ($arrow, $k, $v);
$arrow = "=> ";
while ( ($k,$v) = each(%opctl) ) {
print STDERR ($arrow, "\$opctl{\"$k\"} = \"$v\"\n");
$arrow = " ";
}
}
# Process argument list
while ( $#ARGV >= 0 ) {
# >>> See also the continue block <<<
# Get next argument
$opt = shift (@ARGV);
print STDERR ("=> option \"", $opt, "\"\n") if $debug;
$arg = undef;
# Check for exhausted list.
if ( $opt =~ /^$genprefix/ ) {
# Double occurrence is terminator
return ($error == 0)
if ($opt eq "$+$+") || ((defined $argend) && $opt eq $argend);
$opt = $'; # option name (w/o prefix)
}
else {
# Apparently not an option - push back and exit.
unshift (@ARGV, $opt);
return ($error == 0);
}
# Look it up.
$opt =~ tr/A-Z/a-z/ if $ignorecase;
unless ( defined ( $type = $opctl{$opt} ) ) {
print STDERR ("Unknown option: ", $opt, "\n");
$error++;
next;
}
# Determine argument status.
print STDERR ("=> found \"$type\" for ", $opt, "\n") if $debug;
# If it is an option w/o argument, we're almost finished with it.
if ( $type eq "" ) {
$arg = 1; # supply explicit value
$array = 0;
next;
}
# Get mandatory status and type info.
($mand, $type, $array) = $type =~ /^(.)(.)(@?)$/;
# Check if the argument list is exhausted.
if ( $#ARGV < 0 ) {
# Complain if this option needs an argument.
if ( $mand eq "=" ) {
print STDERR ("Option ", $opt, " requires an argument\n");
$error++;
}
if ( $mand eq ":" ) {
$arg = $type eq "s" ? "" : 0;
}
next;
}
# Get (possibly optional) argument.
$arg = shift (@ARGV);
# Check if it is a valid argument. A mandatory string takes
# anything.
if ( "$mand$type" ne "=s" && $arg =~ /^$genprefix/ ) {
# Check for option list terminator.
if ( $arg eq "$+$+" ||
((defined $argend) && $arg eq $argend)) {
# Push back so the outer loop will terminate.
unshift (@ARGV, $arg);
# Complain if an argument is required.
if ($mand eq "=") {
print STDERR ("Option ", $opt, " requires an argument\n");
$error++;
undef $arg; # don't assign it
}
else {
# Supply empty value.
$arg = $type eq "s" ? "" : 0;
}
next;
}
# Maybe the optional argument is the next option?
if ( $mand eq ":" && ($' eq "" || $' =~ /[a-zA-Z_]/) ) {
# Yep. Push back.
unshift (@ARGV, $arg);
$arg = $type eq "s" ? "" : 0;
next;
}
}
if ( $type eq "n" || $type eq "i" ) { # numeric/integer
if ( $arg !~ /^-?[0-9]+$/ ) {
print STDERR ("Value \"", $arg, "\" invalid for option ",
$opt, " (number expected)\n");
$error++;
undef $arg; # don't assign it
}
next;
}
if ( $type eq "f" ) { # fixed real number, int is also ok
if ( $arg !~ /^-?[0-9.]+$/ ) {
print STDERR ("Value \"", $arg, "\" invalid for option ",
$opt, " (real number expected)\n");
$error++;
undef $arg; # don't assign it
}
next;
}
if ( $type eq "s" ) { # string
next;
}
}
continue {
if ( defined $arg ) {
if ( $array ) {
print STDERR ('=> push (@', $pkg, '\'opt_', $opt, ", \"$arg\")\n")
if $debug;
eval ('push(@' . $pkg . '\'opt_' . $opt . ", \$arg);");
}
else {
print STDERR ('=> $', $pkg, '\'opt_', $opt, " = \"$arg\"\n")
if $debug;
eval ('$' . $pkg . '\'opt_' . $opt . " = \$arg;");
}
}
}
return ($error == 0);
}
1;
|
