local-lib5/lib/perl5/Getopt/Long.pm

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