6 @EXPORT = qw(GetOptions);
9 # newgetopt.pl -- new options parsing
11 # SCCS Status : @(#)@ newgetopt.pl 1.14
12 # Author : Johan Vromans
13 # Created On : Tue Sep 11 15:00:12 1990
14 # Last Modified By: Johan Vromans
15 # Last Modified On: Sat Feb 12 18:24:02 1994
19 ################ Introduction ################
21 # This package implements an extended getopt function. This function adheres
22 # to the new syntax (long option names, no bundling).
23 # It tries to implement the better functionality of traditional, GNU and
24 # POSIX getopt functions.
26 # This program is Copyright 1990,1994 by Johan Vromans.
27 # This program is free software; you can redistribute it and/or
28 # modify it under the terms of the GNU General Public License
29 # as published by the Free Software Foundation; either version 2
30 # of the License, or (at your option) any later version.
32 # This program is distributed in the hope that it will be useful,
33 # but WITHOUT ANY WARRANTY; without even the implied warranty of
34 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
35 # GNU General Public License for more details.
37 # If you do not have a copy of the GNU General Public License write to
38 # the Free Software Foundation, Inc., 675 Mass Ave, Cambridge,
41 ################ Description ################
45 # require "newgetopt.pl";
46 # ...change configuration values, if needed...
47 # $result = &NGetOpt (...option-descriptions...);
49 # Each description should designate a valid perl identifier, optionally
50 # followed by an argument specifier.
52 # Values for argument specifiers are:
54 # <none> option does not take an argument
55 # ! option does not take an argument and may be negated
56 # =s :s option takes a mandatory (=) or optional (:) string argument
57 # =i :i option takes a mandatory (=) or optional (:) integer argument
58 # =f :f option takes a mandatory (=) or optional (:) real number argument
60 # If option "name" is set, it will cause the perl variable $opt_name to
61 # be set to the specified value. The calling program can use this
62 # variable to detect whether the option has been set. Options that do
63 # not take an argument will be set to 1 (one).
65 # Options that take an optional argument will be defined, but set to ''
66 # if no actual argument has been supplied.
68 # If an "@" sign is appended to the argument specifier, the option is
69 # treated as an array. Value(s) are not set, but pushed into array
72 # Options that do not take a value may have an "!" argument spacifier to
73 # indicate that they may be negated. E.g. "foo!" will allow -foo (which
74 # sets $opt_foo to 1) and -nofoo (which will set $opt_foo to 0).
76 # The option name may actually be a list of option names, separated by
77 # '|'s, e.g. "foo|bar|blech=s". In this example, options 'bar' and
78 # 'blech' will set $opt_foo instead.
80 # Option names may be abbreviated to uniqueness, depending on
81 # configuration variable $autoabbrev.
83 # Dashes in option names are allowed (e.g. pcc-struct-return) and will
84 # be translated to underscores in the corresponding perl variable (e.g.
85 # $opt_pcc_struct_return). Note that a lone dash "-" is considered an
86 # option, corresponding perl identifier is $opt_ .
88 # A double dash "--" signals end of the options list.
90 # If the first option of the list consists of non-alphanumeric
91 # characters only, it is interpreted as a generic option starter.
92 # Everything starting with one of the characters from the starter will
93 # be considered an option.
95 # The default values for the option starters are "-" (traditional), "--"
96 # (POSIX) and "+" (GNU, being phased out).
98 # Options that start with "--" may have an argument appended, separated
99 # with an "=", e.g. "--foo=bar".
101 # If configuration varaible $getopt_compat is set to a non-zero value,
102 # options that start with "+" may also include their arguments,
105 # A return status of 0 (false) indicates that the function detected
106 # one or more errors.
108 ################ Some examples ################
110 # If option "one:i" (i.e. takes an optional integer argument), then
111 # the following situations are handled:
113 # -one -two -> $opt_one = '', -two is next option
114 # -one -2 -> $opt_one = -2
116 # Also, assume "foo=s" and "bar:s" :
118 # -bar -xxx -> $opt_bar = '', '-xxx' is next option
119 # -foo -bar -> $opt_foo = '-bar'
120 # -foo -- -> $opt_foo = '--'
122 # In GNU or POSIX format, option names and values can be combined:
124 # +foo=blech -> $opt_foo = 'blech'
125 # --bar= -> $opt_bar = ''
126 # --bar=-- -> $opt_bar = '--'
128 ################ Configuration values ################
130 # $autoabbrev Allow option names to be abbreviated to uniqueness.
131 # Default is 1 unless environment variable
132 # POSIXLY_CORRECT has been set.
134 # $getopt_compat Allow '+' to start options.
135 # Default is 1 unless environment variable
136 # POSIXLY_CORRECT has been set.
138 # $option_start Regexp with option starters.
139 # Default is (--|-) if environment variable
140 # POSIXLY_CORRECT has been set, (--|-|\+) otherwise.
142 # $order Whether non-options are allowed to be mixed with
144 # Default is $REQUIRE_ORDER if environment variable
145 # POSIXLY_CORRECT has been set, $PERMUTE otherwise.
147 # $ignorecase Ignore case when matching options. Default is 1.
149 # $debug Enable debugging output. Default is 0.
151 ################ History ################
153 # 12-Feb-1994 Johan Vromans
154 # Added "!" for negation.
155 # Released to the net.
157 # 26-Aug-1992 Johan Vromans
158 # More POSIX/GNU compliance.
159 # Lone dash and double-dash are now independent of the option prefix
161 # Make errors in NGetOpt parameters fatal.
162 # Allow options to be mixed with arguments.
163 # Check $ENV{"POSIXLY_CORRECT"} to suppress this.
164 # Allow --foo=bar and +foo=bar (but not -foo=bar).
165 # Allow options to be abbreviated to minimum needed for uniqueness.
166 # (Controlled by configuration variable $autoabbrev.)
167 # Allow alias names for options (e.g. "foo|bar=s").
168 # Allow "-" in option names (e.g. --pcc-struct-return). Dashes are
169 # translated to "_" to form valid perl identifiers
170 # (e.g. $opt_pcc_struct_return).
172 # 2-Jun-1992 Johan Vromans
173 # Do not use //o to allow multiple NGetOpt calls with different delimeters.
174 # Prevent typeless option from using previous $array state.
175 # Prevent empty option from being eaten as a (negative) number.
177 # 25-May-1992 Johan Vromans
178 # Add array options. "foo=s@" will return an array @opt_foo that
179 # contains all values that were supplied. E.g. "-foo one -foo -two" will
180 # return @opt_foo = ("one", "-two");
181 # Correct bug in handling options that allow for a argument when followed
184 # 4-May-1992 Johan Vromans
185 # Add $ignorecase to match options in either case.
188 # 19-Mar-1992 Johan Vromans
189 # Allow require from packages.
190 # NGetOpt is now defined in the package that requires it.
191 # @ARGV and $opt_... are taken from the package that calls it.
192 # Use standard (?) option prefixes: -, -- and +.
194 # 20-Sep-1990 Johan Vromans
195 # Set options w/o argument to 1.
196 # Correct the dreadful semicolon/require bug.
198 ################ Configuration Section ################
202 # Values for $order. See GNU getopt.c for details.
205 $RETURN_IN_ORDER = 2;
207 # Handle POSIX compliancy.
208 if ( defined $ENV{"POSIXLY_CORRECT"} ) {
209 $autoabbrev = 0; # no automatic abbrev of options (???)
210 $getopt_compat = 0; # disallow '+' to start options
211 $option_start = "(--|-)";
212 $order = $REQUIRE_ORDER;
215 $autoabbrev = 1; # automatic abbrev of options
216 $getopt_compat = 1; # allow '+' to start options
217 $option_start = "(--|-|\\+)";
221 # Other configurable settings.
222 $debug = 0; # for debugging
223 $ignorecase = 1; # ignore case when matching options
224 $argv_end = "--"; # don't change this!
227 ################ Subroutines ################
231 @optionlist = @_; #';
234 local ($genprefix) = $option_start;
235 local ($argend) = $argv_end;
237 local ($opt, $optx, $arg, $type, $mand, %opctl);
238 local ($pkg) = (caller)[0];
243 print STDERR "NGetOpt 1.14 -- called from $pkg\n" if $debug;
245 # See if the first element of the optionlist contains option
246 # starter characters.
247 if ( $optionlist[0] =~ /^\W+$/ ) {
248 $genprefix = shift (@optionlist);
250 $genprefix =~ s/(\W)/\\$1/g;
251 $genprefix = "[" . $genprefix . "]";
254 # Verify correctness of optionlist.
256 foreach $opt ( @optionlist ) {
257 $opt =~ tr/A-Z/a-z/ if $ignorecase;
258 if ( $opt !~ /^(\w+[-\w|]*)?(!|[=:][infse]@?)?$/ ) {
259 die ("Error in option spec: \"", $opt, "\"\n");
263 local ($o, $c, $a) = ($1, $2);
265 if ( ! defined $o ) {
266 $opctl{''} = defined $c ? $c : '';
270 foreach ( split (/\|/, $o)) {
271 if ( defined $c && $c eq '!' ) {
275 $opctl{$_} = defined $c ? $c : '';
287 @opctl = sort(keys (%opctl)) if $autoabbrev;
292 local ($arrow, $k, $v);
294 while ( ($k,$v) = each(%opctl) ) {
295 print STDERR ($arrow, "\$opctl{\"$k\"} = \"$v\"\n");
300 # Process argument list
302 while ( $#ARGV >= 0 ) {
304 # >>> See also the continue block <<<
306 #### Get next argument ####
308 $opt = shift (@ARGV);
309 print STDERR ("=> option \"", $opt, "\"\n") if $debug;
314 #### Determine what we have ####
316 # Double dash is option list terminator.
317 if ( $opt eq $argend ) {
318 unshift (@ret, @ARGV) if $order == $PERMUTE;
319 return ($error == 0);
321 elsif ( $opt =~ /^$genprefix/ ) {
322 # Looks like an option.
323 $opt = $'; # option name (w/o prefix)
324 # If it is a long opt, it may include the value.
325 if (($+ eq "--" || ($getopt_compat && $+ eq "+")) &&
326 $opt =~ /^([^=]+)=/ ) {
329 print STDERR ("=> option \"", $opt,
330 "\", optarg = \"$optarg\"\n")
335 # Not an option. Save it if we may permute...
336 elsif ( $order == $PERMUTE ) {
340 # ...otherwise, terminate.
342 # Push back and exit.
343 unshift (@ARGV, $opt);
344 return ($error == 0);
349 $opt =~ tr/A-Z/a-z/ if $ignorecase;
351 local ($tryopt) = $opt;
355 # Turn option name into pattern.
356 ($pat = $opt) =~ s/(\W)/\\$1/g;
357 # Look up in option names.
358 @hits = grep (/^$pat/, @opctl);
359 print STDERR ("=> ", 0+@hits, " hits (@hits) with \"$pat\" ",
360 "out of ", 0+@opctl, "\n")
363 # Check for ambiguous results.
364 unless ( (@hits <= 1) || (grep ($_ eq $opt, @hits) == 1) ) {
365 print STDERR ("Option ", $opt, " is ambiguous (",
366 join(", ", @hits), ")\n");
371 # Complete the option name, if appropriate.
372 if ( @hits == 1 && $hits[0] ne $opt ) {
374 print STDERR ("=> option \"$opt\" -> \"$tryopt\"\n")
379 unless ( defined ( $type = $opctl{$tryopt} ) ) {
380 print STDERR ("Unknown option: ", $opt, "\n");
385 print STDERR ("=> found \"$type\" for ", $opt, "\n") if $debug;
387 #### Determine argument status ####
389 # If it is an option w/o argument, we're almost finished with it.
390 if ( $type eq '' || $type eq '!' ) {
391 if ( defined $optarg ) {
392 print STDERR ("Option ", $opt, " does not take an argument\n");
395 elsif ( $type eq '' ) {
396 $arg = 1; # supply explicit value
399 substr ($opt, 0, 2) = ''; # strip NO prefix
400 $arg = 0; # supply explicit value
405 # Get mandatory status and type info.
406 ($mand, $type, $array) = $type =~ /^(.)(.)(@?)$/;
408 # Check if there is an option argument available.
409 if ( defined $optarg ? ($optarg eq '') : ($#ARGV < 0) ) {
411 # Complain if this option needs an argument.
412 if ( $mand eq "=" ) {
413 print STDERR ("Option ", $opt, " requires an argument\n");
416 if ( $mand eq ":" ) {
417 $arg = $type eq "s" ? '' : 0;
422 # Get (possibly optional) argument.
423 $arg = defined $optarg ? $optarg : shift (@ARGV);
425 #### Check if the argument is valid for this option ####
427 if ( $type eq "s" ) { # string
428 # A mandatory string takes anything.
429 next if $mand eq "=";
431 # An optional string takes almost anything.
432 next if defined $optarg;
435 # Check for option or option list terminator.
436 if ($arg eq $argend ||
437 $arg =~ /^$genprefix.+/) {
439 unshift (@ARGV, $arg);
440 # Supply empty value.
446 if ( $type eq "n" || $type eq "i" ) { # numeric/integer
447 if ( $arg !~ /^-?[0-9]+$/ ) {
448 if ( defined $optarg || $mand eq "=" ) {
449 print STDERR ("Value \"", $arg, "\" invalid for option ",
450 $opt, " (number expected)\n");
452 undef $arg; # don't assign it
456 unshift (@ARGV, $arg);
457 # Supply default value.
464 if ( $type eq "f" ) { # fixed real number, int is also ok
465 if ( $arg !~ /^-?[0-9.]+$/ ) {
466 if ( defined $optarg || $mand eq "=" ) {
467 print STDERR ("Value \"", $arg, "\" invalid for option ",
468 $opt, " (real number expected)\n");
470 undef $arg; # don't assign it
474 unshift (@ARGV, $arg);
475 # Supply default value.
482 die ("NGetOpt internal error (Can't happen)\n");
486 if ( defined $arg ) {
487 $opt = $aliases{$opt} if defined $aliases{$opt};
488 # Make sure a valid perl identifier results.
491 print STDERR ('=> push (@', $pkg, '\'opt_', $opt, ", \"$arg\")\n")
493 eval ('push(@' . $pkg . '\'opt_' . $opt . ", \$arg);");
496 print STDERR ('=> $', $pkg, '\'opt_', $opt, " = \"$arg\"\n")
498 eval ('$' . $pkg . '\'opt_' . $opt . " = \$arg;");
503 if ( $order == $PERMUTE && @ret > 0 ) {
504 unshift (@ARGV, @ret);
506 return ($error == 0);
509 ################ Package return ################