This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Minor, optional patch to Makefile.SH
[perl5.git] / lib / Getopt / Long.pm
CommitLineData
a11f5414 1# GetOpt::Long.pm -- Universal options parsing
404cbe93 2
a11f5414
JV
3package Getopt::Long;
4
5# RCS Status : $Id: GetoptLong.pm,v 2.9 1997-03-02 15:00:05+01 jv Exp $
404cbe93
PP
6# Author : Johan Vromans
7# Created On : Tue Sep 11 15:00:12 1990
8# Last Modified By: Johan Vromans
a11f5414
JV
9# Last Modified On: Sun Mar 2 14:59:41 1997
10# Update Count : 586
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
404cbe93
PP
52 &GetOptions("size=i" => \$offset);
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);
63 &GetOptions(\%optctl, "size=i");
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 = ();
147 &GetOptions (\%optctl, "size=i");
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 = ();
156 &GetOptions (\%optctl, "sizes=i@");
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 = ();
167 &GetOptions (\%optctl, "define=s%");
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
183 &GetOptions ("size=i", "sizes=i@");
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
PP
304
305 $ret = &GetOptions ('foo=s', \$foo, 'bar=i', 'ar=s', \@ar);
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);
317 &GetOptions("foo=i", \$myfoo, "<>", \&mysub);
318
319Results:
320
321 &mysub("bar") will be called (with $myfoo being 1)
322 &mysub("blech") will be called (with $myfoo being 2)
323
324Compare this with:
325
326 @ARGV = qw(-foo 1 bar -foo 2 blech);
327 &GetOptions("foo=i", \$myfoo);
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);
528 $VERSION = sprintf("%d.%02d", q$Revision: 2.9 $ =~ /(\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
a11f5414 579 print STDERR ('GetOptions $Revision: 2.9 $ ',
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 }
665 $bopctl{$_} = $c;
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);
713 $opctl{$o} .= '@' unless $opctl{$o} =~ /\@$/;
714 }
715 elsif ( ref($optionlist[0]) =~ /^(HASH)$/ ) {
716 $linkage{$o} = shift (@optionlist);
717 $opctl{$o} .= '%' unless $opctl{$o} =~ /\%$/;
718 }
404cbe93
PP
719 else {
720 warn ("Invalid option linkage for \"", $opt, "\"\n");
88e49c4e 721 $error++;
404cbe93
PP
722 }
723 }
724 else {
725 # Link to global $opt_XXX variable.
726 # Make sure a valid perl identifier results.
727 my $ov = $o;
728 $ov =~ s/\W/_/g;
381319f7 729 if ( $c =~ /@/ ) {
404cbe93
PP
730 print STDERR ("=> link \"$o\" to \@$pkg","::opt_$ov\n")
731 if $debug;
732 eval ("\$linkage{\$o} = \\\@".$pkg."::opt_$ov;");
733 }
381319f7
PP
734 elsif ( $c =~ /%/ ) {
735 print STDERR ("=> link \"$o\" to \%$pkg","::opt_$ov\n")
736 if $debug;
737 eval ("\$linkage{\$o} = \\\%".$pkg."::opt_$ov;");
738 }
404cbe93
PP
739 else {
740 print STDERR ("=> link \"$o\" to \$$pkg","::opt_$ov\n")
741 if $debug;
742 eval ("\$linkage{\$o} = \\\$".$pkg."::opt_$ov;");
743 }
744 }
a0d0e21e 745 }
a0d0e21e 746
404cbe93 747 # Bail out if errors found.
88e49c4e 748 return 0 if $error;
404cbe93 749
88e49c4e 750 # Sort the possible long option names.
a11f5414 751 @opctl = sort(keys (%opctl)) if $autoabbrev;
a0d0e21e 752
88e49c4e 753 # Show the options tables if debugging.
a0d0e21e 754 if ( $debug ) {
404cbe93 755 my ($arrow, $k, $v);
a0d0e21e
LW
756 $arrow = "=> ";
757 while ( ($k,$v) = each(%opctl) ) {
758 print STDERR ($arrow, "\$opctl{\"$k\"} = \"$v\"\n");
759 $arrow = " ";
760 }
88e49c4e
PP
761 $arrow = "=> ";
762 while ( ($k,$v) = each(%bopctl) ) {
763 print STDERR ($arrow, "\$bopctl{\"$k\"} = \"$v\"\n");
764 $arrow = " ";
765 }
a0d0e21e
LW
766 }
767
404cbe93
PP
768 # Process argument list
769 while ( @ARGV > 0 ) {
a0d0e21e 770
a0d0e21e
LW
771 #### Get next argument ####
772
773 $opt = shift (@ARGV);
a0d0e21e 774 $arg = undef;
381319f7 775 $array = $hash = 0;
404cbe93 776 print STDERR ("=> option \"", $opt, "\"\n") if $debug;
a0d0e21e
LW
777
778 #### Determine what we have ####
779
780 # Double dash is option list terminator.
781 if ( $opt eq $argend ) {
404cbe93
PP
782 # Finish. Push back accumulated arguments and return.
783 unshift (@ARGV, @ret)
88e49c4e
PP
784 if $order == $PERMUTE;
785 return ($error == 0);
a0d0e21e 786 }
404cbe93 787
381319f7
PP
788 my $tryopt = $opt;
789
790 # find_option operates on the GLOBAL $opt and $arg!
a11f5414 791 if ( &$find_option () ) {
381319f7
PP
792
793 # find_option undefines $opt in case of errors.
794 next unless defined $opt;
a0d0e21e 795
381319f7
PP
796 if ( defined $arg ) {
797 $opt = $aliases{$opt} if defined $aliases{$opt};
798
799 if ( defined $linkage{$opt} ) {
800 print STDERR ("=> ref(\$L{$opt}) -> ",
801 ref($linkage{$opt}), "\n") if $debug;
802
803 if ( ref($linkage{$opt}) eq 'SCALAR' ) {
804 print STDERR ("=> \$\$L{$opt} = \"$arg\"\n") if $debug;
805 ${$linkage{$opt}} = $arg;
806 }
807 elsif ( ref($linkage{$opt}) eq 'ARRAY' ) {
808 print STDERR ("=> push(\@{\$L{$opt}, \"$arg\")\n")
809 if $debug;
810 push (@{$linkage{$opt}}, $arg);
811 }
812 elsif ( ref($linkage{$opt}) eq 'HASH' ) {
813 print STDERR ("=> \$\$L{$opt}->{$key} = \"$arg\"\n")
814 if $debug;
815 $linkage{$opt}->{$key} = $arg;
816 }
817 elsif ( ref($linkage{$opt}) eq 'CODE' ) {
818 print STDERR ("=> &L{$opt}(\"$opt\", \"$arg\")\n")
819 if $debug;
820 &{$linkage{$opt}}($opt, $arg);
821 }
822 else {
823 print STDERR ("Invalid REF type \"", ref($linkage{$opt}),
824 "\" in linkage\n");
825 die ("Getopt::Long -- internal error!\n");
826 }
827 }
828 # No entry in linkage means entry in userlinkage.
829 elsif ( $array ) {
830 if ( defined $userlinkage->{$opt} ) {
831 print STDERR ("=> push(\@{\$L{$opt}}, \"$arg\")\n")
832 if $debug;
833 push (@{$userlinkage->{$opt}}, $arg);
834 }
835 else {
836 print STDERR ("=>\$L{$opt} = [\"$arg\"]\n")
837 if $debug;
838 $userlinkage->{$opt} = [$arg];
839 }
840 }
841 elsif ( $hash ) {
842 if ( defined $userlinkage->{$opt} ) {
843 print STDERR ("=> \$L{$opt}->{$key} = \"$arg\"\n")
844 if $debug;
845 $userlinkage->{$opt}->{$key} = $arg;
846 }
847 else {
848 print STDERR ("=>\$L{$opt} = {$key => \"$arg\"}\n")
849 if $debug;
850 $userlinkage->{$opt} = {$key => $arg};
851 }
852 }
853 else {
854 print STDERR ("=>\$L{$opt} = \"$arg\"\n") if $debug;
855 $userlinkage->{$opt} = $arg;
856 }
857 }
a0d0e21e 858 }
404cbe93
PP
859
860 # Not an option. Save it if we $PERMUTE and don't have a <>.
88e49c4e 861 elsif ( $order == $PERMUTE ) {
404cbe93
PP
862 # Try non-options call-back.
863 my $cb;
864 if ( (defined ($cb = $linkage{'<>'})) ) {
381319f7 865 &$cb($tryopt);
404cbe93
PP
866 }
867 else {
381319f7 868 print STDERR ("=> saving \"$tryopt\" ",
88e49c4e 869 "(not an option, may permute)\n") if $debug;
381319f7 870 push (@ret, $tryopt);
404cbe93 871 }
a0d0e21e
LW
872 next;
873 }
404cbe93 874
a0d0e21e
LW
875 # ...otherwise, terminate.
876 else {
404cbe93 877 # Push this one back and exit.
381319f7 878 unshift (@ARGV, $tryopt);
88e49c4e 879 return ($error == 0);
a0d0e21e
LW
880 }
881
381319f7
PP
882 }
883
884 # Finish.
885 if ( $order == $PERMUTE ) {
886 # Push back accumulated arguments
887 print STDERR ("=> restoring \"", join('" "', @ret), "\"\n")
888 if $debug && @ret > 0;
889 unshift (@ARGV, @ret) if @ret > 0;
890 }
891
892 return ($error == 0);
893}
894
a11f5414
JV
895sub config (@) {
896 my (@options) = @_;
897 my $opt;
898 foreach $opt ( @options ) {
899 my $try = lc ($opt);
900 my $action = 1;
901 if ( $try =~ /^no_?/ ) {
902 $action = 0;
903 $try = $';
904 }
905 if ( $try eq 'default' or $try eq 'defaults' ) {
906 &$config_defaults () if $action;
907 }
908 elsif ( $try eq 'auto_abbrev' or $try eq 'autoabbrev' ) {
909 $autoabbrev = $action;
910 }
911 elsif ( $try eq 'getopt_compat' ) {
912 $getopt_compat = $action;
913 }
914 elsif ( $try eq 'ignorecase' or $try eq 'ignore_case' ) {
915 $ignorecase = $action;
916 }
917 elsif ( $try eq 'ignore_case_always' ) {
918 $ignorecase = $action ? 2 : 0;
919 }
920 elsif ( $try eq 'bundling' ) {
921 $bundling = $action;
922 }
923 elsif ( $try eq 'bundling_override' ) {
924 $bundling = $action ? 2 : 0;
925 }
926 elsif ( $try eq 'require_order' ) {
927 $order = $action ? $REQUIRE_ORDER : $PERMUTE;
928 }
929 elsif ( $try eq 'permute' ) {
930 $order = $action ? $PERMUTE : $REQUIRE_ORDER;
931 }
932 elsif ( $try eq 'pass_through' or $try eq 'passthrough' ) {
933 $passthrough = $action;
934 }
935 elsif ( $try eq 'debug' ) {
936 $debug = $action;
937 }
938 else {
939 $Carp::CarpLevel = 1;
940 Carp::croak("Getopt::Long: unknown config parameter \"$opt\"")
941 }
942 }
943}
944
945# Modified from Exporter. This one handles 2.001 and 2.01 etc just like 2.1.
946sub require_version {
947 no strict;
948 my ($self, $wanted) = @_;
949 my $pkg = ref $self || $self;
950 my $version = $ {"${pkg}::VERSION"} || "(undef)";
951
952 $wanted .= '.0' unless $wanted =~ /\./;
953 $wanted = $1 * 1000 + $2 if $wanted =~ /^(\d+)\.(\d+)$/;
954 $version = $1 * 1000 + $2 if $version =~ /^(\d+)\.(\d+)$/;
955 if ( $version < $wanted ) {
956 $version =~ s/^(\d+)(\d\d\d)$/$1.'.'.(0+$2)/e;
957 $wanted =~ s/^(\d+)(\d\d\d)$/$1.'.'.(0+$2)/e;
958 $Carp::CarpLevel = 1;
959 Carp::croak("$pkg $wanted required--this is only version $version")
960 }
961 $version;
962}
963
964################ Private Subroutines ################
965
966$find_option = sub {
381319f7 967
a11f5414 968 return 0 unless $opt =~ /^$genprefix/;
381319f7 969
a11f5414
JV
970 $opt = $';
971 my ($starter) = $&;
381319f7
PP
972
973 my $optarg = undef; # value supplied with --opt=value
974 my $rest = undef; # remainder from unbundling
975
976 # If it is a long option, it may include the value.
977 if (($starter eq "--" || $getopt_compat)
a11f5414 978 && $opt =~ /^([^=]+)=/ ) {
381319f7 979 $opt = $1;
a11f5414 980 $optarg = $';
381319f7
PP
981 print STDERR ("=> option \"", $opt,
982 "\", optarg = \"$optarg\"\n") if $debug;
983 }
984
985 #### Look it up ###
986
987 my $tryopt = $opt; # option to try
988 my $optbl = \%opctl; # table to look it up (long names)
a11f5414 989 my $type;
381319f7
PP
990
991 if ( $bundling && $starter eq '-' ) {
992 # Unbundle single letter option.
993 $rest = substr ($tryopt, 1);
994 $tryopt = substr ($tryopt, 0, 1);
995 $tryopt = lc ($tryopt) if $ignorecase > 1;
996 print STDERR ("=> $starter$tryopt unbundled from ",
997 "$starter$tryopt$rest\n") if $debug;
998 $rest = undef unless $rest ne '';
999 $optbl = \%bopctl; # look it up in the short names table
a11f5414
JV
1000
1001 # If bundling == 2, long options can override bundles.
1002 if ( $bundling == 2 and
1003 defined ($type = $opctl{$tryopt.$rest}) ) {
1004 print STDERR ("=> $starter$tryopt rebundled to ",
1005 "$starter$tryopt$rest\n") if $debug;
1006 $tryopt .= $rest;
1007 undef $rest;
1008 }
381319f7
PP
1009 }
1010
1011 # Try auto-abbreviation.
1012 elsif ( $autoabbrev ) {
1013 # Downcase if allowed.
1014 $tryopt = $opt = lc ($opt) if $ignorecase;
1015 # Turn option name into pattern.
1016 my $pat = quotemeta ($opt);
1017 # Look up in option names.
1018 my @hits = grep (/^$pat/, @opctl);
1019 print STDERR ("=> ", scalar(@hits), " hits (@hits) with \"$pat\" ",
1020 "out of ", scalar(@opctl), "\n") if $debug;
1021
1022 # Check for ambiguous results.
1023 unless ( (@hits <= 1) || (grep ($_ eq $opt, @hits) == 1) ) {
1024 # See if all matches are for the same option.
1025 my %hit;
1026 foreach ( @hits ) {
1027 $_ = $aliases{$_} if defined $aliases{$_};
1028 $hit{$_} = 1;
1029 }
1030 # Now see if it really is ambiguous.
1031 unless ( keys(%hit) == 1 ) {
1032 return 0 if $passthrough;
a0d0e21e
LW
1033 print STDERR ("Option ", $opt, " is ambiguous (",
1034 join(", ", @hits), ")\n");
88e49c4e 1035 $error++;
381319f7
PP
1036 undef $opt;
1037 return 1;
a0d0e21e 1038 }
381319f7 1039 @hits = keys(%hit);
a0d0e21e
LW
1040 }
1041
381319f7
PP
1042 # Complete the option name, if appropriate.
1043 if ( @hits == 1 && $hits[0] ne $opt ) {
1044 $tryopt = $hits[0];
1045 $tryopt = lc ($tryopt) if $ignorecase;
1046 print STDERR ("=> option \"$opt\" -> \"$tryopt\"\n")
1047 if $debug;
a0d0e21e 1048 }
381319f7 1049 }
a0d0e21e 1050
16c18a90
JV
1051 # Map to all lowercase if ignoring case.
1052 elsif ( $ignorecase ) {
1053 $tryopt = lc ($opt);
1054 }
1055
381319f7 1056 # Check validity by fetching the info.
a11f5414 1057 $type = $optbl->{$tryopt} unless defined $type;
381319f7
PP
1058 unless ( defined $type ) {
1059 return 0 if $passthrough;
1060 warn ("Unknown option: ", $opt, "\n");
1061 $error++;
1062 return 1;
1063 }
1064 # Apparently valid.
1065 $opt = $tryopt;
1066 print STDERR ("=> found \"$type\" for ", $opt, "\n") if $debug;
a0d0e21e 1067
381319f7 1068 #### Determine argument status ####
a0d0e21e 1069
381319f7
PP
1070 # If it is an option w/o argument, we're almost finished with it.
1071 if ( $type eq '' || $type eq '!' ) {
1072 if ( defined $optarg ) {
1073 return 0 if $passthrough;
1074 print STDERR ("Option ", $opt, " does not take an argument\n");
1075 $error++;
1076 undef $opt;
1077 }
1078 elsif ( $type eq '' ) {
1079 $arg = 1; # supply explicit value
1080 }
1081 else {
1082 substr ($opt, 0, 2) = ''; # strip NO prefix
1083 $arg = 0; # supply explicit value
1084 }
1085 unshift (@ARGV, $starter.$rest) if defined $rest;
1086 return 1;
1087 }
a0d0e21e 1088
381319f7
PP
1089 # Get mandatory status and type info.
1090 my $mand;
1091 ($mand, $type, $array, $hash) = $type =~ /^(.)(.)(@?)(%?)$/;
1092
1093 # Check if there is an option argument available.
1094 if ( defined $optarg ? ($optarg eq '')
1095 : !(defined $rest || @ARGV > 0) ) {
1096 # Complain if this option needs an argument.
1097 if ( $mand eq "=" ) {
1098 return 0 if $passthrough;
1099 print STDERR ("Option ", $opt, " requires an argument\n");
1100 $error++;
1101 undef $opt;
1102 }
1103 if ( $mand eq ":" ) {
1104 $arg = $type eq "s" ? '' : 0;
a0d0e21e 1105 }
381319f7
PP
1106 return 1;
1107 }
a0d0e21e 1108
381319f7
PP
1109 # Get (possibly optional) argument.
1110 $arg = (defined $rest ? $rest
1111 : (defined $optarg ? $optarg : shift (@ARGV)));
a0d0e21e 1112
381319f7
PP
1113 # Get key if this is a "name=value" pair for a hash option.
1114 $key = undef;
1115 if ($hash && defined $arg) {
a11f5414 1116 ($key, $arg) = ($arg =~ /=/o) ? ($`, $') : ($arg, 1);
381319f7 1117 }
a0d0e21e 1118
381319f7 1119 #### Check if the argument is valid for this option ####
a0d0e21e 1120
381319f7
PP
1121 if ( $type eq "s" ) { # string
1122 # A mandatory string takes anything.
1123 return 1 if $mand eq "=";
a0d0e21e 1124
381319f7
PP
1125 # An optional string takes almost anything.
1126 return 1 if defined $optarg || defined $rest;
1127 return 1 if $arg eq "-"; # ??
a0d0e21e 1128
381319f7
PP
1129 # Check for option or option list terminator.
1130 if ($arg eq $argend ||
1131 $arg =~ /^$genprefix.+/) {
1132 # Push back.
1133 unshift (@ARGV, $arg);
1134 # Supply empty value.
1135 $arg = '';
a0d0e21e 1136 }
381319f7 1137 }
a0d0e21e 1138
381319f7
PP
1139 elsif ( $type eq "n" || $type eq "i" ) { # numeric/integer
1140 if ( $arg !~ /^-?[0-9]+$/ ) {
1141 if ( defined $optarg || $mand eq "=" ) {
1142 return 0 if $passthrough;
1143 print STDERR ("Value \"", $arg, "\" invalid for option ",
1144 $opt, " (number expected)\n");
1145 $error++;
1146 undef $opt;
1147 # Push back.
1148 unshift (@ARGV, $starter.$rest) if defined $rest;
1149 }
1150 else {
1151 # Push back.
1152 unshift (@ARGV, defined $rest ? $starter.$rest : $arg);
1153 # Supply default value.
1154 $arg = 0;
a0d0e21e 1155 }
a0d0e21e 1156 }
a0d0e21e
LW
1157 }
1158
381319f7
PP
1159 elsif ( $type eq "f" ) { # real number, int is also ok
1160 if ( $arg !~ /^-?[0-9.]+([eE]-?[0-9]+)?$/ ) {
1161 if ( defined $optarg || $mand eq "=" ) {
1162 return 0 if $passthrough;
1163 print STDERR ("Value \"", $arg, "\" invalid for option ",
1164 $opt, " (real number expected)\n");
1165 $error++;
1166 undef $opt;
1167 # Push back.
1168 unshift (@ARGV, $starter.$rest) if defined $rest;
a0d0e21e
LW
1169 }
1170 else {
381319f7
PP
1171 # Push back.
1172 unshift (@ARGV, defined $rest ? $starter.$rest : $arg);
1173 # Supply default value.
1174 $arg = 0.0;
a0d0e21e
LW
1175 }
1176 }
1177 }
381319f7
PP
1178 else {
1179 die ("GetOpt::Long internal error (Can't happen)\n");
a0d0e21e 1180 }
381319f7 1181 return 1;
a11f5414
JV
1182};
1183
1184$config_defaults = sub {
1185 # Handle POSIX compliancy.
1186 if ( defined $ENV{"POSIXLY_CORRECT"} ) {
1187 $gen_prefix = "(--|-)";
1188 $autoabbrev = 0; # no automatic abbrev of options
1189 $bundling = 0; # no bundling of single letter switches
1190 $getopt_compat = 0; # disallow '+' to start options
1191 $order = $REQUIRE_ORDER;
1192 }
1193 else {
1194 $gen_prefix = "(--|-|\\+)";
1195 $autoabbrev = 1; # automatic abbrev of options
1196 $bundling = 0; # bundling off by default
1197 $getopt_compat = 1; # allow '+' to start options
1198 $order = $PERMUTE;
1199 }
1200 # Other configurable settings.
1201 $debug = 0; # for debugging
1202 $error = 0; # error tally
1203 $ignorecase = 1; # ignore case when matching options
1204 $passthrough = 0; # leave unrecognized options alone
1205};
1206
1207################ Initialization ################
1208
1209# Values for $order. See GNU getopt.c for details.
1210($REQUIRE_ORDER, $PERMUTE, $RETURN_IN_ORDER) = (0..2);
1211# Version major/minor numbers.
1212($major_version, $minor_version) = $VERSION =~ /^(\d+)\.(\d+)/;
1213
1214# Set defaults.
1215&$config_defaults ();
a0d0e21e
LW
1216
1217################ Package return ################
1218
88e49c4e 12191;