lib/Getopt/Long.pm

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