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