lib/Getopt/Long.pm

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