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
|
# newgetopt.pl -- new options parsing
# SCCS Status : @(#)@ newgetopt.pl 1.8
# Author : Johan Vromans
# Created On : Tue Sep 11 15:00:12 1990
# Last Modified By: Johan Vromans
# Last Modified On: Thu Sep 26 20:10:41 1991
# Update Count : 35
# 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 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 "-".
#
# 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
# 20-Sep-1990 Johan Vromans
# Set options w/o argument to 1.
# Correct the dreadful semicolon/require bug.
package newgetopt;
$debug = 0; # for debugging
sub main'NGetOpt {
local (@optionlist) = @_;
local ($[) = 0;
local ($genprefix) = "-";
local ($error) = 0;
local ($opt, $optx, $arg, $type, $mand, @hits);
# See if the first element of the optionlist contains option
# starter characters.
$genprefix = shift (@optionlist) if $optionlist[0] =~ /^\W+$/;
# Turn into regexp.
$genprefix =~ s/(\W)/\\\1/g;
$genprefix = "[" . $genprefix . "]";
# Verify correctness of optionlist.
@hits = grep ($_ !~ /^\w+([=:][infse])?$/, @optionlist);
if ( $#hits >= 0 ) {
foreach $opt ( @hits ) {
print STDERR ("Error in option spec: \"", $opt, "\"\n");
$error++;
}
return 0;
}
# Process argument list
while ( $#main'ARGV >= 0 ) { #'){
# >>> See also the continue block <<<
# Get next argument
$opt = shift (@main'ARGV); #');
print STDERR ("=> option \"", $opt, "\"\n") if $debug;
$arg = undef;
# Check for exhausted list.
if ( $opt =~ /^$genprefix/o ) {
# Double occurrence is terminator
return ($error == 0) if $opt eq "$+$+";
$opt = $'; # option name (w/o prefix)
}
else {
# Apparently not an option - push back and exit.
unshift (@main'ARGV, $opt); #');
return ($error == 0);
}
# Grep in option list. Hide regexp chars from option.
($optx = $opt) =~ s/(\W)/\\\1/g;
@hits = grep (/^$optx([=:].+)?$/, @optionlist);
if ( $#hits != 0 ) {
print STDERR ("Unknown option: ", $opt, "\n");
$error++;
next;
}
# Determine argument status.
undef $type;
$type = $+ if $hits[0] =~ /[=:].+$/;
print STDERR ("=> found \"$hits[0]\" for ", $opt, "\n") if $debug;
# If it is an option w/o argument, we're almost finished with it.
if ( ! defined $type ) {
$arg = 1; # supply explicit value
next;
}
# Get mandatory status and type info.
($mand, $type) = $type =~ /^(.)(.)$/;
# Check if the argument list is exhausted.
if ( $#main'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 (@main'ARGV); #');
# Check if it is a valid argument. A mandatory string takes
# anything.
if ( "$mand$type" ne "=s" && $arg =~ /^$genprefix/o ) {
# Check for option list terminator.
if ( $arg eq "$+$+" ) {
# Complain if an argument is required.
if ($mand eq "=") {
print STDERR ("Option ", $opt, " requires an argument\n");
$error++;
}
# Push back so the outer loop will terminate.
unshift (@main'ARGV, $arg); #');
$arg = ""; # don't assign it
next;
}
# Maybe the optional argument is the next option?
if ( $mand eq ":" && $' =~ /[a-zA-Z_]/ ) {
# Yep. Push back.
unshift (@main'ARGV, $arg); #');
$arg = ""; # don't assign it
next;
}
}
if ( $type eq "n" || $type eq "i" ) { # numeric/integer
if ( $arg !~ /^-?[0-9]+$/ ) {
print STDERR ("Value \"", $arg, "\" invalid for option ",
$opt, " (numeric required)\n");
$error++;
}
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 required)\n");
$error++;
}
next;
}
if ( $type eq "s" ) { # string
next;
}
}
continue {
print STDERR ("=> \$main'opt_$opt = $arg\n") if $debug;
eval ("\$main'opt_$opt = \$arg");
}
return ($error == 0);
}
1;
|
