lib/Getopt/Long.pm

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