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