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