lib/Getopt/Long.pm

   1 # Getopt::Long.pm -- Universal options parsing
   2
   3 package Getopt::Long;
   4
   5 # RCS Status      : $Id: GetoptLong.pm,v 2.68 2003-09-23 15:24:53+02 jv Exp jv $
   6 # Author          : Johan Vromans
   7 # Created On      : Tue Sep 11 15:00:12 1990
   8 # Last Modified By: Johan Vromans
   9 # Last Modified On: Wed Dec 31 20:48:15 2003
  10 # Update Count    : 1440
  11 # Status          : Released
  12
  13 ################ Copyright ################
  14
  15 # This program is Copyright 1990,2002 by Johan Vromans.
  16 # This program is free software; you can redistribute it and/or
  17 # modify it under the terms of the Perl Artistic License or the
  18 # GNU General Public License as published by the Free Software
  19 # Foundation; either version 2 of the License, or (at your option) any
  20 # later version.
  21 #
  22 # This program is distributed in the hope that it will be useful,
  23 # but WITHOUT ANY WARRANTY; without even the implied warranty of
  24 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  25 # GNU General Public License for more details.
  26 #
  27 # If you do not have a copy of the GNU General Public License write to
  28 # the Free Software Foundation, Inc., 675 Mass Ave, Cambridge,
  29 # MA 02139, USA.
  30
  31 ################ Module Preamble ################
  32
  33 use 5.004;
  34
  35 use strict;
  36
  37 use vars qw($VERSION);
  38 $VERSION        =  2.3401;
  39 # For testing versions only.
  40 use vars qw($VERSION_STRING);
  41 $VERSION_STRING = "2.34_01";
  42
  43 use Exporter;
  44 use vars qw(@ISA @EXPORT @EXPORT_OK);
  45 @ISA = qw(Exporter);
  46
  47 # Exported subroutines.
  48 sub GetOptions(@);              # always
  49 sub Configure(@);               # on demand
  50 sub HelpMessage(@);             # on demand
  51 sub VersionMessage(@);          # in demand
  52
  53 BEGIN {
  54     # Init immediately so their contents can be used in the 'use vars' below.
  55     @EXPORT    = qw(&GetOptions $REQUIRE_ORDER $PERMUTE $RETURN_IN_ORDER);
  56     @EXPORT_OK = qw(&HelpMessage &VersionMessage &Configure);
  57 }
  58
  59 # User visible variables.
  60 use vars @EXPORT, @EXPORT_OK;
  61 use vars qw($error $debug $major_version $minor_version);
  62 # Deprecated visible variables.
  63 use vars qw($autoabbrev $getopt_compat $ignorecase $bundling $order
  64             $passthrough);
  65 # Official invisible variables.
  66 use vars qw($genprefix $caller $gnu_compat $auto_help $auto_version);
  67
  68 # Public subroutines.
  69 sub config(@);                  # deprecated name
  70
  71 # Private subroutines.
  72 sub ConfigDefaults();
  73 sub ParseOptionSpec($$);
  74 sub OptCtl($);
  75 sub FindOption($$$$);
  76 sub ValidValue ($$$$$);
  77
  78 ################ Local Variables ################
  79
  80 # $requested_version holds the version that was mentioned in the 'use'
  81 # or 'require', if any. It can be used to enable or disable specific
  82 # features.
  83 my $requested_version = 0;
  84
  85 ################ Resident subroutines ################
  86
  87 sub ConfigDefaults() {
  88     # Handle POSIX compliancy.
  89     if ( defined $ENV{"POSIXLY_CORRECT"} ) {
  90         $genprefix = "(--|-)";
  91         $autoabbrev = 0;                # no automatic abbrev of options
  92         $bundling = 0;                  # no bundling of single letter switches
  93         $getopt_compat = 0;             # disallow '+' to start options
  94         $order = $REQUIRE_ORDER;
  95     }
  96     else {
  97         $genprefix = "(--|-|\\+)";
  98         $autoabbrev = 1;                # automatic abbrev of options
  99         $bundling = 0;                  # bundling off by default
 100         $getopt_compat = 1;             # allow '+' to start options
 101         $order = $PERMUTE;
 102     }
 103     # Other configurable settings.
 104     $debug = 0;                 # for debugging
 105     $error = 0;                 # error tally
 106     $ignorecase = 1;            # ignore case when matching options
 107     $passthrough = 0;           # leave unrecognized options alone
 108     $gnu_compat = 0;            # require --opt=val if value is optional
 109 }
 110
 111 # Override import.
 112 sub import {
 113     my $pkg = shift;            # package
 114     my @syms = ();              # symbols to import
 115     my @config = ();            # configuration
 116     my $dest = \@syms;          # symbols first
 117     for ( @_ ) {
 118         if ( $_ eq ':config' ) {
 119             $dest = \@config;   # config next
 120             next;
 121         }
 122         push(@$dest, $_);       # push
 123     }
 124     # Hide one level and call super.
 125     local $Exporter::ExportLevel = 1;
 126     push(@syms, qw(&GetOptions)) if @syms; # always export GetOptions
 127     $pkg->SUPER::import(@syms);
 128     # And configure.
 129     Configure(@config) if @config;
 130 }
 131
 132 ################ Initialization ################
 133
 134 # Values for $order. See GNU getopt.c for details.
 135 ($REQUIRE_ORDER, $PERMUTE, $RETURN_IN_ORDER) = (0..2);
 136 # Version major/minor numbers.
 137 ($major_version, $minor_version) = $VERSION =~ /^(\d+)\.(\d+)/;
 138
 139 ConfigDefaults();
 140
 141 ################ OO Interface ################
 142
 143 package Getopt::Long::Parser;
 144
 145 # Store a copy of the default configuration. Since ConfigDefaults has
 146 # just been called, what we get from Configure is the default.
 147 my $default_config = do {
 148     Getopt::Long::Configure ()
 149 };
 150
 151 sub new {
 152     my $that = shift;
 153     my $class = ref($that) || $that;
 154     my %atts = @_;
 155
 156     # Register the callers package.
 157     my $self = { caller_pkg => (caller)[0] };
 158
 159     bless ($self, $class);
 160
 161     # Process config attributes.
 162     if ( defined $atts{config} ) {
 163         my $save = Getopt::Long::Configure ($default_config, @{$atts{config}});
 164         $self->{settings} = Getopt::Long::Configure ($save);
 165         delete ($atts{config});
 166     }
 167     # Else use default config.
 168     else {
 169         $self->{settings} = $default_config;
 170     }
 171
 172     if ( %atts ) {              # Oops
 173         die(__PACKAGE__.": unhandled attributes: ".
 174             join(" ", sort(keys(%atts)))."\n");
 175     }
 176
 177     $self;
 178 }
 179
 180 sub configure {
 181     my ($self) = shift;
 182
 183     # Restore settings, merge new settings in.
 184     my $save = Getopt::Long::Configure ($self->{settings}, @_);
 185
 186     # Restore orig config and save the new config.
 187     $self->{settings} = Getopt::Long::Configure ($save);
 188 }
 189
 190 sub getoptions {
 191     my ($self) = shift;
 192
 193     # Restore config settings.
 194     my $save = Getopt::Long::Configure ($self->{settings});
 195
 196     # Call main routine.
 197     my $ret = 0;
 198     $Getopt::Long::caller = $self->{caller_pkg};
 199
 200     eval {
 201         # Locally set exception handler to default, otherwise it will
 202         # be called implicitly here, and again explicitly when we try
 203         # to deliver the messages.
 204         local ($SIG{__DIE__}) = '__DEFAULT__';
 205         $ret = Getopt::Long::GetOptions (@_);
 206     };
 207
 208     # Restore saved settings.
 209     Getopt::Long::Configure ($save);
 210
 211     # Handle errors and return value.
 212     die ($@) if $@;
 213     return $ret;
 214 }
 215
 216 package Getopt::Long;
 217
 218 ################ Back to Normal ################
 219
 220 # Indices in option control info.
 221 # Note that ParseOptions uses the fields directly. Search for 'hard-wired'.
 222 use constant CTL_TYPE    => 0;
 223 #use constant   CTL_TYPE_FLAG   => '';
 224 #use constant   CTL_TYPE_NEG    => '!';
 225 #use constant   CTL_TYPE_INCR   => '+';
 226 #use constant   CTL_TYPE_INT    => 'i';
 227 #use constant   CTL_TYPE_INTINC => 'I';
 228 #use constant   CTL_TYPE_XINT   => 'o';
 229 #use constant   CTL_TYPE_FLOAT  => 'f';
 230 #use constant   CTL_TYPE_STRING => 's';
 231
 232 use constant CTL_CNAME   => 1;
 233
 234 use constant CTL_DEFAULT => 2;
 235
 236 use constant CTL_DEST    => 3;
 237  use constant   CTL_DEST_SCALAR => 0;
 238  use constant   CTL_DEST_ARRAY  => 1;
 239  use constant   CTL_DEST_HASH   => 2;
 240  use constant   CTL_DEST_CODE   => 3;
 241
 242 use constant CTL_AMIN    => 4;
 243 use constant CTL_AMAX    => 5;
 244
 245 # FFU.
 246 #use constant CTL_RANGE   => ;
 247 #use constant CTL_REPEAT  => ;
 248
 249 sub GetOptions(@) {
 250
 251     my @optionlist = @_;        # local copy of the option descriptions
 252     my $argend = '--';          # option list terminator
 253     my %opctl = ();             # table of option specs
 254     my $pkg = $caller || (caller)[0];   # current context
 255                                 # Needed if linkage is omitted.
 256     my @ret = ();               # accum for non-options
 257     my %linkage;                # linkage
 258     my $userlinkage;            # user supplied HASH
 259     my $opt;                    # current option
 260     my $prefix = $genprefix;    # current prefix
 261
 262     $error = '';
 263
 264     if ( $debug ) {
 265         # Avoid some warnings if debugging.
 266         local ($^W) = 0;
 267         print STDERR
 268           ("Getopt::Long $Getopt::Long::VERSION (",
 269            '$Revision: 2.68 $', ") ",
 270            "called from package \"$pkg\".",
 271            "\n  ",
 272            "ARGV: (@ARGV)",
 273            "\n  ",
 274            "autoabbrev=$autoabbrev,".
 275            "bundling=$bundling,",
 276            "getopt_compat=$getopt_compat,",
 277            "gnu_compat=$gnu_compat,",
 278            "order=$order,",
 279            "\n  ",
 280            "ignorecase=$ignorecase,",
 281            "requested_version=$requested_version,",
 282            "passthrough=$passthrough,",
 283            "genprefix=\"$genprefix\".",
 284            "\n");
 285     }
 286
 287     # Check for ref HASH as first argument.
 288     # First argument may be an object. It's OK to use this as long
 289     # as it is really a hash underneath.
 290     $userlinkage = undef;
 291     if ( @optionlist && ref($optionlist[0]) and
 292          "$optionlist[0]" =~ /^(?:.*\=)?HASH\([^\(]*\)$/ ) {
 293         $userlinkage = shift (@optionlist);
 294         print STDERR ("=> user linkage: $userlinkage\n") if $debug;
 295     }
 296
 297     # See if the first element of the optionlist contains option
 298     # starter characters.
 299     # Be careful not to interpret '<>' as option starters.
 300     if ( @optionlist && $optionlist[0] =~ /^\W+$/
 301          && !($optionlist[0] eq '<>'
 302               && @optionlist > 0
 303               && ref($optionlist[1])) ) {
 304         $prefix = shift (@optionlist);
 305         # Turn into regexp. Needs to be parenthesized!
 306         $prefix =~ s/(\W)/\\$1/g;
 307         $prefix = "([" . $prefix . "])";
 308         print STDERR ("=> prefix=\"$prefix\"\n") if $debug;
 309     }
 310
 311     # Verify correctness of optionlist.
 312     %opctl = ();
 313     while ( @optionlist ) {
 314         my $opt = shift (@optionlist);
 315
 316         # Strip leading prefix so people can specify "--foo=i" if they like.
 317         $opt = $+ if $opt =~ /^$prefix+(.*)$/s;
 318
 319         if ( $opt eq '<>' ) {
 320             if ( (defined $userlinkage)
 321                 && !(@optionlist > 0 && ref($optionlist[0]))
 322                 && (exists $userlinkage->{$opt})
 323                 && ref($userlinkage->{$opt}) ) {
 324                 unshift (@optionlist, $userlinkage->{$opt});
 325             }
 326             unless ( @optionlist > 0
 327                     && ref($optionlist[0]) && ref($optionlist[0]) eq 'CODE' ) {
 328                 $error .= "Option spec <> requires a reference to a subroutine\n";
 329                 # Kill the linkage (to avoid another error).
 330                 shift (@optionlist)
 331                   if @optionlist && ref($optionlist[0]);
 332                 next;
 333             }
 334             $linkage{'<>'} = shift (@optionlist);
 335             next;
 336         }
 337
 338         # Parse option spec.
 339         my ($name, $orig) = ParseOptionSpec ($opt, \%opctl);
 340         unless ( defined $name ) {
 341             # Failed. $orig contains the error message. Sorry for the abuse.
 342             $error .= $orig;
 343             # Kill the linkage (to avoid another error).
 344             shift (@optionlist)
 345               if @optionlist && ref($optionlist[0]);
 346             next;
 347         }
 348
 349         # If no linkage is supplied in the @optionlist, copy it from
 350         # the userlinkage if available.
 351         if ( defined $userlinkage ) {
 352             unless ( @optionlist > 0 && ref($optionlist[0]) ) {
 353                 if ( exists $userlinkage->{$orig} &&
 354                      ref($userlinkage->{$orig}) ) {
 355                     print STDERR ("=> found userlinkage for \"$orig\": ",
 356                                   "$userlinkage->{$orig}\n")
 357                         if $debug;
 358                     unshift (@optionlist, $userlinkage->{$orig});
 359                 }
 360                 else {
 361                     # Do nothing. Being undefined will be handled later.
 362                     next;
 363                 }
 364             }
 365         }
 366
 367         # Copy the linkage. If omitted, link to global variable.
 368         if ( @optionlist > 0 && ref($optionlist[0]) ) {
 369             print STDERR ("=> link \"$orig\" to $optionlist[0]\n")
 370                 if $debug;
 371             my $rl = ref($linkage{$orig} = shift (@optionlist));
 372
 373             if ( $rl eq "ARRAY" ) {
 374                 $opctl{$name}[CTL_DEST] = CTL_DEST_ARRAY;
 375             }
 376             elsif ( $rl eq "HASH" ) {
 377                 $opctl{$name}[CTL_DEST] = CTL_DEST_HASH;
 378             }
 379             elsif ( $rl eq "SCALAR" ) {
 380 #               if ( $opctl{$name}[CTL_DEST] == CTL_DEST_ARRAY ) {
 381 #                   my $t = $linkage{$orig};
 382 #                   $$t = $linkage{$orig} = [];
 383 #               }
 384 #               elsif ( $opctl{$name}[CTL_DEST] == CTL_DEST_HASH ) {
 385 #               }
 386 #               else {
 387                     # Ok.
 388 #               }
 389             }
 390             elsif ( $rl eq "CODE" ) {
 391                 # Ok.
 392             }
 393             else {
 394                 $error .= "Invalid option linkage for \"$opt\"\n";
 395             }
 396         }
 397         else {
 398             # Link to global $opt_XXX variable.
 399             # Make sure a valid perl identifier results.
 400             my $ov = $orig;
 401             $ov =~ s/\W/_/g;
 402             if ( $opctl{$name}[CTL_DEST] == CTL_DEST_ARRAY ) {
 403                 print STDERR ("=> link \"$orig\" to \@$pkg","::opt_$ov\n")
 404                     if $debug;
 405                 eval ("\$linkage{\$orig} = \\\@".$pkg."::opt_$ov;");
 406             }
 407             elsif ( $opctl{$name}[CTL_DEST] == CTL_DEST_HASH ) {
 408                 print STDERR ("=> link \"$orig\" to \%$pkg","::opt_$ov\n")
 409                     if $debug;
 410                 eval ("\$linkage{\$orig} = \\\%".$pkg."::opt_$ov;");
 411             }
 412             else {
 413                 print STDERR ("=> link \"$orig\" to \$$pkg","::opt_$ov\n")
 414                     if $debug;
 415                 eval ("\$linkage{\$orig} = \\\$".$pkg."::opt_$ov;");
 416             }
 417         }
 418     }
 419
 420     # Bail out if errors found.
 421     die ($error) if $error;
 422     $error = 0;
 423
 424     # Supply --version and --help support, if needed and allowed.
 425     if ( defined($auto_version) ? $auto_version : ($requested_version >= 2.3203) ) {
 426         if ( !defined($opctl{version}) ) {
 427             $opctl{version} = ['','version',0,CTL_DEST_CODE,undef];
 428             $linkage{version} = \&VersionMessage;
 429         }
 430         $auto_version = 1;
 431     }
 432     if ( defined($auto_help) ? $auto_help : ($requested_version >= 2.3203) ) {
 433         if ( !defined($opctl{help}) && !defined($opctl{'?'}) ) {
 434             $opctl{help} = $opctl{'?'} = ['','help',0,CTL_DEST_CODE,undef];
 435             $linkage{help} = \&HelpMessage;
 436         }
 437         $auto_help = 1;
 438     }
 439
 440     # Show the options tables if debugging.
 441     if ( $debug ) {
 442         my ($arrow, $k, $v);
 443         $arrow = "=> ";
 444         while ( ($k,$v) = each(%opctl) ) {
 445             print STDERR ($arrow, "\$opctl{$k} = $v ", OptCtl($v), "\n");
 446             $arrow = "   ";
 447         }
 448     }
 449
 450     # Process argument list
 451     my $goon = 1;
 452     while ( $goon && @ARGV > 0 ) {
 453
 454         # Get next argument.
 455         $opt = shift (@ARGV);
 456         print STDERR ("=> arg \"", $opt, "\"\n") if $debug;
 457
 458         # Double dash is option list terminator.
 459         if ( $opt eq $argend ) {
 460           push (@ret, $argend) if $passthrough;
 461           last;
 462         }
 463
 464         # Look it up.
 465         my $tryopt = $opt;
 466         my $found;              # success status
 467         my $key;                # key (if hash type)
 468         my $arg;                # option argument
 469         my $ctl;                # the opctl entry
 470
 471         ($found, $opt, $ctl, $arg, $key) =
 472           FindOption ($prefix, $argend, $opt, \%opctl);
 473
 474         if ( $found ) {
 475
 476             # FindOption undefines $opt in case of errors.
 477             next unless defined $opt;
 478
 479             my $argcnt = 0;
 480             while ( defined $arg ) {
 481
 482                 # Get the canonical name.
 483                 print STDERR ("=> cname for \"$opt\" is ") if $debug;
 484                 $opt = $ctl->[CTL_CNAME];
 485                 print STDERR ("\"$ctl->[CTL_CNAME]\"\n") if $debug;
 486
 487                 if ( defined $linkage{$opt} ) {
 488                     print STDERR ("=> ref(\$L{$opt}) -> ",
 489                                   ref($linkage{$opt}), "\n") if $debug;
 490
 491                     if ( ref($linkage{$opt}) eq 'SCALAR' ) {
 492                         if ( $ctl->[CTL_TYPE] eq '+' ) {
 493                             print STDERR ("=> \$\$L{$opt} += \"$arg\"\n")
 494                               if $debug;
 495                             if ( defined ${$linkage{$opt}} ) {
 496                                 ${$linkage{$opt}} += $arg;
 497                             }
 498                             else {
 499                                 ${$linkage{$opt}} = $arg;
 500                             }
 501                         }
 502                         elsif ( $ctl->[CTL_DEST] == CTL_DEST_ARRAY ) {
 503                             print STDERR ("=> ref(\$L{$opt}) auto-vivified",
 504                                           " to ARRAY\n")
 505                               if $debug;
 506                             my $t = $linkage{$opt};
 507                             $$t = $linkage{$opt} = [];
 508                             print STDERR ("=> push(\@{\$L{$opt}, \"$arg\")\n")
 509                               if $debug;
 510                             push (@{$linkage{$opt}}, $arg);
 511                         }
 512                         elsif ( $ctl->[CTL_DEST] == CTL_DEST_HASH ) {
 513                             print STDERR ("=> ref(\$L{$opt}) auto-vivified",
 514                                           " to HASH\n")
 515                               if $debug;
 516                             my $t = $linkage{$opt};
 517                             $$t = $linkage{$opt} = {};
 518                             print STDERR ("=> \$\$L{$opt}->{$key} = \"$arg\"\n")
 519                               if $debug;
 520                             $linkage{$opt}->{$key} = $arg;
 521                         }
 522                         else {
 523                             print STDERR ("=> \$\$L{$opt} = \"$arg\"\n")
 524                               if $debug;
 525                             ${$linkage{$opt}} = $arg;
 526                         }
 527                     }
 528                     elsif ( ref($linkage{$opt}) eq 'ARRAY' ) {
 529                         print STDERR ("=> push(\@{\$L{$opt}, \"$arg\")\n")
 530                             if $debug;
 531                         push (@{$linkage{$opt}}, $arg);
 532                     }
 533                     elsif ( ref($linkage{$opt}) eq 'HASH' ) {
 534                         print STDERR ("=> \$\$L{$opt}->{$key} = \"$arg\"\n")
 535                             if $debug;
 536                         $linkage{$opt}->{$key} = $arg;
 537                     }
 538                     elsif ( ref($linkage{$opt}) eq 'CODE' ) {
 539                         print STDERR ("=> &L{$opt}(\"$opt\"",
 540                                       $ctl->[CTL_DEST] == CTL_DEST_HASH ? ", \"$key\"" : "",
 541                                       ", \"$arg\")\n")
 542                             if $debug;
 543                         my $eval_error = do {
 544                             local $@;
 545                             local $SIG{__DIE__}  = '__DEFAULT__';
 546                             eval {
 547                                 &{$linkage{$opt}}($opt,
 548                                                   $ctl->[CTL_DEST] == CTL_DEST_HASH ? ($key) : (),
 549                                                   $arg);
 550                             };
 551                             $@;
 552                         };
 553                         print STDERR ("=> die($eval_error)\n")
 554                           if $debug && $eval_error ne '';
 555                         if ( $eval_error =~ /^!/ ) {
 556                             if ( $eval_error =~ /^!FINISH\b/ ) {
 557                                 $goon = 0;
 558                             }
 559                         }
 560                         elsif ( $eval_error ne '' ) {
 561                             warn ($eval_error);
 562                             $error++;
 563                         }
 564                     }
 565                     else {
 566                         print STDERR ("Invalid REF type \"", ref($linkage{$opt}),
 567                                       "\" in linkage\n");
 568                         die("Getopt::Long -- internal error!\n");
 569                     }
 570                 }
 571                 # No entry in linkage means entry in userlinkage.
 572                 elsif ( $ctl->[CTL_DEST] == CTL_DEST_ARRAY ) {
 573                     if ( defined $userlinkage->{$opt} ) {
 574                         print STDERR ("=> push(\@{\$L{$opt}}, \"$arg\")\n")
 575                             if $debug;
 576                         push (@{$userlinkage->{$opt}}, $arg);
 577                     }
 578                     else {
 579                         print STDERR ("=>\$L{$opt} = [\"$arg\"]\n")
 580                             if $debug;
 581                         $userlinkage->{$opt} = [$arg];
 582                     }
 583                 }
 584                 elsif ( $ctl->[CTL_DEST] == CTL_DEST_HASH ) {
 585                     if ( defined $userlinkage->{$opt} ) {
 586                         print STDERR ("=> \$L{$opt}->{$key} = \"$arg\"\n")
 587                             if $debug;
 588                         $userlinkage->{$opt}->{$key} = $arg;
 589                     }
 590                     else {
 591                         print STDERR ("=>\$L{$opt} = {$key => \"$arg\"}\n")
 592                             if $debug;
 593                         $userlinkage->{$opt} = {$key => $arg};
 594                     }
 595                 }
 596                 else {
 597                     if ( $ctl->[CTL_TYPE] eq '+' ) {
 598                         print STDERR ("=> \$L{$opt} += \"$arg\"\n")
 599                           if $debug;
 600                         if ( defined $userlinkage->{$opt} ) {
 601                             $userlinkage->{$opt} += $arg;
 602                         }
 603                         else {
 604                             $userlinkage->{$opt} = $arg;
 605                         }
 606                     }
 607                     else {
 608                         print STDERR ("=>\$L{$opt} = \"$arg\"\n") if $debug;
 609                         $userlinkage->{$opt} = $arg;
 610                     }
 611                 }
 612
 613                 $argcnt++;
 614                 last if $argcnt >= $ctl->[CTL_AMAX];
 615                 undef($arg);
 616
 617                 # Need more args?
 618                 if ( $argcnt < $ctl->[CTL_AMIN] ) {
 619                     if ( @ARGV ) {
 620                         if ( ValidValue($ctl, $ARGV[0], 1, $argend, $prefix) ) {
 621                             $arg = shift(@ARGV);
 622                             ($key,$arg) = $arg =~ /^([^=]+)=(.*)/
 623                               if $ctl->[CTL_DEST] == CTL_DEST_HASH;
 624                             next;
 625                         }
 626                         warn("Value \"$ARGV[0]\" invalid for option $opt\n");
 627                         $error++;
 628                     }
 629                     else {
 630                         warn("Insufficient arguments for option $opt\n");
 631                         $error++;
 632                     }
 633                 }
 634
 635                 # Any more args?
 636                 if ( @ARGV && ValidValue($ctl, $ARGV[0], 0, $argend, $prefix) ) {
 637                     $arg = shift(@ARGV);
 638                     ($key,$arg) = $arg =~ /^([^=]+)=(.*)/
 639                       if $ctl->[CTL_DEST] == CTL_DEST_HASH;
 640                     next;
 641                 }
 642             }
 643         }
 644
 645         # Not an option. Save it if we $PERMUTE and don't have a <>.
 646         elsif ( $order == $PERMUTE ) {
 647             # Try non-options call-back.
 648             my $cb;
 649             if ( (defined ($cb = $linkage{'<>'})) ) {
 650                 print STDERR ("=> &L{$tryopt}(\"$tryopt\")\n")
 651                   if $debug;
 652                 my $eval_error = do {
 653                     local $@;
 654                     local $SIG{__DIE__}  = '__DEFAULT__';
 655                     eval { &$cb ($tryopt) };
 656                     $@;
 657                 };
 658                 print STDERR ("=> die($eval_error)\n")
 659                   if $debug && $eval_error ne '';
 660                 if ( $eval_error =~ /^!/ ) {
 661                     if ( $eval_error =~ /^!FINISH\b/ ) {
 662                         $goon = 0;
 663                     }
 664                 }
 665                 elsif ( $eval_error ne '' ) {
 666                     warn ($eval_error);
 667                     $error++;
 668                 }
 669             }
 670             else {
 671                 print STDERR ("=> saving \"$tryopt\" ",
 672                               "(not an option, may permute)\n") if $debug;
 673                 push (@ret, $tryopt);
 674             }
 675             next;
 676         }
 677
 678         # ...otherwise, terminate.
 679         else {
 680             # Push this one back and exit.
 681             unshift (@ARGV, $tryopt);
 682             return ($error == 0);
 683         }
 684
 685     }
 686
 687     # Finish.
 688     if ( @ret && $order == $PERMUTE ) {
 689         #  Push back accumulated arguments
 690         print STDERR ("=> restoring \"", join('" "', @ret), "\"\n")
 691             if $debug;
 692         unshift (@ARGV, @ret);
 693     }
 694
 695     return ($error == 0);
 696 }
 697
 698 # A readable representation of what's in an optbl.
 699 sub OptCtl ($) {
 700     my ($v) = @_;
 701     my @v = map { defined($_) ? ($_) : ("<undef>") } @$v;
 702     "[".
 703       join(",",
 704            "\"$v[CTL_TYPE]\"",
 705            "\"$v[CTL_CNAME]\"",
 706            "\"$v[CTL_DEFAULT]\"",
 707            ("\$","\@","\%","\&")[$v[CTL_DEST] || 0],
 708            $v[CTL_AMIN] || '',
 709            $v[CTL_AMAX] || '',
 710 #          $v[CTL_RANGE] || '',
 711 #          $v[CTL_REPEAT] || '',
 712           ). "]";
 713 }
 714
 715 # Parse an option specification and fill the tables.
 716 sub ParseOptionSpec ($$) {
 717     my ($opt, $opctl) = @_;
 718
 719     # Match option spec.
 720     if ( $opt !~ m;^
 721                    (
 722                      # Option name
 723                      (?: \w+[-\w]* )
 724                      # Alias names, or "?"
 725                      (?: \| (?: \? | \w[-\w]* )? )*
 726                    )?
 727                    (
 728                      # Either modifiers ...
 729                      [!+]
 730                      |
 731                      # ... or a value/dest/repeat specification
 732                      [=:] [ionfs] [@%]? (?: \{\d*,?\d*\} )?
 733                      |
 734                      # ... or an optional-with-default spec
 735                      : (?: -?\d+ | \+ ) [@%]?
 736                    )?
 737                    $;x ) {
 738         return (undef, "Error in option spec: \"$opt\"\n");
 739     }
 740
 741     my ($names, $spec) = ($1, $2);
 742     $spec = '' unless defined $spec;
 743
 744     # $orig keeps track of the primary name the user specified.
 745     # This name will be used for the internal or external linkage.
 746     # In other words, if the user specifies "FoO|BaR", it will
 747     # match any case combinations of 'foo' and 'bar', but if a global
 748     # variable needs to be set, it will be $opt_FoO in the exact case
 749     # as specified.
 750     my $orig;
 751
 752     my @names;
 753     if ( defined $names ) {
 754         @names =  split (/\|/, $names);
 755         $orig = $names[0];
 756     }
 757     else {
 758         @names = ('');
 759         $orig = '';
 760     }
 761
 762     # Construct the opctl entries.
 763     my $entry;
 764     if ( $spec eq '' || $spec eq '+' || $spec eq '!' ) {
 765         # Fields are hard-wired here.
 766         $entry = [$spec,$orig,undef,CTL_DEST_SCALAR,0,0];
 767     }
 768     elsif ( $spec =~ /^:(-?\d+|\+)([@%])?$/ ) {
 769         my $def = $1;
 770         my $dest = $2;
 771         my $type = $def eq '+' ? 'I' : 'i';
 772         $dest ||= '$';
 773         $dest = $dest eq '@' ? CTL_DEST_ARRAY
 774           : $dest eq '%' ? CTL_DEST_HASH : CTL_DEST_SCALAR;
 775         # Fields are hard-wired here.
 776         $entry = [$type,$orig,$def eq '+' ? undef : $def,
 777                   $dest,0,1];
 778     }
 779     else {
 780         my ($mand, $type, $dest) =
 781           $spec =~ /^([=:])([ionfs])([@%])?(\{(\d+)?(,)?(\d+)?\})?$/;
 782         return (undef, "Cannot repeat while bundling: \"$opt\"\n")
 783           if $bundling && defined($4);
 784         my ($mi, $cm, $ma) = ($5, $6, $7);
 785         return (undef, "{0} is useless in option spec: \"$opt\"\n")
 786           if defined($mi) && !$mi && !defined($ma) && !defined($cm);
 787
 788         $type = 'i' if $type eq 'n';
 789         $dest ||= '$';
 790         $dest = $dest eq '@' ? CTL_DEST_ARRAY
 791           : $dest eq '%' ? CTL_DEST_HASH : CTL_DEST_SCALAR;
 792         # Default minargs to 1/0 depending on mand status.
 793         $mi = $mand eq '=' ? 1 : 0 unless defined $mi;
 794         # Adjust mand status according to minargs.
 795         $mand = $mi ? '=' : ':';
 796         # Adjust maxargs.
 797         $ma = $mi ? $mi : 1 unless defined $ma || defined $cm;
 798         return (undef, "Max must be greater than zero in option spec: \"$opt\"\n")
 799           if defined($ma) && !$ma;
 800         return (undef, "Max less than min in option spec: \"$opt\"\n")
 801           if defined($ma) && $ma < $mi;
 802
 803         # Fields are hard-wired here.
 804         $entry = [$type,$orig,undef,$dest,$mi,$ma||-1];
 805     }
 806
 807     # Process all names. First is canonical, the rest are aliases.
 808     my $dups = '';
 809     foreach ( @names ) {
 810
 811         $_ = lc ($_)
 812           if $ignorecase > (($bundling && length($_) == 1) ? 1 : 0);
 813
 814         if ( exists $opctl->{$_} ) {
 815             $dups .= "Duplicate specification \"$opt\" for option \"$_\"\n";
 816         }
 817
 818         if ( $spec eq '!' ) {
 819             $opctl->{"no$_"} = $entry;
 820             $opctl->{"no-$_"} = $entry;
 821             $opctl->{$_} = [@$entry];
 822             $opctl->{$_}->[CTL_TYPE] = '';
 823         }
 824         else {
 825             $opctl->{$_} = $entry;
 826         }
 827     }
 828
 829     if ( $dups && $^W ) {
 830         foreach ( split(/\n+/, $dups) ) {
 831             warn($_."\n");
 832         }
 833     }
 834     ($names[0], $orig);
 835 }
 836
 837 # Option lookup.
 838 sub FindOption ($$$$) {
 839
 840     # returns (1, $opt, $ctl, $arg, $key) if okay,
 841     # returns (1, undef) if option in error,
 842     # returns (0) otherwise.
 843
 844     my ($prefix, $argend, $opt, $opctl) = @_;
 845
 846     print STDERR ("=> find \"$opt\"\n") if $debug;
 847
 848     return (0) unless $opt =~ /^$prefix(.*)$/s;
 849     return (0) if $opt eq "-" && !defined $opctl->{''};
 850
 851     $opt = $+;
 852     my $starter = $1;
 853
 854     print STDERR ("=> split \"$starter\"+\"$opt\"\n") if $debug;
 855
 856     my $optarg;                 # value supplied with --opt=value
 857     my $rest;                   # remainder from unbundling
 858
 859     # If it is a long option, it may include the value.
 860     # With getopt_compat, only if not bundling.
 861     if ( ($starter eq "--"
 862           || ($getopt_compat && ($bundling == 0 || $bundling == 2)))
 863           && $opt =~ /^([^=]+)=(.*)$/s ) {
 864         $opt = $1;
 865         $optarg = $2;
 866         print STDERR ("=> option \"", $opt,
 867                       "\", optarg = \"$optarg\"\n") if $debug;
 868     }
 869
 870     #### Look it up ###
 871
 872     my $tryopt = $opt;          # option to try
 873
 874     if ( $bundling && $starter eq '-' ) {
 875
 876         # To try overrides, obey case ignore.
 877         $tryopt = $ignorecase ? lc($opt) : $opt;
 878
 879         # If bundling == 2, long options can override bundles.
 880         if ( $bundling == 2 && length($tryopt) > 1
 881              && defined ($opctl->{$tryopt}) ) {
 882             print STDERR ("=> $starter$tryopt overrides unbundling\n")
 883               if $debug;
 884         }
 885         else {
 886             $tryopt = $opt;
 887             # Unbundle single letter option.
 888             $rest = length ($tryopt) > 0 ? substr ($tryopt, 1) : '';
 889             $tryopt = substr ($tryopt, 0, 1);
 890             $tryopt = lc ($tryopt) if $ignorecase > 1;
 891             print STDERR ("=> $starter$tryopt unbundled from ",
 892                           "$starter$tryopt$rest\n") if $debug;
 893             $rest = undef unless $rest ne '';
 894         }
 895     }
 896
 897     # Try auto-abbreviation.
 898     elsif ( $autoabbrev ) {
 899         # Sort the possible long option names.
 900         my @names = sort(keys (%$opctl));
 901         # Downcase if allowed.
 902         $opt = lc ($opt) if $ignorecase;
 903         $tryopt = $opt;
 904         # Turn option name into pattern.
 905         my $pat = quotemeta ($opt);
 906         # Look up in option names.
 907         my @hits = grep (/^$pat/, @names);
 908         print STDERR ("=> ", scalar(@hits), " hits (@hits) with \"$pat\" ",
 909                       "out of ", scalar(@names), "\n") if $debug;
 910
 911         # Check for ambiguous results.
 912         unless ( (@hits <= 1) || (grep ($_ eq $opt, @hits) == 1) ) {
 913             # See if all matches are for the same option.
 914             my %hit;
 915             foreach ( @hits ) {
 916                 $_ = $opctl->{$_}->[CTL_CNAME]
 917                   if defined $opctl->{$_}->[CTL_CNAME];
 918                 $hit{$_} = 1;
 919             }
 920             # Remove auto-supplied options (version, help).
 921             if ( keys(%hit) == 2 ) {
 922                 if ( $auto_version && exists($hit{version}) ) {
 923                     delete $hit{version};
 924                 }
 925                 elsif ( $auto_help && exists($hit{help}) ) {
 926                     delete $hit{help};
 927                 }
 928             }
 929             # Now see if it really is ambiguous.
 930             unless ( keys(%hit) == 1 ) {
 931                 return (0) if $passthrough;
 932                 warn ("Option ", $opt, " is ambiguous (",
 933                       join(", ", @hits), ")\n");
 934                 $error++;
 935                 return (1, undef);
 936             }
 937             @hits = keys(%hit);
 938         }
 939
 940         # Complete the option name, if appropriate.
 941         if ( @hits == 1 && $hits[0] ne $opt ) {
 942             $tryopt = $hits[0];
 943             $tryopt = lc ($tryopt) if $ignorecase;
 944             print STDERR ("=> option \"$opt\" -> \"$tryopt\"\n")
 945                 if $debug;
 946         }
 947     }
 948
 949     # Map to all lowercase if ignoring case.
 950     elsif ( $ignorecase ) {
 951         $tryopt = lc ($opt);
 952     }
 953
 954     # Check validity by fetching the info.
 955     my $ctl = $opctl->{$tryopt};
 956     unless  ( defined $ctl ) {
 957         return (0) if $passthrough;
 958         # Pretend one char when bundling.
 959         if ( $bundling == 1) {
 960             $opt = substr($opt,0,1);
 961             unshift (@ARGV, $starter.$rest) if defined $rest;
 962         }
 963         warn ("Unknown option: ", $opt, "\n");
 964         $error++;
 965         return (1, undef);
 966     }
 967     # Apparently valid.
 968     $opt = $tryopt;
 969     print STDERR ("=> found ", OptCtl($ctl),
 970                   " for \"", $opt, "\"\n") if $debug;
 971
 972     #### Determine argument status ####
 973
 974     # If it is an option w/o argument, we're almost finished with it.
 975     my $type = $ctl->[CTL_TYPE];
 976     my $arg;
 977
 978     if ( $type eq '' || $type eq '!' || $type eq '+' ) {
 979         if ( defined $optarg ) {
 980             return (0) if $passthrough;
 981             warn ("Option ", $opt, " does not take an argument\n");
 982             $error++;
 983             undef $opt;
 984         }
 985         elsif ( $type eq '' || $type eq '+' ) {
 986             # Supply explicit value.
 987             $arg = 1;
 988         }
 989         else {
 990             $opt =~ s/^no-?//i; # strip NO prefix
 991             $arg = 0;           # supply explicit value
 992         }
 993         unshift (@ARGV, $starter.$rest) if defined $rest;
 994         return (1, $opt, $ctl, $arg);
 995     }
 996
 997     # Get mandatory status and type info.
 998     my $mand = $ctl->[CTL_AMIN];
 999
1000     # Check if there is an option argument available.
1001     if ( $gnu_compat && defined $optarg && $optarg eq '' ) {
1002         return (1, $opt, $ctl, $type eq 's' ? '' : 0) unless $mand;
1003         $optarg = 0 unless $type eq 's';
1004     }
1005
1006     # Check if there is an option argument available.
1007     if ( defined $optarg
1008          ? ($optarg eq '')
1009          : !(defined $rest || @ARGV > 0) ) {
1010         # Complain if this option needs an argument.
1011         if ( $mand ) {
1012             return (0) if $passthrough;
1013             warn ("Option ", $opt, " requires an argument\n");
1014             $error++;
1015             return (1, undef);
1016         }
1017         if ( $type eq 'I' ) {
1018             # Fake incremental type.
1019             my @c = @$ctl;
1020             $c[CTL_TYPE] = '+';
1021             return (1, $opt, \@c, 1);
1022         }
1023         return (1, $opt, $ctl,
1024                 defined($ctl->[CTL_DEFAULT]) ? $ctl->[CTL_DEFAULT] :
1025                 $type eq 's' ? '' : 0);
1026     }
1027
1028     # Get (possibly optional) argument.
1029     $arg = (defined $rest ? $rest
1030             : (defined $optarg ? $optarg : shift (@ARGV)));
1031
1032     # Get key if this is a "name=value" pair for a hash option.
1033     my $key;
1034     if ($ctl->[CTL_DEST] == CTL_DEST_HASH && defined $arg) {
1035         ($key, $arg) = ($arg =~ /^([^=]*)=(.*)$/s) ? ($1, $2)
1036           : ($arg, defined($ctl->[CTL_DEFAULT]) ? $ctl->[CTL_DEFAULT] :
1037              ($mand ? undef : ($type eq 's' ? "" : 1)));
1038         if (! defined $arg) {
1039             warn ("Option $opt, key \"$key\", requires a value\n");
1040             $error++;
1041             # Push back.
1042             unshift (@ARGV, $starter.$rest) if defined $rest;
1043             return (1, undef);
1044         }
1045     }
1046
1047     #### Check if the argument is valid for this option ####
1048
1049     my $key_valid = $ctl->[CTL_DEST] == CTL_DEST_HASH ? "[^=]+=" : "";
1050
1051     if ( $type eq 's' ) {       # string
1052         # A mandatory string takes anything.
1053         return (1, $opt, $ctl, $arg, $key) if $mand;
1054
1055         # An optional string takes almost anything.
1056         return (1, $opt, $ctl, $arg, $key)
1057           if defined $optarg || defined $rest;
1058         return (1, $opt, $ctl, $arg, $key) if $arg eq "-"; # ??
1059
1060         # Check for option or option list terminator.
1061         if ($arg eq $argend ||
1062             $arg =~ /^$prefix.+/) {
1063             # Push back.
1064             unshift (@ARGV, $arg);
1065             # Supply empty value.
1066             $arg = '';
1067         }
1068     }
1069
1070     elsif ( $type eq 'i'        # numeric/integer
1071             || $type eq 'I'     # numeric/integer w/ incr default
1072             || $type eq 'o' ) { # dec/oct/hex/bin value
1073
1074         my $o_valid =
1075           $type eq 'o' ? "[-+]?[1-9][0-9]*|0x[0-9a-f]+|0b[01]+|0[0-7]*"
1076             : "[-+]?[0-9]+";
1077
1078         if ( $bundling && defined $rest
1079              && $rest =~ /^($key_valid)($o_valid)(.*)$/si ) {
1080             ($key, $arg, $rest) = ($1, $2, $+);
1081             chop($key) if $key;
1082             $arg = ($type eq 'o' && $arg =~ /^0/) ? oct($arg) : 0+$arg;
1083             unshift (@ARGV, $starter.$rest) if defined $rest && $rest ne '';
1084         }
1085         elsif ( $arg =~ /^($o_valid)$/si ) {
1086             $arg = ($type eq 'o' && $arg =~ /^0/) ? oct($arg) : 0+$arg;
1087         }
1088         else {
1089             if ( defined $optarg || $mand ) {
1090                 if ( $passthrough ) {
1091                     unshift (@ARGV, defined $rest ? $starter.$rest : $arg)
1092                       unless defined $optarg;
1093                     return (0);
1094                 }
1095                 warn ("Value \"", $arg, "\" invalid for option ",
1096                       $opt, " (",
1097                       $type eq 'o' ? "extended " : '',
1098                       "number expected)\n");
1099                 $error++;
1100                 # Push back.
1101                 unshift (@ARGV, $starter.$rest) if defined $rest;
1102                 return (1, undef);
1103             }
1104             else {
1105                 # Push back.
1106                 unshift (@ARGV, defined $rest ? $starter.$rest : $arg);
1107                 if ( $type eq 'I' ) {
1108                     # Fake incremental type.
1109                     my @c = @$ctl;
1110                     $c[CTL_TYPE] = '+';
1111                     return (1, $opt, \@c, 1);
1112                 }
1113                 # Supply default value.
1114                 $arg = defined($ctl->[CTL_DEFAULT]) ? $ctl->[CTL_DEFAULT] : 0;
1115             }
1116         }
1117     }
1118
1119     elsif ( $type eq 'f' ) { # real number, int is also ok
1120         # We require at least one digit before a point or 'e',
1121         # and at least one digit following the point and 'e'.
1122         # [-]NN[.NN][eNN]
1123         if ( $bundling && defined $rest &&
1124              $rest =~ /^($key_valid)([-+]?[0-9]+(\.[0-9]+)?([eE][-+]?[0-9]+)?)(.*)$/s ) {
1125             ($key, $arg, $rest) = ($1, $2, $+);
1126             chop($key) if $key;
1127             unshift (@ARGV, $starter.$rest) if defined $rest && $rest ne '';
1128         }
1129         elsif ( $arg !~ /^[-+]?[0-9.]+(\.[0-9]+)?([eE][-+]?[0-9]+)?$/ ) {
1130             if ( defined $optarg || $mand ) {
1131                 if ( $passthrough ) {
1132                     unshift (@ARGV, defined $rest ? $starter.$rest : $arg)
1133                       unless defined $optarg;
1134                     return (0);
1135                 }
1136                 warn ("Value \"", $arg, "\" invalid for option ",
1137                       $opt, " (real number expected)\n");
1138                 $error++;
1139                 # Push back.
1140                 unshift (@ARGV, $starter.$rest) if defined $rest;
1141                 return (1, undef);
1142             }
1143             else {
1144                 # Push back.
1145                 unshift (@ARGV, defined $rest ? $starter.$rest : $arg);
1146                 # Supply default value.
1147                 $arg = 0.0;
1148             }
1149         }
1150     }
1151     else {
1152         die("Getopt::Long internal error (Can't happen)\n");
1153     }
1154     return (1, $opt, $ctl, $arg, $key);
1155 }
1156
1157 sub ValidValue ($$$$$) {
1158     my ($ctl, $arg, $mand, $argend, $prefix) = @_;
1159
1160     if ( $ctl->[CTL_DEST] == CTL_DEST_HASH ) {
1161         return 0 unless $arg =~ /[^=]+=(.*)/;
1162         $arg = $1;
1163     }
1164
1165     my $type = $ctl->[CTL_TYPE];
1166
1167     if ( $type eq 's' ) {       # string
1168         # A mandatory string takes anything.
1169         return (1) if $mand;
1170
1171         return (1) if $arg eq "-";
1172
1173         # Check for option or option list terminator.
1174         return 0 if $arg eq $argend || $arg =~ /^$prefix.+/;
1175         return 1;
1176     }
1177
1178     elsif ( $type eq 'i'        # numeric/integer
1179             || $type eq 'I'     # numeric/integer w/ incr default
1180             || $type eq 'o' ) { # dec/oct/hex/bin value
1181
1182         my $o_valid =
1183           $type eq 'o' ? "[-+]?[1-9][0-9]*|0x[0-9a-f]+|0b[01]+|0[0-7]*"
1184             : "[-+]?[0-9]+";
1185
1186         return $arg =~ /^$o_valid$/si;
1187     }
1188
1189     elsif ( $type eq 'f' ) { # real number, int is also ok
1190         # We require at least one digit before a point or 'e',
1191         # and at least one digit following the point and 'e'.
1192         # [-]NN[.NN][eNN]
1193         return $arg =~ /^[-+]?[0-9.]+(\.[0-9]+)?([eE][-+]?[0-9]+)?$/;
1194     }
1195     die("ValidValue: Cannot happen\n");
1196 }
1197
1198 # Getopt::Long Configuration.
1199 sub Configure (@) {
1200     my (@options) = @_;
1201
1202     my $prevconfig =
1203       [ $error, $debug, $major_version, $minor_version,
1204         $autoabbrev, $getopt_compat, $ignorecase, $bundling, $order,
1205         $gnu_compat, $passthrough, $genprefix, $auto_version, $auto_help ];
1206
1207     if ( ref($options[0]) eq 'ARRAY' ) {
1208         ( $error, $debug, $major_version, $minor_version,
1209           $autoabbrev, $getopt_compat, $ignorecase, $bundling, $order,
1210           $gnu_compat, $passthrough, $genprefix, $auto_version, $auto_help ) =
1211             @{shift(@options)};
1212     }
1213
1214     my $opt;
1215     foreach $opt ( @options ) {
1216         my $try = lc ($opt);
1217         my $action = 1;
1218         if ( $try =~ /^no_?(.*)$/s ) {
1219             $action = 0;
1220             $try = $+;
1221         }
1222         if ( ($try eq 'default' or $try eq 'defaults') && $action ) {
1223             ConfigDefaults ();
1224         }
1225         elsif ( ($try eq 'posix_default' or $try eq 'posix_defaults') ) {
1226             local $ENV{POSIXLY_CORRECT};
1227             $ENV{POSIXLY_CORRECT} = 1 if $action;
1228             ConfigDefaults ();
1229         }
1230         elsif ( $try eq 'auto_abbrev' or $try eq 'autoabbrev' ) {
1231             $autoabbrev = $action;
1232         }
1233         elsif ( $try eq 'getopt_compat' ) {
1234             $getopt_compat = $action;
1235         }
1236         elsif ( $try eq 'gnu_getopt' ) {
1237             if ( $action ) {
1238                 $gnu_compat = 1;
1239                 $bundling = 1;
1240                 $getopt_compat = 0;
1241                 $order = $PERMUTE;
1242             }
1243         }
1244         elsif ( $try eq 'gnu_compat' ) {
1245             $gnu_compat = $action;
1246         }
1247         elsif ( $try =~ /^(auto_?)?version$/ ) {
1248             $auto_version = $action;
1249         }
1250         elsif ( $try =~ /^(auto_?)?help$/ ) {
1251             $auto_help = $action;
1252         }
1253         elsif ( $try eq 'ignorecase' or $try eq 'ignore_case' ) {
1254             $ignorecase = $action;
1255         }
1256         elsif ( $try eq 'ignore_case_always' ) {
1257             $ignorecase = $action ? 2 : 0;
1258         }
1259         elsif ( $try eq 'bundling' ) {
1260             $bundling = $action;
1261         }
1262         elsif ( $try eq 'bundling_override' ) {
1263             $bundling = $action ? 2 : 0;
1264         }
1265         elsif ( $try eq 'require_order' ) {
1266             $order = $action ? $REQUIRE_ORDER : $PERMUTE;
1267         }
1268         elsif ( $try eq 'permute' ) {
1269             $order = $action ? $PERMUTE : $REQUIRE_ORDER;
1270         }
1271         elsif ( $try eq 'pass_through' or $try eq 'passthrough' ) {
1272             $passthrough = $action;
1273         }
1274         elsif ( $try =~ /^prefix=(.+)$/ && $action ) {
1275             $genprefix = $1;
1276             # Turn into regexp. Needs to be parenthesized!
1277             $genprefix = "(" . quotemeta($genprefix) . ")";
1278             eval { '' =~ /$genprefix/; };
1279             die("Getopt::Long: invalid pattern \"$genprefix\"") if $@;
1280         }
1281         elsif ( $try =~ /^prefix_pattern=(.+)$/ && $action ) {
1282             $genprefix = $1;
1283             # Parenthesize if needed.
1284             $genprefix = "(" . $genprefix . ")"
1285               unless $genprefix =~ /^\(.*\)$/;
1286             eval { '' =~ /$genprefix/; };
1287             die("Getopt::Long: invalid pattern \"$genprefix\"") if $@;
1288         }
1289         elsif ( $try eq 'debug' ) {
1290             $debug = $action;
1291         }
1292         else {
1293             die("Getopt::Long: unknown config parameter \"$opt\"")
1294         }
1295     }
1296     $prevconfig;
1297 }
1298
1299 # Deprecated name.
1300 sub config (@) {
1301     Configure (@_);
1302 }
1303
1304 # Issue a standard message for --version.
1305 #
1306 # The arguments are mostly the same as for Pod::Usage::pod2usage:
1307 #
1308 #  - a number (exit value)
1309 #  - a string (lead in message)
1310 #  - a hash with options. See Pod::Usage for details.
1311 #
1312 sub VersionMessage(@) {
1313     # Massage args.
1314     my $pa = setup_pa_args("version", @_);
1315
1316     my $v = $main::VERSION;
1317     my $fh = $pa->{-output} ||
1318       ($pa->{-exitval} eq "NOEXIT" || $pa->{-exitval} < 2) ? \*STDOUT : \*STDERR;
1319
1320     print $fh (defined($pa->{-message}) ? $pa->{-message} : (),
1321                $0, defined $v ? " version $v" : (),
1322                "\n",
1323                "(", __PACKAGE__, "::", "GetOptions",
1324                " version ",
1325                defined($Getopt::Long::VERSION_STRING)
1326                  ? $Getopt::Long::VERSION_STRING : $VERSION, ";",
1327                " Perl version ",
1328                $] >= 5.006 ? sprintf("%vd", $^V) : $],
1329                ")\n");
1330     exit($pa->{-exitval}) unless $pa->{-exitval} eq "NOEXIT";
1331 }
1332
1333 # Issue a standard message for --help.
1334 #
1335 # The arguments are the same as for Pod::Usage::pod2usage:
1336 #
1337 #  - a number (exit value)
1338 #  - a string (lead in message)
1339 #  - a hash with options. See Pod::Usage for details.
1340 #
1341 sub HelpMessage(@) {
1342     eval {
1343         require Pod::Usage;
1344         import Pod::Usage;
1345         1;
1346     } || die("Cannot provide help: cannot load Pod::Usage\n");
1347
1348     # Note that pod2usage will issue a warning if -exitval => NOEXIT.
1349     pod2usage(setup_pa_args("help", @_));
1350
1351 }
1352
1353 # Helper routine to set up a normalized hash ref to be used as
1354 # argument to pod2usage.
1355 sub setup_pa_args($@) {
1356     my $tag = shift;            # who's calling
1357
1358     # If called by direct binding to an option, it will get the option
1359     # name and value as arguments. Remove these, if so.
1360     @_ = () if @_ == 2 && $_[0] eq $tag;
1361
1362     my $pa;
1363     if ( @_ > 1 ) {
1364         $pa = { @_ };
1365     }
1366     else {
1367         $pa = shift || {};
1368     }
1369
1370     # At this point, $pa can be a number (exit value), string
1371     # (message) or hash with options.
1372
1373     if ( UNIVERSAL::isa($pa, 'HASH') ) {
1374         # Get rid of -msg vs. -message ambiguity.
1375         $pa->{-message} = $pa->{-msg};
1376         delete($pa->{-msg});
1377     }
1378     elsif ( $pa =~ /^-?\d+$/ ) {
1379         $pa = { -exitval => $pa };
1380     }
1381     else {
1382         $pa = { -message => $pa };
1383     }
1384
1385     # These are _our_ defaults.
1386     $pa->{-verbose} = 0 unless exists($pa->{-verbose});
1387     $pa->{-exitval} = 0 unless exists($pa->{-exitval});
1388     $pa;
1389 }
1390
1391 # Sneak way to know what version the user requested.
1392 sub VERSION {
1393     $requested_version = $_[1];
1394     shift->SUPER::VERSION(@_);
1395 }
1396
1397 1;
1398
1399 ################ Documentation ################
1400
1401 =head1 NAME
1402
1403 Getopt::Long - Extended processing of command line options
1404
1405 =head1 SYNOPSIS
1406
1407   use Getopt::Long;
1408   my $data   = "file.dat";
1409   my $length = 24;
1410   my $verbose;
1411   $result = GetOptions ("length=i" => \$length,    # numeric
1412                         "file=s"   => \$data,      # string
1413                         "verbose"  => \$verbose);  # flag
1414
1415 =head1 DESCRIPTION
1416
1417 The Getopt::Long module implements an extended getopt function called
1418 GetOptions(). This function adheres to the POSIX syntax for command
1419 line options, with GNU extensions. In general, this means that options
1420 have long names instead of single letters, and are introduced with a
1421 double dash "--". Support for bundling of command line options, as was
1422 the case with the more traditional single-letter approach, is provided
1423 but not enabled by default.
1424
1425 =head1 Command Line Options, an Introduction
1426
1427 Command line operated programs traditionally take their arguments from
1428 the command line, for example filenames or other information that the
1429 program needs to know. Besides arguments, these programs often take
1430 command line I<options> as well. Options are not necessary for the
1431 program to work, hence the name 'option', but are used to modify its
1432 default behaviour. For example, a program could do its job quietly,
1433 but with a suitable option it could provide verbose information about
1434 what it did.
1435
1436 Command line options come in several flavours. Historically, they are
1437 preceded by a single dash C<->, and consist of a single letter.
1438
1439     -l -a -c
1440
1441 Usually, these single-character options can be bundled:
1442
1443     -lac
1444
1445 Options can have values, the value is placed after the option
1446 character. Sometimes with whitespace in between, sometimes not:
1447
1448     -s 24 -s24
1449
1450 Due to the very cryptic nature of these options, another style was
1451 developed that used long names. So instead of a cryptic C<-l> one
1452 could use the more descriptive C<--long>. To distinguish between a
1453 bundle of single-character options and a long one, two dashes are used
1454 to precede the option name. Early implementations of long options used
1455 a plus C<+> instead. Also, option values could be specified either
1456 like
1457
1458     --size=24
1459
1460 or
1461
1462     --size 24
1463
1464 The C<+> form is now obsolete and strongly deprecated.
1465
1466 =head1 Getting Started with Getopt::Long
1467
1468 Getopt::Long is the Perl5 successor of C<newgetopt.pl>. This was
1469 the first Perl module that provided support for handling the new style
1470 of command line options, hence the name Getopt::Long. This module
1471 also supports single-character options and bundling. In this case, the
1472 options are restricted to alphabetic characters only, and the
1473 characters C<?> and C<->.
1474
1475 To use Getopt::Long from a Perl program, you must include the
1476 following line in your Perl program:
1477
1478     use Getopt::Long;
1479
1480 This will load the core of the Getopt::Long module and prepare your
1481 program for using it. Most of the actual Getopt::Long code is not
1482 loaded until you really call one of its functions.
1483
1484 In the default configuration, options names may be abbreviated to
1485 uniqueness, case does not matter, and a single dash is sufficient,
1486 even for long option names. Also, options may be placed between
1487 non-option arguments. See L<Configuring Getopt::Long> for more
1488 details on how to configure Getopt::Long.
1489
1490 =head2 Simple options
1491
1492 The most simple options are the ones that take no values. Their mere
1493 presence on the command line enables the option. Popular examples are:
1494
1495     --all --verbose --quiet --debug
1496
1497 Handling simple options is straightforward:
1498
1499     my $verbose = '';   # option variable with default value (false)
1500     my $all = '';       # option variable with default value (false)
1501     GetOptions ('verbose' => \$verbose, 'all' => \$all);
1502
1503 The call to GetOptions() parses the command line arguments that are
1504 present in C<@ARGV> and sets the option variable to the value C<1> if
1505 the option did occur on the command line. Otherwise, the option
1506 variable is not touched. Setting the option value to true is often
1507 called I<enabling> the option.
1508
1509 The option name as specified to the GetOptions() function is called
1510 the option I<specification>. Later we'll see that this specification
1511 can contain more than just the option name. The reference to the
1512 variable is called the option I<destination>.
1513
1514 GetOptions() will return a true value if the command line could be
1515 processed successfully. Otherwise, it will write error messages to
1516 STDERR, and return a false result.
1517
1518 =head2 A little bit less simple options
1519
1520 Getopt::Long supports two useful variants of simple options:
1521 I<negatable> options and I<incremental> options.
1522
1523 A negatable option is specified with an exclamation mark C<!> after the
1524 option name:
1525
1526     my $verbose = '';   # option variable with default value (false)
1527     GetOptions ('verbose!' => \$verbose);
1528
1529 Now, using C<--verbose> on the command line will enable C<$verbose>,
1530 as expected. But it is also allowed to use C<--noverbose>, which will
1531 disable C<$verbose> by setting its value to C<0>. Using a suitable
1532 default value, the program can find out whether C<$verbose> is false
1533 by default, or disabled by using C<--noverbose>.
1534
1535 An incremental option is specified with a plus C<+> after the
1536 option name:
1537
1538     my $verbose = '';   # option variable with default value (false)
1539     GetOptions ('verbose+' => \$verbose);
1540
1541 Using C<--verbose> on the command line will increment the value of
1542 C<$verbose>. This way the program can keep track of how many times the
1543 option occurred on the command line. For example, each occurrence of
1544 C<--verbose> could increase the verbosity level of the program.
1545
1546 =head2 Mixing command line option with other arguments
1547
1548 Usually programs take command line options as well as other arguments,
1549 for example, file names. It is good practice to always specify the
1550 options first, and the other arguments last. Getopt::Long will,
1551 however, allow the options and arguments to be mixed and 'filter out'
1552 all the options before passing the rest of the arguments to the
1553 program. To stop Getopt::Long from processing further arguments,
1554 insert a double dash C<--> on the command line:
1555
1556     --size 24 -- --all
1557
1558 In this example, C<--all> will I<not> be treated as an option, but
1559 passed to the program unharmed, in C<@ARGV>.
1560
1561 =head2 Options with values
1562
1563 For options that take values it must be specified whether the option
1564 value is required or not, and what kind of value the option expects.
1565
1566 Three kinds of values are supported: integer numbers, floating point
1567 numbers, and strings.
1568
1569 If the option value is required, Getopt::Long will take the
1570 command line argument that follows the option and assign this to the
1571 option variable. If, however, the option value is specified as
1572 optional, this will only be done if that value does not look like a
1573 valid command line option itself.
1574
1575     my $tag = '';       # option variable with default value
1576     GetOptions ('tag=s' => \$tag);
1577
1578 In the option specification, the option name is followed by an equals
1579 sign C<=> and the letter C<s>. The equals sign indicates that this
1580 option requires a value. The letter C<s> indicates that this value is
1581 an arbitrary string. Other possible value types are C<i> for integer
1582 values, and C<f> for floating point values. Using a colon C<:> instead
1583 of the equals sign indicates that the option value is optional. In
1584 this case, if no suitable value is supplied, string valued options get
1585 an empty string C<''> assigned, while numeric options are set to C<0>.
1586
1587 =head2 Options with multiple values
1588
1589 Options sometimes take several values. For example, a program could
1590 use multiple directories to search for library files:
1591
1592     --library lib/stdlib --library lib/extlib
1593
1594 To accomplish this behaviour, simply specify an array reference as the
1595 destination for the option:
1596
1597     GetOptions ("library=s" => \@libfiles);
1598
1599 Alternatively, you can specify that the option can have multiple
1600 values by adding a "@", and pass a scalar reference as the
1601 destination:
1602
1603     GetOptions ("library=s@" => \$libfiles);
1604
1605 Used with the example above, C<@libfiles> (or C<@$libfiles>) would
1606 contain two strings upon completion: C<"lib/srdlib"> and
1607 C<"lib/extlib">, in that order. It is also possible to specify that
1608 only integer or floating point numbers are acceptible values.
1609
1610 Often it is useful to allow comma-separated lists of values as well as
1611 multiple occurrences of the options. This is easy using Perl's split()
1612 and join() operators:
1613
1614     GetOptions ("library=s" => \@libfiles);
1615     @libfiles = split(/,/,join(',',@libfiles));
1616
1617 Of course, it is important to choose the right separator string for
1618 each purpose.
1619
1620 Warning: What follows is an experimental feature.
1621
1622 Options can take multiple values at once, for example
1623
1624     --coordinates 52.2 16.4 --rgbcolor 255 255 149
1625
1626 This can be accomplished by adding a repeat specifier to the option
1627 specification. Repeat specifiers are very similar to the C<{...}>
1628 repeat specifiers that can be used with regular expression patterns.
1629 For example, the above command line would be handled as follows:
1630
1631     GetOptions('coordinates=f{2}' => \@coor, 'rgbcolor=i{3}' => \@color);
1632
1633 The destination for the option must be an array or array reference.
1634
1635 It is also possible to specify the minimal and maximal number of
1636 arguments an option takes. C<foo=s{2,4}> indicates an option that
1637 takes at least two and at most 4 arguments. C<foo=s{,}> indicates one
1638 or more values; C<foo:s{,}> indicates zero or more option values.
1639
1640 =head2 Options with hash values
1641
1642 If the option destination is a reference to a hash, the option will
1643 take, as value, strings of the form I<key>C<=>I<value>. The value will
1644 be stored with the specified key in the hash.
1645
1646     GetOptions ("define=s" => \%defines);
1647
1648 Alternatively you can use:
1649
1650     GetOptions ("define=s%" => \$defines);
1651
1652 When used with command line options:
1653
1654     --define os=linux --define vendor=redhat
1655
1656 the hash C<%defines> (or C<%$defines>) will contain two keys, C<"os">
1657 with value C<"linux> and C<"vendor"> with value C<"redhat">. It is
1658 also possible to specify that only integer or floating point numbers
1659 are acceptible values. The keys are always taken to be strings.
1660
1661 =head2 User-defined subroutines to handle options
1662
1663 Ultimate control over what should be done when (actually: each time)
1664 an option is encountered on the command line can be achieved by
1665 designating a reference to a subroutine (or an anonymous subroutine)
1666 as the option destination. When GetOptions() encounters the option, it
1667 will call the subroutine with two or three arguments. The first
1668 argument is the name of the option. For a scalar or array destination,
1669 the second argument is the value to be stored. For a hash destination,
1670 the second arguments is the key to the hash, and the third argument
1671 the value to be stored. It is up to the subroutine to store the value,
1672 or do whatever it thinks is appropriate.
1673
1674 A trivial application of this mechanism is to implement options that
1675 are related to each other. For example:
1676
1677     my $verbose = '';   # option variable with default value (false)
1678     GetOptions ('verbose' => \$verbose,
1679                 'quiet'   => sub { $verbose = 0 });
1680
1681 Here C<--verbose> and C<--quiet> control the same variable
1682 C<$verbose>, but with opposite values.
1683
1684 If the subroutine needs to signal an error, it should call die() with
1685 the desired error message as its argument. GetOptions() will catch the
1686 die(), issue the error message, and record that an error result must
1687 be returned upon completion.
1688
1689 If the text of the error message starts with an exclamantion mark C<!>
1690 it is interpreted specially by GetOptions(). There is currently one
1691 special command implemented: C<die("!FINISH")> will cause GetOptions()
1692 to stop processing options, as if it encountered a double dash C<-->.
1693
1694 =head2 Options with multiple names
1695
1696 Often it is user friendly to supply alternate mnemonic names for
1697 options. For example C<--height> could be an alternate name for
1698 C<--length>. Alternate names can be included in the option
1699 specification, separated by vertical bar C<|> characters. To implement
1700 the above example:
1701
1702     GetOptions ('length|height=f' => \$length);
1703
1704 The first name is called the I<primary> name, the other names are
1705 called I<aliases>.
1706
1707 Multiple alternate names are possible.
1708
1709 =head2 Case and abbreviations
1710
1711 Without additional configuration, GetOptions() will ignore the case of
1712 option names, and allow the options to be abbreviated to uniqueness.
1713
1714     GetOptions ('length|height=f' => \$length, "head" => \$head);
1715
1716 This call will allow C<--l> and C<--L> for the length option, but
1717 requires a least C<--hea> and C<--hei> for the head and height options.
1718
1719 =head2 Summary of Option Specifications
1720
1721 Each option specifier consists of two parts: the name specification
1722 and the argument specification.
1723
1724 The name specification contains the name of the option, optionally
1725 followed by a list of alternative names separated by vertical bar
1726 characters.
1727
1728     length            option name is "length"
1729     length|size|l     name is "length", aliases are "size" and "l"
1730
1731 The argument specification is optional. If omitted, the option is
1732 considered boolean, a value of 1 will be assigned when the option is
1733 used on the command line.
1734
1735 The argument specification can be
1736
1737 =over 4
1738
1739 =item !
1740
1741 The option does not take an argument and may be negated, i.e. prefixed
1742 by "no". E.g. C<"foo!"> will allow C<--foo> (a value of 1 will be
1743 assigned) and C<--nofoo> and C<--no-foo> (a value of 0 will be assigned). If the
1744 option has aliases, this applies to the aliases as well.
1745
1746 Using negation on a single letter option when bundling is in effect is
1747 pointless and will result in a warning.
1748
1749 =item +
1750
1751 The option does not take an argument and will be incremented by 1
1752 every time it appears on the command line. E.g. C<"more+">, when used
1753 with C<--more --more --more>, will increment the value three times,
1754 resulting in a value of 3 (provided it was 0 or undefined at first).
1755
1756 The C<+> specifier is ignored if the option destination is not a scalar.
1757
1758 =item = I<type> [ I<desttype> ] [ I<repeat> ]
1759
1760 The option requires an argument of the given type. Supported types
1761 are:
1762
1763 =over 4
1764
1765 =item s
1766
1767 String. An arbitrary sequence of characters. It is valid for the
1768 argument to start with C<-> or C<-->.
1769
1770 =item i
1771
1772 Integer. An optional leading plus or minus sign, followed by a
1773 sequence of digits.
1774
1775 =item o
1776
1777 Extended integer, Perl style. This can be either an optional leading
1778 plus or minus sign, followed by a sequence of digits, or an octal
1779 string (a zero, optionally followed by '0', '1', .. '7'), or a
1780 hexadecimal string (C<0x> followed by '0' .. '9', 'a' .. 'f', case
1781 insensitive), or a binary string (C<0b> followed by a series of '0'
1782 and '1').
1783
1784 =item f
1785
1786 Real number. For example C<3.14>, C<-6.23E24> and so on.
1787
1788 =back
1789
1790 The I<desttype> can be C<@> or C<%> to specify that the option is
1791 list or a hash valued. This is only needed when the destination for
1792 the option value is not otherwise specified. It should be omitted when
1793 not needed.
1794
1795 The I<repeat> specifies the number of values this option takes per
1796 occurrence on the command line. It has the format C<{> [ I<min> ] [ C<,> [ I<max> ] ] C<}>.
1797
1798 I<min> denotes the minimal number of arguments. It defaults to 1 for
1799 options with C<=> and to 0 for options with C<:>, see below. Note that
1800 I<min> overrules the C<=> / C<:> semantics.
1801
1802 I<max> denotes the maximum number of arguments. It must be at least
1803 I<min>. If I<max> is omitted, I<but the comma is not>, there is no
1804 upper bound to the number of argument values taken.
1805
1806 =item : I<type> [ I<desttype> ]
1807
1808 Like C<=>, but designates the argument as optional.
1809 If omitted, an empty string will be assigned to string values options,
1810 and the value zero to numeric options.
1811
1812 Note that if a string argument starts with C<-> or C<-->, it will be
1813 considered an option on itself.
1814
1815 =item : I<number> [ I<desttype> ]
1816
1817 Like C<:i>, but if the value is omitted, the I<number> will be assigned.
1818
1819 =item : + [ I<desttype> ]
1820
1821 Like C<:i>, but if the value is omitted, the current value for the
1822 option will be incremented.
1823
1824 =back
1825
1826 =head1 Advanced Possibilities
1827
1828 =head2 Object oriented interface
1829
1830 Getopt::Long can be used in an object oriented way as well:
1831
1832     use Getopt::Long;
1833     $p = new Getopt::Long::Parser;
1834     $p->configure(...configuration options...);
1835     if ($p->getoptions(...options descriptions...)) ...
1836
1837 Configuration options can be passed to the constructor:
1838
1839     $p = new Getopt::Long::Parser
1840              config => [...configuration options...];
1841
1842 =head2 Thread Safety
1843
1844 Getopt::Long is thread safe when using ithreads as of Perl 5.8.  It is
1845 I<not> thread safe when using the older (experimental and now
1846 obsolete) threads implementation that was added to Perl 5.005.
1847
1848 =head2 Documentation and help texts
1849
1850 Getopt::Long encourages the use of Pod::Usage to produce help
1851 messages. For example:
1852
1853     use Getopt::Long;
1854     use Pod::Usage;
1855
1856     my $man = 0;
1857     my $help = 0;
1858
1859     GetOptions('help|?' => \$help, man => \$man) or pod2usage(2);
1860     pod2usage(1) if $help;
1861     pod2usage(-exitstatus => 0, -verbose => 2) if $man;
1862
1863     __END__
1864
1865     =head1 NAME
1866
1867     sample - Using Getopt::Long and Pod::Usage
1868
1869     =head1 SYNOPSIS
1870
1871     sample [options] [file ...]
1872
1873      Options:
1874        -help            brief help message
1875        -man             full documentation
1876
1877     =head1 OPTIONS
1878
1879     =over 8
1880
1881     =item B<-help>
1882
1883     Print a brief help message and exits.
1884
1885     =item B<-man>
1886
1887     Prints the manual page and exits.
1888
1889     =back
1890
1891     =head1 DESCRIPTION
1892
1893     B<This program> will read the given input file(s) and do someting
1894     useful with the contents thereof.
1895
1896     =cut
1897
1898 See L<Pod::Usage> for details.
1899
1900 =head2 Storing options in a hash
1901
1902 Sometimes, for example when there are a lot of options, having a
1903 separate variable for each of them can be cumbersome. GetOptions()
1904 supports, as an alternative mechanism, storing options in a hash.
1905
1906 To obtain this, a reference to a hash must be passed I<as the first
1907 argument> to GetOptions(). For each option that is specified on the
1908 command line, the option value will be stored in the hash with the
1909 option name as key. Options that are not actually used on the command
1910 line will not be put in the hash, on other words,
1911 C<exists($h{option})> (or defined()) can be used to test if an option
1912 was used. The drawback is that warnings will be issued if the program
1913 runs under C<use strict> and uses C<$h{option}> without testing with
1914 exists() or defined() first.
1915
1916     my %h = ();
1917     GetOptions (\%h, 'length=i');       # will store in $h{length}
1918
1919 For options that take list or hash values, it is necessary to indicate
1920 this by appending an C<@> or C<%> sign after the type:
1921
1922     GetOptions (\%h, 'colours=s@');     # will push to @{$h{colours}}
1923
1924 To make things more complicated, the hash may contain references to
1925 the actual destinations, for example:
1926
1927     my $len = 0;
1928     my %h = ('length' => \$len);
1929     GetOptions (\%h, 'length=i');       # will store in $len
1930
1931 This example is fully equivalent with:
1932
1933     my $len = 0;
1934     GetOptions ('length=i' => \$len);   # will store in $len
1935
1936 Any mixture is possible. For example, the most frequently used options
1937 could be stored in variables while all other options get stored in the
1938 hash:
1939
1940     my $verbose = 0;                    # frequently referred
1941     my $debug = 0;                      # frequently referred
1942     my %h = ('verbose' => \$verbose, 'debug' => \$debug);
1943     GetOptions (\%h, 'verbose', 'debug', 'filter', 'size=i');
1944     if ( $verbose ) { ... }
1945     if ( exists $h{filter} ) { ... option 'filter' was specified ... }
1946
1947 =head2 Bundling
1948
1949 With bundling it is possible to set several single-character options
1950 at once. For example if C<a>, C<v> and C<x> are all valid options,
1951
1952     -vax
1953
1954 would set all three.
1955
1956 Getopt::Long supports two levels of bundling. To enable bundling, a
1957 call to Getopt::Long::Configure is required.
1958
1959 The first level of bundling can be enabled with:
1960
1961     Getopt::Long::Configure ("bundling");
1962
1963 Configured this way, single-character options can be bundled but long
1964 options B<must> always start with a double dash C<--> to avoid
1965 abiguity. For example, when C<vax>, C<a>, C<v> and C<x> are all valid
1966 options,
1967
1968     -vax
1969
1970 would set C<a>, C<v> and C<x>, but
1971
1972     --vax
1973
1974 would set C<vax>.
1975
1976 The second level of bundling lifts this restriction. It can be enabled
1977 with:
1978
1979     Getopt::Long::Configure ("bundling_override");
1980
1981 Now, C<-vax> would set the option C<vax>.
1982
1983 When any level of bundling is enabled, option values may be inserted
1984 in the bundle. For example:
1985
1986     -h24w80
1987
1988 is equivalent to
1989
1990     -h 24 -w 80
1991
1992 When configured for bundling, single-character options are matched
1993 case sensitive while long options are matched case insensitive. To
1994 have the single-character options matched case insensitive as well,
1995 use:
1996
1997     Getopt::Long::Configure ("bundling", "ignorecase_always");
1998
1999 It goes without saying that bundling can be quite confusing.
2000
2001 =head2 The lonesome dash
2002
2003 Normally, a lone dash C<-> on the command line will not be considered
2004 an option. Option processing will terminate (unless "permute" is
2005 configured) and the dash will be left in C<@ARGV>.
2006
2007 It is possible to get special treatment for a lone dash. This can be
2008 achieved by adding an option specification with an empty name, for
2009 example:
2010
2011     GetOptions ('' => \$stdio);
2012
2013 A lone dash on the command line will now be a legal option, and using
2014 it will set variable C<$stdio>.
2015
2016 =head2 Argument callback
2017
2018 A special option 'name' C<< <> >> can be used to designate a subroutine
2019 to handle non-option arguments. When GetOptions() encounters an
2020 argument that does not look like an option, it will immediately call this
2021 subroutine and passes it one parameter: the argument name.
2022
2023 For example:
2024
2025     my $width = 80;
2026     sub process { ... }
2027     GetOptions ('width=i' => \$width, '<>' => \&process);
2028
2029 When applied to the following command line:
2030
2031     arg1 --width=72 arg2 --width=60 arg3
2032
2033 This will call
2034 C<process("arg1")> while C<$width> is C<80>,
2035 C<process("arg2")> while C<$width> is C<72>, and
2036 C<process("arg3")> while C<$width> is C<60>.
2037
2038 This feature requires configuration option B<permute>, see section
2039 L<Configuring Getopt::Long>.
2040
2041 =head1 Configuring Getopt::Long
2042
2043 Getopt::Long can be configured by calling subroutine
2044 Getopt::Long::Configure(). This subroutine takes a list of quoted
2045 strings, each specifying a configuration option to be enabled, e.g.
2046 C<ignore_case>, or disabled, e.g. C<no_ignore_case>. Case does not
2047 matter. Multiple calls to Configure() are possible.
2048
2049 Alternatively, as of version 2.24, the configuration options may be
2050 passed together with the C<use> statement:
2051
2052     use Getopt::Long qw(:config no_ignore_case bundling);
2053
2054 The following options are available:
2055
2056 =over 12
2057
2058 =item default
2059
2060 This option causes all configuration options to be reset to their
2061 default values.
2062
2063 =item posix_default
2064
2065 This option causes all configuration options to be reset to their
2066 default values as if the environment variable POSIXLY_CORRECT had
2067 been set.
2068
2069 =item auto_abbrev
2070
2071 Allow option names to be abbreviated to uniqueness.
2072 Default is enabled unless environment variable
2073 POSIXLY_CORRECT has been set, in which case C<auto_abbrev> is disabled.
2074
2075 =item getopt_compat
2076
2077 Allow C<+> to start options.
2078 Default is enabled unless environment variable
2079 POSIXLY_CORRECT has been set, in which case C<getopt_compat> is disabled.
2080
2081 =item gnu_compat
2082
2083 C<gnu_compat> controls whether C<--opt=> is allowed, and what it should
2084 do. Without C<gnu_compat>, C<--opt=> gives an error. With C<gnu_compat>,
2085 C<--opt=> will give option C<opt> and empty value.
2086 This is the way GNU getopt_long() does it.
2087
2088 =item gnu_getopt
2089
2090 This is a short way of setting C<gnu_compat> C<bundling> C<permute>
2091 C<no_getopt_compat>. With C<gnu_getopt>, command line handling should be
2092 fully compatible with GNU getopt_long().
2093
2094 =item require_order
2095
2096 Whether command line arguments are allowed to be mixed with options.
2097 Default is disabled unless environment variable
2098 POSIXLY_CORRECT has been set, in which case C<require_order> is enabled.
2099
2100 See also C<permute>, which is the opposite of C<require_order>.
2101
2102 =item permute
2103
2104 Whether command line arguments are allowed to be mixed with options.
2105 Default is enabled unless environment variable
2106 POSIXLY_CORRECT has been set, in which case C<permute> is disabled.
2107 Note that C<permute> is the opposite of C<require_order>.
2108
2109 If C<permute> is enabled, this means that
2110
2111     --foo arg1 --bar arg2 arg3
2112
2113 is equivalent to
2114
2115     --foo --bar arg1 arg2 arg3
2116
2117 If an argument callback routine is specified, C<@ARGV> will always be
2118 empty upon succesful return of GetOptions() since all options have been
2119 processed. The only exception is when C<--> is used:
2120
2121     --foo arg1 --bar arg2 -- arg3
2122
2123 This will call the callback routine for arg1 and arg2, and then
2124 terminate GetOptions() leaving C<"arg2"> in C<@ARGV>.
2125
2126 If C<require_order> is enabled, options processing
2127 terminates when the first non-option is encountered.
2128
2129     --foo arg1 --bar arg2 arg3
2130
2131 is equivalent to
2132
2133     --foo -- arg1 --bar arg2 arg3
2134
2135 If C<pass_through> is also enabled, options processing will terminate
2136 at the first unrecognized option, or non-option, whichever comes
2137 first.
2138
2139 =item bundling (default: disabled)
2140
2141 Enabling this option will allow single-character options to be
2142 bundled. To distinguish bundles from long option names, long options
2143 I<must> be introduced with C<--> and bundles with C<->.
2144
2145 Note that, if you have options C<a>, C<l> and C<all>, and
2146 auto_abbrev enabled, possible arguments and option settings are:
2147
2148     using argument               sets option(s)
2149     ------------------------------------------
2150     -a, --a                      a
2151     -l, --l                      l
2152     -al, -la, -ala, -all,...     a, l
2153     --al, --all                  all
2154
2155 The suprising part is that C<--a> sets option C<a> (due to auto
2156 completion), not C<all>.
2157
2158 Note: disabling C<bundling> also disables C<bundling_override>.
2159
2160 =item bundling_override (default: disabled)
2161
2162 If C<bundling_override> is enabled, bundling is enabled as with
2163 C<bundling> but now long option names override option bundles.
2164
2165 Note: disabling C<bundling_override> also disables C<bundling>.
2166
2167 B<Note:> Using option bundling can easily lead to unexpected results,
2168 especially when mixing long options and bundles. Caveat emptor.
2169
2170 =item ignore_case  (default: enabled)
2171
2172 If enabled, case is ignored when matching long option names. If,
2173 however, bundling is enabled as well, single character options will be
2174 treated case-sensitive.
2175
2176 With C<ignore_case>, option specifications for options that only
2177 differ in case, e.g., C<"foo"> and C<"Foo">, will be flagged as
2178 duplicates.
2179
2180 Note: disabling C<ignore_case> also disables C<ignore_case_always>.
2181
2182 =item ignore_case_always (default: disabled)
2183
2184 When bundling is in effect, case is ignored on single-character
2185 options also.
2186
2187 Note: disabling C<ignore_case_always> also disables C<ignore_case>.
2188
2189 =item auto_version (default:disabled)
2190
2191 Automatically provide support for the B<--version> option if
2192 the application did not specify a handler for this option itself.
2193
2194 Getopt::Long will provide a standard version message that includes the
2195 program name, its version (if $main::VERSION is defined), and the
2196 versions of Getopt::Long and Perl. The message will be written to
2197 standard output and processing will terminate.
2198
2199 C<auto_version> will be enabled if the calling program explicitly
2200 specified a version number higher than 2.32 in the C<use> or
2201 C<require> statement.
2202
2203 =item auto_help (default:disabled)
2204
2205 Automatically provide support for the B<--help> and B<-?> options if
2206 the application did not specify a handler for this option itself.
2207
2208 Getopt::Long will provide a help message using module L<Pod::Usage>. The
2209 message, derived from the SYNOPSIS POD section, will be written to
2210 standard output and processing will terminate.
2211
2212 C<auto_help> will be enabled if the calling program explicitly
2213 specified a version number higher than 2.32 in the C<use> or
2214 C<require> statement.
2215
2216 =item pass_through (default: disabled)
2217
2218 Options that are unknown, ambiguous or supplied with an invalid option
2219 value are passed through in C<@ARGV> instead of being flagged as
2220 errors. This makes it possible to write wrapper scripts that process
2221 only part of the user supplied command line arguments, and pass the
2222 remaining options to some other program.
2223
2224 If C<require_order> is enabled, options processing will terminate at
2225 the first unrecognized option, or non-option, whichever comes first.
2226 However, if C<permute> is enabled instead, results can become confusing.
2227
2228 Note that the options terminator (default C<-->), if present, will
2229 also be passed through in C<@ARGV>.
2230
2231 =item prefix
2232
2233 The string that starts options. If a constant string is not
2234 sufficient, see C<prefix_pattern>.
2235
2236 =item prefix_pattern
2237
2238 A Perl pattern that identifies the strings that introduce options.
2239 Default is C<(--|-|\+)> unless environment variable
2240 POSIXLY_CORRECT has been set, in which case it is C<(--|-)>.
2241
2242 =item debug (default: disabled)
2243
2244 Enable debugging output.
2245
2246 =back
2247
2248 =head1 Exportable Methods
2249
2250 =over
2251
2252 =item VersionMessage
2253
2254 This subroutine provides a standard version message. Its argument can be:
2255
2256 =over 4
2257
2258 =item *
2259
2260 A string containing the text of a message to print I<before> printing
2261 the standard message.
2262
2263 =item *
2264
2265 A numeric value corresponding to the desired exit status.
2266
2267 =item *
2268
2269 A reference to a hash.
2270
2271 =back
2272
2273 If more than one argument is given then the entire argument list is
2274 assumed to be a hash.  If a hash is supplied (either as a reference or
2275 as a list) it should contain one or more elements with the following
2276 keys:
2277
2278 =over 4
2279
2280 =item C<-message>
2281
2282 =item C<-msg>
2283
2284 The text of a message to print immediately prior to printing the
2285 program's usage message.
2286
2287 =item C<-exitval>
2288
2289 The desired exit status to pass to the B<exit()> function.
2290 This should be an integer, or else the string "NOEXIT" to
2291 indicate that control should simply be returned without
2292 terminating the invoking process.
2293
2294 =item C<-output>
2295
2296 A reference to a filehandle, or the pathname of a file to which the
2297 usage message should be written. The default is C<\*STDERR> unless the
2298 exit value is less than 2 (in which case the default is C<\*STDOUT>).
2299
2300 =back
2301
2302 You cannot tie this routine directly to an option, e.g.:
2303
2304     GetOptions("version" => \&VersionMessage);
2305
2306 Use this instead:
2307
2308     GetOptions("version" => sub { VersionMessage() });
2309
2310 =item HelpMessage
2311
2312 This subroutine produces a standard help message, derived from the
2313 program's POD section SYNOPSIS using L<Pod::Usage>. It takes the same
2314 arguments as VersionMessage(). In particular, you cannot tie it
2315 directly to an option, e.g.:
2316
2317     GetOptions("help" => \&HelpMessage);
2318
2319 Use this instead:
2320
2321     GetOptions("help" => sub { HelpMessage() });
2322
2323 =back
2324
2325 =head1 Return values and Errors
2326
2327 Configuration errors and errors in the option definitions are
2328 signalled using die() and will terminate the calling program unless
2329 the call to Getopt::Long::GetOptions() was embedded in C<eval { ...
2330 }>, or die() was trapped using C<$SIG{__DIE__}>.
2331
2332 GetOptions returns true to indicate success.
2333 It returns false when the function detected one or more errors during
2334 option parsing. These errors are signalled using warn() and can be
2335 trapped with C<$SIG{__WARN__}>.
2336
2337 =head1 Legacy
2338
2339 The earliest development of C<newgetopt.pl> started in 1990, with Perl
2340 version 4. As a result, its development, and the development of
2341 Getopt::Long, has gone through several stages. Since backward
2342 compatibility has always been extremely important, the current version
2343 of Getopt::Long still supports a lot of constructs that nowadays are
2344 no longer necessary or otherwise unwanted. This section describes
2345 briefly some of these 'features'.
2346
2347 =head2 Default destinations
2348
2349 When no destination is specified for an option, GetOptions will store
2350 the resultant value in a global variable named C<opt_>I<XXX>, where
2351 I<XXX> is the primary name of this option. When a progam executes
2352 under C<use strict> (recommended), these variables must be
2353 pre-declared with our() or C<use vars>.
2354
2355     our $opt_length = 0;
2356     GetOptions ('length=i');    # will store in $opt_length
2357
2358 To yield a usable Perl variable, characters that are not part of the
2359 syntax for variables are translated to underscores. For example,
2360 C<--fpp-struct-return> will set the variable
2361 C<$opt_fpp_struct_return>. Note that this variable resides in the
2362 namespace of the calling program, not necessarily C<main>. For
2363 example:
2364
2365     GetOptions ("size=i", "sizes=i@");
2366
2367 with command line "-size 10 -sizes 24 -sizes 48" will perform the
2368 equivalent of the assignments
2369
2370     $opt_size = 10;
2371     @opt_sizes = (24, 48);
2372
2373 =head2 Alternative option starters
2374
2375 A string of alternative option starter characters may be passed as the
2376 first argument (or the first argument after a leading hash reference
2377 argument).
2378
2379     my $len = 0;
2380     GetOptions ('/', 'length=i' => $len);
2381
2382 Now the command line may look like:
2383
2384     /length 24 -- arg
2385
2386 Note that to terminate options processing still requires a double dash
2387 C<-->.
2388
2389 GetOptions() will not interpret a leading C<< "<>" >> as option starters
2390 if the next argument is a reference. To force C<< "<" >> and C<< ">" >> as
2391 option starters, use C<< "><" >>. Confusing? Well, B<using a starter
2392 argument is strongly deprecated> anyway.
2393
2394 =head2 Configuration variables
2395
2396 Previous versions of Getopt::Long used variables for the purpose of
2397 configuring. Although manipulating these variables still work, it is
2398 strongly encouraged to use the C<Configure> routine that was introduced
2399 in version 2.17. Besides, it is much easier.
2400
2401 =head1 Trouble Shooting
2402
2403 =head2 GetOptions does not return a false result when an option is not supplied
2404
2405 That's why they're called 'options'.
2406
2407 =head2 GetOptions does not split the command line correctly
2408
2409 The command line is not split by GetOptions, but by the command line
2410 interpreter (CLI). On Unix, this is the shell. On Windows, it is
2411 COMMAND.COM or CMD.EXE. Other operating systems have other CLIs.
2412
2413 It is important to know that these CLIs may behave different when the
2414 command line contains special characters, in particular quotes or
2415 backslashes. For example, with Unix shells you can use single quotes
2416 (C<'>) and double quotes (C<">) to group words together. The following
2417 alternatives are equivalent on Unix:
2418
2419     "two words"
2420     'two words'
2421     two\ words
2422
2423 In case of doubt, insert the following statement in front of your Perl
2424 program:
2425
2426     print STDERR (join("|",@ARGV),"\n");
2427
2428 to verify how your CLI passes the arguments to the program.
2429
2430 =head2 Undefined subroutine &main::GetOptions called
2431
2432 Are you running Windows, and did you write
2433
2434     use GetOpt::Long;
2435
2436 (note the capital 'O')?
2437
2438 =head2 How do I put a "-?" option into a Getopt::Long?
2439
2440 You can only obtain this using an alias, and Getopt::Long of at least
2441 version 2.13.
2442
2443     use Getopt::Long;
2444     GetOptions ("help|?");    # -help and -? will both set $opt_help
2445
2446 =head1 AUTHOR
2447
2448 Johan Vromans <jvromans@squirrel.nl>
2449
2450 =head1 COPYRIGHT AND DISCLAIMER
2451
2452 This program is Copyright 2003,1990 by Johan Vromans.
2453 This program is free software; you can redistribute it and/or
2454 modify it under the terms of the Perl Artistic License or the
2455 GNU General Public License as published by the Free Software
2456 Foundation; either version 2 of the License, or (at your option) any
2457 later version.
2458
2459 This program is distributed in the hope that it will be useful,
2460 but WITHOUT ANY WARRANTY; without even the implied warranty of
2461 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
2462 GNU General Public License for more details.
2463
2464 If you do not have a copy of the GNU General Public License write to
2465 the Free Software Foundation, Inc., 675 Mass Ave, Cambridge,
2466 MA 02139, USA.
2467
2468 =cut
2469