lib/Getopt/Long.pm

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