Commit | Line | Data |
a0d0e21e |
1 | package Getopt::Long; |
2 | require 5.000; |
3 | require Exporter; |
4 | |
5 | @ISA = qw(Exporter); |
6 | @EXPORT = qw(GetOptions); |
7 | |
8 | |
9 | # newgetopt.pl -- new options parsing |
10 | |
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 |
16 | # Update Count : 138 |
17 | # Status : Okay |
18 | |
19 | ################ Introduction ################ |
20 | # |
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. |
25 | # |
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. |
31 | # |
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. |
36 | # |
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, |
39 | # MA 02139, USA. |
40 | |
41 | ################ Description ################ |
42 | # |
43 | # Usage: |
44 | # |
45 | # require "newgetopt.pl"; |
46 | # ...change configuration values, if needed... |
47 | # $result = &NGetOpt (...option-descriptions...); |
48 | # |
49 | # Each description should designate a valid perl identifier, optionally |
50 | # followed by an argument specifier. |
51 | # |
52 | # Values for argument specifiers are: |
53 | # |
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 |
59 | # |
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). |
64 | # |
65 | # Options that take an optional argument will be defined, but set to '' |
66 | # if no actual argument has been supplied. |
67 | # |
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 |
70 | # @opt_name. |
71 | # |
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). |
75 | # |
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. |
79 | # |
80 | # Option names may be abbreviated to uniqueness, depending on |
81 | # configuration variable $autoabbrev. |
82 | # |
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_ . |
87 | # |
88 | # A double dash "--" signals end of the options list. |
89 | # |
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. |
94 | # |
95 | # The default values for the option starters are "-" (traditional), "--" |
96 | # (POSIX) and "+" (GNU, being phased out). |
97 | # |
98 | # Options that start with "--" may have an argument appended, separated |
99 | # with an "=", e.g. "--foo=bar". |
100 | # |
101 | # If configuration varaible $getopt_compat is set to a non-zero value, |
102 | # options that start with "+" may also include their arguments, |
103 | # e.g. "+foo=bar". |
104 | # |
105 | # A return status of 0 (false) indicates that the function detected |
106 | # one or more errors. |
107 | # |
108 | ################ Some examples ################ |
109 | # |
110 | # If option "one:i" (i.e. takes an optional integer argument), then |
111 | # the following situations are handled: |
112 | # |
113 | # -one -two -> $opt_one = '', -two is next option |
114 | # -one -2 -> $opt_one = -2 |
115 | # |
116 | # Also, assume "foo=s" and "bar:s" : |
117 | # |
118 | # -bar -xxx -> $opt_bar = '', '-xxx' is next option |
119 | # -foo -bar -> $opt_foo = '-bar' |
120 | # -foo -- -> $opt_foo = '--' |
121 | # |
122 | # In GNU or POSIX format, option names and values can be combined: |
123 | # |
124 | # +foo=blech -> $opt_foo = 'blech' |
125 | # --bar= -> $opt_bar = '' |
126 | # --bar=-- -> $opt_bar = '--' |
127 | # |
128 | ################ Configuration values ################ |
129 | # |
130 | # $autoabbrev Allow option names to be abbreviated to uniqueness. |
131 | # Default is 1 unless environment variable |
132 | # POSIXLY_CORRECT has been set. |
133 | # |
134 | # $getopt_compat Allow '+' to start options. |
135 | # Default is 1 unless environment variable |
136 | # POSIXLY_CORRECT has been set. |
137 | # |
138 | # $option_start Regexp with option starters. |
139 | # Default is (--|-) if environment variable |
140 | # POSIXLY_CORRECT has been set, (--|-|\+) otherwise. |
141 | # |
142 | # $order Whether non-options are allowed to be mixed with |
143 | # options. |
144 | # Default is $REQUIRE_ORDER if environment variable |
145 | # POSIXLY_CORRECT has been set, $PERMUTE otherwise. |
146 | # |
147 | # $ignorecase Ignore case when matching options. Default is 1. |
148 | # |
149 | # $debug Enable debugging output. Default is 0. |
150 | |
151 | ################ History ################ |
152 | # |
153 | # 12-Feb-1994 Johan Vromans |
154 | # Added "!" for negation. |
155 | # Released to the net. |
156 | # |
157 | # 26-Aug-1992 Johan Vromans |
158 | # More POSIX/GNU compliance. |
159 | # Lone dash and double-dash are now independent of the option prefix |
160 | # that is used. |
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). |
171 | # |
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. |
176 | # |
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 |
182 | # by another option. |
183 | # |
184 | # 4-May-1992 Johan Vromans |
185 | # Add $ignorecase to match options in either case. |
186 | # Allow '' option. |
187 | # |
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 +. |
193 | # |
194 | # 20-Sep-1990 Johan Vromans |
195 | # Set options w/o argument to 1. |
196 | # Correct the dreadful semicolon/require bug. |
197 | |
198 | ################ Configuration Section ################ |
199 | |
200 | { |
201 | |
202 | # Values for $order. See GNU getopt.c for details. |
203 | $REQUIRE_ORDER = 0; |
204 | $PERMUTE = 1; |
205 | $RETURN_IN_ORDER = 2; |
206 | |
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; |
213 | } |
214 | else { |
215 | $autoabbrev = 1; # automatic abbrev of options |
216 | $getopt_compat = 1; # allow '+' to start options |
217 | $option_start = "(--|-|\\+)"; |
218 | $order = $PERMUTE; |
219 | } |
220 | |
221 | # Other configurable settings. |
222 | $debug = 0; # for debugging |
223 | $ignorecase = 1; # ignore case when matching options |
224 | $argv_end = "--"; # don't change this! |
225 | } |
226 | |
227 | ################ Subroutines ################ |
228 | |
229 | sub GetOptions { |
230 | |
231 | @optionlist = @_; #'; |
232 | |
233 | local ($[) = 0; |
234 | local ($genprefix) = $option_start; |
235 | local ($argend) = $argv_end; |
236 | local ($error) = 0; |
237 | local ($opt, $optx, $arg, $type, $mand, %opctl); |
238 | local ($pkg) = (caller)[0]; |
239 | local ($optarg); |
240 | local (%aliases); |
241 | local (@ret) = (); |
242 | |
243 | print STDERR "NGetOpt 1.14 -- called from $pkg\n" if $debug; |
244 | |
245 | # See if the first element of the optionlist contains option |
246 | # starter characters. |
247 | if ( $optionlist[0] =~ /^\W+$/ ) { |
248 | $genprefix = shift (@optionlist); |
249 | # Turn into regexp. |
250 | $genprefix =~ s/(\W)/\\$1/g; |
251 | $genprefix = "[" . $genprefix . "]"; |
252 | } |
253 | |
254 | # Verify correctness of optionlist. |
255 | %opctl = (); |
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"); |
260 | $error++; |
261 | next; |
262 | } |
263 | local ($o, $c, $a) = ($1, $2); |
264 | |
265 | if ( ! defined $o ) { |
266 | $opctl{''} = defined $c ? $c : ''; |
267 | } |
268 | else { |
269 | # Handle alias names |
270 | foreach ( split (/\|/, $o)) { |
271 | if ( defined $c && $c eq '!' ) { |
272 | $opctl{"no$_"} = $c; |
273 | $c = ''; |
274 | } |
275 | $opctl{$_} = defined $c ? $c : ''; |
276 | if ( defined $a ) { |
277 | # Note alias. |
278 | $aliases{$_} = $a; |
279 | } |
280 | else { |
281 | # Set primary name. |
282 | $a = $_; |
283 | } |
284 | } |
285 | } |
286 | } |
287 | @opctl = sort(keys (%opctl)) if $autoabbrev; |
288 | |
289 | return 0 if $error; |
290 | |
291 | if ( $debug ) { |
292 | local ($arrow, $k, $v); |
293 | $arrow = "=> "; |
294 | while ( ($k,$v) = each(%opctl) ) { |
295 | print STDERR ($arrow, "\$opctl{\"$k\"} = \"$v\"\n"); |
296 | $arrow = " "; |
297 | } |
298 | } |
299 | |
300 | # Process argument list |
301 | |
302 | while ( $#ARGV >= 0 ) { |
303 | |
304 | # >>> See also the continue block <<< |
305 | |
306 | #### Get next argument #### |
307 | |
308 | $opt = shift (@ARGV); |
309 | print STDERR ("=> option \"", $opt, "\"\n") if $debug; |
310 | $arg = undef; |
311 | $optarg = undef; |
312 | $array = 0; |
313 | |
314 | #### Determine what we have #### |
315 | |
316 | # Double dash is option list terminator. |
317 | if ( $opt eq $argend ) { |
318 | unshift (@ret, @ARGV) if $order == $PERMUTE; |
319 | return ($error == 0); |
320 | } |
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 =~ /^([^=]+)=/ ) { |
327 | $opt = $1; |
328 | $optarg = $'; |
329 | print STDERR ("=> option \"", $opt, |
330 | "\", optarg = \"$optarg\"\n") |
331 | if $debug; |
332 | } |
333 | |
334 | } |
335 | # Not an option. Save it if we may permute... |
336 | elsif ( $order == $PERMUTE ) { |
337 | push (@ret, $opt); |
338 | next; |
339 | } |
340 | # ...otherwise, terminate. |
341 | else { |
342 | # Push back and exit. |
343 | unshift (@ARGV, $opt); |
344 | return ($error == 0); |
345 | } |
346 | |
347 | #### Look it up ### |
348 | |
349 | $opt =~ tr/A-Z/a-z/ if $ignorecase; |
350 | |
351 | local ($tryopt) = $opt; |
352 | if ( $autoabbrev ) { |
353 | local ($pat, @hits); |
354 | |
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") |
361 | if $debug; |
362 | |
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"); |
367 | $error++; |
368 | next; |
369 | } |
370 | |
371 | # Complete the option name, if appropriate. |
372 | if ( @hits == 1 && $hits[0] ne $opt ) { |
373 | $tryopt = $hits[0]; |
374 | print STDERR ("=> option \"$opt\" -> \"$tryopt\"\n") |
375 | if $debug; |
376 | } |
377 | } |
378 | |
379 | unless ( defined ( $type = $opctl{$tryopt} ) ) { |
380 | print STDERR ("Unknown option: ", $opt, "\n"); |
381 | $error++; |
382 | next; |
383 | } |
384 | $opt = $tryopt; |
385 | print STDERR ("=> found \"$type\" for ", $opt, "\n") if $debug; |
386 | |
387 | #### Determine argument status #### |
388 | |
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"); |
393 | $error++; |
394 | } |
395 | elsif ( $type eq '' ) { |
396 | $arg = 1; # supply explicit value |
397 | } |
398 | else { |
399 | substr ($opt, 0, 2) = ''; # strip NO prefix |
400 | $arg = 0; # supply explicit value |
401 | } |
402 | next; |
403 | } |
404 | |
405 | # Get mandatory status and type info. |
406 | ($mand, $type, $array) = $type =~ /^(.)(.)(@?)$/; |
407 | |
408 | # Check if there is an option argument available. |
409 | if ( defined $optarg ? ($optarg eq '') : ($#ARGV < 0) ) { |
410 | |
411 | # Complain if this option needs an argument. |
412 | if ( $mand eq "=" ) { |
413 | print STDERR ("Option ", $opt, " requires an argument\n"); |
414 | $error++; |
415 | } |
416 | if ( $mand eq ":" ) { |
417 | $arg = $type eq "s" ? '' : 0; |
418 | } |
419 | next; |
420 | } |
421 | |
422 | # Get (possibly optional) argument. |
423 | $arg = defined $optarg ? $optarg : shift (@ARGV); |
424 | |
425 | #### Check if the argument is valid for this option #### |
426 | |
427 | if ( $type eq "s" ) { # string |
428 | # A mandatory string takes anything. |
429 | next if $mand eq "="; |
430 | |
431 | # An optional string takes almost anything. |
432 | next if defined $optarg; |
433 | next if $arg eq "-"; |
434 | |
435 | # Check for option or option list terminator. |
436 | if ($arg eq $argend || |
437 | $arg =~ /^$genprefix.+/) { |
438 | # Push back. |
439 | unshift (@ARGV, $arg); |
440 | # Supply empty value. |
441 | $arg = ''; |
442 | } |
443 | next; |
444 | } |
445 | |
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"); |
451 | $error++; |
452 | undef $arg; # don't assign it |
453 | } |
454 | else { |
455 | # Push back. |
456 | unshift (@ARGV, $arg); |
457 | # Supply default value. |
458 | $arg = 0; |
459 | } |
460 | } |
461 | next; |
462 | } |
463 | |
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"); |
469 | $error++; |
470 | undef $arg; # don't assign it |
471 | } |
472 | else { |
473 | # Push back. |
474 | unshift (@ARGV, $arg); |
475 | # Supply default value. |
476 | $arg = 0.0; |
477 | } |
478 | } |
479 | next; |
480 | } |
481 | |
482 | die ("NGetOpt internal error (Can't happen)\n"); |
483 | } |
484 | |
485 | continue { |
486 | if ( defined $arg ) { |
487 | $opt = $aliases{$opt} if defined $aliases{$opt}; |
488 | # Make sure a valid perl identifier results. |
489 | $opt =~ s/\W/_/g; |
490 | if ( $array ) { |
491 | print STDERR ('=> push (@', $pkg, '\'opt_', $opt, ", \"$arg\")\n") |
492 | if $debug; |
493 | eval ('push(@' . $pkg . '\'opt_' . $opt . ", \$arg);"); |
494 | } |
495 | else { |
496 | print STDERR ('=> $', $pkg, '\'opt_', $opt, " = \"$arg\"\n") |
497 | if $debug; |
498 | eval ('$' . $pkg . '\'opt_' . $opt . " = \$arg;"); |
499 | } |
500 | } |
501 | } |
502 | |
503 | if ( $order == $PERMUTE && @ret > 0 ) { |
504 | unshift (@ARGV, @ret); |
505 | } |
506 | return ($error == 0); |
507 | } |
508 | |
509 | ################ Package return ################ |
510 | |
511 | 1; |
512 | |
513 | |