lib/Getopt/Long.pm

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