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