lib/Getopt/Long.pm

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