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.45 2001-09-27 17:39:47+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: Thu Sep 27 17:38:47 2001
  10 # Update Count    : 980
  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_02;
  39 # For testing versions only.
  40 use vars qw($VERSION_STRING);
  41 $VERSION_STRING = "2.26_02";
  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.45 $', ") ",
 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 overides, obey case ignore.
 727         $tryopt = $ignorecase ? lc($opt) : $opt;
 728
 729         # If bundling == 2, long options can override bundles.
 730         if ( $bundling == 2 && defined ($opctl->{$tryopt}) ) {
 731             print STDERR ("=> $starter$tryopt overrides unbundling\n")
 732               if $debug;
 733         }
 734         else {
 735             $tryopt = $opt;
 736             # Unbundle single letter option.
 737             $rest = length ($tryopt) > 0 ? substr ($tryopt, 1) : "";
 738             $tryopt = substr ($tryopt, 0, 1);
 739             $tryopt = lc ($tryopt) if $ignorecase > 1;
 740             print STDERR ("=> $starter$tryopt unbundled from ",
 741                           "$starter$tryopt$rest\n") if $debug;
 742             $rest = undef unless $rest ne '';
 743         }
 744     }
 745
 746     # Try auto-abbreviation.
 747     elsif ( $autoabbrev ) {
 748         # Sort the possible long option names.
 749         my @names = sort(keys (%$opctl));
 750         # Downcase if allowed.
 751         $opt = lc ($opt) if $ignorecase;
 752         $tryopt = $opt;
 753         # Turn option name into pattern.
 754         my $pat = quotemeta ($opt);
 755         # Look up in option names.
 756         my @hits = grep (/^$pat/, @names);
 757         print STDERR ("=> ", scalar(@hits), " hits (@hits) with \"$pat\" ",
 758                       "out of ", scalar(@names), "\n") if $debug;
 759
 760         # Check for ambiguous results.
 761         unless ( (@hits <= 1) || (grep ($_ eq $opt, @hits) == 1) ) {
 762             # See if all matches are for the same option.
 763             my %hit;
 764             foreach ( @hits ) {
 765                 $_ = $opctl->{$_}->[CTL_CNAME]
 766                   if defined $opctl->{$_}->[CTL_CNAME];
 767                 $hit{$_} = 1;
 768             }
 769             # Now see if it really is ambiguous.
 770             unless ( keys(%hit) == 1 ) {
 771                 return (0) if $passthrough;
 772                 warn ("Option ", $opt, " is ambiguous (",
 773                       join(", ", @hits), ")\n");
 774                 $error++;
 775                 return (1, undef);
 776             }
 777             @hits = keys(%hit);
 778         }
 779
 780         # Complete the option name, if appropriate.
 781         if ( @hits == 1 && $hits[0] ne $opt ) {
 782             $tryopt = $hits[0];
 783             $tryopt = lc ($tryopt) if $ignorecase;
 784             print STDERR ("=> option \"$opt\" -> \"$tryopt\"\n")
 785                 if $debug;
 786         }
 787     }
 788
 789     # Map to all lowercase if ignoring case.
 790     elsif ( $ignorecase ) {
 791         $tryopt = lc ($opt);
 792     }
 793
 794     # Check validity by fetching the info.
 795     my $ctl = $opctl->{$tryopt};
 796     unless  ( defined $ctl ) {
 797         return (0) if $passthrough;
 798         warn ("Unknown option: ", $opt, "\n");
 799         $error++;
 800         return (1, undef);
 801     }
 802     # Apparently valid.
 803     $opt = $tryopt;
 804     print STDERR ("=> found ", OptCtl($ctl),
 805                   " for \"", $opt, "\"\n") if $debug;
 806
 807     #### Determine argument status ####
 808
 809     # If it is an option w/o argument, we're almost finished with it.
 810     my $type = $ctl->[CTL_TYPE];
 811     my $arg;
 812
 813     if ( $type eq '' || $type eq '!' || $type eq '+' ) {
 814         if ( defined $optarg ) {
 815             return (0) if $passthrough;
 816             warn ("Option ", $opt, " does not take an argument\n");
 817             $error++;
 818             undef $opt;
 819         }
 820         elsif ( $type eq '' || $type eq '+' ) {
 821             $arg = 1;           # supply explicit value
 822         }
 823         else {
 824             $opt =~ s/^no//i;   # strip NO prefix
 825             $arg = 0;           # supply explicit value
 826         }
 827         unshift (@ARGV, $starter.$rest) if defined $rest;
 828         return (1, $opt, $ctl, $arg);
 829     }
 830
 831     # Get mandatory status and type info.
 832     my $mand = $ctl->[CTL_MAND];
 833
 834     # Check if there is an option argument available.
 835     if ( $gnu_compat ) {
 836         return (1, $opt, $ctl, $optarg)
 837           if defined $optarg;
 838         return (1, $opt, $ctl, $type eq "s" ? '' : 0)
 839           unless $mand;
 840     }
 841
 842     # Check if there is an option argument available.
 843     if ( defined $optarg
 844          ? ($optarg eq '')
 845          : !(defined $rest || @ARGV > 0) ) {
 846         # Complain if this option needs an argument.
 847         if ( $mand ) {
 848             return (0) if $passthrough;
 849             warn ("Option ", $opt, " requires an argument\n");
 850             $error++;
 851             return (1, undef);
 852         }
 853         return (1, $opt, $ctl, $type eq "s" ? '' : 0);
 854     }
 855
 856     # Get (possibly optional) argument.
 857     $arg = (defined $rest ? $rest
 858             : (defined $optarg ? $optarg : shift (@ARGV)));
 859
 860     # Get key if this is a "name=value" pair for a hash option.
 861     my $key;
 862     if ($ctl->[CTL_DEST] == CTL_DEST_HASH && defined $arg) {
 863         ($key, $arg) = ($arg =~ /^([^=]*)=(.*)$/s) ? ($1, $2) : ($arg, 1);
 864     }
 865
 866     #### Check if the argument is valid for this option ####
 867
 868     if ( $type eq "s" ) {       # string
 869         # A mandatory string takes anything.
 870         return (1, $opt, $ctl, $arg, $key) if $mand;
 871
 872         # An optional string takes almost anything.
 873         return (1, $opt, $ctl, $arg, $key)
 874           if defined $optarg || defined $rest;
 875         return (1, $opt, $ctl, $arg, $key) if $arg eq "-"; # ??
 876
 877         # Check for option or option list terminator.
 878         if ($arg eq $argend ||
 879             $arg =~ /^$prefix.+/) {
 880             # Push back.
 881             unshift (@ARGV, $arg);
 882             # Supply empty value.
 883             $arg = '';
 884         }
 885     }
 886
 887     elsif ( $type eq "i" # numeric/integer
 888             || $type eq "o" ) { # dec/oct/hex/bin value
 889
 890         my $o_valid =
 891           $type eq "o" ? "[-+]?[1-9][0-9]*|0x[0-9a-f]+|0b[01]+|0[0-7]*"
 892             : "[-+]?[0-9]+";
 893
 894         if ( $bundling && defined $rest && $rest =~ /^($o_valid)(.*)$/si ) {
 895             $arg = $1;
 896             $rest = $2;
 897             $arg = ($type eq "o" && $arg =~ /^0/) ? oct($arg) : 0+$arg;
 898             unshift (@ARGV, $starter.$rest) if defined $rest && $rest ne '';
 899         }
 900         elsif ( $arg =~ /^($o_valid)$/si ) {
 901             $arg = ($type eq "o" && $arg =~ /^0/) ? oct($arg) : 0+$arg;
 902         }
 903         else {
 904             if ( defined $optarg || $mand ) {
 905                 if ( $passthrough ) {
 906                     unshift (@ARGV, defined $rest ? $starter.$rest : $arg)
 907                       unless defined $optarg;
 908                     return (0);
 909                 }
 910                 warn ("Value \"", $arg, "\" invalid for option ",
 911                       $opt, " (",
 912                       $type eq "o" ? "extended " : "",
 913                       "number expected)\n");
 914                 $error++;
 915                 # Push back.
 916                 unshift (@ARGV, $starter.$rest) if defined $rest;
 917                 return (1, undef);
 918             }
 919             else {
 920                 # Push back.
 921                 unshift (@ARGV, defined $rest ? $starter.$rest : $arg);
 922                 # Supply default value.
 923                 $arg = 0;
 924             }
 925         }
 926     }
 927
 928     elsif ( $type eq "f" ) { # real number, int is also ok
 929         # We require at least one digit before a point or 'e',
 930         # and at least one digit following the point and 'e'.
 931         # [-]NN[.NN][eNN]
 932         if ( $bundling && defined $rest &&
 933              $rest =~ /^([-+]?[0-9]+(\.[0-9]+)?([eE][-+]?[0-9]+)?)(.*)$/s ) {
 934             $arg = $1;
 935             $rest = $+;
 936             unshift (@ARGV, $starter.$rest) if defined $rest && $rest ne '';
 937         }
 938         elsif ( $arg !~ /^[-+]?[0-9.]+(\.[0-9]+)?([eE][-+]?[0-9]+)?$/ ) {
 939             if ( defined $optarg || $mand ) {
 940                 if ( $passthrough ) {
 941                     unshift (@ARGV, defined $rest ? $starter.$rest : $arg)
 942                       unless defined $optarg;
 943                     return (0);
 944                 }
 945                 warn ("Value \"", $arg, "\" invalid for option ",
 946                       $opt, " (real number expected)\n");
 947                 $error++;
 948                 # Push back.
 949                 unshift (@ARGV, $starter.$rest) if defined $rest;
 950                 return (1, undef);
 951             }
 952             else {
 953                 # Push back.
 954                 unshift (@ARGV, defined $rest ? $starter.$rest : $arg);
 955                 # Supply default value.
 956                 $arg = 0.0;
 957             }
 958         }
 959     }
 960     else {
 961         Croak ("GetOpt::Long internal error (Can't happen)\n");
 962     }
 963     return (1, $opt, $ctl, $arg, $key);
 964 }
 965
 966 # Getopt::Long Configuration.
 967 sub Configure (@) {
 968     my (@options) = @_;
 969
 970     my $prevconfig =
 971       [ $error, $debug, $major_version, $minor_version,
 972         $autoabbrev, $getopt_compat, $ignorecase, $bundling, $order,
 973         $gnu_compat, $passthrough, $genprefix ];
 974
 975     if ( ref($options[0]) eq 'ARRAY' ) {
 976         ( $error, $debug, $major_version, $minor_version,
 977           $autoabbrev, $getopt_compat, $ignorecase, $bundling, $order,
 978           $gnu_compat, $passthrough, $genprefix ) = @{shift(@options)};
 979     }
 980
 981     my $opt;
 982     foreach $opt ( @options ) {
 983         my $try = lc ($opt);
 984         my $action = 1;
 985         if ( $try =~ /^no_?(.*)$/s ) {
 986             $action = 0;
 987             $try = $+;
 988         }
 989         if ( ($try eq 'default' or $try eq 'defaults') && $action ) {
 990             ConfigDefaults ();
 991         }
 992         elsif ( ($try eq 'posix_default' or $try eq 'posix_defaults') ) {
 993             local $ENV{POSIXLY_CORRECT};
 994             $ENV{POSIXLY_CORRECT} = 1 if $action;
 995             ConfigDefaults ();
 996         }
 997         elsif ( $try eq 'auto_abbrev' or $try eq 'autoabbrev' ) {
 998             $autoabbrev = $action;
 999         }
1000         elsif ( $try eq 'getopt_compat' ) {
1001             $getopt_compat = $action;
1002         }
1003         elsif ( $try eq 'gnu_getopt' ) {
1004             if ( $action ) {
1005                 $gnu_compat = 1;
1006                 $bundling = 1;
1007                 $getopt_compat = 0;
1008                 $order = $PERMUTE;
1009             }
1010         }
1011         elsif ( $try eq 'gnu_compat' ) {
1012             $gnu_compat = $action;
1013         }
1014         elsif ( $try eq 'ignorecase' or $try eq 'ignore_case' ) {
1015             $ignorecase = $action;
1016         }
1017         elsif ( $try eq 'ignore_case_always' ) {
1018             $ignorecase = $action ? 2 : 0;
1019         }
1020         elsif ( $try eq 'bundling' ) {
1021             $bundling = $action;
1022         }
1023         elsif ( $try eq 'bundling_override' ) {
1024             $bundling = $action ? 2 : 0;
1025         }
1026         elsif ( $try eq 'require_order' ) {
1027             $order = $action ? $REQUIRE_ORDER : $PERMUTE;
1028         }
1029         elsif ( $try eq 'permute' ) {
1030             $order = $action ? $PERMUTE : $REQUIRE_ORDER;
1031         }
1032         elsif ( $try eq 'pass_through' or $try eq 'passthrough' ) {
1033             $passthrough = $action;
1034         }
1035         elsif ( $try =~ /^prefix=(.+)$/ && $action ) {
1036             $genprefix = $1;
1037             # Turn into regexp. Needs to be parenthesized!
1038             $genprefix = "(" . quotemeta($genprefix) . ")";
1039             eval { '' =~ /$genprefix/; };
1040             Croak ("Getopt::Long: invalid pattern \"$genprefix\"") if $@;
1041         }
1042         elsif ( $try =~ /^prefix_pattern=(.+)$/ && $action ) {
1043             $genprefix = $1;
1044             # Parenthesize if needed.
1045             $genprefix = "(" . $genprefix . ")"
1046               unless $genprefix =~ /^\(.*\)$/;
1047             eval { '' =~ /$genprefix/; };
1048             Croak ("Getopt::Long: invalid pattern \"$genprefix\"") if $@;
1049         }
1050         elsif ( $try eq 'debug' ) {
1051             $debug = $action;
1052         }
1053         else {
1054             Croak ("Getopt::Long: unknown config parameter \"$opt\"")
1055         }
1056     }
1057     $prevconfig;
1058 }
1059
1060 # Deprecated name.
1061 sub config (@) {
1062     Configure (@_);
1063 }
1064
1065 # To prevent Carp from being loaded unnecessarily.
1066 sub Croak (@) {
1067     require 'Carp.pm';
1068     $Carp::CarpLevel = 1;
1069     Carp::croak(@_);
1070 };
1071
1072 ################ Documentation ################
1073
1074 =head1 NAME
1075
1076 Getopt::Long - Extended processing of command line options
1077
1078 =head1 SYNOPSIS
1079
1080   use Getopt::Long;
1081   my $data   = "file.dat";
1082   my $length = 24;
1083   my $verbose;
1084   $result = GetOptions ("length=i" => \$length,    # numeric
1085                         "file=s"   => \$data,      # string
1086                         "verbose"  => \$verbose);  # flag
1087
1088 =head1 DESCRIPTION
1089
1090 The Getopt::Long module implements an extended getopt function called
1091 GetOptions(). This function adheres to the POSIX syntax for command
1092 line options, with GNU extensions. In general, this means that options
1093 have long names instead of single letters, and are introduced with a
1094 double dash "--". Support for bundling of command line options, as was
1095 the case with the more traditional single-letter approach, is provided
1096 but not enabled by default.
1097
1098 =head1 Command Line Options, an Introduction
1099
1100 Command line operated programs traditionally take their arguments from
1101 the command line, for example filenames or other information that the
1102 program needs to know. Besides arguments, these programs often take
1103 command line I<options> as well. Options are not necessary for the
1104 program to work, hence the name 'option', but are used to modify its
1105 default behaviour. For example, a program could do its job quietly,
1106 but with a suitable option it could provide verbose information about
1107 what it did.
1108
1109 Command line options come in several flavours. Historically, they are
1110 preceded by a single dash C<->, and consist of a single letter.
1111
1112     -l -a -c
1113
1114 Usually, these single-character options can be bundled:
1115
1116     -lac
1117
1118 Options can have values, the value is placed after the option
1119 character. Sometimes with whitespace in between, sometimes not:
1120
1121     -s 24 -s24
1122
1123 Due to the very cryptic nature of these options, another style was
1124 developed that used long names. So instead of a cryptic C<-l> one
1125 could use the more descriptive C<--long>. To distinguish between a
1126 bundle of single-character options and a long one, two dashes are used
1127 to precede the option name. Early implementations of long options used
1128 a plus C<+> instead. Also, option values could be specified either
1129 like
1130
1131     --size=24
1132
1133 or
1134
1135     --size 24
1136
1137 The C<+> form is now obsolete and strongly deprecated.
1138
1139 =head1 Getting Started with Getopt::Long
1140
1141 Getopt::Long is the Perl5 successor of C<newgetopt.pl>. This was
1142 the first Perl module that provided support for handling the new style
1143 of command line options, hence the name Getopt::Long. This module
1144 also supports single-character options and bundling. In this case, the
1145 options are restricted to alphabetic characters only, and the
1146 characters C<?> and C<->.
1147
1148 To use Getopt::Long from a Perl program, you must include the
1149 following line in your Perl program:
1150
1151     use Getopt::Long;
1152
1153 This will load the core of the Getopt::Long module and prepare your
1154 program for using it. Most of the actual Getopt::Long code is not
1155 loaded until you really call one of its functions.
1156
1157 In the default configuration, options names may be abbreviated to
1158 uniqueness, case does not matter, and a single dash is sufficient,
1159 even for long option names. Also, options may be placed between
1160 non-option arguments. See L<Configuring Getopt::Long> for more
1161 details on how to configure Getopt::Long.
1162
1163 =head2 Simple options
1164
1165 The most simple options are the ones that take no values. Their mere
1166 presence on the command line enables the option. Popular examples are:
1167
1168     --all --verbose --quiet --debug
1169
1170 Handling simple options is straightforward:
1171
1172     my $verbose = '';   # option variable with default value (false)
1173     my $all = '';       # option variable with default value (false)
1174     GetOptions ('verbose' => \$verbose, 'all' => \$all);
1175
1176 The call to GetOptions() parses the command line arguments that are
1177 present in C<@ARGV> and sets the option variable to the value C<1> if
1178 the option did occur on the command line. Otherwise, the option
1179 variable is not touched. Setting the option value to true is often
1180 called I<enabling> the option.
1181
1182 The option name as specified to the GetOptions() function is called
1183 the option I<specification>. Later we'll see that this specification
1184 can contain more than just the option name. The reference to the
1185 variable is called the option I<destination>.
1186
1187 GetOptions() will return a true value if the command line could be
1188 processed successfully. Otherwise, it will write error messages to
1189 STDERR, and return a false result.
1190
1191 =head2 A little bit less simple options
1192
1193 Getopt::Long supports two useful variants of simple options:
1194 I<negatable> options and I<incremental> options.
1195
1196 A negatable option is specified with a exclamation mark C<!> after the
1197 option name:
1198
1199     my $verbose = '';   # option variable with default value (false)
1200     GetOptions ('verbose!' => \$verbose);
1201
1202 Now, using C<--verbose> on the command line will enable C<$verbose>,
1203 as expected. But it is also allowed to use C<--noverbose>, which will
1204 disable C<$verbose> by setting its value to C<0>. Using a suitable
1205 default value, the program can find out whether C<$verbose> is false
1206 by default, or disabled by using C<--noverbose>.
1207
1208 An incremental option is specified with a plus C<+> after the
1209 option name:
1210
1211     my $verbose = '';   # option variable with default value (false)
1212     GetOptions ('verbose+' => \$verbose);
1213
1214 Using C<--verbose> on the command line will increment the value of
1215 C<$verbose>. This way the program can keep track of how many times the
1216 option occurred on the command line. For example, each occurrence of
1217 C<--verbose> could increase the verbosity level of the program.
1218
1219 =head2 Mixing command line option with other arguments
1220
1221 Usually programs take command line options as well as other arguments,
1222 for example, file names. It is good practice to always specify the
1223 options first, and the other arguments last. Getopt::Long will,
1224 however, allow the options and arguments to be mixed and 'filter out'
1225 all the options before passing the rest of the arguments to the
1226 program. To stop Getopt::Long from processing further arguments,
1227 insert a double dash C<--> on the command line:
1228
1229     --size 24 -- --all
1230
1231 In this example, C<--all> will I<not> be treated as an option, but
1232 passed to the program unharmed, in C<@ARGV>.
1233
1234 =head2 Options with values
1235
1236 For options that take values it must be specified whether the option
1237 value is required or not, and what kind of value the option expects.
1238
1239 Three kinds of values are supported: integer numbers, floating point
1240 numbers, and strings.
1241
1242 If the option value is required, Getopt::Long will take the
1243 command line argument that follows the option and assign this to the
1244 option variable. If, however, the option value is specified as
1245 optional, this will only be done if that value does not look like a
1246 valid command line option itself.
1247
1248     my $tag = '';       # option variable with default value
1249     GetOptions ('tag=s' => \$tag);
1250
1251 In the option specification, the option name is followed by an equals
1252 sign C<=> and the letter C<s>. The equals sign indicates that this
1253 option requires a value. The letter C<s> indicates that this value is
1254 an arbitrary string. Other possible value types are C<i> for integer
1255 values, and C<f> for floating point values. Using a colon C<:> instead
1256 of the equals sign indicates that the option value is optional. In
1257 this case, if no suitable value is supplied, string valued options get
1258 an empty string C<''> assigned, while numeric options are set to C<0>.
1259
1260 =head2 Options with multiple values
1261
1262 Options sometimes take several values. For example, a program could
1263 use multiple directories to search for library files:
1264
1265     --library lib/stdlib --library lib/extlib
1266
1267 To accomplish this behaviour, simply specify an array reference as the
1268 destination for the option:
1269
1270     my @libfiles = ();
1271     GetOptions ("library=s" => \@libfiles);
1272
1273 Used with the example above, C<@libfiles> would contain two strings
1274 upon completion: C<"lib/srdlib"> and C<"lib/extlib">, in that order.
1275 It is also possible to specify that only integer or floating point
1276 numbers are acceptible values.
1277
1278 Often it is useful to allow comma-separated lists of values as well as
1279 multiple occurrences of the options. This is easy using Perl's split()
1280 and join() operators:
1281
1282     my @libfiles = ();
1283     GetOptions ("library=s" => \@libfiles);
1284     @libfiles = split(/,/,join(',',@libfiles));
1285
1286 Of course, it is important to choose the right separator string for
1287 each purpose.
1288
1289 =head2 Options with hash values
1290
1291 If the option destination is a reference to a hash, the option will
1292 take, as value, strings of the form I<key>C<=>I<value>. The value will
1293 be stored with the specified key in the hash.
1294
1295     my %defines = ();
1296     GetOptions ("define=s" => \%defines);
1297
1298 When used with command line options:
1299
1300     --define os=linux --define vendor=redhat
1301
1302 the hash C<%defines> will contain two keys, C<"os"> with value
1303 C<"linux> and C<"vendor"> with value C<"redhat">.
1304 It is also possible to specify that only integer or floating point
1305 numbers are acceptible values. The keys are always taken to be strings.
1306
1307 =head2 User-defined subroutines to handle options
1308
1309 Ultimate control over what should be done when (actually: each time)
1310 an option is encountered on the command line can be achieved by
1311 designating a reference to a subroutine (or an anonymous subroutine)
1312 as the option destination. When GetOptions() encounters the option, it
1313 will call the subroutine with two or three arguments. The first
1314 argument is the name of the option. For a scalar or array destination,
1315 the second argument is the value to be stored. For a hash destination,
1316 the second arguments is the key to the hash, and the third argument
1317 the value to be stored. It is up to the subroutine to store the value,
1318 or do whatever it thinks is appropriate.
1319
1320 A trivial application of this mechanism is to implement options that
1321 are related to each other. For example:
1322
1323     my $verbose = '';   # option variable with default value (false)
1324     GetOptions ('verbose' => \$verbose,
1325                 'quiet'   => sub { $verbose = 0 });
1326
1327 Here C<--verbose> and C<--quiet> control the same variable
1328 C<$verbose>, but with opposite values.
1329
1330 If the subroutine needs to signal an error, it should call die() with
1331 the desired error message as its argument. GetOptions() will catch the
1332 die(), issue the error message, and record that an error result must
1333 be returned upon completion.
1334
1335 If the text of the error message starts with an exclamantion mark C<!>
1336 it is interpreted specially by GetOptions(). There is currently one
1337 special command implemented: C<die("!FINISH")> will cause GetOptions()
1338 to stop processing options, as if it encountered a double dash C<-->.
1339
1340 =head2 Options with multiple names
1341
1342 Often it is user friendly to supply alternate mnemonic names for
1343 options. For example C<--height> could be an alternate name for
1344 C<--length>. Alternate names can be included in the option
1345 specification, separated by vertical bar C<|> characters. To implement
1346 the above example:
1347
1348     GetOptions ('length|height=f' => \$length);
1349
1350 The first name is called the I<primary> name, the other names are
1351 called I<aliases>.
1352
1353 Multiple alternate names are possible.
1354
1355 =head2 Case and abbreviations
1356
1357 Without additional configuration, GetOptions() will ignore the case of
1358 option names, and allow the options to be abbreviated to uniqueness.
1359
1360     GetOptions ('length|height=f' => \$length, "head" => \$head);
1361
1362 This call will allow C<--l> and C<--L> for the length option, but
1363 requires a least C<--hea> and C<--hei> for the head and height options.
1364
1365 =head2 Summary of Option Specifications
1366
1367 Each option specifier consists of two parts: the name specification
1368 and the argument specification.
1369
1370 The name specification contains the name of the option, optionally
1371 followed by a list of alternative names separated by vertical bar
1372 characters.
1373
1374     length            option name is "length"
1375     length|size|l     name is "length", aliases are "size" and "l"
1376
1377 The argument specification is optional. If omitted, the option is
1378 considered boolean, a value of 1 will be assigned when the option is
1379 used on the command line.
1380
1381 The argument specification can be
1382
1383 =over 4
1384
1385 =item !
1386
1387 The option does not take an argument and may be negated, i.e. prefixed
1388 by "no". E.g. C<"foo!"> will allow C<--foo> (a value of 1 will be
1389 assigned) and C<--nofoo> (a value of 0 will be assigned). If the
1390 option has aliases, this applies to the aliases as well.
1391
1392 Using negation on a single letter option when bundling is in effect is
1393 pointless and will result in a warning.
1394
1395 =item +
1396
1397 The option does not take an argument and will be incremented by 1
1398 every time it appears on the command line. E.g. C<"more+">, when used
1399 with C<--more --more --more>, will increment the value three times,
1400 resulting in a value of 3 (provided it was 0 or undefined at first).
1401
1402 The C<+> specifier is ignored if the option destination is not a scalar.
1403
1404 =item = I<type> [ I<desttype> ]
1405
1406 The option requires an argument of the given type. Supported types
1407 are:
1408
1409 =over 4
1410
1411 =item s
1412
1413 String. An arbitrary sequence of characters. It is valid for the
1414 argument to start with C<-> or C<-->.
1415
1416 =item i
1417
1418 Integer. An optional leading plus or minus sign, followed by a
1419 sequence of digits.
1420
1421 =item o
1422
1423 Extended integer, Perl style. This can be either an optional leading
1424 plus or minus sign, followed by a sequence of digits, or an octal
1425 string (a zero, optionally followed by '0', '1', .. '7'), or a
1426 hexadecimal string (C<0x> followed by '0' .. '9', 'a' .. 'f', case
1427 insensitive), or a binary string (C<0b> followed by a series of '0'
1428 and '1').
1429
1430 =item f
1431
1432 Real number. For example C<3.14>, C<-6.23E24> and so on.
1433
1434 =back
1435
1436 The I<desttype> can be C<@> or C<%> to specify that the option is
1437 list or a hash valued. This is only needed when the destination for
1438 the option value is not otherwise specified. It should be omitted when
1439 not needed.
1440
1441 =item : I<type> [ I<desttype> ]
1442
1443 Like C<=>, but designates the argument as optional.
1444 If omitted, an empty string will be assigned to string values options,
1445 and the value zero to numeric options.
1446
1447 Note that if a string argument starts with C<-> or C<-->, it will be
1448 considered an option on itself.
1449
1450 =back
1451
1452 =head1 Advanced Possibilities
1453
1454 =head2 Object oriented interface
1455
1456 Getopt::Long can be used in an object oriented way as well:
1457
1458     use Getopt::Long;
1459     $p = new Getopt::Long::Parser;
1460     $p->configure(...configuration options...);
1461     if ($p->getoptions(...options descriptions...)) ...
1462
1463 Configuration options can be passed to the constructor:
1464
1465     $p = new Getopt::Long::Parser
1466              config => [...configuration options...];
1467
1468 For thread safety, each method call will acquire an exclusive lock to
1469 the Getopt::Long module. So don't call these methods from a callback
1470 routine!
1471
1472 =head2 Documentation and help texts
1473
1474 Getopt::Long encourages the use of Pod::Usage to produce help
1475 messages. For example:
1476
1477     use Getopt::Long;
1478     use Pod::Usage;
1479
1480     my $man = 0;
1481     my $help = 0;
1482
1483     GetOptions('help|?' => \$help, man => \$man) or pod2usage(2);
1484     pod2usage(1) if $help;
1485     pod2usage(-exitstatus => 0, -verbose => 2) if $man;
1486
1487     __END__
1488
1489     =head1 NAME
1490
1491     sample - Using GetOpt::Long and Pod::Usage
1492
1493     =head1 SYNOPSIS
1494
1495     sample [options] [file ...]
1496
1497      Options:
1498        -help            brief help message
1499        -man             full documentation
1500
1501     =head1 OPTIONS
1502
1503     =over 8
1504
1505     =item B<-help>
1506
1507     Print a brief help message and exits.
1508
1509     =item B<-man>
1510
1511     Prints the manual page and exits.
1512
1513     =back
1514
1515     =head1 DESCRIPTION
1516
1517     B<This program> will read the given input file(s) and do someting
1518     useful with the contents thereof.
1519
1520     =cut
1521
1522 See L<Pod::Usage> for details.
1523
1524 =head2 Storing options in a hash
1525
1526 Sometimes, for example when there are a lot of options, having a
1527 separate variable for each of them can be cumbersome. GetOptions()
1528 supports, as an alternative mechanism, storing options in a hash.
1529
1530 To obtain this, a reference to a hash must be passed I<as the first
1531 argument> to GetOptions(). For each option that is specified on the
1532 command line, the option value will be stored in the hash with the
1533 option name as key. Options that are not actually used on the command
1534 line will not be put in the hash, on other words,
1535 C<exists($h{option})> (or defined()) can be used to test if an option
1536 was used. The drawback is that warnings will be issued if the program
1537 runs under C<use strict> and uses C<$h{option}> without testing with
1538 exists() or defined() first.
1539
1540     my %h = ();
1541     GetOptions (\%h, 'length=i');       # will store in $h{length}
1542
1543 For options that take list or hash values, it is necessary to indicate
1544 this by appending an C<@> or C<%> sign after the type:
1545
1546     GetOptions (\%h, 'colours=s@');     # will push to @{$h{colours}}
1547
1548 To make things more complicated, the hash may contain references to
1549 the actual destinations, for example:
1550
1551     my $len = 0;
1552     my %h = ('length' => \$len);
1553     GetOptions (\%h, 'length=i');       # will store in $len
1554
1555 This example is fully equivalent with:
1556
1557     my $len = 0;
1558     GetOptions ('length=i' => \$len);   # will store in $len
1559
1560 Any mixture is possible. For example, the most frequently used options
1561 could be stored in variables while all other options get stored in the
1562 hash:
1563
1564     my $verbose = 0;                    # frequently referred
1565     my $debug = 0;                      # frequently referred
1566     my %h = ('verbose' => \$verbose, 'debug' => \$debug);
1567     GetOptions (\%h, 'verbose', 'debug', 'filter', 'size=i');
1568     if ( $verbose ) { ... }
1569     if ( exists $h{filter} ) { ... option 'filter' was specified ... }
1570
1571 =head2 Bundling
1572
1573 With bundling it is possible to set several single-character options
1574 at once. For example if C<a>, C<v> and C<x> are all valid options,
1575
1576     -vax
1577
1578 would set all three.
1579
1580 Getopt::Long supports two levels of bundling. To enable bundling, a
1581 call to Getopt::Long::Configure is required.
1582
1583 The first level of bundling can be enabled with:
1584
1585     Getopt::Long::Configure ("bundling");
1586
1587 Configured this way, single-character options can be bundled but long
1588 options B<must> always start with a double dash C<--> to avoid
1589 abiguity. For example, when C<vax>, C<a>, C<v> and C<x> are all valid
1590 options,
1591
1592     -vax
1593
1594 would set C<a>, C<v> and C<x>, but
1595
1596     --vax
1597
1598 would set C<vax>.
1599
1600 The second level of bundling lifts this restriction. It can be enabled
1601 with:
1602
1603     Getopt::Long::Configure ("bundling_override");
1604
1605 Now, C<-vax> would set the option C<vax>.
1606
1607 When any level of bundling is enabled, option values may be inserted
1608 in the bundle. For example:
1609
1610     -h24w80
1611
1612 is equivalent to
1613
1614     -h 24 -w 80
1615
1616 When configured for bundling, single-character options are matched
1617 case sensitive while long options are matched case insensitive. To
1618 have the single-character options matched case insensitive as well,
1619 use:
1620
1621     Getopt::Long::Configure ("bundling", "ignorecase_always");
1622
1623 It goes without saying that bundling can be quite confusing.
1624
1625 =head2 The lonesome dash
1626
1627 Normally, a lone dash C<-> on the command line will not be considered
1628 an option. Option processing will terminate (unless "permute" is
1629 configured) and the dash will be left in C<@ARGV>.
1630
1631 It is possible to get special treatment for a lone dash. This can be
1632 achieved by adding an option specification with an empty name, for
1633 example:
1634
1635     GetOptions ('' => \$stdio);
1636
1637 A lone dash on the command line will now be a legal option, and using
1638 it will set variable C<$stdio>.
1639
1640 =head2 Argument callback
1641
1642 A special option 'name' C<<>> can be used to designate a subroutine
1643 to handle non-option arguments. When GetOptions() encounters an
1644 argument that does not look like an option, it will immediately call this
1645 subroutine and passes it one parameter: the argument name.
1646
1647 For example:
1648
1649     my $width = 80;
1650     sub process { ... }
1651     GetOptions ('width=i' => \$width, '<>' => \&process);
1652
1653 When applied to the following command line:
1654
1655     arg1 --width=72 arg2 --width=60 arg3
1656
1657 This will call
1658 C<process("arg1")> while C<$width> is C<80>,
1659 C<process("arg2")> while C<$width> is C<72>, and
1660 C<process("arg3")> while C<$width> is C<60>.
1661
1662 This feature requires configuration option B<permute>, see section
1663 L<Configuring Getopt::Long>.
1664
1665
1666 =head1 Configuring Getopt::Long
1667
1668 Getopt::Long can be configured by calling subroutine
1669 Getopt::Long::Configure(). This subroutine takes a list of quoted
1670 strings, each specifying a configuration option to be enabled, e.g.
1671 C<ignore_case>, or disabled, e.g. C<no_ignore_case>. Case does not
1672 matter. Multiple calls to Configure() are possible.
1673
1674 Alternatively, as of version 2.24, the configuration options may be
1675 passed together with the C<use> statement:
1676
1677     use Getopt::Long qw(:config no_ignore_case bundling);
1678
1679 The following options are available:
1680
1681 =over 12
1682
1683 =item default
1684
1685 This option causes all configuration options to be reset to their
1686 default values.
1687
1688 =item posix_default
1689
1690 This option causes all configuration options to be reset to their
1691 default values as if the environment variable POSIXLY_CORRECT had
1692 been set.
1693
1694 =item auto_abbrev
1695
1696 Allow option names to be abbreviated to uniqueness.
1697 Default is enabled unless environment variable
1698 POSIXLY_CORRECT has been set, in which case C<auto_abbrev> is disabled.
1699
1700 =item getopt_compat
1701
1702 Allow C<+> to start options.
1703 Default is enabled unless environment variable
1704 POSIXLY_CORRECT has been set, in which case C<getopt_compat> is disabled.
1705
1706 =item gnu_compat
1707
1708 C<gnu_compat> controls whether C<--opt=> is allowed, and what it should
1709 do. Without C<gnu_compat>, C<--opt=> gives an error. With C<gnu_compat>,
1710 C<--opt=> will give option C<opt> and empty value.
1711 This is the way GNU getopt_long() does it.
1712
1713 =item gnu_getopt
1714
1715 This is a short way of setting C<gnu_compat> C<bundling> C<permute>
1716 C<no_getopt_compat>. With C<gnu_getopt>, command line handling should be
1717 fully compatible with GNU getopt_long().
1718
1719 =item require_order
1720
1721 Whether command line arguments are allowed to be mixed with options.
1722 Default is disabled unless environment variable
1723 POSIXLY_CORRECT has been set, in which case C<require_order> is enabled.
1724
1725 See also C<permute>, which is the opposite of C<require_order>.
1726
1727 =item permute
1728
1729 Whether command line arguments are allowed to be mixed with options.
1730 Default is enabled unless environment variable
1731 POSIXLY_CORRECT has been set, in which case C<permute> is disabled.
1732 Note that C<permute> is the opposite of C<require_order>.
1733
1734 If C<permute> is enabled, this means that
1735
1736     --foo arg1 --bar arg2 arg3
1737
1738 is equivalent to
1739
1740     --foo --bar arg1 arg2 arg3
1741
1742 If an argument callback routine is specified, C<@ARGV> will always be
1743 empty upon succesful return of GetOptions() since all options have been
1744 processed. The only exception is when C<--> is used:
1745
1746     --foo arg1 --bar arg2 -- arg3
1747
1748 This will call the callback routine for arg1 and arg2, and then
1749 terminate GetOptions() leaving C<"arg2"> in C<@ARGV>.
1750
1751 If C<require_order> is enabled, options processing
1752 terminates when the first non-option is encountered.
1753
1754     --foo arg1 --bar arg2 arg3
1755
1756 is equivalent to
1757
1758     --foo -- arg1 --bar arg2 arg3
1759
1760 If C<pass_through> is also enabled, options processing will terminate
1761 at the first unrecognized option, or non-option, whichever comes
1762 first.
1763
1764 =item bundling (default: disabled)
1765
1766 Enabling this option will allow single-character options to be bundled.
1767 To distinguish bundles from long option names, long options I<must> be
1768 introduced with C<--> and single-character options (and bundles) with
1769 C<->.
1770
1771 Note: disabling C<bundling> also disables C<bundling_override>.
1772
1773 =item bundling_override (default: disabled)
1774
1775 If C<bundling_override> is enabled, bundling is enabled as with
1776 C<bundling> but now long option names override option bundles.
1777
1778 Note: disabling C<bundling_override> also disables C<bundling>.
1779
1780 B<Note:> Using option bundling can easily lead to unexpected results,
1781 especially when mixing long options and bundles. Caveat emptor.
1782
1783 =item ignore_case  (default: enabled)
1784
1785 If enabled, case is ignored when matching long option names. Single
1786 character options will be treated case-sensitive.
1787
1788 Note: disabling C<ignore_case> also disables C<ignore_case_always>.
1789
1790 =item ignore_case_always (default: disabled)
1791
1792 When bundling is in effect, case is ignored on single-character
1793 options also.
1794
1795 Note: disabling C<ignore_case_always> also disables C<ignore_case>.
1796
1797 =item pass_through (default: disabled)
1798
1799 Options that are unknown, ambiguous or supplied with an invalid option
1800 value are passed through in C<@ARGV> instead of being flagged as
1801 errors. This makes it possible to write wrapper scripts that process
1802 only part of the user supplied command line arguments, and pass the
1803 remaining options to some other program.
1804
1805 If C<require_order> is enabled, options processing will terminate at
1806 the first unrecognized option, or non-option, whichever comes first.
1807 However, if C<permute> is enabled instead, results can become confusing.
1808
1809 =item prefix
1810
1811 The string that starts options. If a constant string is not
1812 sufficient, see C<prefix_pattern>.
1813
1814 =item prefix_pattern
1815
1816 A Perl pattern that identifies the strings that introduce options.
1817 Default is C<(--|-|\+)> unless environment variable
1818 POSIXLY_CORRECT has been set, in which case it is C<(--|-)>.
1819
1820 =item debug (default: disabled)
1821
1822 Enable debugging output.
1823
1824 =back
1825
1826 =head1 Return values and Errors
1827
1828 Configuration errors and errors in the option definitions are
1829 signalled using die() and will terminate the calling program unless
1830 the call to Getopt::Long::GetOptions() was embedded in C<eval { ...
1831 }>, or die() was trapped using C<$SIG{__DIE__}>.
1832
1833 GetOptions returns true to indicate success.
1834 It returns false when the function detected one or more errors during
1835 option parsing. These errors are signalled using warn() and can be
1836 trapped with C<$SIG{__WARN__}>.
1837
1838 Errors that can't happen are signalled using Carp::croak().
1839
1840 =head1 Legacy
1841
1842 The earliest development of C<newgetopt.pl> started in 1990, with Perl
1843 version 4. As a result, its development, and the development of
1844 Getopt::Long, has gone through several stages. Since backward
1845 compatibility has always been extremely important, the current version
1846 of Getopt::Long still supports a lot of constructs that nowadays are
1847 no longer necessary or otherwise unwanted. This section describes
1848 briefly some of these 'features'.
1849
1850 =head2 Default destinations
1851
1852 When no destination is specified for an option, GetOptions will store
1853 the resultant value in a global variable named C<opt_>I<XXX>, where
1854 I<XXX> is the primary name of this option. When a progam executes
1855 under C<use strict> (recommended), these variables must be
1856 pre-declared with our() or C<use vars>.
1857
1858     our $opt_length = 0;
1859     GetOptions ('length=i');    # will store in $opt_length
1860
1861 To yield a usable Perl variable, characters that are not part of the
1862 syntax for variables are translated to underscores. For example,
1863 C<--fpp-struct-return> will set the variable
1864 C<$opt_fpp_struct_return>. Note that this variable resides in the
1865 namespace of the calling program, not necessarily C<main>. For
1866 example:
1867
1868     GetOptions ("size=i", "sizes=i@");
1869
1870 with command line "-size 10 -sizes 24 -sizes 48" will perform the
1871 equivalent of the assignments
1872
1873     $opt_size = 10;
1874     @opt_sizes = (24, 48);
1875
1876 =head2 Alternative option starters
1877
1878 A string of alternative option starter characters may be passed as the
1879 first argument (or the first argument after a leading hash reference
1880 argument).
1881
1882     my $len = 0;
1883     GetOptions ('/', 'length=i' => $len);
1884
1885 Now the command line may look like:
1886
1887     /length 24 -- arg
1888
1889 Note that to terminate options processing still requires a double dash
1890 C<-->.
1891
1892 GetOptions() will not interpret a leading C<< "<>" >> as option starters
1893 if the next argument is a reference. To force C<< "<" >> and C<< ">" >> as
1894 option starters, use C<< "><" >>. Confusing? Well, B<using a starter
1895 argument is strongly deprecated> anyway.
1896
1897 =head2 Configuration variables
1898
1899 Previous versions of Getopt::Long used variables for the purpose of
1900 configuring. Although manipulating these variables still work, it is
1901 strongly encouraged to use the C<Configure> routine that was introduced
1902 in version 2.17. Besides, it is much easier.
1903
1904 =head1 Trouble Shooting
1905
1906 =head2 Warning: Ignoring '!' modifier for short option
1907
1908 This warning is issued when the '!' modifier is applied to a short
1909 (one-character) option and bundling is in effect. E.g.,
1910
1911     Getopt::Long::Configure("bundling");
1912     GetOptions("foo|f!" => \$foo);
1913
1914 Note that older Getopt::Long versions did not issue a warning, because
1915 the '!' modifier was applied to the first name only. This bug was
1916 fixed in 2.22.
1917
1918 Solution: separate the long and short names and apply the '!' to the
1919 long names only, e.g.,
1920
1921     GetOptions("foo!" => \$foo, "f" => \$foo);
1922
1923 =head2 GetOptions does not return a false result when an option is not supplied
1924
1925 That's why they're called 'options'.
1926
1927 =head2 GetOptions does not split the command line correctly
1928
1929 The command line is not split by GetOptions, but by the command line
1930 interpreter (CLI). On Unix, this is the shell. On Windows, it is
1931 COMMAND.COM or CMD.EXE. Other operating systems have other CLIs.
1932
1933 It is important to know that these CLIs may behave different when the
1934 command line contains special characters, in particular quotes or
1935 backslashes. For example, with Unix shells you can use single quotes
1936 (C<'>) and double quotes (C<">) to group words together. The following
1937 alternatives are equivalent on Unix:
1938
1939     "two words"
1940     'two words'
1941     two\ words
1942
1943 In case of doubt, insert the following statement in front of your Perl
1944 program:
1945
1946     print STDERR (join("|",@ARGV),"\n");
1947
1948 to verify how your CLI passes the arguments to the program.
1949
1950 =head2 How do I put a "-?" option into a Getopt::Long?
1951
1952 You can only obtain this using an alias, and Getopt::Long of at least
1953 version 2.13.
1954
1955     use Getopt::Long;
1956     GetOptions ("help|?");    # -help and -? will both set $opt_help
1957
1958 =head1 AUTHOR
1959
1960 Johan Vromans <jvromans@squirrel.nl>
1961
1962 =head1 COPYRIGHT AND DISCLAIMER
1963
1964 This program is Copyright 2001,1990 by Johan Vromans.
1965 This program is free software; you can redistribute it and/or
1966 modify it under the terms of the Perl Artistic License or the
1967 GNU General Public License as published by the Free Software
1968 Foundation; either version 2 of the License, or (at your option) any
1969 later version.
1970
1971 This program is distributed in the hope that it will be useful,
1972 but WITHOUT ANY WARRANTY; without even the implied warranty of
1973 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
1974 GNU General Public License for more details.
1975
1976 If you do not have a copy of the GNU General Public License write to
1977 the Free Software Foundation, Inc., 675 Mass Ave, Cambridge,
1978 MA 02139, USA.
1979
1980 =cut
1981