lib/Getopt/Long.pm

   1 # GetOpt::Long.pm -- Universal options parsing
   2
   3 package Getopt::Long;
   4
   5 # RCS Status      : $Id: GetoptLong.pm,v 2.9 1997-03-02 15:00:05+01 jv Exp $
   6 # Author          : Johan Vromans
   7 # Created On      : Tue Sep 11 15:00:12 1990
   8 # Last Modified By: Johan Vromans
   9 # Last Modified On: Sun Mar  2 14:59:41 1997
  10 # Update Count    : 586
  11 # Status          : Released
  12
  13 =head1 NAME
  14
  15 GetOptions - extended processing of command line options
  16
  17 =head1 SYNOPSIS
  18
  19   use Getopt::Long;
  20   $result = GetOptions (...option-descriptions...);
  21
  22 =head1 DESCRIPTION
  23
  24 The Getopt::Long module implements an extended getopt function called
  25 GetOptions(). This function adheres to the POSIX syntax for command
  26 line options, with GNU extensions. In general, this means that options
  27 have long names instead of single letters, and are introduced with a
  28 double dash "--". Support for bundling of command line options, as was
  29 the case with the more traditional single-letter approach, is provided
  30 but not enabled by default. For example, the UNIX "ps" command can be
  31 given the command line "option"
  32
  33   -vax
  34
  35 which means the combination of B<-v>, B<-a> and B<-x>. With the new
  36 syntax B<--vax> would be a single option, probably indicating a
  37 computer architecture.
  38
  39 Command line options can be used to set values. These values can be
  40 specified in one of two ways:
  41
  42   --size 24
  43   --size=24
  44
  45 GetOptions is called with a list of option-descriptions, each of which
  46 consists of two elements: the option specifier and the option linkage.
  47 The option specifier defines the name of the option and, optionally,
  48 the value it can take. The option linkage is usually a reference to a
  49 variable that will be set when the option is used. For example, the
  50 following call to GetOptions:
  51
  52   &GetOptions("size=i" => \$offset);
  53
  54 will accept a command line option "size" that must have an integer
  55 value. With a command line of "--size 24" this will cause the variable
  56 $offset to get the value 24.
  57
  58 Alternatively, the first argument to GetOptions may be a reference to
  59 a HASH describing the linkage for the options. The following call is
  60 equivalent to the example above:
  61
  62   %optctl = ("size" => \$offset);
  63   &GetOptions(\%optctl, "size=i");
  64
  65 Linkage may be specified using either of the above methods, or both.
  66 Linkage specified in the argument list takes precedence over the
  67 linkage specified in the HASH.
  68
  69 The command line options are taken from array @ARGV. Upon completion
  70 of GetOptions, @ARGV will contain the rest (i.e. the non-options) of
  71 the command line.
  72
  73 Each option specifier designates the name of the option, optionally
  74 followed by an argument specifier. Values for argument specifiers are:
  75
  76 =over 8
  77
  78 =item E<lt>noneE<gt>
  79
  80 Option does not take an argument.
  81 The option variable will be set to 1.
  82
  83 =item !
  84
  85 Option 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).
  88 The option variable will be set to 1, or 0 if negated.
  89
  90 =item =s
  91
  92 Option takes a mandatory string argument.
  93 This string will be assigned to the option variable.
  94 Note that even if the string argument starts with B<-> or B<-->, it
  95 will not be considered an option on itself.
  96
  97 =item :s
  98
  99 Option takes an optional string argument.
 100 This string will be assigned to the option variable.
 101 If omitted, it will be assigned "" (an empty string).
 102 If the string argument starts with B<-> or B<-->, it
 103 will be considered an option on itself.
 104
 105 =item =i
 106
 107 Option takes a mandatory integer argument.
 108 This value will be assigned to the option variable.
 109 Note that the value may start with B<-> to indicate a negative
 110 value.
 111
 112 =item :i
 113
 114 Option takes an optional integer argument.
 115 This value will be assigned to the option variable.
 116 If omitted, the value 0 will be assigned.
 117 Note that the value may start with B<-> to indicate a negative
 118 value.
 119
 120 =item =f
 121
 122 Option takes a mandatory real number argument.
 123 This value will be assigned to the option variable.
 124 Note that the value may start with B<-> to indicate a negative
 125 value.
 126
 127 =item :f
 128
 129 Option takes an optional real number argument.
 130 This value will be assigned to the option variable.
 131 If omitted, the value 0 will be assigned.
 132
 133 =back
 134
 135 A lone dash B<-> is considered an option, the corresponding option
 136 name is the empty string.
 137
 138 A double dash on itself B<--> signals end of the options list.
 139
 140 =head2 Linkage specification
 141
 142 The linkage specifier is optional. If no linkage is explicitly
 143 specified but a ref HASH is passed, GetOptions will place the value in
 144 the HASH. For example:
 145
 146   %optctl = ();
 147   &GetOptions (\%optctl, "size=i");
 148
 149 will perform the equivalent of the assignment
 150
 151   $optctl{"size"} = 24;
 152
 153 For array options, a reference to an array is used, e.g.:
 154
 155   %optctl = ();
 156   &GetOptions (\%optctl, "sizes=i@");
 157
 158 with command line "-sizes 24 -sizes 48" will perform the equivalent of
 159 the assignment
 160
 161   $optctl{"sizes"} = [24, 48];
 162
 163 For hash options (an option whose argument looks like "name=value"),
 164 a reference to a hash is used, e.g.:
 165
 166   %optctl = ();
 167   &GetOptions (\%optctl, "define=s%");
 168
 169 with command line "--define foo=hello --define bar=world" will perform the
 170 equivalent of the assignment
 171
 172   $optctl{"define"} = {foo=>'hello', bar=>'world')
 173
 174 If no linkage is explicitly specified and no ref HASH is passed,
 175 GetOptions will put the value in a global variable named after the
 176 option, prefixed by "opt_". To yield a usable Perl variable,
 177 characters that are not part of the syntax for variables are
 178 translated to underscores. For example, "--fpp-struct-return" will set
 179 the variable $opt_fpp_struct_return. Note that this variable resides
 180 in the namespace of the calling program, not necessarily B<main>.
 181 For example:
 182
 183   &GetOptions ("size=i", "sizes=i@");
 184
 185 with command line "-size 10 -sizes 24 -sizes 48" will perform the
 186 equivalent of the assignments
 187
 188   $opt_size = 10;
 189   @opt_sizes = (24, 48);
 190
 191 A lone dash B<-> is considered an option, the corresponding Perl
 192 identifier is $opt_ .
 193
 194 The linkage specifier can be a reference to a scalar, a reference to
 195 an array, a reference to a hash or a reference to a subroutine.
 196
 197 If a REF SCALAR is supplied, the new value is stored in the referenced
 198 variable. If the option occurs more than once, the previous value is
 199 overwritten.
 200
 201 If a REF ARRAY is supplied, the new value is appended (pushed) to the
 202 referenced array.
 203
 204 If 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).
 206 In this case, the element of the referenced hash with the key "key"
 207 is assigned "value".
 208
 209 If a REF CODE is supplied, the referenced subroutine is called with
 210 two arguments: the option name and the option value.
 211 The option name is always the true name, not an abbreviation or alias.
 212
 213 =head2 Aliases and abbreviations
 214
 215 The option name may actually be a list of option names, separated by
 216 "|"s, e.g. "foo|bar|blech=s". In this example, "foo" is the true name
 217 of this option. If no linkage is specified, options "foo", "bar" and
 218 "blech" all will set $opt_foo.
 219
 220 Option names may be abbreviated to uniqueness, depending on
 221 configuration option B<auto_abbrev>.
 222
 223 =head2 Non-option call-back routine
 224
 225 A special option specifier, E<lt>E<gt>, can be used to designate a subroutine
 226 to handle non-option arguments. GetOptions will immediately call this
 227 subroutine for every non-option it encounters in the options list.
 228 This subroutine gets the name of the non-option passed.
 229 This feature requires configuration option B<permute>, see section
 230 CONFIGURATION OPTIONS.
 231
 232 See also the examples.
 233
 234 =head2 Option starters
 235
 236 On the command line, options can start with B<-> (traditional), B<-->
 237 (POSIX) and B<+> (GNU, now being phased out). The latter is not
 238 allowed if the environment variable B<POSIXLY_CORRECT> has been
 239 defined.
 240
 241 Options that start with "--" may have an argument appended, separated
 242 with an "=", e.g. "--foo=bar".
 243
 244 =head2 Return value
 245
 246 A return status of 0 (false) indicates that the function detected
 247 one or more errors.
 248
 249 =head1 COMPATIBILITY
 250
 251 Getopt::Long::GetOptions() is the successor of
 252 B<newgetopt.pl> that came with Perl 4. It is fully upward compatible.
 253 In fact, the Perl 5 version of newgetopt.pl is just a wrapper around
 254 the module.
 255
 256 If an "@" sign is appended to the argument specifier, the option is
 257 treated 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
 259 to an ARRAY.
 260
 261 If an "%" sign is appended to the argument specifier, the option is
 262 treated as a hash. Value(s) of the form "name=value" are set by
 263 setting 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
 265 linkage is supplied, this must be a reference to a HASH.
 266
 267 If configuration option B<getopt_compat> is set (see section
 268 CONFIGURATION OPTIONS), options that start with "+" or "-" may also
 269 include their arguments, e.g. "+foo=bar". This is for compatiblity
 270 with older implementations of the GNU "getopt" routine.
 271
 272 If the first argument to GetOptions is a string consisting of only
 273 non-alphanumeric characters, it is taken to specify the option starter
 274 characters. Everything starting with one of these characters from the
 275 starter will be considered an option. B<Using a starter argument is
 276 strongly deprecated.>
 277
 278 For convenience, option specifiers may have a leading B<-> or B<-->,
 279 so it is possible to write:
 280
 281    GetOptions qw(-foo=s --bar=i --ar=s);
 282
 283 =head1 EXAMPLES
 284
 285 If the option specifier is "one:i" (i.e. takes an optional integer
 286 argument), then the following situations are handled:
 287
 288    -one -two            -> $opt_one = '', -two is next option
 289    -one -2              -> $opt_one = -2
 290
 291 Also, assume specifiers "foo=s" and "bar:s" :
 292
 293    -bar -xxx            -> $opt_bar = '', '-xxx' is next option
 294    -foo -bar            -> $opt_foo = '-bar'
 295    -foo --              -> $opt_foo = '--'
 296
 297 In 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
 303 Example of using variable references:
 304
 305    $ret = &GetOptions ('foo=s', \$foo, 'bar=i', 'ar=s', \@ar);
 306
 307 With command line options "-foo blech -bar 24 -ar xx -ar yy"
 308 this will result in:
 309
 310    $foo = 'blech'
 311    $opt_bar = 24
 312    @ar = ('xx','yy')
 313
 314 Example of using the E<lt>E<gt> option specifier:
 315
 316    @ARGV = qw(-foo 1 bar -foo 2 blech);
 317    &GetOptions("foo=i", \$myfoo, "<>", \&mysub);
 318
 319 Results:
 320
 321    &mysub("bar") will be called (with $myfoo being 1)
 322    &mysub("blech") will be called (with $myfoo being 2)
 323
 324 Compare this with:
 325
 326    @ARGV = qw(-foo 1 bar -foo 2 blech);
 327    &GetOptions("foo=i", \$myfoo);
 328
 329 This will leave the non-options in @ARGV:
 330
 331    $myfoo -> 2
 332    @ARGV -> qw(bar blech)
 333
 334 =head1 CONFIGURATION OPTIONS
 335
 336 B<GetOptions> can be configured by calling subroutine
 337 B<Getopt::Long::config>. This subroutine takes a list of quoted
 338 strings, each specifying a configuration option to be set, e.g.
 339 B<ignore_case>. Options can be reset by prefixing with B<no_>, e.g.
 340 B<no_ignore_case>. Case does not matter. Multiple calls to B<config>
 341 are possible.
 342
 343 Previous versions of Getopt::Long used variables for the purpose of
 344 configuring. Although manipulating these variables still work, it
 345 is strongly encouraged to use the new B<config> routine. Besides, it
 346 is much easier.
 347
 348 The following options are available:
 349
 350 =over 12
 351
 352 =item default
 353
 354 This option causes all configuration options to be reset to their
 355 default values.
 356
 357 =item auto_abbrev
 358
 359 Allow option names to be abbreviated to uniqueness.
 360 Default is set unless environment variable
 361 POSIXLY_CORRECT has been set, in which case B<auto_abbrev> is reset.
 362
 363 =item getopt_compat
 364
 365 Allow '+' to start options.
 366 Default is set unless environment variable
 367 POSIXLY_CORRECT has been set, in which case B<getopt_compat> is reset.
 368
 369 =item require_order
 370
 371 Whether non-options are allowed to be mixed with
 372 options.
 373 Default is set unless environment variable
 374 POSIXLY_CORRECT has been set, in which case b<require_order> is reset.
 375
 376 See also B<permute>, which is the opposite of B<require_order>.
 377
 378 =item permute
 379
 380 Whether non-options are allowed to be mixed with
 381 options.
 382 Default is set unless environment variable
 383 POSIXLY_CORRECT has been set, in which case B<permute> is reset.
 384 Note that B<permute> is the opposite of B<require_order>.
 385
 386 If B<permute> is set, this means that
 387
 388     -foo arg1 -bar arg2 arg3
 389
 390 is equivalent to
 391
 392     -foo -bar arg1 arg2 arg3
 393
 394 If a non-option call-back routine is specified, @ARGV will always be
 395 empty upon succesful return of GetOptions since all options have been
 396 processed, except when B<--> is used:
 397
 398     -foo arg1 -bar arg2 -- arg3
 399
 400 will call the call-back routine for arg1 and arg2, and terminate
 401 leaving arg2 in @ARGV.
 402
 403 If B<require_order> is set, options processing
 404 terminates when the first non-option is encountered.
 405
 406     -foo arg1 -bar arg2 arg3
 407
 408 is equivalent to
 409
 410     -foo -- arg1 -bar arg2 arg3
 411
 412 =item bundling (default: reset)
 413
 414 Setting this variable to a non-zero value will allow single-character
 415 options to be bundled. To distinguish bundles from long option names,
 416 long options must be introduced with B<--> and single-character
 417 options (and bundles) with B<->. For example,
 418
 419     ps -vax --vax
 420
 421 would be equivalent to
 422
 423     ps -v -a -x --vax
 424
 425 provided "vax", "v", "a" and "x" have been defined to be valid
 426 options.
 427
 428 Bundled options can also include a value in the bundle; this value has
 429 to be the last part of the bundle, e.g.
 430
 431     scale -h24 -w80
 432
 433 is equivalent to
 434
 435     scale -h 24 -w 80
 436
 437 Note: resetting B<bundling> also resets B<bundling_override>.
 438
 439 =item bundling_override (default: reset)
 440
 441 If B<bundling_override> is set, bundling is enabled as with
 442 B<bundling> but now long option names override option bundles. In the
 443 above example, B<-vax> would be interpreted as the option "vax", not
 444 the bundle "v", "a", "x".
 445
 446 Note: resetting B<bundling_override> also resets B<bundling>.
 447
 448 B<Note:> Using option bundling can easily lead to unexpected results,
 449 especially when mixing long options and bundles. Caveat emptor.
 450
 451 =item ignore_case  (default: set)
 452
 453 If set, case is ignored when matching options.
 454
 455 Note: resetting B<ignore_case> also resets B<ignore_case_always>.
 456
 457 =item ignore_case_always (default: reset)
 458
 459 When bundling is in effect, case is ignored on single-character
 460 options also.
 461
 462 Note: resetting B<ignore_case_always> also resets B<ignore_case>.
 463
 464 =item pass_through (default: reset)
 465
 466 Unknown options are passed through in @ARGV instead of being flagged
 467 as errors. This makes it possible to write wrapper scripts that
 468 process only part of the user supplied options, and passes the
 469 remaining options to some other program.
 470
 471 This can be very confusing, especially when B<permute> is also set.
 472
 473 =item debug (default: reset)
 474
 475 Enable copious debugging output.
 476
 477 =back
 478
 479 =head1 OTHER USEFUL VARIABLES
 480
 481 =over 12
 482
 483 =item $Getopt::Long::VERSION
 484
 485 The version number of this Getopt::Long implementation in the format
 486 C<major>.C<minor>. This can be used to have Exporter check the
 487 version, e.g.
 488
 489     use Getopt::Long 3.00;
 490
 491 You can inspect $Getopt::Long::major_version and
 492 $Getopt::Long::minor_version for the individual components.
 493
 494 =item $Getopt::Long::error
 495
 496 Internal error flag. May be incremented from a call-back routine to
 497 cause options parsing to fail.
 498
 499 =back
 500
 501 =cut
 502
 503 ################ Copyright ################
 504
 505 # This program is Copyright 1990,1997 by Johan Vromans.
 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
 520 ################ Module Preamble ################
 521
 522 use strict;
 523
 524 BEGIN {
 525     require 5.003;
 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+)/);
 529
 530     @ISA       = qw(Exporter);
 531     @EXPORT    = qw(&GetOptions $REQUIRE_ORDER $PERMUTE $RETURN_IN_ORDER);
 532     %EXPORT_TAGS = ();
 533     @EXPORT_OK = qw();
 534 }
 535
 536 use vars @EXPORT, @EXPORT_OK;
 537 # User visible variables.
 538 use vars qw($error $debug $major_version $minor_version);
 539 # Deprecated visible variables.
 540 use vars qw($autoabbrev $getopt_compat $ignorecase $bundling $order
 541             $passthrough);
 542
 543 ################ Local Variables ################
 544
 545 my $gen_prefix;                 # generic prefix (option starters)
 546 my $argend;                     # option list terminator
 547 my %opctl;                      # table of arg.specs (long and abbrevs)
 548 my %bopctl;                     # table of arg.specs (bundles)
 549 my @opctl;                      # the possible long option names
 550 my $pkg;                        # current context. Needed if no linkage.
 551 my %aliases;                    # alias table
 552 my $genprefix;                  # so we can call the same module more
 553 my $opt;                        # current option
 554 my $arg;                        # current option value, if any
 555 my $array;                      # current option is array typed
 556 my $hash;                       # current option is hash typed
 557 my $key;                        # hash key for a hash option
 558                                 # than once in differing environments
 559 my $config_defaults;            # set config defaults
 560 my $find_option;                # helper routine
 561
 562 ################ Subroutines ################
 563
 564 sub GetOptions {
 565
 566     my @optionlist = @_;        # local copy of the option descriptions
 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
 571                                 # Needed if linkage is omitted.
 572     %aliases= ();               # alias table
 573     my @ret = ();               # accum for non-options
 574     my %linkage;                # linkage
 575     my $userlinkage;            # user supplied HASH
 576     $genprefix = $gen_prefix;   # so we can call the same module many times
 577     $error = 0;
 578
 579     print STDERR ('GetOptions $Revision: 2.9 $ ',
 580                   "[GetOpt::Long $Getopt::Long::VERSION] -- ",
 581                   "called from package \"$pkg\".\n",
 582                   "  (@ARGV)\n",
 583                   "  autoabbrev=$autoabbrev".
 584                   ",bundling=$bundling",
 585                   ",getopt_compat=$getopt_compat",
 586                   ",order=$order",
 587                   ",\n  ignorecase=$ignorecase",
 588                   ",passthrough=$passthrough",
 589                   ",genprefix=\"$genprefix\"",
 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     }
 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 = ();
 610     %bopctl = ();
 611     while ( @optionlist > 0 ) {
 612         my $opt = shift (@optionlist);
 613
 614         # Strip leading prefix so people can specify "--foo=i" if they like.
 615         $opt = $' if $opt =~ /^($genprefix)+/;
 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");
 627                 $error++;
 628                 next;
 629             }
 630             $linkage{'<>'} = shift (@optionlist);
 631             next;
 632         }
 633
 634         if ( $opt !~ /^(\w+[-\w|]*)?(!|[=:][infse][@%]?)?$/ ) {
 635             warn ("Error in option spec: \"", $opt, "\"\n");
 636             $error++;
 637             next;
 638         }
 639         my ($o, $c, $a) = ($1, $2);
 640         $c = '' unless defined $c;
 641
 642         if ( ! defined $o ) {
 643             # empty -> '-' option
 644             $opctl{$o = ''} = $c;
 645         }
 646         else {
 647             # Handle alias names
 648             my @o =  split (/\|/, $o);
 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);
 652             $o = lc ($o)
 653                 if $ignorecase > 1
 654                     || ($ignorecase
 655                         && ($bundling ? length($o) > 1  : 1));
 656
 657             foreach ( @o ) {
 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;
 674                 }
 675                 if ( defined $a ) {
 676                     # Note alias.
 677                     $aliases{$_} = $a;
 678                 }
 679                 else {
 680                     # Set primary name.
 681                     $a = $_;
 682                 }
 683             }
 684             $o = $linko;
 685         }
 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;
 708             if ( ref($optionlist[0]) =~ /^(SCALAR|CODE)$/ ) {
 709                 $linkage{$o} = shift (@optionlist);
 710             }
 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             }
 719             else {
 720                 warn ("Invalid option linkage for \"", $opt, "\"\n");
 721                 $error++;
 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;
 729             if ( $c =~ /@/ ) {
 730                 print STDERR ("=> link \"$o\" to \@$pkg","::opt_$ov\n")
 731                     if $debug;
 732                 eval ("\$linkage{\$o} = \\\@".$pkg."::opt_$ov;");
 733             }
 734             elsif ( $c =~ /%/ ) {
 735                 print STDERR ("=> link \"$o\" to \%$pkg","::opt_$ov\n")
 736                     if $debug;
 737                 eval ("\$linkage{\$o} = \\\%".$pkg."::opt_$ov;");
 738             }
 739             else {
 740                 print STDERR ("=> link \"$o\" to \$$pkg","::opt_$ov\n")
 741                     if $debug;
 742                 eval ("\$linkage{\$o} = \\\$".$pkg."::opt_$ov;");
 743             }
 744         }
 745     }
 746
 747     # Bail out if errors found.
 748     return 0 if $error;
 749
 750     # Sort the possible long option names.
 751     @opctl = sort(keys (%opctl)) if $autoabbrev;
 752
 753     # Show the options tables if debugging.
 754     if ( $debug ) {
 755         my ($arrow, $k, $v);
 756         $arrow = "=> ";
 757         while ( ($k,$v) = each(%opctl) ) {
 758             print STDERR ($arrow, "\$opctl{\"$k\"} = \"$v\"\n");
 759             $arrow = "   ";
 760         }
 761         $arrow = "=> ";
 762         while ( ($k,$v) = each(%bopctl) ) {
 763             print STDERR ($arrow, "\$bopctl{\"$k\"} = \"$v\"\n");
 764             $arrow = "   ";
 765         }
 766     }
 767
 768     # Process argument list
 769     while ( @ARGV > 0 ) {
 770
 771         #### Get next argument ####
 772
 773         $opt = shift (@ARGV);
 774         $arg = undef;
 775         $array = $hash = 0;
 776         print STDERR ("=> option \"", $opt, "\"\n") if $debug;
 777
 778         #### Determine what we have ####
 779
 780         # Double dash is option list terminator.
 781         if ( $opt eq $argend ) {
 782             # Finish. Push back accumulated arguments and return.
 783             unshift (@ARGV, @ret)
 784                 if $order == $PERMUTE;
 785             return ($error == 0);
 786         }
 787
 788         my $tryopt = $opt;
 789
 790         # find_option operates on the GLOBAL $opt and $arg!
 791         if ( &$find_option () ) {
 792
 793             # find_option undefines $opt in case of errors.
 794             next unless defined $opt;
 795
 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             }
 858         }
 859
 860         # Not an option. Save it if we $PERMUTE and don't have a <>.
 861         elsif ( $order == $PERMUTE ) {
 862             # Try non-options call-back.
 863             my $cb;
 864             if ( (defined ($cb = $linkage{'<>'})) ) {
 865                 &$cb($tryopt);
 866             }
 867             else {
 868                 print STDERR ("=> saving \"$tryopt\" ",
 869                               "(not an option, may permute)\n") if $debug;
 870                 push (@ret, $tryopt);
 871             }
 872             next;
 873         }
 874
 875         # ...otherwise, terminate.
 876         else {
 877             # Push this one back and exit.
 878             unshift (@ARGV, $tryopt);
 879             return ($error == 0);
 880         }
 881
 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
 895 sub 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.
 946 sub 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 {
 967
 968     return 0 unless $opt =~ /^$genprefix/;
 969
 970     $opt = $';
 971     my ($starter) = $&;
 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)
 978         && $opt =~ /^([^=]+)=/ ) {
 979         $opt = $1;
 980         $optarg = $';
 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)
 989     my $type;
 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
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         }
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;
1033                 print STDERR ("Option ", $opt, " is ambiguous (",
1034                               join(", ", @hits), ")\n");
1035                 $error++;
1036                 undef $opt;
1037                 return 1;
1038             }
1039             @hits = keys(%hit);
1040         }
1041
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;
1048         }
1049     }
1050
1051     # Map to all lowercase if ignoring case.
1052     elsif ( $ignorecase ) {
1053         $tryopt = lc ($opt);
1054     }
1055
1056     # Check validity by fetching the info.
1057     $type = $optbl->{$tryopt} unless defined $type;
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;
1067
1068     #### Determine argument status ####
1069
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     }
1088
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;
1105         }
1106         return 1;
1107     }
1108
1109     # Get (possibly optional) argument.
1110     $arg = (defined $rest ? $rest
1111             : (defined $optarg ? $optarg : shift (@ARGV)));
1112
1113     # Get key if this is a "name=value" pair for a hash option.
1114     $key = undef;
1115     if ($hash && defined $arg) {
1116         ($key, $arg) = ($arg =~ /=/o) ? ($`, $') : ($arg, 1);
1117     }
1118
1119     #### Check if the argument is valid for this option ####
1120
1121     if ( $type eq "s" ) {       # string
1122         # A mandatory string takes anything.
1123         return 1 if $mand eq "=";
1124
1125         # An optional string takes almost anything.
1126         return 1 if defined $optarg || defined $rest;
1127         return 1 if $arg eq "-"; # ??
1128
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 = '';
1136         }
1137     }
1138
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;
1155             }
1156         }
1157     }
1158
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;
1169             }
1170             else {
1171                 # Push back.
1172                 unshift (@ARGV, defined $rest ? $starter.$rest : $arg);
1173                 # Supply default value.
1174                 $arg = 0.0;
1175             }
1176         }
1177     }
1178     else {
1179         die ("GetOpt::Long internal error (Can't happen)\n");
1180     }
1181     return 1;
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 ();
1216
1217 ################ Package return ################
1218
1219 1;