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