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