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