1 # newgetopt.pl -- new options parsing
3 # SCCS Status : @(#)@ newgetopt.pl 1.7
4 # Author : Johan Vromans
5 # Created On : Tue Sep 11 15:00:12 1990
6 # Last Modified By: Johan Vromans
7 # Last Modified On: Sun Oct 14 14:35:36 1990
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.
22 # - if the first option of the list consists of non-alphanumeric
23 # characters only, it is interpreted as a generic option starter.
24 # Everything starting with one of the characters from the starter
25 # will be considered an option.
26 # Likewise, a double occurrence (e.g. "--") signals end of
28 # The default value for the starter is "-".
30 # Upon return, the option variables, prefixed with "opt_", are defined
31 # and set to the respective option arguments, if any.
32 # Options that do not take an argument are set to 1. Note that an
33 # option with an optional argument will be defined, but set to '' if
34 # no actual argument has been supplied.
35 # A return status of 0 (false) indicates that the function detected
38 # Special care is taken to give a correct treatment to optional arguments.
40 # E.g. if option "one:i" (i.e. takes an optional integer argument),
41 # then the following situations are handled:
43 # -one -two -> $opt_one = '', -two is next option
44 # -one -2 -> $opt_one = -2
46 # Also, assume "foo=s" and "bar:s" :
48 # -bar -xxx -> $opt_bar = '', '-xxx' is next option
49 # -foo -bar -> $opt_foo = '-bar'
50 # -foo -- -> $opt_foo = '--'
54 # 20-Sep-1990 Johan Vromans
55 # Set options w/o argument to 1.
56 # Correct the dreadful semicolon/require bug.
61 $debug = 0; # for debugging
64 local (@optionlist) = @_;
66 local ($genprefix) = "-";
68 local ($opt, $optx, $arg, $type, $mand, @hits);
70 # See if the first element of the optionlist contains option
72 $genprefix = shift (@optionlist) if $optionlist[0] =~ /^\W+$/;
75 $genprefix =~ s/(\W)/\\\1/g;
76 $genprefix = "[" . $genprefix . "]";
78 # Verify correctness of optionlist.
79 @hits = grep ($_ !~ /^\w+([=:][infse])?$/, @optionlist);
81 foreach $opt ( @hits ) {
82 print STDERR ("Error in option spec: \"", $opt, "\"\n");
88 # Process argument list
90 while ( $#main'ARGV >= 0 ) { #'){
92 # >>> See also the continue block <<<
95 $opt = shift (@main'ARGV); #');
96 print STDERR ("=> option \"", $opt, "\"\n") if $debug;
99 # Check for exhausted list.
100 if ( $opt =~ /^$genprefix/o ) {
101 # Double occurrence is terminator
102 return ($error == 0) if $opt eq "$+$+";
103 $opt = $'; # option name (w/o prefix)
106 # Apparently not an option - push back and exit.
107 unshift (@main'ARGV, $opt); #');
108 return ($error == 0);
111 # Grep in option list. Hide regexp chars from option.
112 ($optx = $opt) =~ s/(\W)/\\\1/g;
113 @hits = grep (/^$optx([=:].+)?$/, @optionlist);
115 print STDERR ("Unknown option: ", $opt, "\n");
120 # Determine argument status.
122 $type = $+ if $hits[0] =~ /[=:].+$/;
123 print STDERR ("=> found \"$hits[0]\" for ", $opt, "\n") if $debug;
125 # If it is an option w/o argument, we're almost finished with it.
126 if ( ! defined $type ) {
127 $arg = 1; # supply explicit value
131 # Get mandatory status and type info.
132 ($mand, $type) = $type =~ /^(.)(.)$/;
134 # Check if the argument list is exhausted.
135 if ( $#main'ARGV < 0 ) { #'){
137 # Complain if this option needs an argument.
138 if ( $mand eq "=" ) {
139 print STDERR ("Option ", $opt, " requires an argument\n");
145 # Get (possibly optional) argument.
146 $arg = shift (@main'ARGV); #');
148 # Check if it is a valid argument. A mandatory string takes
150 if ( "$mand$type" ne "=s" && $arg =~ /^$genprefix/o ) {
152 # Check for option list terminator.
153 if ( $arg eq "$+$+" ) {
154 # Complain if an argument is required.
156 print STDERR ("Option ", $opt, " requires an argument\n");
159 # Push back so the outer loop will terminate.
160 unshift (@main'ARGV, $arg); #');
161 $arg = ""; # don't assign it
165 # Maybe the optional argument is the next option?
166 if ( $mand eq ":" && $' =~ /[a-zA-Z_]/ ) {
168 unshift (@main'ARGV, $arg); #');
169 $arg = ""; # don't assign it
174 if ( $type eq "n" || $type eq "i" ) { # numeric/integer
175 if ( $arg !~ /^-?[0-9]+$/ ) {
176 print STDERR ("Value \"", $arg, "\" invalid for option ",
177 $opt, " (numeric required)\n");
183 if ( $type eq "f" ) { # fixed real number, int is also ok
184 if ( $arg !~ /^-?[0-9.]+$/ ) {
185 print STDERR ("Value \"", $arg, "\" invalid for option ",
186 $opt, " (real number required)\n");
192 if ( $type eq "s" ) { # string
198 print STDERR ("=> \$main'opt_$opt = $arg\n") if $debug;
199 eval ("\$main'opt_$opt = \$arg");
202 return ($error == 0);