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