lib/Getopt/Long.pm

   1 # GetOpt::Long.pm -- Universal options parsing
   2
   3 package Getopt::Long;
   4
   5 # RCS Status      : $Id: GetoptLong.pm,v 2.16 1998-03-13 11:05:29+01 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: Fri Mar 13 11:05:28 1998
  10 # Update Count    : 659
  11 # Status          : Released
  12
  13 ################ Copyright ################
  14
  15 # This program is Copyright 1990,1998 by Johan Vromans.
  16 # This program is free software; you can redistribute it and/or
  17 # modify it under the terms of the GNU General Public License
  18 # as published by the Free Software Foundation; either version 2
  19 # of the License, or (at your option) any later version.
  20 #
  21 # This program is distributed in the hope that it will be useful,
  22 # but WITHOUT ANY WARRANTY; without even the implied warranty of
  23 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  24 # GNU General Public License for more details.
  25 #
  26 # If you do not have a copy of the GNU General Public License write to
  27 # the Free Software Foundation, Inc., 675 Mass Ave, Cambridge,
  28 # MA 02139, USA.
  29
  30 ################ Module Preamble ################
  31
  32 use strict;
  33
  34 BEGIN {
  35     require 5.004;
  36     use Exporter ();
  37     use vars   qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
  38     $VERSION   = sprintf("%d.%02d", q$Revision: 2.16 $ =~ /(\d+)\.(\d+)/);
  39
  40     @ISA       = qw(Exporter);
  41     @EXPORT    = qw(&GetOptions $REQUIRE_ORDER $PERMUTE $RETURN_IN_ORDER);
  42     %EXPORT_TAGS = ();
  43     @EXPORT_OK = qw();
  44 }
  45
  46 use vars @EXPORT, @EXPORT_OK;
  47 # User visible variables.
  48 use vars qw($error $debug $major_version $minor_version);
  49 # Deprecated visible variables.
  50 use vars qw($autoabbrev $getopt_compat $ignorecase $bundling $order
  51             $passthrough);
  52
  53 ################ Local Variables ################
  54
  55 my $gen_prefix;                 # generic prefix (option starters)
  56 my $argend;                     # option list terminator
  57 my %opctl;                      # table of arg.specs (long and abbrevs)
  58 my %bopctl;                     # table of arg.specs (bundles)
  59 my @opctl;                      # the possible long option names
  60 my $pkg;                        # current context. Needed if no linkage.
  61 my %aliases;                    # alias table
  62 my $genprefix;                  # so we can call the same module more
  63 my $opt;                        # current option
  64 my $arg;                        # current option value, if any
  65 my $array;                      # current option is array typed
  66 my $hash;                       # current option is hash typed
  67 my $key;                        # hash key for a hash option
  68                                 # than once in differing environments
  69 my $config_defaults;            # set config defaults
  70 my $find_option;                # helper routine
  71 my $croak;                      # helper routine
  72
  73 ################ Subroutines ################
  74
  75 sub GetOptions {
  76
  77     my @optionlist = @_;        # local copy of the option descriptions
  78     $argend = '--';             # option list terminator
  79     %opctl = ();                # table of arg.specs (long and abbrevs)
  80     %bopctl = ();               # table of arg.specs (bundles)
  81     $pkg = (caller)[0];         # current context
  82                                 # Needed if linkage is omitted.
  83     %aliases= ();               # alias table
  84     my @ret = ();               # accum for non-options
  85     my %linkage;                # linkage
  86     my $userlinkage;            # user supplied HASH
  87     $genprefix = $gen_prefix;   # so we can call the same module many times
  88     $error = '';
  89
  90     print STDERR ('GetOptions $Revision: 2.16 $ ',
  91                   "[GetOpt::Long $Getopt::Long::VERSION] -- ",
  92                   "called from package \"$pkg\".\n",
  93                   "  (@ARGV)\n",
  94                   "  autoabbrev=$autoabbrev".
  95                   ",bundling=$bundling",
  96                   ",getopt_compat=$getopt_compat",
  97                   ",order=$order",
  98                   ",\n  ignorecase=$ignorecase",
  99                   ",passthrough=$passthrough",
 100                   ",genprefix=\"$genprefix\"",
 101                   ".\n")
 102         if $debug;
 103
 104     # Check for ref HASH as first argument.
 105     # First argument may be an object. It's OK to use this as long
 106     # as it is really a hash underneath.
 107     $userlinkage = undef;
 108     if ( ref($optionlist[0]) and
 109          "$optionlist[0]" =~ /^(?:.*\=)?HASH\([^\(]*\)$/ ) {
 110         $userlinkage = shift (@optionlist);
 111         print STDERR ("=> user linkage: $userlinkage\n") if $debug;
 112     }
 113
 114     # See if the first element of the optionlist contains option
 115     # starter characters.
 116     if ( $optionlist[0] =~ /^\W+$/ ) {
 117         $genprefix = shift (@optionlist);
 118         # Turn into regexp. Needs to be parenthesized!
 119         $genprefix =~ s/(\W)/\\$1/g;
 120         $genprefix = "([" . $genprefix . "])";
 121     }
 122
 123     # Verify correctness of optionlist.
 124     %opctl = ();
 125     %bopctl = ();
 126     while ( @optionlist > 0 ) {
 127         my $opt = shift (@optionlist);
 128
 129         # Strip leading prefix so people can specify "--foo=i" if they like.
 130         $opt = $+ if $opt =~ /^$genprefix+(.*)$/s;
 131
 132         if ( $opt eq '<>' ) {
 133             if ( (defined $userlinkage)
 134                 && !(@optionlist > 0 && ref($optionlist[0]))
 135                 && (exists $userlinkage->{$opt})
 136                 && ref($userlinkage->{$opt}) ) {
 137                 unshift (@optionlist, $userlinkage->{$opt});
 138             }
 139             unless ( @optionlist > 0
 140                     && ref($optionlist[0]) && ref($optionlist[0]) eq 'CODE' ) {
 141                 $error .= "Option spec <> requires a reference to a subroutine\n";
 142                 next;
 143             }
 144             $linkage{'<>'} = shift (@optionlist);
 145             next;
 146         }
 147
 148         # Match option spec. Allow '?' as an alias.
 149         if ( $opt !~ /^((\w+[-\w]*)(\|(\?|\w[-\w]*)?)*)?(!|[=:][infse][@%]?)?$/ ) {
 150             $error .= "Error in option spec: \"$opt\"\n";
 151             next;
 152         }
 153         my ($o, $c, $a) = ($1, $5);
 154         $c = '' unless defined $c;
 155
 156         if ( ! defined $o ) {
 157             # empty -> '-' option
 158             $opctl{$o = ''} = $c;
 159         }
 160         else {
 161             # Handle alias names
 162             my @o =  split (/\|/, $o);
 163             my $linko = $o = $o[0];
 164             # Force an alias if the option name is not locase.
 165             $a = $o unless $o eq lc($o);
 166             $o = lc ($o)
 167                 if $ignorecase > 1
 168                     || ($ignorecase
 169                         && ($bundling ? length($o) > 1  : 1));
 170
 171             foreach ( @o ) {
 172                 if ( $bundling && length($_) == 1 ) {
 173                     $_ = lc ($_) if $ignorecase > 1;
 174                     if ( $c eq '!' ) {
 175                         $opctl{"no$_"} = $c;
 176                         warn ("Ignoring '!' modifier for short option $_\n");
 177                         $c = '';
 178                     }
 179                     $opctl{$_} = $bopctl{$_} = $c;
 180                 }
 181                 else {
 182                     $_ = lc ($_) if $ignorecase;
 183                     if ( $c eq '!' ) {
 184                         $opctl{"no$_"} = $c;
 185                         $c = '';
 186                     }
 187                     $opctl{$_} = $c;
 188                 }
 189                 if ( defined $a ) {
 190                     # Note alias.
 191                     $aliases{$_} = $a;
 192                 }
 193                 else {
 194                     # Set primary name.
 195                     $a = $_;
 196                 }
 197             }
 198             $o = $linko;
 199         }
 200
 201         # If no linkage is supplied in the @optionlist, copy it from
 202         # the userlinkage if available.
 203         if ( defined $userlinkage ) {
 204             unless ( @optionlist > 0 && ref($optionlist[0]) ) {
 205                 if ( exists $userlinkage->{$o} && ref($userlinkage->{$o}) ) {
 206                     print STDERR ("=> found userlinkage for \"$o\": ",
 207                                   "$userlinkage->{$o}\n")
 208                         if $debug;
 209                     unshift (@optionlist, $userlinkage->{$o});
 210                 }
 211                 else {
 212                     # Do nothing. Being undefined will be handled later.
 213                     next;
 214                 }
 215             }
 216         }
 217
 218         # Copy the linkage. If omitted, link to global variable.
 219         if ( @optionlist > 0 && ref($optionlist[0]) ) {
 220             print STDERR ("=> link \"$o\" to $optionlist[0]\n")
 221                 if $debug;
 222             if ( ref($optionlist[0]) =~ /^(SCALAR|CODE)$/ ) {
 223                 $linkage{$o} = shift (@optionlist);
 224             }
 225             elsif ( ref($optionlist[0]) =~ /^(ARRAY)$/ ) {
 226                 $linkage{$o} = shift (@optionlist);
 227                 $opctl{$o} .= '@'
 228                   if $opctl{$o} ne '' and $opctl{$o} !~ /\@$/;
 229                 $bopctl{$o} .= '@'
 230                   if $bundling and defined $bopctl{$o} and
 231                     $bopctl{$o} ne '' and $bopctl{$o} !~ /\@$/;
 232             }
 233             elsif ( ref($optionlist[0]) =~ /^(HASH)$/ ) {
 234                 $linkage{$o} = shift (@optionlist);
 235                 $opctl{$o} .= '%'
 236                   if $opctl{$o} ne '' and $opctl{$o} !~ /\%$/;
 237                 $bopctl{$o} .= '%'
 238                   if $bundling and defined $bopctl{$o} and
 239                     $bopctl{$o} ne '' and $bopctl{$o} !~ /\%$/;
 240             }
 241             else {
 242                 $error .= "Invalid option linkage for \"$opt\"\n";
 243             }
 244         }
 245         else {
 246             # Link to global $opt_XXX variable.
 247             # Make sure a valid perl identifier results.
 248             my $ov = $o;
 249             $ov =~ s/\W/_/g;
 250             if ( $c =~ /@/ ) {
 251                 print STDERR ("=> link \"$o\" to \@$pkg","::opt_$ov\n")
 252                     if $debug;
 253                 eval ("\$linkage{\$o} = \\\@".$pkg."::opt_$ov;");
 254             }
 255             elsif ( $c =~ /%/ ) {
 256                 print STDERR ("=> link \"$o\" to \%$pkg","::opt_$ov\n")
 257                     if $debug;
 258                 eval ("\$linkage{\$o} = \\\%".$pkg."::opt_$ov;");
 259             }
 260             else {
 261                 print STDERR ("=> link \"$o\" to \$$pkg","::opt_$ov\n")
 262                     if $debug;
 263                 eval ("\$linkage{\$o} = \\\$".$pkg."::opt_$ov;");
 264             }
 265         }
 266     }
 267
 268     # Bail out if errors found.
 269     die ($error) if $error;
 270     $error = 0;
 271
 272     # Sort the possible long option names.
 273     @opctl = sort(keys (%opctl)) if $autoabbrev;
 274
 275     # Show the options tables if debugging.
 276     if ( $debug ) {
 277         my ($arrow, $k, $v);
 278         $arrow = "=> ";
 279         while ( ($k,$v) = each(%opctl) ) {
 280             print STDERR ($arrow, "\$opctl{\"$k\"} = \"$v\"\n");
 281             $arrow = "   ";
 282         }
 283         $arrow = "=> ";
 284         while ( ($k,$v) = each(%bopctl) ) {
 285             print STDERR ($arrow, "\$bopctl{\"$k\"} = \"$v\"\n");
 286             $arrow = "   ";
 287         }
 288     }
 289
 290     # Process argument list
 291     while ( @ARGV > 0 ) {
 292
 293         #### Get next argument ####
 294
 295         $opt = shift (@ARGV);
 296         $arg = undef;
 297         $array = $hash = 0;
 298         print STDERR ("=> option \"", $opt, "\"\n") if $debug;
 299
 300         #### Determine what we have ####
 301
 302         # Double dash is option list terminator.
 303         if ( $opt eq $argend ) {
 304             # Finish. Push back accumulated arguments and return.
 305             unshift (@ARGV, @ret)
 306                 if $order == $PERMUTE;
 307             return ($error == 0);
 308         }
 309
 310         my $tryopt = $opt;
 311
 312         # find_option operates on the GLOBAL $opt and $arg!
 313         if ( &$find_option () ) {
 314
 315             # find_option undefines $opt in case of errors.
 316             next unless defined $opt;
 317
 318             if ( defined $arg ) {
 319                 $opt = $aliases{$opt} if defined $aliases{$opt};
 320
 321                 if ( defined $linkage{$opt} ) {
 322                     print STDERR ("=> ref(\$L{$opt}) -> ",
 323                                   ref($linkage{$opt}), "\n") if $debug;
 324
 325                     if ( ref($linkage{$opt}) eq 'SCALAR' ) {
 326                         print STDERR ("=> \$\$L{$opt} = \"$arg\"\n") if $debug;
 327                         ${$linkage{$opt}} = $arg;
 328                     }
 329                     elsif ( ref($linkage{$opt}) eq 'ARRAY' ) {
 330                         print STDERR ("=> push(\@{\$L{$opt}, \"$arg\")\n")
 331                             if $debug;
 332                         push (@{$linkage{$opt}}, $arg);
 333                     }
 334                     elsif ( ref($linkage{$opt}) eq 'HASH' ) {
 335                         print STDERR ("=> \$\$L{$opt}->{$key} = \"$arg\"\n")
 336                             if $debug;
 337                         $linkage{$opt}->{$key} = $arg;
 338                     }
 339                     elsif ( ref($linkage{$opt}) eq 'CODE' ) {
 340                         print STDERR ("=> &L{$opt}(\"$opt\", \"$arg\")\n")
 341                             if $debug;
 342                         &{$linkage{$opt}}($opt, $arg);
 343                     }
 344                     else {
 345                         print STDERR ("Invalid REF type \"", ref($linkage{$opt}),
 346                                       "\" in linkage\n");
 347                         &$croak ("Getopt::Long -- internal error!\n");
 348                     }
 349                 }
 350                 # No entry in linkage means entry in userlinkage.
 351                 elsif ( $array ) {
 352                     if ( defined $userlinkage->{$opt} ) {
 353                         print STDERR ("=> push(\@{\$L{$opt}}, \"$arg\")\n")
 354                             if $debug;
 355                         push (@{$userlinkage->{$opt}}, $arg);
 356                     }
 357                     else {
 358                         print STDERR ("=>\$L{$opt} = [\"$arg\"]\n")
 359                             if $debug;
 360                         $userlinkage->{$opt} = [$arg];
 361                     }
 362                 }
 363                 elsif ( $hash ) {
 364                     if ( defined $userlinkage->{$opt} ) {
 365                         print STDERR ("=> \$L{$opt}->{$key} = \"$arg\"\n")
 366                             if $debug;
 367                         $userlinkage->{$opt}->{$key} = $arg;
 368                     }
 369                     else {
 370                         print STDERR ("=>\$L{$opt} = {$key => \"$arg\"}\n")
 371                             if $debug;
 372                         $userlinkage->{$opt} = {$key => $arg};
 373                     }
 374                 }
 375                 else {
 376                     print STDERR ("=>\$L{$opt} = \"$arg\"\n") if $debug;
 377                     $userlinkage->{$opt} = $arg;
 378                 }
 379             }
 380         }
 381
 382         # Not an option. Save it if we $PERMUTE and don't have a <>.
 383         elsif ( $order == $PERMUTE ) {
 384             # Try non-options call-back.
 385             my $cb;
 386             if ( (defined ($cb = $linkage{'<>'})) ) {
 387                 &$cb ($tryopt);
 388             }
 389             else {
 390                 print STDERR ("=> saving \"$tryopt\" ",
 391                               "(not an option, may permute)\n") if $debug;
 392                 push (@ret, $tryopt);
 393             }
 394             next;
 395         }
 396
 397         # ...otherwise, terminate.
 398         else {
 399             # Push this one back and exit.
 400             unshift (@ARGV, $tryopt);
 401             return ($error == 0);
 402         }
 403
 404     }
 405
 406     # Finish.
 407     if ( $order == $PERMUTE ) {
 408         #  Push back accumulated arguments
 409         print STDERR ("=> restoring \"", join('" "', @ret), "\"\n")
 410             if $debug && @ret > 0;
 411         unshift (@ARGV, @ret) if @ret > 0;
 412     }
 413
 414     return ($error == 0);
 415 }
 416
 417 sub config (@) {
 418     my (@options) = @_;
 419     my $opt;
 420     foreach $opt ( @options ) {
 421         my $try = lc ($opt);
 422         my $action = 1;
 423         if ( $try =~ /^no_?(.*)$/s ) {
 424             $action = 0;
 425             $try = $+;
 426         }
 427         if ( $try eq 'default' or $try eq 'defaults' ) {
 428             &$config_defaults () if $action;
 429         }
 430         elsif ( $try eq 'auto_abbrev' or $try eq 'autoabbrev' ) {
 431             $autoabbrev = $action;
 432         }
 433         elsif ( $try eq 'getopt_compat' ) {
 434             $getopt_compat = $action;
 435         }
 436         elsif ( $try eq 'ignorecase' or $try eq 'ignore_case' ) {
 437             $ignorecase = $action;
 438         }
 439         elsif ( $try eq 'ignore_case_always' ) {
 440             $ignorecase = $action ? 2 : 0;
 441         }
 442         elsif ( $try eq 'bundling' ) {
 443             $bundling = $action;
 444         }
 445         elsif ( $try eq 'bundling_override' ) {
 446             $bundling = $action ? 2 : 0;
 447         }
 448         elsif ( $try eq 'require_order' ) {
 449             $order = $action ? $REQUIRE_ORDER : $PERMUTE;
 450         }
 451         elsif ( $try eq 'permute' ) {
 452             $order = $action ? $PERMUTE : $REQUIRE_ORDER;
 453         }
 454         elsif ( $try eq 'pass_through' or $try eq 'passthrough' ) {
 455             $passthrough = $action;
 456         }
 457         elsif ( $try =~ /^prefix=(.+)$/ ) {
 458             $gen_prefix = $1;
 459             # Turn into regexp. Needs to be parenthesized!
 460             $gen_prefix = "(" . quotemeta($gen_prefix) . ")";
 461             eval { '' =~ /$gen_prefix/; };
 462             &$croak ("Getopt::Long: invalid pattern \"$gen_prefix\"") if $@;
 463         }
 464         elsif ( $try =~ /^prefix_pattern=(.+)$/ ) {
 465             $gen_prefix = $1;
 466             # Parenthesize if needed.
 467             $gen_prefix = "(" . $gen_prefix . ")"
 468               unless $gen_prefix =~ /^\(.*\)$/;
 469             eval { '' =~ /$gen_prefix/; };
 470             &$croak ("Getopt::Long: invalid pattern \"$gen_prefix\"") if $@;
 471         }
 472         elsif ( $try eq 'debug' ) {
 473             $debug = $action;
 474         }
 475         else {
 476             &$croak ("Getopt::Long: unknown config parameter \"$opt\"")
 477         }
 478     }
 479 }
 480
 481 # To prevent Carp from being loaded unnecessarily.
 482 $croak = sub {
 483     require 'Carp.pm';
 484     $Carp::CarpLevel = 1;
 485     Carp::croak(@_);
 486 };
 487
 488 ################ Private Subroutines ################
 489
 490 $find_option = sub {
 491
 492     print STDERR ("=> find \"$opt\", genprefix=\"$genprefix\"\n") if $debug;
 493
 494     return 0 unless $opt =~ /^$genprefix(.*)$/s;
 495
 496     $opt = $+;
 497     my ($starter) = $1;
 498
 499     print STDERR ("=> split \"$starter\"+\"$opt\"\n") if $debug;
 500
 501     my $optarg = undef; # value supplied with --opt=value
 502     my $rest = undef;   # remainder from unbundling
 503
 504     # If it is a long option, it may include the value.
 505     if (($starter eq "--" || ($getopt_compat && !$bundling))
 506         && $opt =~ /^([^=]+)=(.*)$/s ) {
 507         $opt = $1;
 508         $optarg = $2;
 509         print STDERR ("=> option \"", $opt,
 510                       "\", optarg = \"$optarg\"\n") if $debug;
 511     }
 512
 513     #### Look it up ###
 514
 515     my $tryopt = $opt;          # option to try
 516     my $optbl = \%opctl;        # table to look it up (long names)
 517     my $type;
 518
 519     if ( $bundling && $starter eq '-' ) {
 520         # Unbundle single letter option.
 521         $rest = substr ($tryopt, 1);
 522         $tryopt = substr ($tryopt, 0, 1);
 523         $tryopt = lc ($tryopt) if $ignorecase > 1;
 524         print STDERR ("=> $starter$tryopt unbundled from ",
 525                       "$starter$tryopt$rest\n") if $debug;
 526         $rest = undef unless $rest ne '';
 527         $optbl = \%bopctl;      # look it up in the short names table
 528
 529         # If bundling == 2, long options can override bundles.
 530         if ( $bundling == 2 and
 531              defined ($type = $opctl{$tryopt.$rest}) ) {
 532             print STDERR ("=> $starter$tryopt rebundled to ",
 533                           "$starter$tryopt$rest\n") if $debug;
 534             $tryopt .= $rest;
 535             undef $rest;
 536         }
 537     }
 538
 539     # Try auto-abbreviation.
 540     elsif ( $autoabbrev ) {
 541         # Downcase if allowed.
 542         $tryopt = $opt = lc ($opt) if $ignorecase;
 543         # Turn option name into pattern.
 544         my $pat = quotemeta ($opt);
 545         # Look up in option names.
 546         my @hits = grep (/^$pat/, @opctl);
 547         print STDERR ("=> ", scalar(@hits), " hits (@hits) with \"$pat\" ",
 548                       "out of ", scalar(@opctl), "\n") if $debug;
 549
 550         # Check for ambiguous results.
 551         unless ( (@hits <= 1) || (grep ($_ eq $opt, @hits) == 1) ) {
 552             # See if all matches are for the same option.
 553             my %hit;
 554             foreach ( @hits ) {
 555                 $_ = $aliases{$_} if defined $aliases{$_};
 556                 $hit{$_} = 1;
 557             }
 558             # Now see if it really is ambiguous.
 559             unless ( keys(%hit) == 1 ) {
 560                 return 0 if $passthrough;
 561                 warn ("Option ", $opt, " is ambiguous (",
 562                       join(", ", @hits), ")\n");
 563                 $error++;
 564                 undef $opt;
 565                 return 1;
 566             }
 567             @hits = keys(%hit);
 568         }
 569
 570         # Complete the option name, if appropriate.
 571         if ( @hits == 1 && $hits[0] ne $opt ) {
 572             $tryopt = $hits[0];
 573             $tryopt = lc ($tryopt) if $ignorecase;
 574             print STDERR ("=> option \"$opt\" -> \"$tryopt\"\n")
 575                 if $debug;
 576         }
 577     }
 578
 579     # Map to all lowercase if ignoring case.
 580     elsif ( $ignorecase ) {
 581         $tryopt = lc ($opt);
 582     }
 583
 584     # Check validity by fetching the info.
 585     $type = $optbl->{$tryopt} unless defined $type;
 586     unless  ( defined $type ) {
 587         return 0 if $passthrough;
 588         warn ("Unknown option: ", $opt, "\n");
 589         $error++;
 590         return 1;
 591     }
 592     # Apparently valid.
 593     $opt = $tryopt;
 594     print STDERR ("=> found \"$type\" for ", $opt, "\n") if $debug;
 595
 596     #### Determine argument status ####
 597
 598     # If it is an option w/o argument, we're almost finished with it.
 599     if ( $type eq '' || $type eq '!' ) {
 600         if ( defined $optarg ) {
 601             return 0 if $passthrough;
 602             warn ("Option ", $opt, " does not take an argument\n");
 603             $error++;
 604             undef $opt;
 605         }
 606         elsif ( $type eq '' ) {
 607             $arg = 1;           # supply explicit value
 608         }
 609         else {
 610             substr ($opt, 0, 2) = ''; # strip NO prefix
 611             $arg = 0;           # supply explicit value
 612         }
 613         unshift (@ARGV, $starter.$rest) if defined $rest;
 614         return 1;
 615     }
 616
 617     # Get mandatory status and type info.
 618     my $mand;
 619     ($mand, $type, $array, $hash) = $type =~ /^(.)(.)(@?)(%?)$/;
 620
 621     # Check if there is an option argument available.
 622     if ( defined $optarg ? ($optarg eq '')
 623          : !(defined $rest || @ARGV > 0) ) {
 624         # Complain if this option needs an argument.
 625         if ( $mand eq "=" ) {
 626             return 0 if $passthrough;
 627             warn ("Option ", $opt, " requires an argument\n");
 628             $error++;
 629             undef $opt;
 630         }
 631         if ( $mand eq ":" ) {
 632             $arg = $type eq "s" ? '' : 0;
 633         }
 634         return 1;
 635     }
 636
 637     # Get (possibly optional) argument.
 638     $arg = (defined $rest ? $rest
 639             : (defined $optarg ? $optarg : shift (@ARGV)));
 640
 641     # Get key if this is a "name=value" pair for a hash option.
 642     $key = undef;
 643     if ($hash && defined $arg) {
 644         ($key, $arg) = ($arg =~ /^(.*)=(.*)$/s) ? ($1, $2) : ($arg, 1);
 645     }
 646
 647     #### Check if the argument is valid for this option ####
 648
 649     if ( $type eq "s" ) {       # string
 650         # A mandatory string takes anything.
 651         return 1 if $mand eq "=";
 652
 653         # An optional string takes almost anything.
 654         return 1 if defined $optarg || defined $rest;
 655         return 1 if $arg eq "-"; # ??
 656
 657         # Check for option or option list terminator.
 658         if ($arg eq $argend ||
 659             $arg =~ /^$genprefix.+/) {
 660             # Push back.
 661             unshift (@ARGV, $arg);
 662             # Supply empty value.
 663             $arg = '';
 664         }
 665     }
 666
 667     elsif ( $type eq "n" || $type eq "i" ) { # numeric/integer
 668         if ( $bundling && defined $rest && $rest =~ /^(-?[0-9]+)(.*)$/s ) {
 669             $arg = $1;
 670             $rest = $2;
 671             unshift (@ARGV, $starter.$rest) if defined $rest && $rest ne '';
 672         }
 673         elsif ( $arg !~ /^-?[0-9]+$/ ) {
 674             if ( defined $optarg || $mand eq "=" ) {
 675                 if ( $passthrough ) {
 676                     unshift (@ARGV, defined $rest ? $starter.$rest : $arg)
 677                       unless defined $optarg;
 678                     return 0;
 679                 }
 680                 warn ("Value \"", $arg, "\" invalid for option ",
 681                       $opt, " (number expected)\n");
 682                 $error++;
 683                 undef $opt;
 684                 # Push back.
 685                 unshift (@ARGV, $starter.$rest) if defined $rest;
 686             }
 687             else {
 688                 # Push back.
 689                 unshift (@ARGV, defined $rest ? $starter.$rest : $arg);
 690                 # Supply default value.
 691                 $arg = 0;
 692             }
 693         }
 694     }
 695
 696     elsif ( $type eq "f" ) { # real number, int is also ok
 697         # We require at least one digit before a point or 'e',
 698         # and at least one digit following the point and 'e'.
 699         # [-]NN[.NN][eNN]
 700         if ( $bundling && defined $rest &&
 701              $rest =~ /^(-?[0-9]+(\.[0-9]+)?([eE]-?[0-9]+)?)(.*)$/s ) {
 702             $arg = $1;
 703             $rest = $+;
 704             unshift (@ARGV, $starter.$rest) if defined $rest && $rest ne '';
 705         }
 706         elsif ( $arg !~ /^-?[0-9.]+(\.[0-9]+)?([eE]-?[0-9]+)?$/ ) {
 707             if ( defined $optarg || $mand eq "=" ) {
 708                 if ( $passthrough ) {
 709                     unshift (@ARGV, defined $rest ? $starter.$rest : $arg)
 710                       unless defined $optarg;
 711                     return 0;
 712                 }
 713                 warn ("Value \"", $arg, "\" invalid for option ",
 714                       $opt, " (real number expected)\n");
 715                 $error++;
 716                 undef $opt;
 717                 # Push back.
 718                 unshift (@ARGV, $starter.$rest) if defined $rest;
 719             }
 720             else {
 721                 # Push back.
 722                 unshift (@ARGV, defined $rest ? $starter.$rest : $arg);
 723                 # Supply default value.
 724                 $arg = 0.0;
 725             }
 726         }
 727     }
 728     else {
 729         &$croak ("GetOpt::Long internal error (Can't happen)\n");
 730     }
 731     return 1;
 732 };
 733
 734 $config_defaults = sub {
 735     # Handle POSIX compliancy.
 736     if ( defined $ENV{"POSIXLY_CORRECT"} ) {
 737         $gen_prefix = "(--|-)";
 738         $autoabbrev = 0;                # no automatic abbrev of options
 739         $bundling = 0;                  # no bundling of single letter switches
 740         $getopt_compat = 0;             # disallow '+' to start options
 741         $order = $REQUIRE_ORDER;
 742     }
 743     else {
 744         $gen_prefix = "(--|-|\\+)";
 745         $autoabbrev = 1;                # automatic abbrev of options
 746         $bundling = 0;                  # bundling off by default
 747         $getopt_compat = 1;             # allow '+' to start options
 748         $order = $PERMUTE;
 749     }
 750     # Other configurable settings.
 751     $debug = 0;                 # for debugging
 752     $error = 0;                 # error tally
 753     $ignorecase = 1;            # ignore case when matching options
 754     $passthrough = 0;           # leave unrecognized options alone
 755 };
 756
 757 ################ Initialization ################
 758
 759 # Values for $order. See GNU getopt.c for details.
 760 ($REQUIRE_ORDER, $PERMUTE, $RETURN_IN_ORDER) = (0..2);
 761 # Version major/minor numbers.
 762 ($major_version, $minor_version) = $VERSION =~ /^(\d+)\.(\d+)/;
 763
 764 # Set defaults.
 765 &$config_defaults ();
 766
 767 ################ Package return ################
 768
 769 1;
 770
 771 __END__
 772
 773 =head1 NAME
 774
 775 GetOptions - extended processing of command line options
 776
 777 =head1 SYNOPSIS
 778
 779   use Getopt::Long;
 780   $result = GetOptions (...option-descriptions...);
 781
 782 =head1 DESCRIPTION
 783
 784 The Getopt::Long module implements an extended getopt function called
 785 GetOptions(). This function adheres to the POSIX syntax for command
 786 line options, with GNU extensions. In general, this means that options
 787 have long names instead of single letters, and are introduced with a
 788 double dash "--". Support for bundling of command line options, as was
 789 the case with the more traditional single-letter approach, is provided
 790 but not enabled by default. For example, the UNIX "ps" command can be
 791 given the command line "option"
 792
 793   -vax
 794
 795 which means the combination of B<-v>, B<-a> and B<-x>. With the new
 796 syntax B<--vax> would be a single option, probably indicating a
 797 computer architecture.
 798
 799 Command line options can be used to set values. These values can be
 800 specified in one of two ways:
 801
 802   --size 24
 803   --size=24
 804
 805 GetOptions is called with a list of option-descriptions, each of which
 806 consists of two elements: the option specifier and the option linkage.
 807 The option specifier defines the name of the option and, optionally,
 808 the value it can take. The option linkage is usually a reference to a
 809 variable that will be set when the option is used. For example, the
 810 following call to GetOptions:
 811
 812   GetOptions("size=i" => \$offset);
 813
 814 will accept a command line option "size" that must have an integer
 815 value. With a command line of "--size 24" this will cause the variable
 816 $offset to get the value 24.
 817
 818 Alternatively, the first argument to GetOptions may be a reference to
 819 a HASH describing the linkage for the options, or an object whose
 820 class is based on a HASH. The following call is equivalent to the
 821 example above:
 822
 823   %optctl = ("size" => \$offset);
 824   GetOptions(\%optctl, "size=i");
 825
 826 Linkage may be specified using either of the above methods, or both.
 827 Linkage specified in the argument list takes precedence over the
 828 linkage specified in the HASH.
 829
 830 The command line options are taken from array @ARGV. Upon completion
 831 of GetOptions, @ARGV will contain the rest (i.e. the non-options) of
 832 the command line.
 833
 834 Each option specifier designates the name of the option, optionally
 835 followed by an argument specifier.
 836
 837 Options that do not take arguments will have no argument specifier.
 838 The option variable will be set to 1 if the option is used.
 839
 840 For the other options, the values for argument specifiers are:
 841
 842 =over 8
 843
 844 =item !
 845
 846 Option does not take an argument and may be negated, i.e. prefixed by
 847 "no". E.g. "foo!" will allow B<--foo> (with value 1) and B<-nofoo>
 848 (with value 0).
 849 The option variable will be set to 1, or 0 if negated.
 850
 851 =item =s
 852
 853 Option takes a mandatory string argument.
 854 This string will be assigned to the option variable.
 855 Note that even if the string argument starts with B<-> or B<-->, it
 856 will not be considered an option on itself.
 857
 858 =item :s
 859
 860 Option takes an optional string argument.
 861 This string will be assigned to the option variable.
 862 If omitted, it will be assigned "" (an empty string).
 863 If the string argument starts with B<-> or B<-->, it
 864 will be considered an option on itself.
 865
 866 =item =i
 867
 868 Option takes a mandatory integer argument.
 869 This value will be assigned to the option variable.
 870 Note that the value may start with B<-> to indicate a negative
 871 value.
 872
 873 =item :i
 874
 875 Option takes an optional integer argument.
 876 This value will be assigned to the option variable.
 877 If omitted, the value 0 will be assigned.
 878 Note that the value may start with B<-> to indicate a negative
 879 value.
 880
 881 =item =f
 882
 883 Option takes a mandatory real number argument.
 884 This value will be assigned to the option variable.
 885 Note that the value may start with B<-> to indicate a negative
 886 value.
 887
 888 =item :f
 889
 890 Option takes an optional real number argument.
 891 This value will be assigned to the option variable.
 892 If omitted, the value 0 will be assigned.
 893
 894 =back
 895
 896 A lone dash B<-> is considered an option, the corresponding option
 897 name is the empty string.
 898
 899 A double dash on itself B<--> signals end of the options list.
 900
 901 =head2 Linkage specification
 902
 903 The linkage specifier is optional. If no linkage is explicitly
 904 specified but a ref HASH is passed, GetOptions will place the value in
 905 the HASH. For example:
 906
 907   %optctl = ();
 908   GetOptions (\%optctl, "size=i");
 909
 910 will perform the equivalent of the assignment
 911
 912   $optctl{"size"} = 24;
 913
 914 For array options, a reference to an array is used, e.g.:
 915
 916   %optctl = ();
 917   GetOptions (\%optctl, "sizes=i@");
 918
 919 with command line "-sizes 24 -sizes 48" will perform the equivalent of
 920 the assignment
 921
 922   $optctl{"sizes"} = [24, 48];
 923
 924 For hash options (an option whose argument looks like "name=value"),
 925 a reference to a hash is used, e.g.:
 926
 927   %optctl = ();
 928   GetOptions (\%optctl, "define=s%");
 929
 930 with command line "--define foo=hello --define bar=world" will perform the
 931 equivalent of the assignment
 932
 933   $optctl{"define"} = {foo=>'hello', bar=>'world')
 934
 935 If no linkage is explicitly specified and no ref HASH is passed,
 936 GetOptions will put the value in a global variable named after the
 937 option, prefixed by "opt_". To yield a usable Perl variable,
 938 characters that are not part of the syntax for variables are
 939 translated to underscores. For example, "--fpp-struct-return" will set
 940 the variable $opt_fpp_struct_return. Note that this variable resides
 941 in the namespace of the calling program, not necessarily B<main>.
 942 For example:
 943
 944   GetOptions ("size=i", "sizes=i@");
 945
 946 with command line "-size 10 -sizes 24 -sizes 48" will perform the
 947 equivalent of the assignments
 948
 949   $opt_size = 10;
 950   @opt_sizes = (24, 48);
 951
 952 A lone dash B<-> is considered an option, the corresponding Perl
 953 identifier is $opt_ .
 954
 955 The linkage specifier can be a reference to a scalar, a reference to
 956 an array, a reference to a hash or a reference to a subroutine.
 957
 958 If a REF SCALAR is supplied, the new value is stored in the referenced
 959 variable. If the option occurs more than once, the previous value is
 960 overwritten.
 961
 962 If a REF ARRAY is supplied, the new value is appended (pushed) to the
 963 referenced array.
 964
 965 If a REF HASH is supplied, the option value should look like "key" or
 966 "key=value" (if the "=value" is omitted then a value of 1 is implied).
 967 In this case, the element of the referenced hash with the key "key"
 968 is assigned "value".
 969
 970 If a REF CODE is supplied, the referenced subroutine is called with
 971 two arguments: the option name and the option value.
 972 The option name is always the true name, not an abbreviation or alias.
 973
 974 =head2 Aliases and abbreviations
 975
 976 The option name may actually be a list of option names, separated by
 977 "|"s, e.g. "foo|bar|blech=s". In this example, "foo" is the true name
 978 of this option. If no linkage is specified, options "foo", "bar" and
 979 "blech" all will set $opt_foo. For convenience, the single character
 980 "?" is allowed as an alias, e.g. "help|?".
 981
 982 Option names may be abbreviated to uniqueness, depending on
 983 configuration option B<auto_abbrev>.
 984
 985 =head2 Non-option call-back routine
 986
 987 A special option specifier, E<lt>E<gt>, can be used to designate a subroutine
 988 to handle non-option arguments. GetOptions will immediately call this
 989 subroutine for every non-option it encounters in the options list.
 990 This subroutine gets the name of the non-option passed.
 991 This feature requires configuration option B<permute>, see section
 992 CONFIGURATION OPTIONS.
 993
 994 See also the examples.
 995
 996 =head2 Option starters
 997
 998 On the command line, options can start with B<-> (traditional), B<-->
 999 (POSIX) and B<+> (GNU, now being phased out). The latter is not
1000 allowed if the environment variable B<POSIXLY_CORRECT> has been
1001 defined.
1002
1003 Options that start with "--" may have an argument appended, separated
1004 with an "=", e.g. "--foo=bar".
1005
1006 =head2 Return values and Errors
1007
1008 Configuration errors and errors in the option definitions are
1009 signalled using C<die()> and will terminate the calling
1010 program unless the call to C<Getopt::Long::GetOptions()> was embedded
1011 in C<eval { ... }> or C<die()> was trapped using C<$SIG{__DIE__}>.
1012
1013 A return value of 1 (true) indicates success.
1014
1015 A return status of 0 (false) indicates that the function detected one
1016 or more errors during option parsing. These errors are signalled using
1017 C<warn()> and can be trapped with C<$SIG{__WARN__}>.
1018
1019 Errors that can't happen are signalled using C<Carp::croak()>.
1020
1021 =head1 COMPATIBILITY
1022
1023 Getopt::Long::GetOptions() is the successor of
1024 B<newgetopt.pl> that came with Perl 4. It is fully upward compatible.
1025 In fact, the Perl 5 version of newgetopt.pl is just a wrapper around
1026 the module.
1027
1028 If an "@" sign is appended to the argument specifier, the option is
1029 treated as an array. Value(s) are not set, but pushed into array
1030 @opt_name. If explicit linkage is supplied, this must be a reference
1031 to an ARRAY.
1032
1033 If an "%" sign is appended to the argument specifier, the option is
1034 treated as a hash. Value(s) of the form "name=value" are set by
1035 setting the element of the hash %opt_name with key "name" to "value"
1036 (if the "=value" portion is omitted it defaults to 1). If explicit
1037 linkage is supplied, this must be a reference to a HASH.
1038
1039 If configuration option B<getopt_compat> is set (see section
1040 CONFIGURATION OPTIONS), options that start with "+" or "-" may also
1041 include their arguments, e.g. "+foo=bar". This is for compatiblity
1042 with older implementations of the GNU "getopt" routine.
1043
1044 If the first argument to GetOptions is a string consisting of only
1045 non-alphanumeric characters, it is taken to specify the option starter
1046 characters. Everything starting with one of these characters from the
1047 starter will be considered an option. B<Using a starter argument is
1048 strongly deprecated.>
1049
1050 For convenience, option specifiers may have a leading B<-> or B<-->,
1051 so it is possible to write:
1052
1053    GetOptions qw(-foo=s --bar=i --ar=s);
1054
1055 =head1 EXAMPLES
1056
1057 If the option specifier is "one:i" (i.e. takes an optional integer
1058 argument), then the following situations are handled:
1059
1060    -one -two            -> $opt_one = '', -two is next option
1061    -one -2              -> $opt_one = -2
1062
1063 Also, assume specifiers "foo=s" and "bar:s" :
1064
1065    -bar -xxx            -> $opt_bar = '', '-xxx' is next option
1066    -foo -bar            -> $opt_foo = '-bar'
1067    -foo --              -> $opt_foo = '--'
1068
1069 In GNU or POSIX format, option names and values can be combined:
1070
1071    +foo=blech           -> $opt_foo = 'blech'
1072    --bar=               -> $opt_bar = ''
1073    --bar=--             -> $opt_bar = '--'
1074
1075 Example of using variable references:
1076
1077    $ret = GetOptions ('foo=s', \$foo, 'bar=i', 'ar=s', \@ar);
1078
1079 With command line options "-foo blech -bar 24 -ar xx -ar yy"
1080 this will result in:
1081
1082    $foo = 'blech'
1083    $opt_bar = 24
1084    @ar = ('xx','yy')
1085
1086 Example of using the E<lt>E<gt> option specifier:
1087
1088    @ARGV = qw(-foo 1 bar -foo 2 blech);
1089    GetOptions("foo=i", \$myfoo, "<>", \&mysub);
1090
1091 Results:
1092
1093    mysub("bar") will be called (with $myfoo being 1)
1094    mysub("blech") will be called (with $myfoo being 2)
1095
1096 Compare this with:
1097
1098    @ARGV = qw(-foo 1 bar -foo 2 blech);
1099    GetOptions("foo=i", \$myfoo);
1100
1101 This will leave the non-options in @ARGV:
1102
1103    $myfoo -> 2
1104    @ARGV -> qw(bar blech)
1105
1106 =head1 CONFIGURATION OPTIONS
1107
1108 B<GetOptions> can be configured by calling subroutine
1109 B<Getopt::Long::config>. This subroutine takes a list of quoted
1110 strings, each specifying a configuration option to be set, e.g.
1111 B<ignore_case>. Options can be reset by prefixing with B<no_>, e.g.
1112 B<no_ignore_case>. Case does not matter. Multiple calls to B<config>
1113 are possible.
1114
1115 Previous versions of Getopt::Long used variables for the purpose of
1116 configuring. Although manipulating these variables still work, it
1117 is strongly encouraged to use the new B<config> routine. Besides, it
1118 is much easier.
1119
1120 The following options are available:
1121
1122 =over 12
1123
1124 =item default
1125
1126 This option causes all configuration options to be reset to their
1127 default values.
1128
1129 =item auto_abbrev
1130
1131 Allow option names to be abbreviated to uniqueness.
1132 Default is set unless environment variable
1133 POSIXLY_CORRECT has been set, in which case B<auto_abbrev> is reset.
1134
1135 =item getopt_compat
1136
1137 Allow '+' to start options.
1138 Default is set unless environment variable
1139 POSIXLY_CORRECT has been set, in which case B<getopt_compat> is reset.
1140
1141 =item require_order
1142
1143 Whether non-options are allowed to be mixed with
1144 options.
1145 Default is set unless environment variable
1146 POSIXLY_CORRECT has been set, in which case b<require_order> is reset.
1147
1148 See also B<permute>, which is the opposite of B<require_order>.
1149
1150 =item permute
1151
1152 Whether non-options are allowed to be mixed with
1153 options.
1154 Default is set unless environment variable
1155 POSIXLY_CORRECT has been set, in which case B<permute> is reset.
1156 Note that B<permute> is the opposite of B<require_order>.
1157
1158 If B<permute> is set, this means that
1159
1160     -foo arg1 -bar arg2 arg3
1161
1162 is equivalent to
1163
1164     -foo -bar arg1 arg2 arg3
1165
1166 If a non-option call-back routine is specified, @ARGV will always be
1167 empty upon succesful return of GetOptions since all options have been
1168 processed, except when B<--> is used:
1169
1170     -foo arg1 -bar arg2 -- arg3
1171
1172 will call the call-back routine for arg1 and arg2, and terminate
1173 leaving arg2 in @ARGV.
1174
1175 If B<require_order> is set, options processing
1176 terminates when the first non-option is encountered.
1177
1178     -foo arg1 -bar arg2 arg3
1179
1180 is equivalent to
1181
1182     -foo -- arg1 -bar arg2 arg3
1183
1184 =item bundling (default: reset)
1185
1186 Setting this variable to a non-zero value will allow single-character
1187 options to be bundled. To distinguish bundles from long option names,
1188 long options must be introduced with B<--> and single-character
1189 options (and bundles) with B<->. For example,
1190
1191     ps -vax --vax
1192
1193 would be equivalent to
1194
1195     ps -v -a -x --vax
1196
1197 provided "vax", "v", "a" and "x" have been defined to be valid
1198 options.
1199
1200 Bundled options can also include a value in the bundle; for strings
1201 this value is the rest of the bundle, but integer and floating values
1202 may be combined in the bundle, e.g.
1203
1204     scale -h24w80
1205
1206 is equivalent to
1207
1208     scale -h 24 -w 80
1209
1210 Note: resetting B<bundling> also resets B<bundling_override>.
1211
1212 =item bundling_override (default: reset)
1213
1214 If B<bundling_override> is set, bundling is enabled as with
1215 B<bundling> but now long option names override option bundles. In the
1216 above example, B<-vax> would be interpreted as the option "vax", not
1217 the bundle "v", "a", "x".
1218
1219 Note: resetting B<bundling_override> also resets B<bundling>.
1220
1221 B<Note:> Using option bundling can easily lead to unexpected results,
1222 especially when mixing long options and bundles. Caveat emptor.
1223
1224 =item ignore_case  (default: set)
1225
1226 If set, case is ignored when matching options.
1227
1228 Note: resetting B<ignore_case> also resets B<ignore_case_always>.
1229
1230 =item ignore_case_always (default: reset)
1231
1232 When bundling is in effect, case is ignored on single-character
1233 options also.
1234
1235 Note: resetting B<ignore_case_always> also resets B<ignore_case>.
1236
1237 =item pass_through (default: reset)
1238
1239 Unknown options are passed through in @ARGV instead of being flagged
1240 as errors. This makes it possible to write wrapper scripts that
1241 process only part of the user supplied options, and passes the
1242 remaining options to some other program.
1243
1244 This can be very confusing, especially when B<permute> is also set.
1245
1246 =item prefix
1247
1248 The string that starts options. See also B<prefix_pattern>.
1249
1250 =item prefix_pattern
1251
1252 A Perl pattern that identifies the strings that introduce options.
1253 Default is C<(--|-|\+)> unless environment variable
1254 POSIXLY_CORRECT has been set, in which case it is C<(--|-)>.
1255
1256 =item debug (default: reset)
1257
1258 Enable copious debugging output.
1259
1260 =back
1261
1262 =head1 OTHER USEFUL VARIABLES
1263
1264 =over 12
1265
1266 =item $Getopt::Long::VERSION
1267
1268 The version number of this Getopt::Long implementation in the format
1269 C<major>.C<minor>. This can be used to have Exporter check the
1270 version, e.g.
1271
1272     use Getopt::Long 3.00;
1273
1274 You can inspect $Getopt::Long::major_version and
1275 $Getopt::Long::minor_version for the individual components.
1276
1277 =item $Getopt::Long::error
1278
1279 Internal error flag. May be incremented from a call-back routine to
1280 cause options parsing to fail.
1281
1282 =back
1283
1284 =head1 AUTHOR
1285
1286 Johan Vromans E<lt>jvromans@squirrel.nlE<gt>
1287
1288 =head1 COPYRIGHT AND DISCLAIMER
1289
1290 This program is Copyright 1990,1998 by Johan Vromans.
1291 This program is free software; you can redistribute it and/or
1292 modify it under the terms of the GNU General Public License
1293 as published by the Free Software Foundation; either version 2
1294 of the License, or (at your option) any later version.
1295
1296 This program is distributed in the hope that it will be useful,
1297 but WITHOUT ANY WARRANTY; without even the implied warranty of
1298 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
1299 GNU General Public License for more details.
1300
1301 If you do not have a copy of the GNU General Public License write to
1302 the Free Software Foundation, Inc., 675 Mass Ave, Cambridge,
1303 MA 02139, USA.
1304
1305 =cut