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