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.73 2007/01/27 20:00:34 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 Jan 27 20:59:00 2007
  10 # Update Count    : 1552
  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.36;
  39 # For testing versions only.
  40 use vars qw($VERSION_STRING);
  41 $VERSION_STRING = "2.36";
  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.73 $', ") ",
 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 ) {
1068             return (0) if $passthrough;
1069             warn ("Option ", $opt, " requires an argument\n");
1070             $error++;
1071             return (1, undef);
1072         }
1073         if ( $type eq 'I' ) {
1074             # Fake incremental type.
1075             my @c = @$ctl;
1076             $c[CTL_TYPE] = '+';
1077             return (1, $opt, \@c, 1);
1078         }
1079         return (1, $opt, $ctl,
1080                 defined($ctl->[CTL_DEFAULT]) ? $ctl->[CTL_DEFAULT] :
1081                 $type eq 's' ? '' : 0);
1082     }
1083
1084     # Get (possibly optional) argument.
1085     $arg = (defined $rest ? $rest
1086             : (defined $optarg ? $optarg : shift (@$argv)));
1087
1088     # Get key if this is a "name=value" pair for a hash option.
1089     my $key;
1090     if ($ctl->[CTL_DEST] == CTL_DEST_HASH && defined $arg) {
1091         ($key, $arg) = ($arg =~ /^([^=]*)=(.*)$/s) ? ($1, $2)
1092           : ($arg, defined($ctl->[CTL_DEFAULT]) ? $ctl->[CTL_DEFAULT] :
1093              ($mand ? undef : ($type eq 's' ? "" : 1)));
1094         if (! defined $arg) {
1095             warn ("Option $opt, key \"$key\", requires a value\n");
1096             $error++;
1097             # Push back.
1098             unshift (@$argv, $starter.$rest) if defined $rest;
1099             return (1, undef);
1100         }
1101     }
1102
1103     #### Check if the argument is valid for this option ####
1104
1105     my $key_valid = $ctl->[CTL_DEST] == CTL_DEST_HASH ? "[^=]+=" : "";
1106
1107     if ( $type eq 's' ) {       # string
1108         # A mandatory string takes anything.
1109         return (1, $opt, $ctl, $arg, $key) if $mand;
1110
1111         # Same for optional string as a hash value
1112         return (1, $opt, $ctl, $arg, $key)
1113           if $ctl->[CTL_DEST] == CTL_DEST_HASH;
1114
1115         # An optional string takes almost anything.
1116         return (1, $opt, $ctl, $arg, $key)
1117           if defined $optarg || defined $rest;
1118         return (1, $opt, $ctl, $arg, $key) if $arg eq "-"; # ??
1119
1120         # Check for option or option list terminator.
1121         if ($arg eq $argend ||
1122             $arg =~ /^$prefix.+/) {
1123             # Push back.
1124             unshift (@$argv, $arg);
1125             # Supply empty value.
1126             $arg = '';
1127         }
1128     }
1129
1130     elsif ( $type eq 'i'        # numeric/integer
1131             || $type eq 'I'     # numeric/integer w/ incr default
1132             || $type eq 'o' ) { # dec/oct/hex/bin value
1133
1134         my $o_valid = $type eq 'o' ? PAT_XINT : PAT_INT;
1135
1136         if ( $bundling && defined $rest
1137              && $rest =~ /^($key_valid)($o_valid)(.*)$/si ) {
1138             ($key, $arg, $rest) = ($1, $2, $+);
1139             chop($key) if $key;
1140             $arg = ($type eq 'o' && $arg =~ /^0/) ? oct($arg) : 0+$arg;
1141             unshift (@$argv, $starter.$rest) if defined $rest && $rest ne '';
1142         }
1143         elsif ( $arg =~ /^$o_valid$/si ) {
1144             $arg =~ tr/_//d;
1145             $arg = ($type eq 'o' && $arg =~ /^0/) ? oct($arg) : 0+$arg;
1146         }
1147         else {
1148             if ( defined $optarg || $mand ) {
1149                 if ( $passthrough ) {
1150                     unshift (@$argv, defined $rest ? $starter.$rest : $arg)
1151                       unless defined $optarg;
1152                     return (0);
1153                 }
1154                 warn ("Value \"", $arg, "\" invalid for option ",
1155                       $opt, " (",
1156                       $type eq 'o' ? "extended " : '',
1157                       "number expected)\n");
1158                 $error++;
1159                 # Push back.
1160                 unshift (@$argv, $starter.$rest) if defined $rest;
1161                 return (1, undef);
1162             }
1163             else {
1164                 # Push back.
1165                 unshift (@$argv, defined $rest ? $starter.$rest : $arg);
1166                 if ( $type eq 'I' ) {
1167                     # Fake incremental type.
1168                     my @c = @$ctl;
1169                     $c[CTL_TYPE] = '+';
1170                     return (1, $opt, \@c, 1);
1171                 }
1172                 # Supply default value.
1173                 $arg = defined($ctl->[CTL_DEFAULT]) ? $ctl->[CTL_DEFAULT] : 0;
1174             }
1175         }
1176     }
1177
1178     elsif ( $type eq 'f' ) { # real number, int is also ok
1179         # We require at least one digit before a point or 'e',
1180         # and at least one digit following the point and 'e'.
1181         # [-]NN[.NN][eNN]
1182         my $o_valid = PAT_FLOAT;
1183         if ( $bundling && defined $rest &&
1184              $rest =~ /^($key_valid)($o_valid)(.*)$/s ) {
1185             $arg =~ tr/_//d;
1186             ($key, $arg, $rest) = ($1, $2, $+);
1187             chop($key) if $key;
1188             unshift (@$argv, $starter.$rest) if defined $rest && $rest ne '';
1189         }
1190         elsif ( $arg =~ /^$o_valid$/ ) {
1191             $arg =~ tr/_//d;
1192         }
1193         else {
1194             if ( defined $optarg || $mand ) {
1195                 if ( $passthrough ) {
1196                     unshift (@$argv, defined $rest ? $starter.$rest : $arg)
1197                       unless defined $optarg;
1198                     return (0);
1199                 }
1200                 warn ("Value \"", $arg, "\" invalid for option ",
1201                       $opt, " (real number expected)\n");
1202                 $error++;
1203                 # Push back.
1204                 unshift (@$argv, $starter.$rest) if defined $rest;
1205                 return (1, undef);
1206             }
1207             else {
1208                 # Push back.
1209                 unshift (@$argv, defined $rest ? $starter.$rest : $arg);
1210                 # Supply default value.
1211                 $arg = 0.0;
1212             }
1213         }
1214     }
1215     else {
1216         die("Getopt::Long internal error (Can't happen)\n");
1217     }
1218     return (1, $opt, $ctl, $arg, $key);
1219 }
1220
1221 sub ValidValue ($$$$$) {
1222     my ($ctl, $arg, $mand, $argend, $prefix) = @_;
1223
1224     if ( $ctl->[CTL_DEST] == CTL_DEST_HASH ) {
1225         return 0 unless $arg =~ /[^=]+=(.*)/;
1226         $arg = $1;
1227     }
1228
1229     my $type = $ctl->[CTL_TYPE];
1230
1231     if ( $type eq 's' ) {       # string
1232         # A mandatory string takes anything.
1233         return (1) if $mand;
1234
1235         return (1) if $arg eq "-";
1236
1237         # Check for option or option list terminator.
1238         return 0 if $arg eq $argend || $arg =~ /^$prefix.+/;
1239         return 1;
1240     }
1241
1242     elsif ( $type eq 'i'        # numeric/integer
1243             || $type eq 'I'     # numeric/integer w/ incr default
1244             || $type eq 'o' ) { # dec/oct/hex/bin value
1245
1246         my $o_valid = $type eq 'o' ? PAT_XINT : PAT_INT;
1247         return $arg =~ /^$o_valid$/si;
1248     }
1249
1250     elsif ( $type eq 'f' ) { # real number, int is also ok
1251         # We require at least one digit before a point or 'e',
1252         # and at least one digit following the point and 'e'.
1253         # [-]NN[.NN][eNN]
1254         my $o_valid = PAT_FLOAT;
1255         return $arg =~ /^$o_valid$/;
1256     }
1257     die("ValidValue: Cannot happen\n");
1258 }
1259
1260 # Getopt::Long Configuration.
1261 sub Configure (@) {
1262     my (@options) = @_;
1263
1264     my $prevconfig =
1265       [ $error, $debug, $major_version, $minor_version,
1266         $autoabbrev, $getopt_compat, $ignorecase, $bundling, $order,
1267         $gnu_compat, $passthrough, $genprefix, $auto_version, $auto_help,
1268         $longprefix ];
1269
1270     if ( ref($options[0]) eq 'ARRAY' ) {
1271         ( $error, $debug, $major_version, $minor_version,
1272           $autoabbrev, $getopt_compat, $ignorecase, $bundling, $order,
1273           $gnu_compat, $passthrough, $genprefix, $auto_version, $auto_help,
1274           $longprefix ) = @{shift(@options)};
1275     }
1276
1277     my $opt;
1278     foreach $opt ( @options ) {
1279         my $try = lc ($opt);
1280         my $action = 1;
1281         if ( $try =~ /^no_?(.*)$/s ) {
1282             $action = 0;
1283             $try = $+;
1284         }
1285         if ( ($try eq 'default' or $try eq 'defaults') && $action ) {
1286             ConfigDefaults ();
1287         }
1288         elsif ( ($try eq 'posix_default' or $try eq 'posix_defaults') ) {
1289             local $ENV{POSIXLY_CORRECT};
1290             $ENV{POSIXLY_CORRECT} = 1 if $action;
1291             ConfigDefaults ();
1292         }
1293         elsif ( $try eq 'auto_abbrev' or $try eq 'autoabbrev' ) {
1294             $autoabbrev = $action;
1295         }
1296         elsif ( $try eq 'getopt_compat' ) {
1297             $getopt_compat = $action;
1298             $genprefix = $action ? "(--|-|\\+)" : "(--|-)";
1299         }
1300         elsif ( $try eq 'gnu_getopt' ) {
1301             if ( $action ) {
1302                 $gnu_compat = 1;
1303                 $bundling = 1;
1304                 $getopt_compat = 0;
1305                 $genprefix = "(--|-)";
1306                 $order = $PERMUTE;
1307             }
1308         }
1309         elsif ( $try eq 'gnu_compat' ) {
1310             $gnu_compat = $action;
1311         }
1312         elsif ( $try =~ /^(auto_?)?version$/ ) {
1313             $auto_version = $action;
1314         }
1315         elsif ( $try =~ /^(auto_?)?help$/ ) {
1316             $auto_help = $action;
1317         }
1318         elsif ( $try eq 'ignorecase' or $try eq 'ignore_case' ) {
1319             $ignorecase = $action;
1320         }
1321         elsif ( $try eq 'ignorecase_always' or $try eq 'ignore_case_always' ) {
1322             $ignorecase = $action ? 2 : 0;
1323         }
1324         elsif ( $try eq 'bundling' ) {
1325             $bundling = $action;
1326         }
1327         elsif ( $try eq 'bundling_override' ) {
1328             $bundling = $action ? 2 : 0;
1329         }
1330         elsif ( $try eq 'require_order' ) {
1331             $order = $action ? $REQUIRE_ORDER : $PERMUTE;
1332         }
1333         elsif ( $try eq 'permute' ) {
1334             $order = $action ? $PERMUTE : $REQUIRE_ORDER;
1335         }
1336         elsif ( $try eq 'pass_through' or $try eq 'passthrough' ) {
1337             $passthrough = $action;
1338         }
1339         elsif ( $try =~ /^prefix=(.+)$/ && $action ) {
1340             $genprefix = $1;
1341             # Turn into regexp. Needs to be parenthesized!
1342             $genprefix = "(" . quotemeta($genprefix) . ")";
1343             eval { '' =~ /$genprefix/; };
1344             die("Getopt::Long: invalid pattern \"$genprefix\"") if $@;
1345         }
1346         elsif ( $try =~ /^prefix_pattern=(.+)$/ && $action ) {
1347             $genprefix = $1;
1348             # Parenthesize if needed.
1349             $genprefix = "(" . $genprefix . ")"
1350               unless $genprefix =~ /^\(.*\)$/;
1351             eval { '' =~ m"$genprefix"; };
1352             die("Getopt::Long: invalid pattern \"$genprefix\"") if $@;
1353         }
1354         elsif ( $try =~ /^long_prefix_pattern=(.+)$/ && $action ) {
1355             $longprefix = $1;
1356             # Parenthesize if needed.
1357             $longprefix = "(" . $longprefix . ")"
1358               unless $longprefix =~ /^\(.*\)$/;
1359             eval { '' =~ m"$longprefix"; };
1360             die("Getopt::Long: invalid long prefix pattern \"$longprefix\"") if $@;
1361         }
1362         elsif ( $try eq 'debug' ) {
1363             $debug = $action;
1364         }
1365         else {
1366             die("Getopt::Long: unknown config parameter \"$opt\"")
1367         }
1368     }
1369     $prevconfig;
1370 }
1371
1372 # Deprecated name.
1373 sub config (@) {
1374     Configure (@_);
1375 }
1376
1377 # Issue a standard message for --version.
1378 #
1379 # The arguments are mostly the same as for Pod::Usage::pod2usage:
1380 #
1381 #  - a number (exit value)
1382 #  - a string (lead in message)
1383 #  - a hash with options. See Pod::Usage for details.
1384 #
1385 sub VersionMessage(@) {
1386     # Massage args.
1387     my $pa = setup_pa_args("version", @_);
1388
1389     my $v = $main::VERSION;
1390     my $fh = $pa->{-output} ||
1391       ($pa->{-exitval} eq "NOEXIT" || $pa->{-exitval} < 2) ? \*STDOUT : \*STDERR;
1392
1393     print $fh (defined($pa->{-message}) ? $pa->{-message} : (),
1394                $0, defined $v ? " version $v" : (),
1395                "\n",
1396                "(", __PACKAGE__, "::", "GetOptions",
1397                " version ",
1398                defined($Getopt::Long::VERSION_STRING)
1399                  ? $Getopt::Long::VERSION_STRING : $VERSION, ";",
1400                " Perl version ",
1401                $] >= 5.006 ? sprintf("%vd", $^V) : $],
1402                ")\n");
1403     exit($pa->{-exitval}) unless $pa->{-exitval} eq "NOEXIT";
1404 }
1405
1406 # Issue a standard message for --help.
1407 #
1408 # The arguments are the same as for Pod::Usage::pod2usage:
1409 #
1410 #  - a number (exit value)
1411 #  - a string (lead in message)
1412 #  - a hash with options. See Pod::Usage for details.
1413 #
1414 sub HelpMessage(@) {
1415     eval {
1416         require Pod::Usage;
1417         import Pod::Usage;
1418         1;
1419     } || die("Cannot provide help: cannot load Pod::Usage\n");
1420
1421     # Note that pod2usage will issue a warning if -exitval => NOEXIT.
1422     pod2usage(setup_pa_args("help", @_));
1423
1424 }
1425
1426 # Helper routine to set up a normalized hash ref to be used as
1427 # argument to pod2usage.
1428 sub setup_pa_args($@) {
1429     my $tag = shift;            # who's calling
1430
1431     # If called by direct binding to an option, it will get the option
1432     # name and value as arguments. Remove these, if so.
1433     @_ = () if @_ == 2 && $_[0] eq $tag;
1434
1435     my $pa;
1436     if ( @_ > 1 ) {
1437         $pa = { @_ };
1438     }
1439     else {
1440         $pa = shift || {};
1441     }
1442
1443     # At this point, $pa can be a number (exit value), string
1444     # (message) or hash with options.
1445
1446     if ( UNIVERSAL::isa($pa, 'HASH') ) {
1447         # Get rid of -msg vs. -message ambiguity.
1448         $pa->{-message} = $pa->{-msg};
1449         delete($pa->{-msg});
1450     }
1451     elsif ( $pa =~ /^-?\d+$/ ) {
1452         $pa = { -exitval => $pa };
1453     }
1454     else {
1455         $pa = { -message => $pa };
1456     }
1457
1458     # These are _our_ defaults.
1459     $pa->{-verbose} = 0 unless exists($pa->{-verbose});
1460     $pa->{-exitval} = 0 unless exists($pa->{-exitval});
1461     $pa;
1462 }
1463
1464 # Sneak way to know what version the user requested.
1465 sub VERSION {
1466     $requested_version = $_[1];
1467     shift->SUPER::VERSION(@_);
1468 }
1469
1470 package Getopt::Long::CallBack;
1471
1472 sub new {
1473     my ($pkg, %atts) = @_;
1474     bless { %atts }, $pkg;
1475 }
1476
1477 sub name {
1478     my $self = shift;
1479     ''.$self->{name};
1480 }
1481
1482 use overload
1483   # Treat this object as an oridinary string for legacy API.
1484   '""'     => \&name,
1485   '0+'     => sub { 0 },
1486   fallback => 1;
1487
1488 1;
1489
1490 ################ Documentation ################
1491
1492 =head1 NAME
1493
1494 Getopt::Long - Extended processing of command line options
1495
1496 =head1 SYNOPSIS
1497
1498   use Getopt::Long;
1499   my $data   = "file.dat";
1500   my $length = 24;
1501   my $verbose;
1502   $result = GetOptions ("length=i" => \$length,    # numeric
1503                         "file=s"   => \$data,      # string
1504                         "verbose"  => \$verbose);  # flag
1505
1506 =head1 DESCRIPTION
1507
1508 The Getopt::Long module implements an extended getopt function called
1509 GetOptions(). This function adheres to the POSIX syntax for command
1510 line options, with GNU extensions. In general, this means that options
1511 have long names instead of single letters, and are introduced with a
1512 double dash "--". Support for bundling of command line options, as was
1513 the case with the more traditional single-letter approach, is provided
1514 but not enabled by default.
1515
1516 =head1 Command Line Options, an Introduction
1517
1518 Command line operated programs traditionally take their arguments from
1519 the command line, for example filenames or other information that the
1520 program needs to know. Besides arguments, these programs often take
1521 command line I<options> as well. Options are not necessary for the
1522 program to work, hence the name 'option', but are used to modify its
1523 default behaviour. For example, a program could do its job quietly,
1524 but with a suitable option it could provide verbose information about
1525 what it did.
1526
1527 Command line options come in several flavours. Historically, they are
1528 preceded by a single dash C<->, and consist of a single letter.
1529
1530     -l -a -c
1531
1532 Usually, these single-character options can be bundled:
1533
1534     -lac
1535
1536 Options can have values, the value is placed after the option
1537 character. Sometimes with whitespace in between, sometimes not:
1538
1539     -s 24 -s24
1540
1541 Due to the very cryptic nature of these options, another style was
1542 developed that used long names. So instead of a cryptic C<-l> one
1543 could use the more descriptive C<--long>. To distinguish between a
1544 bundle of single-character options and a long one, two dashes are used
1545 to precede the option name. Early implementations of long options used
1546 a plus C<+> instead. Also, option values could be specified either
1547 like
1548
1549     --size=24
1550
1551 or
1552
1553     --size 24
1554
1555 The C<+> form is now obsolete and strongly deprecated.
1556
1557 =head1 Getting Started with Getopt::Long
1558
1559 Getopt::Long is the Perl5 successor of C<newgetopt.pl>. This was the
1560 first Perl module that provided support for handling the new style of
1561 command line options, hence the name Getopt::Long. This module also
1562 supports single-character options and bundling. Single character
1563 options may be any alphabetic character, a question mark, and a dash.
1564 Long options may consist of a series of letters, digits, and dashes.
1565 Although this is currently not enforced by Getopt::Long, multiple
1566 consecutive dashes are not allowed, and the option name must not end
1567 with a dash.
1568
1569 To use Getopt::Long from a Perl program, you must include the
1570 following line in your Perl program:
1571
1572     use Getopt::Long;
1573
1574 This will load the core of the Getopt::Long module and prepare your
1575 program for using it. Most of the actual Getopt::Long code is not
1576 loaded until you really call one of its functions.
1577
1578 In the default configuration, options names may be abbreviated to
1579 uniqueness, case does not matter, and a single dash is sufficient,
1580 even for long option names. Also, options may be placed between
1581 non-option arguments. See L<Configuring Getopt::Long> for more
1582 details on how to configure Getopt::Long.
1583
1584 =head2 Simple options
1585
1586 The most simple options are the ones that take no values. Their mere
1587 presence on the command line enables the option. Popular examples are:
1588
1589     --all --verbose --quiet --debug
1590
1591 Handling simple options is straightforward:
1592
1593     my $verbose = '';   # option variable with default value (false)
1594     my $all = '';       # option variable with default value (false)
1595     GetOptions ('verbose' => \$verbose, 'all' => \$all);
1596
1597 The call to GetOptions() parses the command line arguments that are
1598 present in C<@ARGV> and sets the option variable to the value C<1> if
1599 the option did occur on the command line. Otherwise, the option
1600 variable is not touched. Setting the option value to true is often
1601 called I<enabling> the option.
1602
1603 The option name as specified to the GetOptions() function is called
1604 the option I<specification>. Later we'll see that this specification
1605 can contain more than just the option name. The reference to the
1606 variable is called the option I<destination>.
1607
1608 GetOptions() will return a true value if the command line could be
1609 processed successfully. Otherwise, it will write error messages to
1610 STDERR, and return a false result.
1611
1612 =head2 A little bit less simple options
1613
1614 Getopt::Long supports two useful variants of simple options:
1615 I<negatable> options and I<incremental> options.
1616
1617 A negatable option is specified with an exclamation mark C<!> after the
1618 option name:
1619
1620     my $verbose = '';   # option variable with default value (false)
1621     GetOptions ('verbose!' => \$verbose);
1622
1623 Now, using C<--verbose> on the command line will enable C<$verbose>,
1624 as expected. But it is also allowed to use C<--noverbose>, which will
1625 disable C<$verbose> by setting its value to C<0>. Using a suitable
1626 default value, the program can find out whether C<$verbose> is false
1627 by default, or disabled by using C<--noverbose>.
1628
1629 An incremental option is specified with a plus C<+> after the
1630 option name:
1631
1632     my $verbose = '';   # option variable with default value (false)
1633     GetOptions ('verbose+' => \$verbose);
1634
1635 Using C<--verbose> on the command line will increment the value of
1636 C<$verbose>. This way the program can keep track of how many times the
1637 option occurred on the command line. For example, each occurrence of
1638 C<--verbose> could increase the verbosity level of the program.
1639
1640 =head2 Mixing command line option with other arguments
1641
1642 Usually programs take command line options as well as other arguments,
1643 for example, file names. It is good practice to always specify the
1644 options first, and the other arguments last. Getopt::Long will,
1645 however, allow the options and arguments to be mixed and 'filter out'
1646 all the options before passing the rest of the arguments to the
1647 program. To stop Getopt::Long from processing further arguments,
1648 insert a double dash C<--> on the command line:
1649
1650     --size 24 -- --all
1651
1652 In this example, C<--all> will I<not> be treated as an option, but
1653 passed to the program unharmed, in C<@ARGV>.
1654
1655 =head2 Options with values
1656
1657 For options that take values it must be specified whether the option
1658 value is required or not, and what kind of value the option expects.
1659
1660 Three kinds of values are supported: integer numbers, floating point
1661 numbers, and strings.
1662
1663 If the option value is required, Getopt::Long will take the
1664 command line argument that follows the option and assign this to the
1665 option variable. If, however, the option value is specified as
1666 optional, this will only be done if that value does not look like a
1667 valid command line option itself.
1668
1669     my $tag = '';       # option variable with default value
1670     GetOptions ('tag=s' => \$tag);
1671
1672 In the option specification, the option name is followed by an equals
1673 sign C<=> and the letter C<s>. The equals sign indicates that this
1674 option requires a value. The letter C<s> indicates that this value is
1675 an arbitrary string. Other possible value types are C<i> for integer
1676 values, and C<f> for floating point values. Using a colon C<:> instead
1677 of the equals sign indicates that the option value is optional. In
1678 this case, if no suitable value is supplied, string valued options get
1679 an empty string C<''> assigned, while numeric options are set to C<0>.
1680
1681 =head2 Options with multiple values
1682
1683 Options sometimes take several values. For example, a program could
1684 use multiple directories to search for library files:
1685
1686     --library lib/stdlib --library lib/extlib
1687
1688 To accomplish this behaviour, simply specify an array reference as the
1689 destination for the option:
1690
1691     GetOptions ("library=s" => \@libfiles);
1692
1693 Alternatively, you can specify that the option can have multiple
1694 values by adding a "@", and pass a scalar reference as the
1695 destination:
1696
1697     GetOptions ("library=s@" => \$libfiles);
1698
1699 Used with the example above, C<@libfiles> (or C<@$libfiles>) would
1700 contain two strings upon completion: C<"lib/srdlib"> and
1701 C<"lib/extlib">, in that order. It is also possible to specify that
1702 only integer or floating point numbers are acceptable values.
1703
1704 Often it is useful to allow comma-separated lists of values as well as
1705 multiple occurrences of the options. This is easy using Perl's split()
1706 and join() operators:
1707
1708     GetOptions ("library=s" => \@libfiles);
1709     @libfiles = split(/,/,join(',',@libfiles));
1710
1711 Of course, it is important to choose the right separator string for
1712 each purpose.
1713
1714 Warning: What follows is an experimental feature.
1715
1716 Options can take multiple values at once, for example
1717
1718     --coordinates 52.2 16.4 --rgbcolor 255 255 149
1719
1720 This can be accomplished by adding a repeat specifier to the option
1721 specification. Repeat specifiers are very similar to the C<{...}>
1722 repeat specifiers that can be used with regular expression patterns.
1723 For example, the above command line would be handled as follows:
1724
1725     GetOptions('coordinates=f{2}' => \@coor, 'rgbcolor=i{3}' => \@color);
1726
1727 The destination for the option must be an array or array reference.
1728
1729 It is also possible to specify the minimal and maximal number of
1730 arguments an option takes. C<foo=s{2,4}> indicates an option that
1731 takes at least two and at most 4 arguments. C<foo=s{,}> indicates one
1732 or more values; C<foo:s{,}> indicates zero or more option values.
1733
1734 =head2 Options with hash values
1735
1736 If the option destination is a reference to a hash, the option will
1737 take, as value, strings of the form I<key>C<=>I<value>. The value will
1738 be stored with the specified key in the hash.
1739
1740     GetOptions ("define=s" => \%defines);
1741
1742 Alternatively you can use:
1743
1744     GetOptions ("define=s%" => \$defines);
1745
1746 When used with command line options:
1747
1748     --define os=linux --define vendor=redhat
1749
1750 the hash C<%defines> (or C<%$defines>) will contain two keys, C<"os">
1751 with value C<"linux> and C<"vendor"> with value C<"redhat">. It is
1752 also possible to specify that only integer or floating point numbers
1753 are acceptable values. The keys are always taken to be strings.
1754
1755 =head2 User-defined subroutines to handle options
1756
1757 Ultimate control over what should be done when (actually: each time)
1758 an option is encountered on the command line can be achieved by
1759 designating a reference to a subroutine (or an anonymous subroutine)
1760 as the option destination. When GetOptions() encounters the option, it
1761 will call the subroutine with two or three arguments. The first
1762 argument is the name of the option. For a scalar or array destination,
1763 the second argument is the value to be stored. For a hash destination,
1764 the second arguments is the key to the hash, and the third argument
1765 the value to be stored. It is up to the subroutine to store the value,
1766 or do whatever it thinks is appropriate.
1767
1768 A trivial application of this mechanism is to implement options that
1769 are related to each other. For example:
1770
1771     my $verbose = '';   # option variable with default value (false)
1772     GetOptions ('verbose' => \$verbose,
1773                 'quiet'   => sub { $verbose = 0 });
1774
1775 Here C<--verbose> and C<--quiet> control the same variable
1776 C<$verbose>, but with opposite values.
1777
1778 If the subroutine needs to signal an error, it should call die() with
1779 the desired error message as its argument. GetOptions() will catch the
1780 die(), issue the error message, and record that an error result must
1781 be returned upon completion.
1782
1783 If the text of the error message starts with an exclamation mark C<!>
1784 it is interpreted specially by GetOptions(). There is currently one
1785 special command implemented: C<die("!FINISH")> will cause GetOptions()
1786 to stop processing options, as if it encountered a double dash C<-->.
1787
1788 =head2 Options with multiple names
1789
1790 Often it is user friendly to supply alternate mnemonic names for
1791 options. For example C<--height> could be an alternate name for
1792 C<--length>. Alternate names can be included in the option
1793 specification, separated by vertical bar C<|> characters. To implement
1794 the above example:
1795
1796     GetOptions ('length|height=f' => \$length);
1797
1798 The first name is called the I<primary> name, the other names are
1799 called I<aliases>. When using a hash to store options, the key will
1800 always be the primary name.
1801
1802 Multiple alternate names are possible.
1803
1804 =head2 Case and abbreviations
1805
1806 Without additional configuration, GetOptions() will ignore the case of
1807 option names, and allow the options to be abbreviated to uniqueness.
1808
1809     GetOptions ('length|height=f' => \$length, "head" => \$head);
1810
1811 This call will allow C<--l> and C<--L> for the length option, but
1812 requires a least C<--hea> and C<--hei> for the head and height options.
1813
1814 =head2 Summary of Option Specifications
1815
1816 Each option specifier consists of two parts: the name specification
1817 and the argument specification.
1818
1819 The name specification contains the name of the option, optionally
1820 followed by a list of alternative names separated by vertical bar
1821 characters.
1822
1823     length            option name is "length"
1824     length|size|l     name is "length", aliases are "size" and "l"
1825
1826 The argument specification is optional. If omitted, the option is
1827 considered boolean, a value of 1 will be assigned when the option is
1828 used on the command line.
1829
1830 The argument specification can be
1831
1832 =over 4
1833
1834 =item !
1835
1836 The option does not take an argument and may be negated by prefixing
1837 it with "no" or "no-". E.g. C<"foo!"> will allow C<--foo> (a value of
1838 1 will be assigned) as well as C<--nofoo> and C<--no-foo> (a value of
1839 0 will be assigned). If the option has aliases, this applies to the
1840 aliases as well.
1841
1842 Using negation on a single letter option when bundling is in effect is
1843 pointless and will result in a warning.
1844
1845 =item +
1846
1847 The option does not take an argument and will be incremented by 1
1848 every time it appears on the command line. E.g. C<"more+">, when used
1849 with C<--more --more --more>, will increment the value three times,
1850 resulting in a value of 3 (provided it was 0 or undefined at first).
1851
1852 The C<+> specifier is ignored if the option destination is not a scalar.
1853
1854 =item = I<type> [ I<desttype> ] [ I<repeat> ]
1855
1856 The option requires an argument of the given type. Supported types
1857 are:
1858
1859 =over 4
1860
1861 =item s
1862
1863 String. An arbitrary sequence of characters. It is valid for the
1864 argument to start with C<-> or C<-->.
1865
1866 =item i
1867
1868 Integer. An optional leading plus or minus sign, followed by a
1869 sequence of digits.
1870
1871 =item o
1872
1873 Extended integer, Perl style. This can be either an optional leading
1874 plus or minus sign, followed by a sequence of digits, or an octal
1875 string (a zero, optionally followed by '0', '1', .. '7'), or a
1876 hexadecimal string (C<0x> followed by '0' .. '9', 'a' .. 'f', case
1877 insensitive), or a binary string (C<0b> followed by a series of '0'
1878 and '1').
1879
1880 =item f
1881
1882 Real number. For example C<3.14>, C<-6.23E24> and so on.
1883
1884 =back
1885
1886 The I<desttype> can be C<@> or C<%> to specify that the option is
1887 list or a hash valued. This is only needed when the destination for
1888 the option value is not otherwise specified. It should be omitted when
1889 not needed.
1890
1891 The I<repeat> specifies the number of values this option takes per
1892 occurrence on the command line. It has the format C<{> [ I<min> ] [ C<,> [ I<max> ] ] C<}>.
1893
1894 I<min> denotes the minimal number of arguments. It defaults to 1 for
1895 options with C<=> and to 0 for options with C<:>, see below. Note that
1896 I<min> overrules the C<=> / C<:> semantics.
1897
1898 I<max> denotes the maximum number of arguments. It must be at least
1899 I<min>. If I<max> is omitted, I<but the comma is not>, there is no
1900 upper bound to the number of argument values taken.
1901
1902 =item : I<type> [ I<desttype> ]
1903
1904 Like C<=>, but designates the argument as optional.
1905 If omitted, an empty string will be assigned to string values options,
1906 and the value zero to numeric options.
1907
1908 Note that if a string argument starts with C<-> or C<-->, it will be
1909 considered an option on itself.
1910
1911 =item : I<number> [ I<desttype> ]
1912
1913 Like C<:i>, but if the value is omitted, the I<number> will be assigned.
1914
1915 =item : + [ I<desttype> ]
1916
1917 Like C<:i>, but if the value is omitted, the current value for the
1918 option will be incremented.
1919
1920 =back
1921
1922 =head1 Advanced Possibilities
1923
1924 =head2 Object oriented interface
1925
1926 Getopt::Long can be used in an object oriented way as well:
1927
1928     use Getopt::Long;
1929     $p = new Getopt::Long::Parser;
1930     $p->configure(...configuration options...);
1931     if ($p->getoptions(...options descriptions...)) ...
1932
1933 Configuration options can be passed to the constructor:
1934
1935     $p = new Getopt::Long::Parser
1936              config => [...configuration options...];
1937
1938 =head2 Thread Safety
1939
1940 Getopt::Long is thread safe when using ithreads as of Perl 5.8.  It is
1941 I<not> thread safe when using the older (experimental and now
1942 obsolete) threads implementation that was added to Perl 5.005.
1943
1944 =head2 Documentation and help texts
1945
1946 Getopt::Long encourages the use of Pod::Usage to produce help
1947 messages. For example:
1948
1949     use Getopt::Long;
1950     use Pod::Usage;
1951
1952     my $man = 0;
1953     my $help = 0;
1954
1955     GetOptions('help|?' => \$help, man => \$man) or pod2usage(2);
1956     pod2usage(1) if $help;
1957     pod2usage(-exitstatus => 0, -verbose => 2) if $man;
1958
1959     __END__
1960
1961     =head1 NAME
1962
1963     sample - Using Getopt::Long and Pod::Usage
1964
1965     =head1 SYNOPSIS
1966
1967     sample [options] [file ...]
1968
1969      Options:
1970        -help            brief help message
1971        -man             full documentation
1972
1973     =head1 OPTIONS
1974
1975     =over 8
1976
1977     =item B<-help>
1978
1979     Print a brief help message and exits.
1980
1981     =item B<-man>
1982
1983     Prints the manual page and exits.
1984
1985     =back
1986
1987     =head1 DESCRIPTION
1988
1989     B<This program> will read the given input file(s) and do something
1990     useful with the contents thereof.
1991
1992     =cut
1993
1994 See L<Pod::Usage> for details.
1995
1996 =head2 Parsing options from an arbitrary array
1997
1998 By default, GetOptions parses the options that are present in the
1999 global array C<@ARGV>. A special entry C<GetOptionsFromArray> can be
2000 used to parse options from an arbitrary array.
2001
2002     use Getopt::Long qw(GetOptionsFromArray);
2003     $ret = GetOptionsFromArray(\@myopts, ...);
2004
2005 When used like this, the global C<@ARGV> is not touched at all.
2006
2007 The following two calls behave identically:
2008
2009     $ret = GetOptions( ... );
2010     $ret = GetOptionsFromArray(\@ARGV, ... );
2011
2012 =head2 Parsing options from an arbitrary string
2013
2014 A special entry C<GetOptionsFromString> can be used to parse options
2015 from an arbitrary string.
2016
2017     use Getopt::Long qw(GetOptionsFromString);
2018     $ret = GetOptionsFromString($string, ...);
2019
2020 The contents of the string are split into arguments using a call to
2021 C<Text::ParseWords::shellwords>. As with C<GetOptionsFromArray>, the
2022 global C<@ARGV> is not touched.
2023
2024 It is possible that, upon completion, not all arguments in the string
2025 have been processed. C<GetOptionsFromString> will, when called in list
2026 context, return both the return status and an array reference to any
2027 remaining arguments:
2028
2029     ($ret, $args) = GetOptionsFromString($string, ... );
2030
2031 If any arguments remain, and C<GetOptionsFromString> was not called in
2032 list context, a message will be given and C<GetOptionsFromString> will
2033 return failure.
2034
2035 =head2 Storing options values in a hash
2036
2037 Sometimes, for example when there are a lot of options, having a
2038 separate variable for each of them can be cumbersome. GetOptions()
2039 supports, as an alternative mechanism, storing options values in a
2040 hash.
2041
2042 To obtain this, a reference to a hash must be passed I<as the first
2043 argument> to GetOptions(). For each option that is specified on the
2044 command line, the option value will be stored in the hash with the
2045 option name as key. Options that are not actually used on the command
2046 line will not be put in the hash, on other words,
2047 C<exists($h{option})> (or defined()) can be used to test if an option
2048 was used. The drawback is that warnings will be issued if the program
2049 runs under C<use strict> and uses C<$h{option}> without testing with
2050 exists() or defined() first.
2051
2052     my %h = ();
2053     GetOptions (\%h, 'length=i');       # will store in $h{length}
2054
2055 For options that take list or hash values, it is necessary to indicate
2056 this by appending an C<@> or C<%> sign after the type:
2057
2058     GetOptions (\%h, 'colours=s@');     # will push to @{$h{colours}}
2059
2060 To make things more complicated, the hash may contain references to
2061 the actual destinations, for example:
2062
2063     my $len = 0;
2064     my %h = ('length' => \$len);
2065     GetOptions (\%h, 'length=i');       # will store in $len
2066
2067 This example is fully equivalent with:
2068
2069     my $len = 0;
2070     GetOptions ('length=i' => \$len);   # will store in $len
2071
2072 Any mixture is possible. For example, the most frequently used options
2073 could be stored in variables while all other options get stored in the
2074 hash:
2075
2076     my $verbose = 0;                    # frequently referred
2077     my $debug = 0;                      # frequently referred
2078     my %h = ('verbose' => \$verbose, 'debug' => \$debug);
2079     GetOptions (\%h, 'verbose', 'debug', 'filter', 'size=i');
2080     if ( $verbose ) { ... }
2081     if ( exists $h{filter} ) { ... option 'filter' was specified ... }
2082
2083 =head2 Bundling
2084
2085 With bundling it is possible to set several single-character options
2086 at once. For example if C<a>, C<v> and C<x> are all valid options,
2087
2088     -vax
2089
2090 would set all three.
2091
2092 Getopt::Long supports two levels of bundling. To enable bundling, a
2093 call to Getopt::Long::Configure is required.
2094
2095 The first level of bundling can be enabled with:
2096
2097     Getopt::Long::Configure ("bundling");
2098
2099 Configured this way, single-character options can be bundled but long
2100 options B<must> always start with a double dash C<--> to avoid
2101 ambiguity. For example, when C<vax>, C<a>, C<v> and C<x> are all valid
2102 options,
2103
2104     -vax
2105
2106 would set C<a>, C<v> and C<x>, but
2107
2108     --vax
2109
2110 would set C<vax>.
2111
2112 The second level of bundling lifts this restriction. It can be enabled
2113 with:
2114
2115     Getopt::Long::Configure ("bundling_override");
2116
2117 Now, C<-vax> would set the option C<vax>.
2118
2119 When any level of bundling is enabled, option values may be inserted
2120 in the bundle. For example:
2121
2122     -h24w80
2123
2124 is equivalent to
2125
2126     -h 24 -w 80
2127
2128 When configured for bundling, single-character options are matched
2129 case sensitive while long options are matched case insensitive. To
2130 have the single-character options matched case insensitive as well,
2131 use:
2132
2133     Getopt::Long::Configure ("bundling", "ignorecase_always");
2134
2135 It goes without saying that bundling can be quite confusing.
2136
2137 =head2 The lonesome dash
2138
2139 Normally, a lone dash C<-> on the command line will not be considered
2140 an option. Option processing will terminate (unless "permute" is
2141 configured) and the dash will be left in C<@ARGV>.
2142
2143 It is possible to get special treatment for a lone dash. This can be
2144 achieved by adding an option specification with an empty name, for
2145 example:
2146
2147     GetOptions ('' => \$stdio);
2148
2149 A lone dash on the command line will now be a legal option, and using
2150 it will set variable C<$stdio>.
2151
2152 =head2 Argument callback
2153
2154 A special option 'name' C<< <> >> can be used to designate a subroutine
2155 to handle non-option arguments. When GetOptions() encounters an
2156 argument that does not look like an option, it will immediately call this
2157 subroutine and passes it one parameter: the argument name.
2158
2159 For example:
2160
2161     my $width = 80;
2162     sub process { ... }
2163     GetOptions ('width=i' => \$width, '<>' => \&process);
2164
2165 When applied to the following command line:
2166
2167     arg1 --width=72 arg2 --width=60 arg3
2168
2169 This will call
2170 C<process("arg1")> while C<$width> is C<80>,
2171 C<process("arg2")> while C<$width> is C<72>, and
2172 C<process("arg3")> while C<$width> is C<60>.
2173
2174 This feature requires configuration option B<permute>, see section
2175 L<Configuring Getopt::Long>.
2176
2177 =head1 Configuring Getopt::Long
2178
2179 Getopt::Long can be configured by calling subroutine
2180 Getopt::Long::Configure(). This subroutine takes a list of quoted
2181 strings, each specifying a configuration option to be enabled, e.g.
2182 C<ignore_case>, or disabled, e.g. C<no_ignore_case>. Case does not
2183 matter. Multiple calls to Configure() are possible.
2184
2185 Alternatively, as of version 2.24, the configuration options may be
2186 passed together with the C<use> statement:
2187
2188     use Getopt::Long qw(:config no_ignore_case bundling);
2189
2190 The following options are available:
2191
2192 =over 12
2193
2194 =item default
2195
2196 This option causes all configuration options to be reset to their
2197 default values.
2198
2199 =item posix_default
2200
2201 This option causes all configuration options to be reset to their
2202 default values as if the environment variable POSIXLY_CORRECT had
2203 been set.
2204
2205 =item auto_abbrev
2206
2207 Allow option names to be abbreviated to uniqueness.
2208 Default is enabled unless environment variable
2209 POSIXLY_CORRECT has been set, in which case C<auto_abbrev> is disabled.
2210
2211 =item getopt_compat
2212
2213 Allow C<+> to start options.
2214 Default is enabled unless environment variable
2215 POSIXLY_CORRECT has been set, in which case C<getopt_compat> is disabled.
2216
2217 =item gnu_compat
2218
2219 C<gnu_compat> controls whether C<--opt=> is allowed, and what it should
2220 do. Without C<gnu_compat>, C<--opt=> gives an error. With C<gnu_compat>,
2221 C<--opt=> will give option C<opt> and empty value.
2222 This is the way GNU getopt_long() does it.
2223
2224 =item gnu_getopt
2225
2226 This is a short way of setting C<gnu_compat> C<bundling> C<permute>
2227 C<no_getopt_compat>. With C<gnu_getopt>, command line handling should be
2228 fully compatible with GNU getopt_long().
2229
2230 =item require_order
2231
2232 Whether command line arguments are allowed to be mixed with options.
2233 Default is disabled unless environment variable
2234 POSIXLY_CORRECT has been set, in which case C<require_order> is enabled.
2235
2236 See also C<permute>, which is the opposite of C<require_order>.
2237
2238 =item permute
2239
2240 Whether command line arguments are allowed to be mixed with options.
2241 Default is enabled unless environment variable
2242 POSIXLY_CORRECT has been set, in which case C<permute> is disabled.
2243 Note that C<permute> is the opposite of C<require_order>.
2244
2245 If C<permute> is enabled, this means that
2246
2247     --foo arg1 --bar arg2 arg3
2248
2249 is equivalent to
2250
2251     --foo --bar arg1 arg2 arg3
2252
2253 If an argument callback routine is specified, C<@ARGV> will always be
2254 empty upon successful return of GetOptions() since all options have been
2255 processed. The only exception is when C<--> is used:
2256
2257     --foo arg1 --bar arg2 -- arg3
2258
2259 This will call the callback routine for arg1 and arg2, and then
2260 terminate GetOptions() leaving C<"arg2"> in C<@ARGV>.
2261
2262 If C<require_order> is enabled, options processing
2263 terminates when the first non-option is encountered.
2264
2265     --foo arg1 --bar arg2 arg3
2266
2267 is equivalent to
2268
2269     --foo -- arg1 --bar arg2 arg3
2270
2271 If C<pass_through> is also enabled, options processing will terminate
2272 at the first unrecognized option, or non-option, whichever comes
2273 first.
2274
2275 =item bundling (default: disabled)
2276
2277 Enabling this option will allow single-character options to be
2278 bundled. To distinguish bundles from long option names, long options
2279 I<must> be introduced with C<--> and bundles with C<->.
2280
2281 Note that, if you have options C<a>, C<l> and C<all>, and
2282 auto_abbrev enabled, possible arguments and option settings are:
2283
2284     using argument               sets option(s)
2285     ------------------------------------------
2286     -a, --a                      a
2287     -l, --l                      l
2288     -al, -la, -ala, -all,...     a, l
2289     --al, --all                  all
2290
2291 The surprising part is that C<--a> sets option C<a> (due to auto
2292 completion), not C<all>.
2293
2294 Note: disabling C<bundling> also disables C<bundling_override>.
2295
2296 =item bundling_override (default: disabled)
2297
2298 If C<bundling_override> is enabled, bundling is enabled as with
2299 C<bundling> but now long option names override option bundles.
2300
2301 Note: disabling C<bundling_override> also disables C<bundling>.
2302
2303 B<Note:> Using option bundling can easily lead to unexpected results,
2304 especially when mixing long options and bundles. Caveat emptor.
2305
2306 =item ignore_case  (default: enabled)
2307
2308 If enabled, case is ignored when matching long option names. If,
2309 however, bundling is enabled as well, single character options will be
2310 treated case-sensitive.
2311
2312 With C<ignore_case>, option specifications for options that only
2313 differ in case, e.g., C<"foo"> and C<"Foo">, will be flagged as
2314 duplicates.
2315
2316 Note: disabling C<ignore_case> also disables C<ignore_case_always>.
2317
2318 =item ignore_case_always (default: disabled)
2319
2320 When bundling is in effect, case is ignored on single-character
2321 options also.
2322
2323 Note: disabling C<ignore_case_always> also disables C<ignore_case>.
2324
2325 =item auto_version (default:disabled)
2326
2327 Automatically provide support for the B<--version> option if
2328 the application did not specify a handler for this option itself.
2329
2330 Getopt::Long will provide a standard version message that includes the
2331 program name, its version (if $main::VERSION is defined), and the
2332 versions of Getopt::Long and Perl. The message will be written to
2333 standard output and processing will terminate.
2334
2335 C<auto_version> will be enabled if the calling program explicitly
2336 specified a version number higher than 2.32 in the C<use> or
2337 C<require> statement.
2338
2339 =item auto_help (default:disabled)
2340
2341 Automatically provide support for the B<--help> and B<-?> options if
2342 the application did not specify a handler for this option itself.
2343
2344 Getopt::Long will provide a help message using module L<Pod::Usage>. The
2345 message, derived from the SYNOPSIS POD section, will be written to
2346 standard output and processing will terminate.
2347
2348 C<auto_help> will be enabled if the calling program explicitly
2349 specified a version number higher than 2.32 in the C<use> or
2350 C<require> statement.
2351
2352 =item pass_through (default: disabled)
2353
2354 Options that are unknown, ambiguous or supplied with an invalid option
2355 value are passed through in C<@ARGV> instead of being flagged as
2356 errors. This makes it possible to write wrapper scripts that process
2357 only part of the user supplied command line arguments, and pass the
2358 remaining options to some other program.
2359
2360 If C<require_order> is enabled, options processing will terminate at
2361 the first unrecognized option, or non-option, whichever comes first.
2362 However, if C<permute> is enabled instead, results can become confusing.
2363
2364 Note that the options terminator (default C<-->), if present, will
2365 also be passed through in C<@ARGV>.
2366
2367 =item prefix
2368
2369 The string that starts options. If a constant string is not
2370 sufficient, see C<prefix_pattern>.
2371
2372 =item prefix_pattern
2373
2374 A Perl pattern that identifies the strings that introduce options.
2375 Default is C<--|-|\+> unless environment variable
2376 POSIXLY_CORRECT has been set, in which case it is C<--|->.
2377
2378 =item long_prefix_pattern
2379
2380 A Perl pattern that allows the disambiguation of long and short
2381 prefixes. Default is C<-->.
2382
2383 Typically you only need to set this if you are using nonstandard
2384 prefixes and want some or all of them to have the same semantics as
2385 '--' does under normal circumstances.
2386
2387 For example, setting prefix_pattern to C<--|-|\+|\/> and
2388 long_prefix_pattern to C<--|\/> would add Win32 style argument
2389 handling.
2390
2391 =item debug (default: disabled)
2392
2393 Enable debugging output.
2394
2395 =back
2396
2397 =head1 Exportable Methods
2398
2399 =over
2400
2401 =item VersionMessage
2402
2403 This subroutine provides a standard version message. Its argument can be:
2404
2405 =over 4
2406
2407 =item *
2408
2409 A string containing the text of a message to print I<before> printing
2410 the standard message.
2411
2412 =item *
2413
2414 A numeric value corresponding to the desired exit status.
2415
2416 =item *
2417
2418 A reference to a hash.
2419
2420 =back
2421
2422 If more than one argument is given then the entire argument list is
2423 assumed to be a hash.  If a hash is supplied (either as a reference or
2424 as a list) it should contain one or more elements with the following
2425 keys:
2426
2427 =over 4
2428
2429 =item C<-message>
2430
2431 =item C<-msg>
2432
2433 The text of a message to print immediately prior to printing the
2434 program's usage message.
2435
2436 =item C<-exitval>
2437
2438 The desired exit status to pass to the B<exit()> function.
2439 This should be an integer, or else the string "NOEXIT" to
2440 indicate that control should simply be returned without
2441 terminating the invoking process.
2442
2443 =item C<-output>
2444
2445 A reference to a filehandle, or the pathname of a file to which the
2446 usage message should be written. The default is C<\*STDERR> unless the
2447 exit value is less than 2 (in which case the default is C<\*STDOUT>).
2448
2449 =back
2450
2451 You cannot tie this routine directly to an option, e.g.:
2452
2453     GetOptions("version" => \&VersionMessage);
2454
2455 Use this instead:
2456
2457     GetOptions("version" => sub { VersionMessage() });
2458
2459 =item HelpMessage
2460
2461 This subroutine produces a standard help message, derived from the
2462 program's POD section SYNOPSIS using L<Pod::Usage>. It takes the same
2463 arguments as VersionMessage(). In particular, you cannot tie it
2464 directly to an option, e.g.:
2465
2466     GetOptions("help" => \&HelpMessage);
2467
2468 Use this instead:
2469
2470     GetOptions("help" => sub { HelpMessage() });
2471
2472 =back
2473
2474 =head1 Return values and Errors
2475
2476 Configuration errors and errors in the option definitions are
2477 signalled using die() and will terminate the calling program unless
2478 the call to Getopt::Long::GetOptions() was embedded in C<eval { ...
2479 }>, or die() was trapped using C<$SIG{__DIE__}>.
2480
2481 GetOptions returns true to indicate success.
2482 It returns false when the function detected one or more errors during
2483 option parsing. These errors are signalled using warn() and can be
2484 trapped with C<$SIG{__WARN__}>.
2485
2486 =head1 Legacy
2487
2488 The earliest development of C<newgetopt.pl> started in 1990, with Perl
2489 version 4. As a result, its development, and the development of
2490 Getopt::Long, has gone through several stages. Since backward
2491 compatibility has always been extremely important, the current version
2492 of Getopt::Long still supports a lot of constructs that nowadays are
2493 no longer necessary or otherwise unwanted. This section describes
2494 briefly some of these 'features'.
2495
2496 =head2 Default destinations
2497
2498 When no destination is specified for an option, GetOptions will store
2499 the resultant value in a global variable named C<opt_>I<XXX>, where
2500 I<XXX> is the primary name of this option. When a progam executes
2501 under C<use strict> (recommended), these variables must be
2502 pre-declared with our() or C<use vars>.
2503
2504     our $opt_length = 0;
2505     GetOptions ('length=i');    # will store in $opt_length
2506
2507 To yield a usable Perl variable, characters that are not part of the
2508 syntax for variables are translated to underscores. For example,
2509 C<--fpp-struct-return> will set the variable
2510 C<$opt_fpp_struct_return>. Note that this variable resides in the
2511 namespace of the calling program, not necessarily C<main>. For
2512 example:
2513
2514     GetOptions ("size=i", "sizes=i@");
2515
2516 with command line "-size 10 -sizes 24 -sizes 48" will perform the
2517 equivalent of the assignments
2518
2519     $opt_size = 10;
2520     @opt_sizes = (24, 48);
2521
2522 =head2 Alternative option starters
2523
2524 A string of alternative option starter characters may be passed as the
2525 first argument (or the first argument after a leading hash reference
2526 argument).
2527
2528     my $len = 0;
2529     GetOptions ('/', 'length=i' => $len);
2530
2531 Now the command line may look like:
2532
2533     /length 24 -- arg
2534
2535 Note that to terminate options processing still requires a double dash
2536 C<-->.
2537
2538 GetOptions() will not interpret a leading C<< "<>" >> as option starters
2539 if the next argument is a reference. To force C<< "<" >> and C<< ">" >> as
2540 option starters, use C<< "><" >>. Confusing? Well, B<using a starter
2541 argument is strongly deprecated> anyway.
2542
2543 =head2 Configuration variables
2544
2545 Previous versions of Getopt::Long used variables for the purpose of
2546 configuring. Although manipulating these variables still work, it is
2547 strongly encouraged to use the C<Configure> routine that was introduced
2548 in version 2.17. Besides, it is much easier.
2549
2550 =head1 Tips and Techniques
2551
2552 =head2 Pushing multiple values in a hash option
2553
2554 Sometimes you want to combine the best of hashes and arrays. For
2555 example, the command line:
2556
2557   --list add=first --list add=second --list add=third
2558
2559 where each successive 'list add' option will push the value of add
2560 into array ref $list->{'add'}. The result would be like
2561
2562   $list->{add} = [qw(first second third)];
2563
2564 This can be accomplished with a destination routine:
2565
2566   GetOptions('list=s%' =>
2567                sub { push(@{$list{$_[1]}}, $_[2]) });
2568
2569 =head1 Trouble Shooting
2570
2571 =head2 GetOptions does not return a false result when an option is not supplied
2572
2573 That's why they're called 'options'.
2574
2575 =head2 GetOptions does not split the command line correctly
2576
2577 The command line is not split by GetOptions, but by the command line
2578 interpreter (CLI). On Unix, this is the shell. On Windows, it is
2579 COMMAND.COM or CMD.EXE. Other operating systems have other CLIs.
2580
2581 It is important to know that these CLIs may behave different when the
2582 command line contains special characters, in particular quotes or
2583 backslashes. For example, with Unix shells you can use single quotes
2584 (C<'>) and double quotes (C<">) to group words together. The following
2585 alternatives are equivalent on Unix:
2586
2587     "two words"
2588     'two words'
2589     two\ words
2590
2591 In case of doubt, insert the following statement in front of your Perl
2592 program:
2593
2594     print STDERR (join("|",@ARGV),"\n");
2595
2596 to verify how your CLI passes the arguments to the program.
2597
2598 =head2 Undefined subroutine &main::GetOptions called
2599
2600 Are you running Windows, and did you write
2601
2602     use GetOpt::Long;
2603
2604 (note the capital 'O')?
2605
2606 =head2 How do I put a "-?" option into a Getopt::Long?
2607
2608 You can only obtain this using an alias, and Getopt::Long of at least
2609 version 2.13.
2610
2611     use Getopt::Long;
2612     GetOptions ("help|?");    # -help and -? will both set $opt_help
2613
2614 =head1 AUTHOR
2615
2616 Johan Vromans <jvromans@squirrel.nl>
2617
2618 =head1 COPYRIGHT AND DISCLAIMER
2619
2620 This program is Copyright 1990,2007 by Johan Vromans.
2621 This program is free software; you can redistribute it and/or
2622 modify it under the terms of the Perl Artistic License or the
2623 GNU General Public License as published by the Free Software
2624 Foundation; either version 2 of the License, or (at your option) any
2625 later version.
2626
2627 This program is distributed in the hope that it will be useful,
2628 but WITHOUT ANY WARRANTY; without even the implied warranty of
2629 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
2630 GNU General Public License for more details.
2631
2632 If you do not have a copy of the GNU General Public License write to
2633 the Free Software Foundation, Inc., 675 Mass Ave, Cambridge,
2634 MA 02139, USA.
2635
2636 =cut
2637