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