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