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