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