This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Fix variable export and threading configuration for AIX:
[perl5.git] / lib / Getopt / Long.pm
CommitLineData
a11f5414 1# GetOpt::Long.pm -- Universal options parsing
404cbe93 2
a11f5414
JV
3package Getopt::Long;
4
82032852 5# RCS Status : $Id: GetoptLong.pm,v 2.11 1997-09-17 12:23:51+02 jv Exp $
404cbe93
PP
6# Author : Johan Vromans
7# Created On : Tue Sep 11 15:00:12 1990
8# Last Modified By: Johan Vromans
82032852
JV
9# Last Modified On: Wed Sep 17 12:20:10 1997
10# Update Count : 608
404cbe93
PP
11# Status : Released
12
f06db76b
AD
13=head1 NAME
14
404cbe93 15GetOptions - extended processing of command line options
f06db76b
AD
16
17=head1 SYNOPSIS
18
404cbe93
PP
19 use Getopt::Long;
20 $result = GetOptions (...option-descriptions...);
f06db76b
AD
21
22=head1 DESCRIPTION
23
24The Getopt::Long module implements an extended getopt function called
404cbe93
PP
25GetOptions(). This function adheres to the POSIX syntax for command
26line options, with GNU extensions. In general, this means that options
27have long names instead of single letters, and are introduced with a
88e49c4e
PP
28double dash "--". Support for bundling of command line options, as was
29the case with the more traditional single-letter approach, is provided
30but not enabled by default. For example, the UNIX "ps" command can be
31given the command line "option"
f06db76b 32
404cbe93 33 -vax
f06db76b 34
404cbe93
PP
35which means the combination of B<-v>, B<-a> and B<-x>. With the new
36syntax B<--vax> would be a single option, probably indicating a
37computer architecture.
f06db76b 38
404cbe93
PP
39Command line options can be used to set values. These values can be
40specified in one of two ways:
f06db76b 41
404cbe93
PP
42 --size 24
43 --size=24
f06db76b 44
404cbe93
PP
45GetOptions is called with a list of option-descriptions, each of which
46consists of two elements: the option specifier and the option linkage.
47The option specifier defines the name of the option and, optionally,
48the value it can take. The option linkage is usually a reference to a
49variable that will be set when the option is used. For example, the
50following call to GetOptions:
f06db76b 51
02a7d5cb 52 GetOptions("size=i" => \$offset);
404cbe93
PP
53
54will accept a command line option "size" that must have an integer
55value. With a command line of "--size 24" this will cause the variable
56$offset to get the value 24.
57
58Alternatively, the first argument to GetOptions may be a reference to
82032852
JV
59a HASH describing the linkage for the options, or an object whose
60class is based on a HASH. The following call is equivalent to the
61example above:
404cbe93
PP
62
63 %optctl = ("size" => \$offset);
02a7d5cb 64 GetOptions(\%optctl, "size=i");
404cbe93
PP
65
66Linkage may be specified using either of the above methods, or both.
67Linkage specified in the argument list takes precedence over the
68linkage specified in the HASH.
69
70The command line options are taken from array @ARGV. Upon completion
71of GetOptions, @ARGV will contain the rest (i.e. the non-options) of
72the command line.
16c18a90 73
404cbe93
PP
74Each option specifier designates the name of the option, optionally
75followed by an argument specifier. Values for argument specifiers are:
76
77=over 8
78
5f05dabc 79=item E<lt>noneE<gt>
404cbe93
PP
80
81Option does not take an argument.
82The option variable will be set to 1.
83
84=item !
85
86Option does not take an argument and may be negated, i.e. prefixed by
87"no". E.g. "foo!" will allow B<--foo> (with value 1) and B<-nofoo>
88(with value 0).
89The option variable will be set to 1, or 0 if negated.
90
91=item =s
92
93Option takes a mandatory string argument.
94This string will be assigned to the option variable.
95Note that even if the string argument starts with B<-> or B<-->, it
96will not be considered an option on itself.
97
98=item :s
99
100Option takes an optional string argument.
101This string will be assigned to the option variable.
102If omitted, it will be assigned "" (an empty string).
103If the string argument starts with B<-> or B<-->, it
104will be considered an option on itself.
105
106=item =i
107
108Option takes a mandatory integer argument.
109This value will be assigned to the option variable.
110Note that the value may start with B<-> to indicate a negative
111value.
112
113=item :i
114
115Option takes an optional integer argument.
116This value will be assigned to the option variable.
117If omitted, the value 0 will be assigned.
118Note that the value may start with B<-> to indicate a negative
119value.
120
121=item =f
122
123Option takes a mandatory real number argument.
124This value will be assigned to the option variable.
125Note that the value may start with B<-> to indicate a negative
126value.
127
128=item :f
129
130Option takes an optional real number argument.
131This value will be assigned to the option variable.
132If omitted, the value 0 will be assigned.
133
134=back
135
136A lone dash B<-> is considered an option, the corresponding option
137name is the empty string.
138
139A double dash on itself B<--> signals end of the options list.
140
141=head2 Linkage specification
142
143The linkage specifier is optional. If no linkage is explicitly
144specified but a ref HASH is passed, GetOptions will place the value in
145the HASH. For example:
146
147 %optctl = ();
02a7d5cb 148 GetOptions (\%optctl, "size=i");
404cbe93
PP
149
150will perform the equivalent of the assignment
151
152 $optctl{"size"} = 24;
153
154For array options, a reference to an array is used, e.g.:
155
156 %optctl = ();
02a7d5cb 157 GetOptions (\%optctl, "sizes=i@");
404cbe93
PP
158
159with command line "-sizes 24 -sizes 48" will perform the equivalent of
160the assignment
161
162 $optctl{"sizes"} = [24, 48];
163
381319f7
PP
164For hash options (an option whose argument looks like "name=value"),
165a reference to a hash is used, e.g.:
166
167 %optctl = ();
02a7d5cb 168 GetOptions (\%optctl, "define=s%");
381319f7
PP
169
170with command line "--define foo=hello --define bar=world" will perform the
171equivalent of the assignment
172
173 $optctl{"define"} = {foo=>'hello', bar=>'world')
174
404cbe93
PP
175If no linkage is explicitly specified and no ref HASH is passed,
176GetOptions will put the value in a global variable named after the
177option, prefixed by "opt_". To yield a usable Perl variable,
178characters that are not part of the syntax for variables are
179translated to underscores. For example, "--fpp-struct-return" will set
180the variable $opt_fpp_struct_return. Note that this variable resides
181in the namespace of the calling program, not necessarily B<main>.
182For example:
183
02a7d5cb 184 GetOptions ("size=i", "sizes=i@");
404cbe93
PP
185
186with command line "-size 10 -sizes 24 -sizes 48" will perform the
187equivalent of the assignments
188
189 $opt_size = 10;
190 @opt_sizes = (24, 48);
191
192A lone dash B<-> is considered an option, the corresponding Perl
193identifier is $opt_ .
194
195The linkage specifier can be a reference to a scalar, a reference to
381319f7 196an array, a reference to a hash or a reference to a subroutine.
404cbe93
PP
197
198If a REF SCALAR is supplied, the new value is stored in the referenced
199variable. If the option occurs more than once, the previous value is
200overwritten.
201
202If a REF ARRAY is supplied, the new value is appended (pushed) to the
203referenced array.
204
381319f7
PP
205If a REF HASH is supplied, the option value should look like "key" or
206"key=value" (if the "=value" is omitted then a value of 1 is implied).
207In this case, the element of the referenced hash with the key "key"
208is assigned "value".
209
404cbe93
PP
210If a REF CODE is supplied, the referenced subroutine is called with
211two arguments: the option name and the option value.
212The option name is always the true name, not an abbreviation or alias.
f06db76b 213
404cbe93 214=head2 Aliases and abbreviations
f06db76b
AD
215
216The option name may actually be a list of option names, separated by
404cbe93 217"|"s, e.g. "foo|bar|blech=s". In this example, "foo" is the true name
5f05dabc 218of this option. If no linkage is specified, options "foo", "bar" and
404cbe93 219"blech" all will set $opt_foo.
f06db76b
AD
220
221Option names may be abbreviated to uniqueness, depending on
a11f5414 222configuration option B<auto_abbrev>.
f06db76b 223
404cbe93 224=head2 Non-option call-back routine
f06db76b 225
5f05dabc 226A special option specifier, E<lt>E<gt>, can be used to designate a subroutine
404cbe93
PP
227to handle non-option arguments. GetOptions will immediately call this
228subroutine for every non-option it encounters in the options list.
229This subroutine gets the name of the non-option passed.
a11f5414
JV
230This feature requires configuration option B<permute>, see section
231CONFIGURATION OPTIONS.
232
404cbe93 233See also the examples.
f06db76b 234
404cbe93 235=head2 Option starters
f06db76b 236
404cbe93
PP
237On the command line, options can start with B<-> (traditional), B<-->
238(POSIX) and B<+> (GNU, now being phased out). The latter is not
239allowed if the environment variable B<POSIXLY_CORRECT> has been
240defined.
f06db76b
AD
241
242Options that start with "--" may have an argument appended, separated
243with an "=", e.g. "--foo=bar".
244
404cbe93 245=head2 Return value
f06db76b
AD
246
247A return status of 0 (false) indicates that the function detected
248one or more errors.
249
404cbe93
PP
250=head1 COMPATIBILITY
251
252Getopt::Long::GetOptions() is the successor of
253B<newgetopt.pl> that came with Perl 4. It is fully upward compatible.
254In fact, the Perl 5 version of newgetopt.pl is just a wrapper around
255the module.
256
257If an "@" sign is appended to the argument specifier, the option is
381319f7
PP
258treated as an array. Value(s) are not set, but pushed into array
259@opt_name. If explicit linkage is supplied, this must be a reference
260to an ARRAY.
261
262If an "%" sign is appended to the argument specifier, the option is
263treated as a hash. Value(s) of the form "name=value" are set by
264setting the element of the hash %opt_name with key "name" to "value"
265(if the "=value" portion is omitted it defaults to 1). If explicit
266linkage is supplied, this must be a reference to a HASH.
404cbe93 267
a11f5414
JV
268If configuration option B<getopt_compat> is set (see section
269CONFIGURATION OPTIONS), options that start with "+" or "-" may also
270include their arguments, e.g. "+foo=bar". This is for compatiblity
271with older implementations of the GNU "getopt" routine.
404cbe93
PP
272
273If the first argument to GetOptions is a string consisting of only
274non-alphanumeric characters, it is taken to specify the option starter
275characters. Everything starting with one of these characters from the
276starter will be considered an option. B<Using a starter argument is
277strongly deprecated.>
278
279For convenience, option specifiers may have a leading B<-> or B<-->,
280so it is possible to write:
281
282 GetOptions qw(-foo=s --bar=i --ar=s);
283
f06db76b
AD
284=head1 EXAMPLES
285
404cbe93
PP
286If the option specifier is "one:i" (i.e. takes an optional integer
287argument), then the following situations are handled:
f06db76b
AD
288
289 -one -two -> $opt_one = '', -two is next option
290 -one -2 -> $opt_one = -2
291
404cbe93 292Also, assume specifiers "foo=s" and "bar:s" :
f06db76b
AD
293
294 -bar -xxx -> $opt_bar = '', '-xxx' is next option
295 -foo -bar -> $opt_foo = '-bar'
296 -foo -- -> $opt_foo = '--'
297
298In GNU or POSIX format, option names and values can be combined:
299
300 +foo=blech -> $opt_foo = 'blech'
301 --bar= -> $opt_bar = ''
302 --bar=-- -> $opt_bar = '--'
303
1fef88e7 304Example of using variable references:
404cbe93 305
02a7d5cb 306 $ret = GetOptions ('foo=s', \$foo, 'bar=i', 'ar=s', \@ar);
404cbe93
PP
307
308With command line options "-foo blech -bar 24 -ar xx -ar yy"
309this will result in:
310
5f05dabc 311 $foo = 'blech'
404cbe93
PP
312 $opt_bar = 24
313 @ar = ('xx','yy')
314
5f05dabc 315Example of using the E<lt>E<gt> option specifier:
404cbe93
PP
316
317 @ARGV = qw(-foo 1 bar -foo 2 blech);
02a7d5cb 318 GetOptions("foo=i", \$myfoo, "<>", \&mysub);
404cbe93
PP
319
320Results:
321
02a7d5cb
JV
322 mysub("bar") will be called (with $myfoo being 1)
323 mysub("blech") will be called (with $myfoo being 2)
404cbe93
PP
324
325Compare this with:
326
327 @ARGV = qw(-foo 1 bar -foo 2 blech);
02a7d5cb 328 GetOptions("foo=i", \$myfoo);
404cbe93
PP
329
330This will leave the non-options in @ARGV:
331
332 $myfoo -> 2
333 @ARGV -> qw(bar blech)
334
a11f5414
JV
335=head1 CONFIGURATION OPTIONS
336
337B<GetOptions> can be configured by calling subroutine
338B<Getopt::Long::config>. This subroutine takes a list of quoted
339strings, each specifying a configuration option to be set, e.g.
340B<ignore_case>. Options can be reset by prefixing with B<no_>, e.g.
341B<no_ignore_case>. Case does not matter. Multiple calls to B<config>
342are possible.
404cbe93 343
a11f5414
JV
344Previous versions of Getopt::Long used variables for the purpose of
345configuring. Although manipulating these variables still work, it
346is strongly encouraged to use the new B<config> routine. Besides, it
347is much easier.
348
349The following options are available:
404cbe93 350
f06db76b
AD
351=over 12
352
a11f5414
JV
353=item default
354
355This option causes all configuration options to be reset to their
356default values.
357
358=item auto_abbrev
f06db76b
AD
359
360Allow option names to be abbreviated to uniqueness.
a11f5414
JV
361Default is set unless environment variable
362POSIXLY_CORRECT has been set, in which case B<auto_abbrev> is reset.
f06db76b 363
a11f5414 364=item getopt_compat
f06db76b
AD
365
366Allow '+' to start options.
a11f5414
JV
367Default is set unless environment variable
368POSIXLY_CORRECT has been set, in which case B<getopt_compat> is reset.
369
370=item require_order
371
372Whether non-options are allowed to be mixed with
373options.
374Default is set unless environment variable
375POSIXLY_CORRECT has been set, in which case b<require_order> is reset.
f06db76b 376
a11f5414
JV
377See also B<permute>, which is the opposite of B<require_order>.
378
379=item permute
f06db76b
AD
380
381Whether non-options are allowed to be mixed with
382options.
a11f5414
JV
383Default is set unless environment variable
384POSIXLY_CORRECT has been set, in which case B<permute> is reset.
385Note that B<permute> is the opposite of B<require_order>.
f06db76b 386
a11f5414 387If B<permute> is set, this means that
404cbe93
PP
388
389 -foo arg1 -bar arg2 arg3
390
391is equivalent to
392
393 -foo -bar arg1 arg2 arg3
394
395If a non-option call-back routine is specified, @ARGV will always be
396empty upon succesful return of GetOptions since all options have been
397processed, except when B<--> is used:
398
399 -foo arg1 -bar arg2 -- arg3
400
401will call the call-back routine for arg1 and arg2, and terminate
402leaving arg2 in @ARGV.
403
a11f5414 404If B<require_order> is set, options processing
404cbe93
PP
405terminates when the first non-option is encountered.
406
407 -foo arg1 -bar arg2 arg3
408
409is equivalent to
410
411 -foo -- arg1 -bar arg2 arg3
412
a11f5414 413=item bundling (default: reset)
f06db76b 414
88e49c4e
PP
415Setting this variable to a non-zero value will allow single-character
416options to be bundled. To distinguish bundles from long option names,
417long options must be introduced with B<--> and single-character
418options (and bundles) with B<->. For example,
419
420 ps -vax --vax
421
422would be equivalent to
423
424 ps -v -a -x --vax
425
426provided "vax", "v", "a" and "x" have been defined to be valid
427options.
428
429Bundled options can also include a value in the bundle; this value has
430to be the last part of the bundle, e.g.
431
432 scale -h24 -w80
433
434is equivalent to
435
436 scale -h 24 -w 80
437
a11f5414
JV
438Note: resetting B<bundling> also resets B<bundling_override>.
439
440=item bundling_override (default: reset)
441
442If B<bundling_override> is set, bundling is enabled as with
443B<bundling> but now long option names override option bundles. In the
444above example, B<-vax> would be interpreted as the option "vax", not
445the bundle "v", "a", "x".
446
447Note: resetting B<bundling_override> also resets B<bundling>.
448
88e49c4e
PP
449B<Note:> Using option bundling can easily lead to unexpected results,
450especially when mixing long options and bundles. Caveat emptor.
451
a11f5414
JV
452=item ignore_case (default: set)
453
454If set, case is ignored when matching options.
455
456Note: resetting B<ignore_case> also resets B<ignore_case_always>.
457
458=item ignore_case_always (default: reset)
459
460When bundling is in effect, case is ignored on single-character
461options also.
88e49c4e 462
a11f5414 463Note: resetting B<ignore_case_always> also resets B<ignore_case>.
f06db76b 464
a11f5414 465=item pass_through (default: reset)
381319f7
PP
466
467Unknown options are passed through in @ARGV instead of being flagged
468as errors. This makes it possible to write wrapper scripts that
469process only part of the user supplied options, and passes the
470remaining options to some other program.
471
a11f5414
JV
472This can be very confusing, especially when B<permute> is also set.
473
474=item debug (default: reset)
475
476Enable copious debugging output.
477
478=back
479
480=head1 OTHER USEFUL VARIABLES
481
482=over 12
381319f7 483
404cbe93 484=item $Getopt::Long::VERSION
f06db76b 485
404cbe93
PP
486The version number of this Getopt::Long implementation in the format
487C<major>.C<minor>. This can be used to have Exporter check the
488version, e.g.
f06db76b 489
a11f5414 490 use Getopt::Long 3.00;
f06db76b 491
404cbe93
PP
492You can inspect $Getopt::Long::major_version and
493$Getopt::Long::minor_version for the individual components.
a0d0e21e 494
404cbe93 495=item $Getopt::Long::error
a0d0e21e 496
404cbe93
PP
497Internal error flag. May be incremented from a call-back routine to
498cause options parsing to fail.
499
404cbe93
PP
500=back
501
502=cut
a0d0e21e 503
a11f5414
JV
504################ Copyright ################
505
506# This program is Copyright 1990,1997 by Johan Vromans.
a0d0e21e
LW
507# This program is free software; you can redistribute it and/or
508# modify it under the terms of the GNU General Public License
509# as published by the Free Software Foundation; either version 2
510# of the License, or (at your option) any later version.
511#
512# This program is distributed in the hope that it will be useful,
513# but WITHOUT ANY WARRANTY; without even the implied warranty of
514# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
515# GNU General Public License for more details.
516#
517# If you do not have a copy of the GNU General Public License write to
518# the Free Software Foundation, Inc., 675 Mass Ave, Cambridge,
519# MA 02139, USA.
520
a11f5414 521################ Module Preamble ################
a0d0e21e 522
a11f5414 523use strict;
a0d0e21e 524
a11f5414 525BEGIN {
24a13b90 526 require 5.003;
a11f5414
JV
527 use Exporter ();
528 use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
82032852 529 $VERSION = sprintf("%d.%02d", q$Revision: 2.11 $ =~ /(\d+)\.(\d+)/);
a0d0e21e 530
a11f5414
JV
531 @ISA = qw(Exporter);
532 @EXPORT = qw(&GetOptions $REQUIRE_ORDER $PERMUTE $RETURN_IN_ORDER);
533 %EXPORT_TAGS = ();
534 @EXPORT_OK = qw();
a0d0e21e
LW
535}
536
a11f5414
JV
537use vars @EXPORT, @EXPORT_OK;
538# User visible variables.
68dc0745 539use vars qw($error $debug $major_version $minor_version);
a11f5414
JV
540# Deprecated visible variables.
541use vars qw($autoabbrev $getopt_compat $ignorecase $bundling $order
542 $passthrough);
543
544################ Local Variables ################
404cbe93 545
a11f5414
JV
546my $gen_prefix; # generic prefix (option starters)
547my $argend; # option list terminator
548my %opctl; # table of arg.specs (long and abbrevs)
549my %bopctl; # table of arg.specs (bundles)
550my @opctl; # the possible long option names
551my $pkg; # current context. Needed if no linkage.
552my %aliases; # alias table
553my $genprefix; # so we can call the same module more
554my $opt; # current option
555my $arg; # current option value, if any
556my $array; # current option is array typed
557my $hash; # current option is hash typed
558my $key; # hash key for a hash option
559 # than once in differing environments
560my $config_defaults; # set config defaults
561my $find_option; # helper routine
381319f7 562
a0d0e21e
LW
563################ Subroutines ################
564
565sub GetOptions {
566
404cbe93 567 my @optionlist = @_; # local copy of the option descriptions
a11f5414
JV
568 $argend = '--'; # option list terminator
569 %opctl = (); # table of arg.specs (long and abbrevs)
570 %bopctl = (); # table of arg.specs (bundles)
571 $pkg = (caller)[0]; # current context
404cbe93 572 # Needed if linkage is omitted.
a11f5414 573 %aliases= (); # alias table
404cbe93
PP
574 my @ret = (); # accum for non-options
575 my %linkage; # linkage
576 my $userlinkage; # user supplied HASH
a11f5414 577 $genprefix = $gen_prefix; # so we can call the same module many times
88e49c4e 578 $error = 0;
404cbe93 579
82032852 580 print STDERR ('GetOptions $Revision: 2.11 $ ',
88e49c4e 581 "[GetOpt::Long $Getopt::Long::VERSION] -- ",
404cbe93 582 "called from package \"$pkg\".\n",
381319f7 583 " (@ARGV)\n",
88e49c4e
PP
584 " autoabbrev=$autoabbrev".
585 ",bundling=$bundling",
586 ",getopt_compat=$getopt_compat",
88e49c4e 587 ",order=$order",
381319f7
PP
588 ",\n ignorecase=$ignorecase",
589 ",passthrough=$passthrough",
590 ",genprefix=\"$genprefix\"",
404cbe93
PP
591 ".\n")
592 if $debug;
593
594 # Check for ref HASH as first argument.
82032852
JV
595 # First argument may be an object. It's OK to use this as long
596 # as it is really a hash underneath.
404cbe93 597 $userlinkage = undef;
82032852
JV
598 if ( ref($optionlist[0]) and
599 "$optionlist[0]" =~ /^(?:.*\=)?HASH\([^\(]*\)$/ ) {
404cbe93 600 $userlinkage = shift (@optionlist);
82032852 601 print STDERR ("=> user linkage: $userlinkage\n") if $debug;
404cbe93 602 }
a0d0e21e
LW
603
604 # See if the first element of the optionlist contains option
605 # starter characters.
606 if ( $optionlist[0] =~ /^\W+$/ ) {
607 $genprefix = shift (@optionlist);
608 # Turn into regexp.
609 $genprefix =~ s/(\W)/\\$1/g;
610 $genprefix = "[" . $genprefix . "]";
611 }
612
613 # Verify correctness of optionlist.
614 %opctl = ();
88e49c4e 615 %bopctl = ();
404cbe93
PP
616 while ( @optionlist > 0 ) {
617 my $opt = shift (@optionlist);
618
381319f7 619 # Strip leading prefix so people can specify "--foo=i" if they like.
a11f5414 620 $opt = $' if $opt =~ /^($genprefix)+/;
404cbe93
PP
621
622 if ( $opt eq '<>' ) {
623 if ( (defined $userlinkage)
624 && !(@optionlist > 0 && ref($optionlist[0]))
625 && (exists $userlinkage->{$opt})
626 && ref($userlinkage->{$opt}) ) {
627 unshift (@optionlist, $userlinkage->{$opt});
628 }
629 unless ( @optionlist > 0
630 && ref($optionlist[0]) && ref($optionlist[0]) eq 'CODE' ) {
631 warn ("Option spec <> requires a reference to a subroutine\n");
88e49c4e 632 $error++;
404cbe93
PP
633 next;
634 }
635 $linkage{'<>'} = shift (@optionlist);
636 next;
637 }
638
381319f7 639 if ( $opt !~ /^(\w+[-\w|]*)?(!|[=:][infse][@%]?)?$/ ) {
404cbe93 640 warn ("Error in option spec: \"", $opt, "\"\n");
88e49c4e 641 $error++;
a0d0e21e
LW
642 next;
643 }
404cbe93 644 my ($o, $c, $a) = ($1, $2);
88e49c4e 645 $c = '' unless defined $c;
a0d0e21e
LW
646
647 if ( ! defined $o ) {
404cbe93 648 # empty -> '-' option
88e49c4e 649 $opctl{$o = ''} = $c;
a0d0e21e
LW
650 }
651 else {
652 # Handle alias names
404cbe93 653 my @o = split (/\|/, $o);
381319f7
PP
654 my $linko = $o = $o[0];
655 # Force an alias if the option name is not locase.
656 $a = $o unless $o eq lc($o);
88e49c4e
PP
657 $o = lc ($o)
658 if $ignorecase > 1
659 || ($ignorecase
660 && ($bundling ? length($o) > 1 : 1));
661
404cbe93 662 foreach ( @o ) {
88e49c4e
PP
663 if ( $bundling && length($_) == 1 ) {
664 $_ = lc ($_) if $ignorecase > 1;
665 if ( $c eq '!' ) {
666 $opctl{"no$_"} = $c;
667 warn ("Ignoring '!' modifier for short option $_\n");
668 $c = '';
669 }
02a7d5cb 670 $opctl{$_} = $bopctl{$_} = $c;
88e49c4e
PP
671 }
672 else {
673 $_ = lc ($_) if $ignorecase;
674 if ( $c eq '!' ) {
675 $opctl{"no$_"} = $c;
676 $c = '';
677 }
678 $opctl{$_} = $c;
a0d0e21e 679 }
a0d0e21e
LW
680 if ( defined $a ) {
681 # Note alias.
682 $aliases{$_} = $a;
683 }
684 else {
685 # Set primary name.
686 $a = $_;
687 }
688 }
381319f7 689 $o = $linko;
a0d0e21e 690 }
404cbe93
PP
691
692 # If no linkage is supplied in the @optionlist, copy it from
693 # the userlinkage if available.
694 if ( defined $userlinkage ) {
695 unless ( @optionlist > 0 && ref($optionlist[0]) ) {
696 if ( exists $userlinkage->{$o} && ref($userlinkage->{$o}) ) {
697 print STDERR ("=> found userlinkage for \"$o\": ",
698 "$userlinkage->{$o}\n")
699 if $debug;
700 unshift (@optionlist, $userlinkage->{$o});
701 }
702 else {
703 # Do nothing. Being undefined will be handled later.
704 next;
705 }
706 }
707 }
708
709 # Copy the linkage. If omitted, link to global variable.
710 if ( @optionlist > 0 && ref($optionlist[0]) ) {
711 print STDERR ("=> link \"$o\" to $optionlist[0]\n")
712 if $debug;
381319f7 713 if ( ref($optionlist[0]) =~ /^(SCALAR|CODE)$/ ) {
404cbe93
PP
714 $linkage{$o} = shift (@optionlist);
715 }
381319f7
PP
716 elsif ( ref($optionlist[0]) =~ /^(ARRAY)$/ ) {
717 $linkage{$o} = shift (@optionlist);
02a7d5cb
JV
718 $opctl{$o} .= '@'
719 if $opctl{$o} ne '' and $opctl{$o} !~ /\@$/;
720 $bopctl{$o} .= '@'
721 if $bundling and $bopctl{$o} ne '' and $bopctl{$o} !~ /\@$/;
381319f7
PP
722 }
723 elsif ( ref($optionlist[0]) =~ /^(HASH)$/ ) {
724 $linkage{$o} = shift (@optionlist);
02a7d5cb
JV
725 $opctl{$o} .= '%'
726 if $opctl{$o} ne '' and $opctl{$o} !~ /\%$/;
727 $bopctl{$o} .= '%'
728 if $bundling and $bopctl{$o} ne '' and $bopctl{$o} !~ /\%$/;
381319f7 729 }
404cbe93
PP
730 else {
731 warn ("Invalid option linkage for \"", $opt, "\"\n");
88e49c4e 732 $error++;
404cbe93
PP
733 }
734 }
735 else {
736 # Link to global $opt_XXX variable.
737 # Make sure a valid perl identifier results.
738 my $ov = $o;
739 $ov =~ s/\W/_/g;
381319f7 740 if ( $c =~ /@/ ) {
404cbe93
PP
741 print STDERR ("=> link \"$o\" to \@$pkg","::opt_$ov\n")
742 if $debug;
743 eval ("\$linkage{\$o} = \\\@".$pkg."::opt_$ov;");
744 }
381319f7
PP
745 elsif ( $c =~ /%/ ) {
746 print STDERR ("=> link \"$o\" to \%$pkg","::opt_$ov\n")
747 if $debug;
748 eval ("\$linkage{\$o} = \\\%".$pkg."::opt_$ov;");
749 }
404cbe93
PP
750 else {
751 print STDERR ("=> link \"$o\" to \$$pkg","::opt_$ov\n")
752 if $debug;
753 eval ("\$linkage{\$o} = \\\$".$pkg."::opt_$ov;");
754 }
755 }
a0d0e21e 756 }
a0d0e21e 757
404cbe93 758 # Bail out if errors found.
88e49c4e 759 return 0 if $error;
404cbe93 760
88e49c4e 761 # Sort the possible long option names.
a11f5414 762 @opctl = sort(keys (%opctl)) if $autoabbrev;
a0d0e21e 763
88e49c4e 764 # Show the options tables if debugging.
a0d0e21e 765 if ( $debug ) {
404cbe93 766 my ($arrow, $k, $v);
a0d0e21e
LW
767 $arrow = "=> ";
768 while ( ($k,$v) = each(%opctl) ) {
769 print STDERR ($arrow, "\$opctl{\"$k\"} = \"$v\"\n");
770 $arrow = " ";
771 }
88e49c4e
PP
772 $arrow = "=> ";
773 while ( ($k,$v) = each(%bopctl) ) {
774 print STDERR ($arrow, "\$bopctl{\"$k\"} = \"$v\"\n");
775 $arrow = " ";
776 }
a0d0e21e
LW
777 }
778
404cbe93
PP
779 # Process argument list
780 while ( @ARGV > 0 ) {
a0d0e21e 781
a0d0e21e
LW
782 #### Get next argument ####
783
784 $opt = shift (@ARGV);
a0d0e21e 785 $arg = undef;
381319f7 786 $array = $hash = 0;
404cbe93 787 print STDERR ("=> option \"", $opt, "\"\n") if $debug;
a0d0e21e
LW
788
789 #### Determine what we have ####
790
791 # Double dash is option list terminator.
792 if ( $opt eq $argend ) {
404cbe93
PP
793 # Finish. Push back accumulated arguments and return.
794 unshift (@ARGV, @ret)
88e49c4e
PP
795 if $order == $PERMUTE;
796 return ($error == 0);
a0d0e21e 797 }
404cbe93 798
381319f7
PP
799 my $tryopt = $opt;
800
801 # find_option operates on the GLOBAL $opt and $arg!
a11f5414 802 if ( &$find_option () ) {
381319f7
PP
803
804 # find_option undefines $opt in case of errors.
805 next unless defined $opt;
a0d0e21e 806
381319f7
PP
807 if ( defined $arg ) {
808 $opt = $aliases{$opt} if defined $aliases{$opt};
809
810 if ( defined $linkage{$opt} ) {
811 print STDERR ("=> ref(\$L{$opt}) -> ",
812 ref($linkage{$opt}), "\n") if $debug;
813
814 if ( ref($linkage{$opt}) eq 'SCALAR' ) {
815 print STDERR ("=> \$\$L{$opt} = \"$arg\"\n") if $debug;
816 ${$linkage{$opt}} = $arg;
817 }
818 elsif ( ref($linkage{$opt}) eq 'ARRAY' ) {
819 print STDERR ("=> push(\@{\$L{$opt}, \"$arg\")\n")
820 if $debug;
821 push (@{$linkage{$opt}}, $arg);
822 }
823 elsif ( ref($linkage{$opt}) eq 'HASH' ) {
824 print STDERR ("=> \$\$L{$opt}->{$key} = \"$arg\"\n")
825 if $debug;
826 $linkage{$opt}->{$key} = $arg;
827 }
828 elsif ( ref($linkage{$opt}) eq 'CODE' ) {
829 print STDERR ("=> &L{$opt}(\"$opt\", \"$arg\")\n")
830 if $debug;
831 &{$linkage{$opt}}($opt, $arg);
832 }
833 else {
834 print STDERR ("Invalid REF type \"", ref($linkage{$opt}),
835 "\" in linkage\n");
836 die ("Getopt::Long -- internal error!\n");
837 }
838 }
839 # No entry in linkage means entry in userlinkage.
840 elsif ( $array ) {
841 if ( defined $userlinkage->{$opt} ) {
842 print STDERR ("=> push(\@{\$L{$opt}}, \"$arg\")\n")
843 if $debug;
844 push (@{$userlinkage->{$opt}}, $arg);
845 }
846 else {
847 print STDERR ("=>\$L{$opt} = [\"$arg\"]\n")
848 if $debug;
849 $userlinkage->{$opt} = [$arg];
850 }
851 }
852 elsif ( $hash ) {
853 if ( defined $userlinkage->{$opt} ) {
854 print STDERR ("=> \$L{$opt}->{$key} = \"$arg\"\n")
855 if $debug;
856 $userlinkage->{$opt}->{$key} = $arg;
857 }
858 else {
859 print STDERR ("=>\$L{$opt} = {$key => \"$arg\"}\n")
860 if $debug;
861 $userlinkage->{$opt} = {$key => $arg};
862 }
863 }
864 else {
865 print STDERR ("=>\$L{$opt} = \"$arg\"\n") if $debug;
866 $userlinkage->{$opt} = $arg;
867 }
868 }
a0d0e21e 869 }
404cbe93
PP
870
871 # Not an option. Save it if we $PERMUTE and don't have a <>.
88e49c4e 872 elsif ( $order == $PERMUTE ) {
404cbe93
PP
873 # Try non-options call-back.
874 my $cb;
875 if ( (defined ($cb = $linkage{'<>'})) ) {
381319f7 876 &$cb($tryopt);
404cbe93
PP
877 }
878 else {
381319f7 879 print STDERR ("=> saving \"$tryopt\" ",
88e49c4e 880 "(not an option, may permute)\n") if $debug;
381319f7 881 push (@ret, $tryopt);
404cbe93 882 }
a0d0e21e
LW
883 next;
884 }
404cbe93 885
a0d0e21e
LW
886 # ...otherwise, terminate.
887 else {
404cbe93 888 # Push this one back and exit.
381319f7 889 unshift (@ARGV, $tryopt);
88e49c4e 890 return ($error == 0);
a0d0e21e
LW
891 }
892
381319f7
PP
893 }
894
895 # Finish.
896 if ( $order == $PERMUTE ) {
897 # Push back accumulated arguments
898 print STDERR ("=> restoring \"", join('" "', @ret), "\"\n")
899 if $debug && @ret > 0;
900 unshift (@ARGV, @ret) if @ret > 0;
901 }
902
903 return ($error == 0);
904}
905
a11f5414
JV
906sub config (@) {
907 my (@options) = @_;
908 my $opt;
909 foreach $opt ( @options ) {
910 my $try = lc ($opt);
911 my $action = 1;
912 if ( $try =~ /^no_?/ ) {
913 $action = 0;
914 $try = $';
915 }
916 if ( $try eq 'default' or $try eq 'defaults' ) {
917 &$config_defaults () if $action;
918 }
919 elsif ( $try eq 'auto_abbrev' or $try eq 'autoabbrev' ) {
920 $autoabbrev = $action;
921 }
922 elsif ( $try eq 'getopt_compat' ) {
923 $getopt_compat = $action;
924 }
925 elsif ( $try eq 'ignorecase' or $try eq 'ignore_case' ) {
926 $ignorecase = $action;
927 }
928 elsif ( $try eq 'ignore_case_always' ) {
929 $ignorecase = $action ? 2 : 0;
930 }
931 elsif ( $try eq 'bundling' ) {
932 $bundling = $action;
933 }
934 elsif ( $try eq 'bundling_override' ) {
935 $bundling = $action ? 2 : 0;
936 }
937 elsif ( $try eq 'require_order' ) {
938 $order = $action ? $REQUIRE_ORDER : $PERMUTE;
939 }
940 elsif ( $try eq 'permute' ) {
941 $order = $action ? $PERMUTE : $REQUIRE_ORDER;
942 }
943 elsif ( $try eq 'pass_through' or $try eq 'passthrough' ) {
944 $passthrough = $action;
945 }
946 elsif ( $try eq 'debug' ) {
947 $debug = $action;
948 }
949 else {
950 $Carp::CarpLevel = 1;
951 Carp::croak("Getopt::Long: unknown config parameter \"$opt\"")
952 }
953 }
954}
955
956# Modified from Exporter. This one handles 2.001 and 2.01 etc just like 2.1.
957sub require_version {
958 no strict;
959 my ($self, $wanted) = @_;
960 my $pkg = ref $self || $self;
961 my $version = $ {"${pkg}::VERSION"} || "(undef)";
962
963 $wanted .= '.0' unless $wanted =~ /\./;
964 $wanted = $1 * 1000 + $2 if $wanted =~ /^(\d+)\.(\d+)$/;
965 $version = $1 * 1000 + $2 if $version =~ /^(\d+)\.(\d+)$/;
966 if ( $version < $wanted ) {
967 $version =~ s/^(\d+)(\d\d\d)$/$1.'.'.(0+$2)/e;
968 $wanted =~ s/^(\d+)(\d\d\d)$/$1.'.'.(0+$2)/e;
969 $Carp::CarpLevel = 1;
970 Carp::croak("$pkg $wanted required--this is only version $version")
971 }
972 $version;
973}
974
975################ Private Subroutines ################
976
977$find_option = sub {
381319f7 978
a11f5414 979 return 0 unless $opt =~ /^$genprefix/;
381319f7 980
a11f5414
JV
981 $opt = $';
982 my ($starter) = $&;
381319f7
PP
983
984 my $optarg = undef; # value supplied with --opt=value
985 my $rest = undef; # remainder from unbundling
986
987 # If it is a long option, it may include the value.
988 if (($starter eq "--" || $getopt_compat)
a11f5414 989 && $opt =~ /^([^=]+)=/ ) {
381319f7 990 $opt = $1;
a11f5414 991 $optarg = $';
381319f7
PP
992 print STDERR ("=> option \"", $opt,
993 "\", optarg = \"$optarg\"\n") if $debug;
994 }
995
996 #### Look it up ###
997
998 my $tryopt = $opt; # option to try
999 my $optbl = \%opctl; # table to look it up (long names)
a11f5414 1000 my $type;
381319f7
PP
1001
1002 if ( $bundling && $starter eq '-' ) {
1003 # Unbundle single letter option.
1004 $rest = substr ($tryopt, 1);
1005 $tryopt = substr ($tryopt, 0, 1);
1006 $tryopt = lc ($tryopt) if $ignorecase > 1;
1007 print STDERR ("=> $starter$tryopt unbundled from ",
1008 "$starter$tryopt$rest\n") if $debug;
1009 $rest = undef unless $rest ne '';
1010 $optbl = \%bopctl; # look it up in the short names table
a11f5414
JV
1011
1012 # If bundling == 2, long options can override bundles.
1013 if ( $bundling == 2 and
1014 defined ($type = $opctl{$tryopt.$rest}) ) {
1015 print STDERR ("=> $starter$tryopt rebundled to ",
1016 "$starter$tryopt$rest\n") if $debug;
1017 $tryopt .= $rest;
1018 undef $rest;
1019 }
381319f7
PP
1020 }
1021
1022 # Try auto-abbreviation.
1023 elsif ( $autoabbrev ) {
1024 # Downcase if allowed.
1025 $tryopt = $opt = lc ($opt) if $ignorecase;
1026 # Turn option name into pattern.
1027 my $pat = quotemeta ($opt);
1028 # Look up in option names.
1029 my @hits = grep (/^$pat/, @opctl);
1030 print STDERR ("=> ", scalar(@hits), " hits (@hits) with \"$pat\" ",
1031 "out of ", scalar(@opctl), "\n") if $debug;
1032
1033 # Check for ambiguous results.
1034 unless ( (@hits <= 1) || (grep ($_ eq $opt, @hits) == 1) ) {
1035 # See if all matches are for the same option.
1036 my %hit;
1037 foreach ( @hits ) {
1038 $_ = $aliases{$_} if defined $aliases{$_};
1039 $hit{$_} = 1;
1040 }
1041 # Now see if it really is ambiguous.
1042 unless ( keys(%hit) == 1 ) {
1043 return 0 if $passthrough;
a0d0e21e
LW
1044 print STDERR ("Option ", $opt, " is ambiguous (",
1045 join(", ", @hits), ")\n");
88e49c4e 1046 $error++;
381319f7
PP
1047 undef $opt;
1048 return 1;
a0d0e21e 1049 }
381319f7 1050 @hits = keys(%hit);
a0d0e21e
LW
1051 }
1052
381319f7
PP
1053 # Complete the option name, if appropriate.
1054 if ( @hits == 1 && $hits[0] ne $opt ) {
1055 $tryopt = $hits[0];
1056 $tryopt = lc ($tryopt) if $ignorecase;
1057 print STDERR ("=> option \"$opt\" -> \"$tryopt\"\n")
1058 if $debug;
a0d0e21e 1059 }
381319f7 1060 }
a0d0e21e 1061
16c18a90
JV
1062 # Map to all lowercase if ignoring case.
1063 elsif ( $ignorecase ) {
1064 $tryopt = lc ($opt);
1065 }
1066
381319f7 1067 # Check validity by fetching the info.
a11f5414 1068 $type = $optbl->{$tryopt} unless defined $type;
381319f7
PP
1069 unless ( defined $type ) {
1070 return 0 if $passthrough;
1071 warn ("Unknown option: ", $opt, "\n");
1072 $error++;
1073 return 1;
1074 }
1075 # Apparently valid.
1076 $opt = $tryopt;
1077 print STDERR ("=> found \"$type\" for ", $opt, "\n") if $debug;
a0d0e21e 1078
381319f7 1079 #### Determine argument status ####
a0d0e21e 1080
381319f7
PP
1081 # If it is an option w/o argument, we're almost finished with it.
1082 if ( $type eq '' || $type eq '!' ) {
1083 if ( defined $optarg ) {
1084 return 0 if $passthrough;
1085 print STDERR ("Option ", $opt, " does not take an argument\n");
1086 $error++;
1087 undef $opt;
1088 }
1089 elsif ( $type eq '' ) {
1090 $arg = 1; # supply explicit value
1091 }
1092 else {
1093 substr ($opt, 0, 2) = ''; # strip NO prefix
1094 $arg = 0; # supply explicit value
1095 }
1096 unshift (@ARGV, $starter.$rest) if defined $rest;
1097 return 1;
1098 }
a0d0e21e 1099
381319f7
PP
1100 # Get mandatory status and type info.
1101 my $mand;
1102 ($mand, $type, $array, $hash) = $type =~ /^(.)(.)(@?)(%?)$/;
1103
1104 # Check if there is an option argument available.
1105 if ( defined $optarg ? ($optarg eq '')
1106 : !(defined $rest || @ARGV > 0) ) {
1107 # Complain if this option needs an argument.
1108 if ( $mand eq "=" ) {
1109 return 0 if $passthrough;
1110 print STDERR ("Option ", $opt, " requires an argument\n");
1111 $error++;
1112 undef $opt;
1113 }
1114 if ( $mand eq ":" ) {
1115 $arg = $type eq "s" ? '' : 0;
a0d0e21e 1116 }
381319f7
PP
1117 return 1;
1118 }
a0d0e21e 1119
381319f7
PP
1120 # Get (possibly optional) argument.
1121 $arg = (defined $rest ? $rest
1122 : (defined $optarg ? $optarg : shift (@ARGV)));
a0d0e21e 1123
381319f7
PP
1124 # Get key if this is a "name=value" pair for a hash option.
1125 $key = undef;
1126 if ($hash && defined $arg) {
a11f5414 1127 ($key, $arg) = ($arg =~ /=/o) ? ($`, $') : ($arg, 1);
381319f7 1128 }
a0d0e21e 1129
381319f7 1130 #### Check if the argument is valid for this option ####
a0d0e21e 1131
381319f7
PP
1132 if ( $type eq "s" ) { # string
1133 # A mandatory string takes anything.
1134 return 1 if $mand eq "=";
a0d0e21e 1135
381319f7
PP
1136 # An optional string takes almost anything.
1137 return 1 if defined $optarg || defined $rest;
1138 return 1 if $arg eq "-"; # ??
a0d0e21e 1139
381319f7
PP
1140 # Check for option or option list terminator.
1141 if ($arg eq $argend ||
1142 $arg =~ /^$genprefix.+/) {
1143 # Push back.
1144 unshift (@ARGV, $arg);
1145 # Supply empty value.
1146 $arg = '';
a0d0e21e 1147 }
381319f7 1148 }
a0d0e21e 1149
381319f7
PP
1150 elsif ( $type eq "n" || $type eq "i" ) { # numeric/integer
1151 if ( $arg !~ /^-?[0-9]+$/ ) {
1152 if ( defined $optarg || $mand eq "=" ) {
82032852
JV
1153 if ( $passthrough ) {
1154 unshift (@ARGV, defined $rest ? $starter.$rest : $arg)
1155 unless defined $optarg;
1156 return 0;
1157 }
381319f7
PP
1158 print STDERR ("Value \"", $arg, "\" invalid for option ",
1159 $opt, " (number expected)\n");
1160 $error++;
1161 undef $opt;
1162 # Push back.
1163 unshift (@ARGV, $starter.$rest) if defined $rest;
1164 }
1165 else {
1166 # Push back.
1167 unshift (@ARGV, defined $rest ? $starter.$rest : $arg);
1168 # Supply default value.
1169 $arg = 0;
a0d0e21e 1170 }
a0d0e21e 1171 }
a0d0e21e
LW
1172 }
1173
381319f7
PP
1174 elsif ( $type eq "f" ) { # real number, int is also ok
1175 if ( $arg !~ /^-?[0-9.]+([eE]-?[0-9]+)?$/ ) {
1176 if ( defined $optarg || $mand eq "=" ) {
82032852
JV
1177 if ( $passthrough ) {
1178 unshift (@ARGV, defined $rest ? $starter.$rest : $arg)
1179 unless defined $optarg;
1180 return 0;
1181 }
381319f7
PP
1182 print STDERR ("Value \"", $arg, "\" invalid for option ",
1183 $opt, " (real number expected)\n");
1184 $error++;
1185 undef $opt;
1186 # Push back.
1187 unshift (@ARGV, $starter.$rest) if defined $rest;
a0d0e21e
LW
1188 }
1189 else {
381319f7
PP
1190 # Push back.
1191 unshift (@ARGV, defined $rest ? $starter.$rest : $arg);
1192 # Supply default value.
1193 $arg = 0.0;
a0d0e21e
LW
1194 }
1195 }
1196 }
381319f7
PP
1197 else {
1198 die ("GetOpt::Long internal error (Can't happen)\n");
a0d0e21e 1199 }
381319f7 1200 return 1;
a11f5414
JV
1201};
1202
1203$config_defaults = sub {
1204 # Handle POSIX compliancy.
1205 if ( defined $ENV{"POSIXLY_CORRECT"} ) {
1206 $gen_prefix = "(--|-)";
1207 $autoabbrev = 0; # no automatic abbrev of options
1208 $bundling = 0; # no bundling of single letter switches
1209 $getopt_compat = 0; # disallow '+' to start options
1210 $order = $REQUIRE_ORDER;
1211 }
1212 else {
1213 $gen_prefix = "(--|-|\\+)";
1214 $autoabbrev = 1; # automatic abbrev of options
1215 $bundling = 0; # bundling off by default
1216 $getopt_compat = 1; # allow '+' to start options
1217 $order = $PERMUTE;
1218 }
1219 # Other configurable settings.
1220 $debug = 0; # for debugging
1221 $error = 0; # error tally
1222 $ignorecase = 1; # ignore case when matching options
1223 $passthrough = 0; # leave unrecognized options alone
1224};
1225
1226################ Initialization ################
1227
1228# Values for $order. See GNU getopt.c for details.
1229($REQUIRE_ORDER, $PERMUTE, $RETURN_IN_ORDER) = (0..2);
1230# Version major/minor numbers.
1231($major_version, $minor_version) = $VERSION =~ /^(\d+)\.(\d+)/;
1232
1233# Set defaults.
1234&$config_defaults ();
a0d0e21e
LW
1235
1236################ Package return ################
1237
88e49c4e 12381;