1 # newgetopt.pl -- new options parsing
3 # SCCS Status : @(#)@ newgetopt.pl 1.13
4 # Author : Johan Vromans
5 # Created On : Tue Sep 11 15:00:12 1990
6 # Last Modified By: Johan Vromans
7 # Last Modified On: Tue Jun 2 11:24:03 1992
11 # This package implements a new getopt function. This function adheres
12 # to the new syntax (long option names, no bundling).
14 # Arguments to the function are:
16 # - a list of possible options. These should designate valid perl
17 # identifiers, optionally followed by an argument specifier ("="
18 # for mandatory arguments or ":" for optional arguments) and an
19 # argument type specifier: "n" or "i" for integer numbers, "f" for
20 # real (fix) numbers or "s" for strings.
21 # If an "@" sign is appended, the option is treated as an array.
22 # Value(s) are not set, but pushed.
24 # - if the first option of the list consists of non-alphanumeric
25 # characters only, it is interpreted as a generic option starter.
26 # Everything starting with one of the characters from the starter
27 # will be considered an option.
28 # Likewise, a double occurrence (e.g. "--") signals end of
30 # The default value for the starter is "-", "--" or "+".
32 # Upon return, the option variables, prefixed with "opt_", are defined
33 # and set to the respective option arguments, if any.
34 # Options that do not take an argument are set to 1. Note that an
35 # option with an optional argument will be defined, but set to '' if
36 # no actual argument has been supplied.
37 # A return status of 0 (false) indicates that the function detected
40 # Special care is taken to give a correct treatment to optional arguments.
42 # E.g. if option "one:i" (i.e. takes an optional integer argument),
43 # then the following situations are handled:
45 # -one -two -> $opt_one = '', -two is next option
46 # -one -2 -> $opt_one = -2
48 # Also, assume "foo=s" and "bar:s" :
50 # -bar -xxx -> $opt_bar = '', '-xxx' is next option
51 # -foo -bar -> $opt_foo = '-bar'
52 # -foo -- -> $opt_foo = '--'
55 # 2-Jun-1992 Johan Vromans
56 # Do not use //o to allow multiple NGetOpt calls with different delimeters.
57 # Prevent typeless option from using previous $array state.
58 # Prevent empty option from being eaten as a (negative) number.
60 # 25-May-1992 Johan Vromans
61 # Add array options. "foo=s@" will return an array @opt_foo that
62 # contains all values that were supplied. E.g. "-foo one -foo -two" will
63 # return @opt_foo = ("one", "-two");
64 # Correct bug in handling options that allow for a argument when followed
67 # 4-May-1992 Johan Vromans
68 # Add $ignorecase to match options in either case.
71 # 19-Mar-1992 Johan Vromans
72 # Allow require from packages.
73 # NGetOpt is now defined in the package that requires it.
74 # @ARGV and $opt_... are taken from the package that calls it.
75 # Use standard (?) option prefixes: -, -- and +.
77 # 20-Sep-1990 Johan Vromans
78 # Set options w/o argument to 1.
79 # Correct the dreadful semicolon/require bug.
83 $debug = 0; # for debugging
84 $ignorecase = 1; # ignore case when matching options
89 @newgetopt'optionlist = @_;
90 *newgetopt'ARGV = *ARGV;
95 local ($genprefix) = "(--|-|\\+)";
96 local ($argend) = "--";
98 local ($opt, $optx, $arg, $type, $mand, %opctl);
99 local ($pkg) = (caller)[0];
101 print STDERR "NGetOpt 1.13 -- called from $pkg\n" if $debug;
103 # See if the first element of the optionlist contains option
104 # starter characters.
105 if ( $optionlist[0] =~ /^\W+$/ ) {
106 $genprefix = shift (@optionlist);
108 $genprefix =~ s/(\W)/\\\1/g;
109 $genprefix = "[" . $genprefix . "]";
113 # Verify correctness of optionlist.
115 foreach $opt ( @optionlist ) {
116 $opt =~ tr/A-Z/a-z/ if $ignorecase;
117 if ( $opt !~ /^(\w*)([=:][infse]@?)?$/ ) {
118 print STDERR ("Error in option spec: \"", $opt, "\"\n");
122 $opctl{$1} = defined $2 ? $2 : "";
128 local ($arrow, $k, $v);
130 while ( ($k,$v) = each(%opctl) ) {
131 print STDERR ($arrow, "\$opctl{\"$k\"} = \"$v\"\n");
136 # Process argument list
138 while ( $#ARGV >= 0 ) {
140 # >>> See also the continue block <<<
143 $opt = shift (@ARGV);
144 print STDERR ("=> option \"", $opt, "\"\n") if $debug;
147 # Check for exhausted list.
148 if ( $opt =~ /^$genprefix/ ) {
149 # Double occurrence is terminator
151 if ($opt eq "$+$+") || ((defined $argend) && $opt eq $argend);
152 $opt = $'; # option name (w/o prefix)
155 # Apparently not an option - push back and exit.
156 unshift (@ARGV, $opt);
157 return ($error == 0);
161 $opt =~ tr/A-Z/a-z/ if $ignorecase;
162 unless ( defined ( $type = $opctl{$opt} ) ) {
163 print STDERR ("Unknown option: ", $opt, "\n");
168 # Determine argument status.
169 print STDERR ("=> found \"$type\" for ", $opt, "\n") if $debug;
171 # If it is an option w/o argument, we're almost finished with it.
173 $arg = 1; # supply explicit value
178 # Get mandatory status and type info.
179 ($mand, $type, $array) = $type =~ /^(.)(.)(@?)$/;
181 # Check if the argument list is exhausted.
184 # Complain if this option needs an argument.
185 if ( $mand eq "=" ) {
186 print STDERR ("Option ", $opt, " requires an argument\n");
189 if ( $mand eq ":" ) {
190 $arg = $type eq "s" ? "" : 0;
195 # Get (possibly optional) argument.
196 $arg = shift (@ARGV);
198 # Check if it is a valid argument. A mandatory string takes
200 if ( "$mand$type" ne "=s" && $arg =~ /^$genprefix/ ) {
202 # Check for option list terminator.
203 if ( $arg eq "$+$+" ||
204 ((defined $argend) && $arg eq $argend)) {
205 # Push back so the outer loop will terminate.
206 unshift (@ARGV, $arg);
207 # Complain if an argument is required.
209 print STDERR ("Option ", $opt, " requires an argument\n");
211 undef $arg; # don't assign it
214 # Supply empty value.
215 $arg = $type eq "s" ? "" : 0;
220 # Maybe the optional argument is the next option?
221 if ( $mand eq ":" && ($' eq "" || $' =~ /[a-zA-Z_]/) ) {
223 unshift (@ARGV, $arg);
224 $arg = $type eq "s" ? "" : 0;
229 if ( $type eq "n" || $type eq "i" ) { # numeric/integer
230 if ( $arg !~ /^-?[0-9]+$/ ) {
231 print STDERR ("Value \"", $arg, "\" invalid for option ",
232 $opt, " (number expected)\n");
234 undef $arg; # don't assign it
239 if ( $type eq "f" ) { # fixed real number, int is also ok
240 if ( $arg !~ /^-?[0-9.]+$/ ) {
241 print STDERR ("Value \"", $arg, "\" invalid for option ",
242 $opt, " (real number expected)\n");
244 undef $arg; # don't assign it
249 if ( $type eq "s" ) { # string
255 if ( defined $arg ) {
257 print STDERR ('=> push (@', $pkg, '\'opt_', $opt, ", \"$arg\")\n")
259 eval ('push(@' . $pkg . '\'opt_' . $opt . ", \$arg);");
262 print STDERR ('=> $', $pkg, '\'opt_', $opt, " = \"$arg\"\n")
264 eval ('$' . $pkg . '\'opt_' . $opt . " = \$arg;");
269 return ($error == 0);