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