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