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