Commit | Line | Data |
404cbe93 |
1 | # GetOpt::Long.pm -- POSIX compatible options parsing |
2 | |
88e49c4e |
3 | # RCS Status : $Id: GetoptLong.pm,v 2.3 1996-04-05 21:03:05+02 jv Exp $ |
404cbe93 |
4 | # Author : Johan Vromans |
5 | # Created On : Tue Sep 11 15:00:12 1990 |
6 | # Last Modified By: Johan Vromans |
88e49c4e |
7 | # Last Modified On: Fri Apr 5 21:02:52 1996 |
8 | # Update Count : 433 |
404cbe93 |
9 | # Status : Released |
10 | |
a0d0e21e |
11 | package Getopt::Long; |
12 | require 5.000; |
13 | require Exporter; |
14 | |
15 | @ISA = qw(Exporter); |
404cbe93 |
16 | @EXPORT = qw(&GetOptions $REQUIRE_ORDER $PERMUTE $RETURN_IN_ORDER); |
88e49c4e |
17 | $VERSION = sprintf("%d.%02d", '$Revision: 2.3 $ ' =~ /(\d+)\.(\d+)/); |
18 | use vars qw($autoabbrev $getopt_compat $ignorecase $bundling $order |
19 | $error $debug $REQUIRE_ORDER $PERMUTE $RETURN_IN_ORDER |
20 | $VERSION $major_version $minor_version); |
404cbe93 |
21 | use strict; |
a0d0e21e |
22 | |
f06db76b |
23 | =head1 NAME |
24 | |
404cbe93 |
25 | GetOptions - extended processing of command line options |
f06db76b |
26 | |
27 | =head1 SYNOPSIS |
28 | |
404cbe93 |
29 | use Getopt::Long; |
30 | $result = GetOptions (...option-descriptions...); |
f06db76b |
31 | |
32 | =head1 DESCRIPTION |
33 | |
34 | The Getopt::Long module implements an extended getopt function called |
404cbe93 |
35 | GetOptions(). This function adheres to the POSIX syntax for command |
36 | line options, with GNU extensions. In general, this means that options |
37 | have long names instead of single letters, and are introduced with a |
88e49c4e |
38 | double dash "--". Support for bundling of command line options, as was |
39 | the case with the more traditional single-letter approach, is provided |
40 | but not enabled by default. For example, the UNIX "ps" command can be |
41 | given the command line "option" |
f06db76b |
42 | |
404cbe93 |
43 | -vax |
f06db76b |
44 | |
404cbe93 |
45 | which means the combination of B<-v>, B<-a> and B<-x>. With the new |
46 | syntax B<--vax> would be a single option, probably indicating a |
47 | computer architecture. |
f06db76b |
48 | |
404cbe93 |
49 | Command line options can be used to set values. These values can be |
50 | specified in one of two ways: |
f06db76b |
51 | |
404cbe93 |
52 | --size 24 |
53 | --size=24 |
f06db76b |
54 | |
404cbe93 |
55 | GetOptions is called with a list of option-descriptions, each of which |
56 | consists of two elements: the option specifier and the option linkage. |
57 | The option specifier defines the name of the option and, optionally, |
58 | the value it can take. The option linkage is usually a reference to a |
59 | variable that will be set when the option is used. For example, the |
60 | following call to GetOptions: |
f06db76b |
61 | |
404cbe93 |
62 | &GetOptions("size=i" => \$offset); |
63 | |
64 | will accept a command line option "size" that must have an integer |
65 | value. With a command line of "--size 24" this will cause the variable |
66 | $offset to get the value 24. |
67 | |
68 | Alternatively, the first argument to GetOptions may be a reference to |
69 | a HASH describing the linkage for the options. The following call is |
70 | equivalent to the example above: |
71 | |
72 | %optctl = ("size" => \$offset); |
73 | &GetOptions(\%optctl, "size=i"); |
74 | |
75 | Linkage may be specified using either of the above methods, or both. |
76 | Linkage specified in the argument list takes precedence over the |
77 | linkage specified in the HASH. |
78 | |
79 | The command line options are taken from array @ARGV. Upon completion |
80 | of GetOptions, @ARGV will contain the rest (i.e. the non-options) of |
81 | the command line. |
82 | |
83 | Each option specifier designates the name of the option, optionally |
84 | followed by an argument specifier. Values for argument specifiers are: |
85 | |
86 | =over 8 |
87 | |
88 | =item <none> |
89 | |
90 | Option does not take an argument. |
91 | The option variable will be set to 1. |
92 | |
93 | =item ! |
94 | |
95 | Option does not take an argument and may be negated, i.e. prefixed by |
96 | "no". E.g. "foo!" will allow B<--foo> (with value 1) and B<-nofoo> |
97 | (with value 0). |
98 | The option variable will be set to 1, or 0 if negated. |
99 | |
100 | =item =s |
101 | |
102 | Option takes a mandatory string argument. |
103 | This string will be assigned to the option variable. |
104 | Note that even if the string argument starts with B<-> or B<-->, it |
105 | will not be considered an option on itself. |
106 | |
107 | =item :s |
108 | |
109 | Option takes an optional string argument. |
110 | This string will be assigned to the option variable. |
111 | If omitted, it will be assigned "" (an empty string). |
112 | If the string argument starts with B<-> or B<-->, it |
113 | will be considered an option on itself. |
114 | |
115 | =item =i |
116 | |
117 | Option takes a mandatory integer argument. |
118 | This value will be assigned to the option variable. |
119 | Note that the value may start with B<-> to indicate a negative |
120 | value. |
121 | |
122 | =item :i |
123 | |
124 | Option takes an optional integer argument. |
125 | This value will be assigned to the option variable. |
126 | If omitted, the value 0 will be assigned. |
127 | Note that the value may start with B<-> to indicate a negative |
128 | value. |
129 | |
130 | =item =f |
131 | |
132 | Option takes a mandatory real number argument. |
133 | This value will be assigned to the option variable. |
134 | Note that the value may start with B<-> to indicate a negative |
135 | value. |
136 | |
137 | =item :f |
138 | |
139 | Option takes an optional real number argument. |
140 | This value will be assigned to the option variable. |
141 | If omitted, the value 0 will be assigned. |
142 | |
143 | =back |
144 | |
145 | A lone dash B<-> is considered an option, the corresponding option |
146 | name is the empty string. |
147 | |
148 | A double dash on itself B<--> signals end of the options list. |
149 | |
150 | =head2 Linkage specification |
151 | |
152 | The linkage specifier is optional. If no linkage is explicitly |
153 | specified but a ref HASH is passed, GetOptions will place the value in |
154 | the HASH. For example: |
155 | |
156 | %optctl = (); |
157 | &GetOptions (\%optctl, "size=i"); |
158 | |
159 | will perform the equivalent of the assignment |
160 | |
161 | $optctl{"size"} = 24; |
162 | |
163 | For array options, a reference to an array is used, e.g.: |
164 | |
165 | %optctl = (); |
166 | &GetOptions (\%optctl, "sizes=i@"); |
167 | |
168 | with command line "-sizes 24 -sizes 48" will perform the equivalent of |
169 | the assignment |
170 | |
171 | $optctl{"sizes"} = [24, 48]; |
172 | |
173 | If no linkage is explicitly specified and no ref HASH is passed, |
174 | GetOptions will put the value in a global variable named after the |
175 | option, prefixed by "opt_". To yield a usable Perl variable, |
176 | characters that are not part of the syntax for variables are |
177 | translated to underscores. For example, "--fpp-struct-return" will set |
178 | the variable $opt_fpp_struct_return. Note that this variable resides |
179 | in the namespace of the calling program, not necessarily B<main>. |
180 | For example: |
181 | |
182 | &GetOptions ("size=i", "sizes=i@"); |
183 | |
184 | with command line "-size 10 -sizes 24 -sizes 48" will perform the |
185 | equivalent of the assignments |
186 | |
187 | $opt_size = 10; |
188 | @opt_sizes = (24, 48); |
189 | |
190 | A lone dash B<-> is considered an option, the corresponding Perl |
191 | identifier is $opt_ . |
192 | |
193 | The linkage specifier can be a reference to a scalar, a reference to |
194 | an array or a reference to a subroutine. |
195 | |
196 | If a REF SCALAR is supplied, the new value is stored in the referenced |
197 | variable. If the option occurs more than once, the previous value is |
198 | overwritten. |
199 | |
200 | If a REF ARRAY is supplied, the new value is appended (pushed) to the |
201 | referenced array. |
202 | |
203 | If a REF CODE is supplied, the referenced subroutine is called with |
204 | two arguments: the option name and the option value. |
205 | The option name is always the true name, not an abbreviation or alias. |
f06db76b |
206 | |
404cbe93 |
207 | =head2 Aliases and abbreviations |
f06db76b |
208 | |
209 | The option name may actually be a list of option names, separated by |
404cbe93 |
210 | "|"s, e.g. "foo|bar|blech=s". In this example, "foo" is the true name |
211 | op this option. If no linkage is specified, options "foo", "bar" and |
212 | "blech" all will set $opt_foo. |
f06db76b |
213 | |
214 | Option names may be abbreviated to uniqueness, depending on |
404cbe93 |
215 | configuration variable $Getopt::Long::autoabbrev. |
f06db76b |
216 | |
404cbe93 |
217 | =head2 Non-option call-back routine |
f06db76b |
218 | |
404cbe93 |
219 | A special option specifier, <>, can be used to designate a subroutine |
220 | to handle non-option arguments. GetOptions will immediately call this |
221 | subroutine for every non-option it encounters in the options list. |
222 | This subroutine gets the name of the non-option passed. |
223 | This feature requires $Getopt::Long::order to have the value $PERMUTE. |
224 | See also the examples. |
f06db76b |
225 | |
404cbe93 |
226 | =head2 Option starters |
f06db76b |
227 | |
404cbe93 |
228 | On the command line, options can start with B<-> (traditional), B<--> |
229 | (POSIX) and B<+> (GNU, now being phased out). The latter is not |
230 | allowed if the environment variable B<POSIXLY_CORRECT> has been |
231 | defined. |
f06db76b |
232 | |
233 | Options that start with "--" may have an argument appended, separated |
234 | with an "=", e.g. "--foo=bar". |
235 | |
404cbe93 |
236 | =head2 Return value |
f06db76b |
237 | |
238 | A return status of 0 (false) indicates that the function detected |
239 | one or more errors. |
240 | |
404cbe93 |
241 | =head1 COMPATIBILITY |
242 | |
243 | Getopt::Long::GetOptions() is the successor of |
244 | B<newgetopt.pl> that came with Perl 4. It is fully upward compatible. |
245 | In fact, the Perl 5 version of newgetopt.pl is just a wrapper around |
246 | the module. |
247 | |
248 | If an "@" sign is appended to the argument specifier, the option is |
249 | treated as an array. Value(s) are not set, but pushed into array |
250 | @opt_name. This only applies if no linkage is supplied. |
251 | |
252 | If configuration variable $Getopt::Long::getopt_compat is set to a |
253 | non-zero value, options that start with "+" may also include their |
254 | arguments, e.g. "+foo=bar". This is for compatiblity with older |
255 | implementations of the GNU "getopt" routine. |
256 | |
257 | If the first argument to GetOptions is a string consisting of only |
258 | non-alphanumeric characters, it is taken to specify the option starter |
259 | characters. Everything starting with one of these characters from the |
260 | starter will be considered an option. B<Using a starter argument is |
261 | strongly deprecated.> |
262 | |
263 | For convenience, option specifiers may have a leading B<-> or B<-->, |
264 | so it is possible to write: |
265 | |
266 | GetOptions qw(-foo=s --bar=i --ar=s); |
267 | |
f06db76b |
268 | =head1 EXAMPLES |
269 | |
404cbe93 |
270 | If the option specifier is "one:i" (i.e. takes an optional integer |
271 | argument), then the following situations are handled: |
f06db76b |
272 | |
273 | -one -two -> $opt_one = '', -two is next option |
274 | -one -2 -> $opt_one = -2 |
275 | |
404cbe93 |
276 | Also, assume specifiers "foo=s" and "bar:s" : |
f06db76b |
277 | |
278 | -bar -xxx -> $opt_bar = '', '-xxx' is next option |
279 | -foo -bar -> $opt_foo = '-bar' |
280 | -foo -- -> $opt_foo = '--' |
281 | |
282 | In GNU or POSIX format, option names and values can be combined: |
283 | |
284 | +foo=blech -> $opt_foo = 'blech' |
285 | --bar= -> $opt_bar = '' |
286 | --bar=-- -> $opt_bar = '--' |
287 | |
404cbe93 |
288 | Example of using variabel references: |
289 | |
290 | $ret = &GetOptions ('foo=s', \$foo, 'bar=i', 'ar=s', \@ar); |
291 | |
292 | With command line options "-foo blech -bar 24 -ar xx -ar yy" |
293 | this will result in: |
294 | |
295 | $bar = 'blech' |
296 | $opt_bar = 24 |
297 | @ar = ('xx','yy') |
298 | |
299 | Example of using the <> option specifier: |
300 | |
301 | @ARGV = qw(-foo 1 bar -foo 2 blech); |
302 | &GetOptions("foo=i", \$myfoo, "<>", \&mysub); |
303 | |
304 | Results: |
305 | |
306 | &mysub("bar") will be called (with $myfoo being 1) |
307 | &mysub("blech") will be called (with $myfoo being 2) |
308 | |
309 | Compare this with: |
310 | |
311 | @ARGV = qw(-foo 1 bar -foo 2 blech); |
312 | &GetOptions("foo=i", \$myfoo); |
313 | |
314 | This will leave the non-options in @ARGV: |
315 | |
316 | $myfoo -> 2 |
317 | @ARGV -> qw(bar blech) |
318 | |
319 | =head1 CONFIGURATION VARIABLES |
320 | |
321 | The following variables can be set to change the default behaviour of |
322 | GetOptions(): |
323 | |
f06db76b |
324 | =over 12 |
325 | |
404cbe93 |
326 | =item $Getopt::Long::autoabbrev |
f06db76b |
327 | |
328 | Allow option names to be abbreviated to uniqueness. |
329 | Default is 1 unless environment variable |
330 | POSIXLY_CORRECT has been set. |
331 | |
404cbe93 |
332 | =item $Getopt::Long::getopt_compat |
f06db76b |
333 | |
334 | Allow '+' to start options. |
335 | Default is 1 unless environment variable |
336 | POSIXLY_CORRECT has been set. |
337 | |
404cbe93 |
338 | =item $Getopt::Long::order |
f06db76b |
339 | |
340 | Whether non-options are allowed to be mixed with |
341 | options. |
342 | Default is $REQUIRE_ORDER if environment variable |
343 | POSIXLY_CORRECT has been set, $PERMUTE otherwise. |
344 | |
404cbe93 |
345 | $PERMUTE means that |
346 | |
347 | -foo arg1 -bar arg2 arg3 |
348 | |
349 | is equivalent to |
350 | |
351 | -foo -bar arg1 arg2 arg3 |
352 | |
353 | If a non-option call-back routine is specified, @ARGV will always be |
354 | empty upon succesful return of GetOptions since all options have been |
355 | processed, except when B<--> is used: |
356 | |
357 | -foo arg1 -bar arg2 -- arg3 |
358 | |
359 | will call the call-back routine for arg1 and arg2, and terminate |
360 | leaving arg2 in @ARGV. |
361 | |
362 | If $Getopt::Long::order is $REQUIRE_ORDER, options processing |
363 | terminates when the first non-option is encountered. |
364 | |
365 | -foo arg1 -bar arg2 arg3 |
366 | |
367 | is equivalent to |
368 | |
369 | -foo -- arg1 -bar arg2 arg3 |
370 | |
371 | $RETURN_IN_ORDER is not supported by GetOptions(). |
372 | |
88e49c4e |
373 | =item $Getopt::Long::bundling |
f06db76b |
374 | |
88e49c4e |
375 | Setting this variable to a non-zero value will allow single-character |
376 | options to be bundled. To distinguish bundles from long option names, |
377 | long options must be introduced with B<--> and single-character |
378 | options (and bundles) with B<->. For example, |
379 | |
380 | ps -vax --vax |
381 | |
382 | would be equivalent to |
383 | |
384 | ps -v -a -x --vax |
385 | |
386 | provided "vax", "v", "a" and "x" have been defined to be valid |
387 | options. |
388 | |
389 | Bundled options can also include a value in the bundle; this value has |
390 | to be the last part of the bundle, e.g. |
391 | |
392 | scale -h24 -w80 |
393 | |
394 | is equivalent to |
395 | |
396 | scale -h 24 -w 80 |
397 | |
398 | B<Note:> Using option bundling can easily lead to unexpected results, |
399 | especially when mixing long options and bundles. Caveat emptor. |
400 | |
401 | =item $Getopt::Long::ignorecase |
402 | |
403 | Ignore case when matching options. Default is 1. When bundling is in |
404 | effect, case is ignored on single-character options only if |
405 | $Getopt::Long::ignorecase is greater than 1. |
f06db76b |
406 | |
404cbe93 |
407 | =item $Getopt::Long::VERSION |
f06db76b |
408 | |
404cbe93 |
409 | The version number of this Getopt::Long implementation in the format |
410 | C<major>.C<minor>. This can be used to have Exporter check the |
411 | version, e.g. |
f06db76b |
412 | |
404cbe93 |
413 | use Getopt::Long 2.00; |
f06db76b |
414 | |
404cbe93 |
415 | You can inspect $Getopt::Long::major_version and |
416 | $Getopt::Long::minor_version for the individual components. |
a0d0e21e |
417 | |
404cbe93 |
418 | =item $Getopt::Long::error |
a0d0e21e |
419 | |
404cbe93 |
420 | Internal error flag. May be incremented from a call-back routine to |
421 | cause options parsing to fail. |
422 | |
423 | =item $Getopt::Long::debug |
424 | |
425 | Enable copious debugging output. Default is 0. |
426 | |
427 | =back |
428 | |
429 | =cut |
a0d0e21e |
430 | |
431 | ################ Introduction ################ |
432 | # |
404cbe93 |
433 | # This program is Copyright 1990,1996 by Johan Vromans. |
a0d0e21e |
434 | # This program is free software; you can redistribute it and/or |
435 | # modify it under the terms of the GNU General Public License |
436 | # as published by the Free Software Foundation; either version 2 |
437 | # of the License, or (at your option) any later version. |
438 | # |
439 | # This program is distributed in the hope that it will be useful, |
440 | # but WITHOUT ANY WARRANTY; without even the implied warranty of |
441 | # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
442 | # GNU General Public License for more details. |
443 | # |
444 | # If you do not have a copy of the GNU General Public License write to |
445 | # the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, |
446 | # MA 02139, USA. |
447 | |
a0d0e21e |
448 | ################ Configuration Section ################ |
449 | |
404cbe93 |
450 | # Values for $order. See GNU getopt.c for details. |
88e49c4e |
451 | ($REQUIRE_ORDER, $PERMUTE, $RETURN_IN_ORDER) = (0..2); |
a0d0e21e |
452 | |
404cbe93 |
453 | my $gen_prefix; # generic prefix (option starters) |
a0d0e21e |
454 | |
404cbe93 |
455 | # Handle POSIX compliancy. |
456 | if ( defined $ENV{"POSIXLY_CORRECT"} ) { |
88e49c4e |
457 | $gen_prefix = "--|-"; |
458 | $autoabbrev = 0; # no automatic abbrev of options |
459 | $bundling = 0; # no bundling of single letter switches |
460 | $getopt_compat = 0; # disallow '+' to start options |
461 | $order = $REQUIRE_ORDER; |
404cbe93 |
462 | } |
463 | else { |
88e49c4e |
464 | $gen_prefix = "--|-|\\+"; |
465 | $autoabbrev = 1; # automatic abbrev of options |
466 | $bundling = 0; # bundling off by default |
467 | $getopt_compat = 1; # allow '+' to start options |
468 | $order = $PERMUTE; |
a0d0e21e |
469 | } |
470 | |
404cbe93 |
471 | # Other configurable settings. |
88e49c4e |
472 | $debug = 0; # for debugging |
473 | $error = 0; # error tally |
474 | $ignorecase = 1; # ignore case when matching options |
475 | ($major_version, $minor_version) = $VERSION =~ /^(\d+)\.(\d+)/; |
404cbe93 |
476 | |
a0d0e21e |
477 | ################ Subroutines ################ |
478 | |
479 | sub GetOptions { |
480 | |
404cbe93 |
481 | my @optionlist = @_; # local copy of the option descriptions |
482 | my $argend = '--'; # option list terminator |
88e49c4e |
483 | my %opctl; # table of arg.specs (long and abbrevs) |
484 | my %bopctl; # table of arg.specs (bundles) |
404cbe93 |
485 | my $pkg = (caller)[0]; # current context |
486 | # Needed if linkage is omitted. |
487 | my %aliases; # alias table |
488 | my @ret = (); # accum for non-options |
489 | my %linkage; # linkage |
490 | my $userlinkage; # user supplied HASH |
404cbe93 |
491 | my $genprefix = $gen_prefix; # so we can call the same module more |
492 | # than once in differing environments |
88e49c4e |
493 | $error = 0; |
404cbe93 |
494 | |
88e49c4e |
495 | print STDERR ('GetOptions $Revision: 2.3 $ ', |
496 | "[GetOpt::Long $Getopt::Long::VERSION] -- ", |
404cbe93 |
497 | "called from package \"$pkg\".\n", |
88e49c4e |
498 | " autoabbrev=$autoabbrev". |
499 | ",bundling=$bundling", |
500 | ",getopt_compat=$getopt_compat", |
404cbe93 |
501 | ",genprefix=\"$genprefix\"", |
88e49c4e |
502 | ",order=$order", |
503 | ",ignorecase=$ignorecase", |
404cbe93 |
504 | ".\n") |
505 | if $debug; |
506 | |
507 | # Check for ref HASH as first argument. |
508 | $userlinkage = undef; |
509 | if ( ref($optionlist[0]) && ref($optionlist[0]) eq 'HASH' ) { |
510 | $userlinkage = shift (@optionlist); |
511 | } |
a0d0e21e |
512 | |
513 | # See if the first element of the optionlist contains option |
514 | # starter characters. |
515 | if ( $optionlist[0] =~ /^\W+$/ ) { |
516 | $genprefix = shift (@optionlist); |
517 | # Turn into regexp. |
518 | $genprefix =~ s/(\W)/\\$1/g; |
519 | $genprefix = "[" . $genprefix . "]"; |
520 | } |
521 | |
522 | # Verify correctness of optionlist. |
523 | %opctl = (); |
88e49c4e |
524 | %bopctl = (); |
404cbe93 |
525 | while ( @optionlist > 0 ) { |
526 | my $opt = shift (@optionlist); |
527 | |
528 | # Strip leading prefix so people can specify "-foo=i" if they like. |
88e49c4e |
529 | $opt = $2 if $opt =~ /^($genprefix)+([\x00-\xff]*)/; |
404cbe93 |
530 | |
531 | if ( $opt eq '<>' ) { |
532 | if ( (defined $userlinkage) |
533 | && !(@optionlist > 0 && ref($optionlist[0])) |
534 | && (exists $userlinkage->{$opt}) |
535 | && ref($userlinkage->{$opt}) ) { |
536 | unshift (@optionlist, $userlinkage->{$opt}); |
537 | } |
538 | unless ( @optionlist > 0 |
539 | && ref($optionlist[0]) && ref($optionlist[0]) eq 'CODE' ) { |
540 | warn ("Option spec <> requires a reference to a subroutine\n"); |
88e49c4e |
541 | $error++; |
404cbe93 |
542 | next; |
543 | } |
544 | $linkage{'<>'} = shift (@optionlist); |
545 | next; |
546 | } |
547 | |
a0d0e21e |
548 | if ( $opt !~ /^(\w+[-\w|]*)?(!|[=:][infse]@?)?$/ ) { |
404cbe93 |
549 | warn ("Error in option spec: \"", $opt, "\"\n"); |
88e49c4e |
550 | $error++; |
a0d0e21e |
551 | next; |
552 | } |
404cbe93 |
553 | my ($o, $c, $a) = ($1, $2); |
88e49c4e |
554 | $c = '' unless defined $c; |
a0d0e21e |
555 | |
556 | if ( ! defined $o ) { |
404cbe93 |
557 | # empty -> '-' option |
88e49c4e |
558 | $opctl{$o = ''} = $c; |
a0d0e21e |
559 | } |
560 | else { |
561 | # Handle alias names |
404cbe93 |
562 | my @o = split (/\|/, $o); |
563 | $o = $o[0]; |
88e49c4e |
564 | $o = lc ($o) |
565 | if $ignorecase > 1 |
566 | || ($ignorecase |
567 | && ($bundling ? length($o) > 1 : 1)); |
568 | |
404cbe93 |
569 | foreach ( @o ) { |
88e49c4e |
570 | if ( $bundling && length($_) == 1 ) { |
571 | $_ = lc ($_) if $ignorecase > 1; |
572 | if ( $c eq '!' ) { |
573 | $opctl{"no$_"} = $c; |
574 | warn ("Ignoring '!' modifier for short option $_\n"); |
575 | $c = ''; |
576 | } |
577 | $bopctl{$_} = $c; |
578 | } |
579 | else { |
580 | $_ = lc ($_) if $ignorecase; |
581 | if ( $c eq '!' ) { |
582 | $opctl{"no$_"} = $c; |
583 | $c = ''; |
584 | } |
585 | $opctl{$_} = $c; |
a0d0e21e |
586 | } |
a0d0e21e |
587 | if ( defined $a ) { |
588 | # Note alias. |
589 | $aliases{$_} = $a; |
590 | } |
591 | else { |
592 | # Set primary name. |
593 | $a = $_; |
594 | } |
595 | } |
596 | } |
404cbe93 |
597 | |
598 | # If no linkage is supplied in the @optionlist, copy it from |
599 | # the userlinkage if available. |
600 | if ( defined $userlinkage ) { |
601 | unless ( @optionlist > 0 && ref($optionlist[0]) ) { |
602 | if ( exists $userlinkage->{$o} && ref($userlinkage->{$o}) ) { |
603 | print STDERR ("=> found userlinkage for \"$o\": ", |
604 | "$userlinkage->{$o}\n") |
605 | if $debug; |
606 | unshift (@optionlist, $userlinkage->{$o}); |
607 | } |
608 | else { |
609 | # Do nothing. Being undefined will be handled later. |
610 | next; |
611 | } |
612 | } |
613 | } |
614 | |
615 | # Copy the linkage. If omitted, link to global variable. |
616 | if ( @optionlist > 0 && ref($optionlist[0]) ) { |
617 | print STDERR ("=> link \"$o\" to $optionlist[0]\n") |
618 | if $debug; |
88e49c4e |
619 | if ( ref($optionlist[0]) =~ /^(SCALAR|ARRAY|CODE)$/ ) { |
404cbe93 |
620 | $linkage{$o} = shift (@optionlist); |
621 | } |
622 | else { |
623 | warn ("Invalid option linkage for \"", $opt, "\"\n"); |
88e49c4e |
624 | $error++; |
404cbe93 |
625 | } |
626 | } |
627 | else { |
628 | # Link to global $opt_XXX variable. |
629 | # Make sure a valid perl identifier results. |
630 | my $ov = $o; |
631 | $ov =~ s/\W/_/g; |
88e49c4e |
632 | if ( defined($c) && $c =~ /@/ ) { |
404cbe93 |
633 | print STDERR ("=> link \"$o\" to \@$pkg","::opt_$ov\n") |
634 | if $debug; |
635 | eval ("\$linkage{\$o} = \\\@".$pkg."::opt_$ov;"); |
636 | } |
637 | else { |
638 | print STDERR ("=> link \"$o\" to \$$pkg","::opt_$ov\n") |
639 | if $debug; |
640 | eval ("\$linkage{\$o} = \\\$".$pkg."::opt_$ov;"); |
641 | } |
642 | } |
a0d0e21e |
643 | } |
a0d0e21e |
644 | |
404cbe93 |
645 | # Bail out if errors found. |
88e49c4e |
646 | return 0 if $error; |
404cbe93 |
647 | |
88e49c4e |
648 | # Sort the possible long option names. |
649 | my @opctl = sort(keys (%opctl)) if $autoabbrev; |
a0d0e21e |
650 | |
88e49c4e |
651 | # Show the options tables if debugging. |
a0d0e21e |
652 | if ( $debug ) { |
404cbe93 |
653 | my ($arrow, $k, $v); |
a0d0e21e |
654 | $arrow = "=> "; |
655 | while ( ($k,$v) = each(%opctl) ) { |
656 | print STDERR ($arrow, "\$opctl{\"$k\"} = \"$v\"\n"); |
657 | $arrow = " "; |
658 | } |
88e49c4e |
659 | $arrow = "=> "; |
660 | while ( ($k,$v) = each(%bopctl) ) { |
661 | print STDERR ($arrow, "\$bopctl{\"$k\"} = \"$v\"\n"); |
662 | $arrow = " "; |
663 | } |
a0d0e21e |
664 | } |
665 | |
404cbe93 |
666 | my $opt; # current option |
88e49c4e |
667 | my $arg; # current option value, if any |
404cbe93 |
668 | my $array; # current option is array typed |
a0d0e21e |
669 | |
404cbe93 |
670 | # Process argument list |
671 | while ( @ARGV > 0 ) { |
a0d0e21e |
672 | |
673 | # >>> See also the continue block <<< |
674 | |
675 | #### Get next argument #### |
676 | |
88e49c4e |
677 | my $starter; # option starter string, e.g. '-' or '--' |
678 | my $rest = undef; # remainder from unbundling |
679 | my $optarg = undef; # value supplied with --opt=value |
680 | |
a0d0e21e |
681 | $opt = shift (@ARGV); |
a0d0e21e |
682 | $arg = undef; |
a0d0e21e |
683 | $array = 0; |
404cbe93 |
684 | print STDERR ("=> option \"", $opt, "\"\n") if $debug; |
a0d0e21e |
685 | |
686 | #### Determine what we have #### |
687 | |
688 | # Double dash is option list terminator. |
689 | if ( $opt eq $argend ) { |
404cbe93 |
690 | # Finish. Push back accumulated arguments and return. |
691 | unshift (@ARGV, @ret) |
88e49c4e |
692 | if $order == $PERMUTE; |
693 | return ($error == 0); |
a0d0e21e |
694 | } |
404cbe93 |
695 | |
88e49c4e |
696 | if ( $opt =~ /^($genprefix)([\x00-\xff]*)/ ) { |
a0d0e21e |
697 | # Looks like an option. |
88e49c4e |
698 | $opt = $2; # option name (w/o prefix) |
699 | $starter = $1; # option starter |
700 | |
701 | # If it is a long option, it may include the value. |
702 | if (($starter eq "--" |
703 | || ($getopt_compat && $starter eq "+")) |
704 | && $opt =~ /^([^=]+)=([\x00-\xff]*)/ ) { |
a0d0e21e |
705 | $opt = $1; |
88e49c4e |
706 | $optarg = $2; |
a0d0e21e |
707 | print STDERR ("=> option \"", $opt, |
404cbe93 |
708 | "\", optarg = \"$optarg\"\n") if $debug; |
a0d0e21e |
709 | } |
710 | |
711 | } |
404cbe93 |
712 | |
713 | # Not an option. Save it if we $PERMUTE and don't have a <>. |
88e49c4e |
714 | elsif ( $order == $PERMUTE ) { |
404cbe93 |
715 | # Try non-options call-back. |
716 | my $cb; |
717 | if ( (defined ($cb = $linkage{'<>'})) ) { |
718 | &$cb($opt); |
719 | } |
720 | else { |
88e49c4e |
721 | print STDERR ("=> saving \"$opt\" ", |
722 | "(not an option, may permute)\n") if $debug; |
404cbe93 |
723 | push (@ret, $opt); |
724 | } |
a0d0e21e |
725 | next; |
726 | } |
404cbe93 |
727 | |
a0d0e21e |
728 | # ...otherwise, terminate. |
729 | else { |
404cbe93 |
730 | # Push this one back and exit. |
a0d0e21e |
731 | unshift (@ARGV, $opt); |
88e49c4e |
732 | return ($error == 0); |
a0d0e21e |
733 | } |
734 | |
735 | #### Look it up ### |
736 | |
88e49c4e |
737 | my $tryopt = $opt; # option to try |
738 | my $optbl = \%opctl; # table to look it up (long names) |
739 | |
740 | if ( $bundling && $starter eq '-' ) { |
741 | # Unbundle single letter option. |
742 | $rest = substr ($tryopt, 1); |
743 | $tryopt = substr ($tryopt, 0, 1); |
744 | $tryopt = lc ($tryopt) if $ignorecase > 1; |
745 | print STDERR ("=> $starter$tryopt unbundled from ", |
746 | "$starter$tryopt$rest\n") if $debug; |
747 | $rest = undef unless $rest ne ''; |
748 | $optbl = \%bopctl; # look it up in the short names table |
749 | } |
750 | |
751 | # Try auto-abbreviation. |
752 | elsif ( $autoabbrev ) { |
753 | # Downcase if allowed. |
754 | $tryopt = $opt = lc ($opt) if $ignorecase; |
a0d0e21e |
755 | # Turn option name into pattern. |
88e49c4e |
756 | my $pat = quotemeta ($opt); |
a0d0e21e |
757 | # Look up in option names. |
404cbe93 |
758 | my @hits = grep (/^$pat/, @opctl); |
88e49c4e |
759 | print STDERR ("=> ", scalar(@hits), " hits (@hits) with \"$pat\" ", |
760 | "out of ", scalar(@opctl), "\n") if $debug; |
a0d0e21e |
761 | |
762 | # Check for ambiguous results. |
763 | unless ( (@hits <= 1) || (grep ($_ eq $opt, @hits) == 1) ) { |
764 | print STDERR ("Option ", $opt, " is ambiguous (", |
765 | join(", ", @hits), ")\n"); |
88e49c4e |
766 | $error++; |
a0d0e21e |
767 | next; |
768 | } |
769 | |
770 | # Complete the option name, if appropriate. |
771 | if ( @hits == 1 && $hits[0] ne $opt ) { |
772 | $tryopt = $hits[0]; |
773 | print STDERR ("=> option \"$opt\" -> \"$tryopt\"\n") |
774 | if $debug; |
775 | } |
776 | } |
777 | |
88e49c4e |
778 | # Check validity by fetching the info. |
779 | my $type = $optbl->{$tryopt}; |
780 | unless ( defined $type ) { |
781 | warn ("Unknown option: ", $opt, "\n"); |
782 | $error++; |
a0d0e21e |
783 | next; |
784 | } |
88e49c4e |
785 | # Apparently valid. |
a0d0e21e |
786 | $opt = $tryopt; |
787 | print STDERR ("=> found \"$type\" for ", $opt, "\n") if $debug; |
788 | |
789 | #### Determine argument status #### |
790 | |
791 | # If it is an option w/o argument, we're almost finished with it. |
792 | if ( $type eq '' || $type eq '!' ) { |
793 | if ( defined $optarg ) { |
794 | print STDERR ("Option ", $opt, " does not take an argument\n"); |
88e49c4e |
795 | $error++; |
a0d0e21e |
796 | } |
797 | elsif ( $type eq '' ) { |
798 | $arg = 1; # supply explicit value |
799 | } |
800 | else { |
801 | substr ($opt, 0, 2) = ''; # strip NO prefix |
802 | $arg = 0; # supply explicit value |
803 | } |
88e49c4e |
804 | # When unbundling, unshift the rest with the starter. |
805 | unshift (@ARGV, $starter.$rest) if defined $rest; |
a0d0e21e |
806 | next; |
807 | } |
808 | |
809 | # Get mandatory status and type info. |
404cbe93 |
810 | my $mand; |
a0d0e21e |
811 | ($mand, $type, $array) = $type =~ /^(.)(.)(@?)$/; |
812 | |
813 | # Check if there is an option argument available. |
88e49c4e |
814 | if ( defined $optarg ? ($optarg eq '') |
815 | : !(defined $rest || @ARGV > 0) ) { |
a0d0e21e |
816 | # Complain if this option needs an argument. |
817 | if ( $mand eq "=" ) { |
818 | print STDERR ("Option ", $opt, " requires an argument\n"); |
88e49c4e |
819 | $error++; |
a0d0e21e |
820 | } |
821 | if ( $mand eq ":" ) { |
822 | $arg = $type eq "s" ? '' : 0; |
823 | } |
824 | next; |
825 | } |
826 | |
827 | # Get (possibly optional) argument. |
88e49c4e |
828 | $arg = (defined $rest ? $rest |
829 | : (defined $optarg ? $optarg : shift (@ARGV))); |
a0d0e21e |
830 | |
831 | #### Check if the argument is valid for this option #### |
832 | |
833 | if ( $type eq "s" ) { # string |
834 | # A mandatory string takes anything. |
835 | next if $mand eq "="; |
836 | |
837 | # An optional string takes almost anything. |
88e49c4e |
838 | next if defined $optarg || defined $rest; |
839 | next if $arg eq "-"; # ?? |
a0d0e21e |
840 | |
841 | # Check for option or option list terminator. |
842 | if ($arg eq $argend || |
843 | $arg =~ /^$genprefix.+/) { |
844 | # Push back. |
845 | unshift (@ARGV, $arg); |
846 | # Supply empty value. |
847 | $arg = ''; |
848 | } |
849 | next; |
850 | } |
851 | |
852 | if ( $type eq "n" || $type eq "i" ) { # numeric/integer |
853 | if ( $arg !~ /^-?[0-9]+$/ ) { |
854 | if ( defined $optarg || $mand eq "=" ) { |
855 | print STDERR ("Value \"", $arg, "\" invalid for option ", |
856 | $opt, " (number expected)\n"); |
88e49c4e |
857 | $error++; |
a0d0e21e |
858 | undef $arg; # don't assign it |
88e49c4e |
859 | # Push back. |
860 | unshift (@ARGV, $starter.$rest) if defined $rest; |
a0d0e21e |
861 | } |
862 | else { |
863 | # Push back. |
88e49c4e |
864 | unshift (@ARGV, defined $rest ? $starter.$rest : $arg); |
a0d0e21e |
865 | # Supply default value. |
866 | $arg = 0; |
867 | } |
868 | } |
869 | next; |
870 | } |
871 | |
872 | if ( $type eq "f" ) { # fixed real number, int is also ok |
873 | if ( $arg !~ /^-?[0-9.]+$/ ) { |
874 | if ( defined $optarg || $mand eq "=" ) { |
875 | print STDERR ("Value \"", $arg, "\" invalid for option ", |
876 | $opt, " (real number expected)\n"); |
88e49c4e |
877 | $error++; |
a0d0e21e |
878 | undef $arg; # don't assign it |
88e49c4e |
879 | # Push back. |
880 | unshift (@ARGV, $starter.$rest) if defined $rest; |
a0d0e21e |
881 | } |
882 | else { |
883 | # Push back. |
88e49c4e |
884 | unshift (@ARGV, defined $rest ? $starter.$rest : $arg); |
a0d0e21e |
885 | # Supply default value. |
886 | $arg = 0.0; |
887 | } |
888 | } |
889 | next; |
890 | } |
891 | |
404cbe93 |
892 | die ("GetOpt::Long internal error (Can't happen)\n"); |
a0d0e21e |
893 | } |
894 | |
895 | continue { |
896 | if ( defined $arg ) { |
897 | $opt = $aliases{$opt} if defined $aliases{$opt}; |
404cbe93 |
898 | |
899 | if ( defined $linkage{$opt} ) { |
900 | print STDERR ("=> ref(\$L{$opt}) -> ", |
901 | ref($linkage{$opt}), "\n") if $debug; |
902 | |
903 | if ( ref($linkage{$opt}) eq 'SCALAR' ) { |
904 | print STDERR ("=> \$\$L{$opt} = \"$arg\"\n") if $debug; |
905 | ${$linkage{$opt}} = $arg; |
906 | } |
907 | elsif ( ref($linkage{$opt}) eq 'ARRAY' ) { |
908 | print STDERR ("=> push(\@{\$L{$opt}, \"$arg\")\n") |
909 | if $debug; |
910 | push (@{$linkage{$opt}}, $arg); |
911 | } |
912 | elsif ( ref($linkage{$opt}) eq 'CODE' ) { |
913 | print STDERR ("=> &L{$opt}(\"$opt\", \"$arg\")\n") |
914 | if $debug; |
915 | &{$linkage{$opt}}($opt, $arg); |
916 | } |
917 | else { |
918 | print STDERR ("Invalid REF type \"", ref($linkage{$opt}), |
919 | "\" in linkage\n"); |
920 | die ("Getopt::Long -- internal error!\n"); |
921 | } |
922 | } |
923 | # No entry in linkage means entry in userlinkage. |
924 | elsif ( $array ) { |
925 | if ( defined $userlinkage->{$opt} ) { |
926 | print STDERR ("=> push(\@{\$L{$opt}}, \"$arg\")\n") |
927 | if $debug; |
928 | push (@{$userlinkage->{$opt}}, $arg); |
929 | } |
930 | else { |
931 | print STDERR ("=>\$L{$opt} = [\"$arg\"]\n") |
932 | if $debug; |
933 | $userlinkage->{$opt} = [$arg]; |
934 | } |
a0d0e21e |
935 | } |
936 | else { |
404cbe93 |
937 | print STDERR ("=>\$L{$opt} = \"$arg\"\n") if $debug; |
938 | $userlinkage->{$opt} = $arg; |
a0d0e21e |
939 | } |
940 | } |
941 | } |
942 | |
404cbe93 |
943 | # Finish. |
88e49c4e |
944 | if ( $order == $PERMUTE ) { |
404cbe93 |
945 | # Push back accumulated arguments |
88e49c4e |
946 | print STDERR ("=> restoring \"", join('" "', @ret), "\"\n") |
947 | if $debug && @ret > 0; |
404cbe93 |
948 | unshift (@ARGV, @ret) if @ret > 0; |
a0d0e21e |
949 | } |
404cbe93 |
950 | |
88e49c4e |
951 | return ($error == 0); |
a0d0e21e |
952 | } |
953 | |
954 | ################ Package return ################ |
955 | |
88e49c4e |
956 | 1; |