lib/Getopt/Long.pm

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