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