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.13 1997-12-25 16:20:17+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: Thu Dec 25 16:18:08 1997
  10 # Update Count    : 647
  11 # Status          : Released
  12
  13 ################ Copyright ################
  14
  15 # This program is Copyright 1990,1997 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.003;
  36     use Exporter ();
  37     use vars   qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
  38     $VERSION   = sprintf("%d.%02d", q$Revision: 2.13 $ =~ /(\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.13 $ ',
  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 = $2 if $opt =~ /^$genprefix+(.*)$/;
 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_?(.*)$/ ) {
 424             $action = 0;
 425             $try = $1;
 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 eq 'debug' ) {
 458             $debug = $action;
 459         }
 460         else {
 461             &$croak ("Getopt::Long: unknown config parameter \"$opt\"")
 462         }
 463     }
 464 }
 465
 466 # To prevent Carp from being loaded unnecessarily.
 467 $croak = sub {
 468     require 'Carp.pm';
 469     $Carp::CarpLevel = 1;
 470     Carp::croak(@_);
 471 };
 472
 473 ################ Private Subroutines ################
 474
 475 $find_option = sub {
 476
 477     print STDERR ("=> find \"$opt\", genprefix=\"$genprefix\"\n") if $debug;
 478
 479     return 0 unless $opt =~ /^$genprefix(.*)$/;
 480
 481     $opt = $2;
 482     my ($starter) = $1;
 483
 484     print STDERR ("=> split \"$starter\"+\"$opt\"\n") if $debug;
 485
 486     my $optarg = undef; # value supplied with --opt=value
 487     my $rest = undef;   # remainder from unbundling
 488
 489     # If it is a long option, it may include the value.
 490     if (($starter eq "--" || ($getopt_compat && !$bundling))
 491         && $opt =~ /^([^=]+)=(.*)$/ ) {
 492         $opt = $1;
 493         $optarg = $2;
 494         print STDERR ("=> option \"", $opt,
 495                       "\", optarg = \"$optarg\"\n") if $debug;
 496     }
 497
 498     #### Look it up ###
 499
 500     my $tryopt = $opt;          # option to try
 501     my $optbl = \%opctl;        # table to look it up (long names)
 502     my $type;
 503
 504     if ( $bundling && $starter eq '-' ) {
 505         # Unbundle single letter option.
 506         $rest = substr ($tryopt, 1);
 507         $tryopt = substr ($tryopt, 0, 1);
 508         $tryopt = lc ($tryopt) if $ignorecase > 1;
 509         print STDERR ("=> $starter$tryopt unbundled from ",
 510                       "$starter$tryopt$rest\n") if $debug;
 511         $rest = undef unless $rest ne '';
 512         $optbl = \%bopctl;      # look it up in the short names table
 513
 514         # If bundling == 2, long options can override bundles.
 515         if ( $bundling == 2 and
 516              defined ($type = $opctl{$tryopt.$rest}) ) {
 517             print STDERR ("=> $starter$tryopt rebundled to ",
 518                           "$starter$tryopt$rest\n") if $debug;
 519             $tryopt .= $rest;
 520             undef $rest;
 521         }
 522     }
 523
 524     # Try auto-abbreviation.
 525     elsif ( $autoabbrev ) {
 526         # Downcase if allowed.
 527         $tryopt = $opt = lc ($opt) if $ignorecase;
 528         # Turn option name into pattern.
 529         my $pat = quotemeta ($opt);
 530         # Look up in option names.
 531         my @hits = grep (/^$pat/, @opctl);
 532         print STDERR ("=> ", scalar(@hits), " hits (@hits) with \"$pat\" ",
 533                       "out of ", scalar(@opctl), "\n") if $debug;
 534
 535         # Check for ambiguous results.
 536         unless ( (@hits <= 1) || (grep ($_ eq $opt, @hits) == 1) ) {
 537             # See if all matches are for the same option.
 538             my %hit;
 539             foreach ( @hits ) {
 540                 $_ = $aliases{$_} if defined $aliases{$_};
 541                 $hit{$_} = 1;
 542             }
 543             # Now see if it really is ambiguous.
 544             unless ( keys(%hit) == 1 ) {
 545                 return 0 if $passthrough;
 546                 warn ("Option ", $opt, " is ambiguous (",
 547                       join(", ", @hits), ")\n");
 548                 $error++;
 549                 undef $opt;
 550                 return 1;
 551             }
 552             @hits = keys(%hit);
 553         }
 554
 555         # Complete the option name, if appropriate.
 556         if ( @hits == 1 && $hits[0] ne $opt ) {
 557             $tryopt = $hits[0];
 558             $tryopt = lc ($tryopt) if $ignorecase;
 559             print STDERR ("=> option \"$opt\" -> \"$tryopt\"\n")
 560                 if $debug;
 561         }
 562     }
 563
 564     # Map to all lowercase if ignoring case.
 565     elsif ( $ignorecase ) {
 566         $tryopt = lc ($opt);
 567     }
 568
 569     # Check validity by fetching the info.
 570     $type = $optbl->{$tryopt} unless defined $type;
 571     unless  ( defined $type ) {
 572         return 0 if $passthrough;
 573         warn ("Unknown option: ", $opt, "\n");
 574         $error++;
 575         return 1;
 576     }
 577     # Apparently valid.
 578     $opt = $tryopt;
 579     print STDERR ("=> found \"$type\" for ", $opt, "\n") if $debug;
 580
 581     #### Determine argument status ####
 582
 583     # If it is an option w/o argument, we're almost finished with it.
 584     if ( $type eq '' || $type eq '!' ) {
 585         if ( defined $optarg ) {
 586             return 0 if $passthrough;
 587             warn ("Option ", $opt, " does not take an argument\n");
 588             $error++;
 589             undef $opt;
 590         }
 591         elsif ( $type eq '' ) {
 592             $arg = 1;           # supply explicit value
 593         }
 594         else {
 595             substr ($opt, 0, 2) = ''; # strip NO prefix
 596             $arg = 0;           # supply explicit value
 597         }
 598         unshift (@ARGV, $starter.$rest) if defined $rest;
 599         return 1;
 600     }
 601
 602     # Get mandatory status and type info.
 603     my $mand;
 604     ($mand, $type, $array, $hash) = $type =~ /^(.)(.)(@?)(%?)$/;
 605
 606     # Check if there is an option argument available.
 607     if ( defined $optarg ? ($optarg eq '')
 608          : !(defined $rest || @ARGV > 0) ) {
 609         # Complain if this option needs an argument.
 610         if ( $mand eq "=" ) {
 611             return 0 if $passthrough;
 612             warn ("Option ", $opt, " requires an argument\n");
 613             $error++;
 614             undef $opt;
 615         }
 616         if ( $mand eq ":" ) {
 617             $arg = $type eq "s" ? '' : 0;
 618         }
 619         return 1;
 620     }
 621
 622     # Get (possibly optional) argument.
 623     $arg = (defined $rest ? $rest
 624             : (defined $optarg ? $optarg : shift (@ARGV)));
 625
 626     # Get key if this is a "name=value" pair for a hash option.
 627     $key = undef;
 628     if ($hash && defined $arg) {
 629         ($key, $arg) = ($arg =~ /^(.*)=(.*)$/o) ? ($1, $2) : ($arg, 1);
 630     }
 631
 632     #### Check if the argument is valid for this option ####
 633
 634     if ( $type eq "s" ) {       # string
 635         # A mandatory string takes anything.
 636         return 1 if $mand eq "=";
 637
 638         # An optional string takes almost anything.
 639         return 1 if defined $optarg || defined $rest;
 640         return 1 if $arg eq "-"; # ??
 641
 642         # Check for option or option list terminator.
 643         if ($arg eq $argend ||
 644             $arg =~ /^$genprefix.+/) {
 645             # Push back.
 646             unshift (@ARGV, $arg);
 647             # Supply empty value.
 648             $arg = '';
 649         }
 650     }
 651
 652     elsif ( $type eq "n" || $type eq "i" ) { # numeric/integer
 653         if ( $bundling && defined $rest && $rest =~ /^(-?[0-9]+)(.*)$/ ) {
 654             $arg = $1;
 655             $rest = $2;
 656             unshift (@ARGV, $starter.$rest) if defined $rest && $rest ne '';
 657         }
 658         elsif ( $arg !~ /^-?[0-9]+$/ ) {
 659             if ( defined $optarg || $mand eq "=" ) {
 660                 if ( $passthrough ) {
 661                     unshift (@ARGV, defined $rest ? $starter.$rest : $arg)
 662                       unless defined $optarg;
 663                     return 0;
 664                 }
 665                 warn ("Value \"", $arg, "\" invalid for option ",
 666                       $opt, " (number expected)\n");
 667                 $error++;
 668                 undef $opt;
 669                 # Push back.
 670                 unshift (@ARGV, $starter.$rest) if defined $rest;
 671             }
 672             else {
 673                 # Push back.
 674                 unshift (@ARGV, defined $rest ? $starter.$rest : $arg);
 675                 # Supply default value.
 676                 $arg = 0;
 677             }
 678         }
 679     }
 680
 681     elsif ( $type eq "f" ) { # real number, int is also ok
 682         # We require at least one digit before a point or 'e',
 683         # and at least one digit following the point and 'e'.
 684         # [-]NN[.NN][eNN]
 685         if ( $bundling && defined $rest &&
 686              $rest =~ /^(-?[0-9]+(\.[0-9]+)?([eE]-?[0-9]+)?)(.*)$/ ) {
 687             $arg = $1;
 688             $rest = $4;
 689             unshift (@ARGV, $starter.$rest) if defined $rest && $rest ne '';
 690         }
 691         elsif ( $arg !~ /^-?[0-9.]+(\.[0-9]+)?([eE]-?[0-9]+)?$/ ) {
 692             if ( defined $optarg || $mand eq "=" ) {
 693                 if ( $passthrough ) {
 694                     unshift (@ARGV, defined $rest ? $starter.$rest : $arg)
 695                       unless defined $optarg;
 696                     return 0;
 697                 }
 698                 warn ("Value \"", $arg, "\" invalid for option ",
 699                       $opt, " (real number expected)\n");
 700                 $error++;
 701                 undef $opt;
 702                 # Push back.
 703                 unshift (@ARGV, $starter.$rest) if defined $rest;
 704             }
 705             else {
 706                 # Push back.
 707                 unshift (@ARGV, defined $rest ? $starter.$rest : $arg);
 708                 # Supply default value.
 709                 $arg = 0.0;
 710             }
 711         }
 712     }
 713     else {
 714         &$croak ("GetOpt::Long internal error (Can't happen)\n");
 715     }
 716     return 1;
 717 };
 718
 719 $config_defaults = sub {
 720     # Handle POSIX compliancy.
 721     if ( defined $ENV{"POSIXLY_CORRECT"} ) {
 722         $gen_prefix = "(--|-)";
 723         $autoabbrev = 0;                # no automatic abbrev of options
 724         $bundling = 0;                  # no bundling of single letter switches
 725         $getopt_compat = 0;             # disallow '+' to start options
 726         $order = $REQUIRE_ORDER;
 727     }
 728     else {
 729         $gen_prefix = "(--|-|\\+)";
 730         $autoabbrev = 1;                # automatic abbrev of options
 731         $bundling = 0;                  # bundling off by default
 732         $getopt_compat = 1;             # allow '+' to start options
 733         $order = $PERMUTE;
 734     }
 735     # Other configurable settings.
 736     $debug = 0;                 # for debugging
 737     $error = 0;                 # error tally
 738     $ignorecase = 1;            # ignore case when matching options
 739     $passthrough = 0;           # leave unrecognized options alone
 740 };
 741
 742 ################ Initialization ################
 743
 744 # Values for $order. See GNU getopt.c for details.
 745 ($REQUIRE_ORDER, $PERMUTE, $RETURN_IN_ORDER) = (0..2);
 746 # Version major/minor numbers.
 747 ($major_version, $minor_version) = $VERSION =~ /^(\d+)\.(\d+)/;
 748
 749 # Set defaults.
 750 &$config_defaults ();
 751
 752 ################ Package return ################
 753
 754 1;
 755
 756 __END__
 757
 758 =head1 NAME
 759
 760 GetOptions - extended processing of command line options
 761
 762 =head1 SYNOPSIS
 763
 764   use Getopt::Long;
 765   $result = GetOptions (...option-descriptions...);
 766
 767 =head1 DESCRIPTION
 768
 769 The Getopt::Long module implements an extended getopt function called
 770 GetOptions(). This function adheres to the POSIX syntax for command
 771 line options, with GNU extensions. In general, this means that options
 772 have long names instead of single letters, and are introduced with a
 773 double dash "--". Support for bundling of command line options, as was
 774 the case with the more traditional single-letter approach, is provided
 775 but not enabled by default. For example, the UNIX "ps" command can be
 776 given the command line "option"
 777
 778   -vax
 779
 780 which means the combination of B<-v>, B<-a> and B<-x>. With the new
 781 syntax B<--vax> would be a single option, probably indicating a
 782 computer architecture.
 783
 784 Command line options can be used to set values. These values can be
 785 specified in one of two ways:
 786
 787   --size 24
 788   --size=24
 789
 790 GetOptions is called with a list of option-descriptions, each of which
 791 consists of two elements: the option specifier and the option linkage.
 792 The option specifier defines the name of the option and, optionally,
 793 the value it can take. The option linkage is usually a reference to a
 794 variable that will be set when the option is used. For example, the
 795 following call to GetOptions:
 796
 797   GetOptions("size=i" => \$offset);
 798
 799 will accept a command line option "size" that must have an integer
 800 value. With a command line of "--size 24" this will cause the variable
 801 $offset to get the value 24.
 802
 803 Alternatively, the first argument to GetOptions may be a reference to
 804 a HASH describing the linkage for the options, or an object whose
 805 class is based on a HASH. The following call is equivalent to the
 806 example above:
 807
 808   %optctl = ("size" => \$offset);
 809   GetOptions(\%optctl, "size=i");
 810
 811 Linkage may be specified using either of the above methods, or both.
 812 Linkage specified in the argument list takes precedence over the
 813 linkage specified in the HASH.
 814
 815 The command line options are taken from array @ARGV. Upon completion
 816 of GetOptions, @ARGV will contain the rest (i.e. the non-options) of
 817 the command line.
 818
 819 Each option specifier designates the name of the option, optionally
 820 followed by an argument specifier.
 821
 822 Options that do not take arguments will have no argument specifier.
 823 The option variable will be set to 1 if the option is used.
 824
 825 For the other options, the values for argument specifiers are:
 826
 827 =over 8
 828
 829 =item !
 830
 831 Option does not take an argument and may be negated, i.e. prefixed by
 832 "no". E.g. "foo!" will allow B<--foo> (with value 1) and B<-nofoo>
 833 (with value 0).
 834 The option variable will be set to 1, or 0 if negated.
 835
 836 =item =s
 837
 838 Option takes a mandatory string argument.
 839 This string will be assigned to the option variable.
 840 Note that even if the string argument starts with B<-> or B<-->, it
 841 will not be considered an option on itself.
 842
 843 =item :s
 844
 845 Option takes an optional string argument.
 846 This string will be assigned to the option variable.
 847 If omitted, it will be assigned "" (an empty string).
 848 If the string argument starts with B<-> or B<-->, it
 849 will be considered an option on itself.
 850
 851 =item =i
 852
 853 Option takes a mandatory integer argument.
 854 This value will be assigned to the option variable.
 855 Note that the value may start with B<-> to indicate a negative
 856 value.
 857
 858 =item :i
 859
 860 Option takes an optional integer argument.
 861 This value will be assigned to the option variable.
 862 If omitted, the value 0 will be assigned.
 863 Note that the value may start with B<-> to indicate a negative
 864 value.
 865
 866 =item =f
 867
 868 Option takes a mandatory real number 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 :f
 874
 875 Option takes an optional real number argument.
 876 This value will be assigned to the option variable.
 877 If omitted, the value 0 will be assigned.
 878
 879 =back
 880
 881 A lone dash B<-> is considered an option, the corresponding option
 882 name is the empty string.
 883
 884 A double dash on itself B<--> signals end of the options list.
 885
 886 =head2 Linkage specification
 887
 888 The linkage specifier is optional. If no linkage is explicitly
 889 specified but a ref HASH is passed, GetOptions will place the value in
 890 the HASH. For example:
 891
 892   %optctl = ();
 893   GetOptions (\%optctl, "size=i");
 894
 895 will perform the equivalent of the assignment
 896
 897   $optctl{"size"} = 24;
 898
 899 For array options, a reference to an array is used, e.g.:
 900
 901   %optctl = ();
 902   GetOptions (\%optctl, "sizes=i@");
 903
 904 with command line "-sizes 24 -sizes 48" will perform the equivalent of
 905 the assignment
 906
 907   $optctl{"sizes"} = [24, 48];
 908
 909 For hash options (an option whose argument looks like "name=value"),
 910 a reference to a hash is used, e.g.:
 911
 912   %optctl = ();
 913   GetOptions (\%optctl, "define=s%");
 914
 915 with command line "--define foo=hello --define bar=world" will perform the
 916 equivalent of the assignment
 917
 918   $optctl{"define"} = {foo=>'hello', bar=>'world')
 919
 920 If no linkage is explicitly specified and no ref HASH is passed,
 921 GetOptions will put the value in a global variable named after the
 922 option, prefixed by "opt_". To yield a usable Perl variable,
 923 characters that are not part of the syntax for variables are
 924 translated to underscores. For example, "--fpp-struct-return" will set
 925 the variable $opt_fpp_struct_return. Note that this variable resides
 926 in the namespace of the calling program, not necessarily B<main>.
 927 For example:
 928
 929   GetOptions ("size=i", "sizes=i@");
 930
 931 with command line "-size 10 -sizes 24 -sizes 48" will perform the
 932 equivalent of the assignments
 933
 934   $opt_size = 10;
 935   @opt_sizes = (24, 48);
 936
 937 A lone dash B<-> is considered an option, the corresponding Perl
 938 identifier is $opt_ .
 939
 940 The linkage specifier can be a reference to a scalar, a reference to
 941 an array, a reference to a hash or a reference to a subroutine.
 942
 943 If a REF SCALAR is supplied, the new value is stored in the referenced
 944 variable. If the option occurs more than once, the previous value is
 945 overwritten.
 946
 947 If a REF ARRAY is supplied, the new value is appended (pushed) to the
 948 referenced array.
 949
 950 If a REF HASH is supplied, the option value should look like "key" or
 951 "key=value" (if the "=value" is omitted then a value of 1 is implied).
 952 In this case, the element of the referenced hash with the key "key"
 953 is assigned "value".
 954
 955 If a REF CODE is supplied, the referenced subroutine is called with
 956 two arguments: the option name and the option value.
 957 The option name is always the true name, not an abbreviation or alias.
 958
 959 =head2 Aliases and abbreviations
 960
 961 The option name may actually be a list of option names, separated by
 962 "|"s, e.g. "foo|bar|blech=s". In this example, "foo" is the true name
 963 of this option. If no linkage is specified, options "foo", "bar" and
 964 "blech" all will set $opt_foo. For convenience, the single character
 965 "?" is allowed as an alias, e.g. "help|?".
 966
 967 Option names may be abbreviated to uniqueness, depending on
 968 configuration option B<auto_abbrev>.
 969
 970 =head2 Non-option call-back routine
 971
 972 A special option specifier, E<lt>E<gt>, can be used to designate a subroutine
 973 to handle non-option arguments. GetOptions will immediately call this
 974 subroutine for every non-option it encounters in the options list.
 975 This subroutine gets the name of the non-option passed.
 976 This feature requires configuration option B<permute>, see section
 977 CONFIGURATION OPTIONS.
 978
 979 See also the examples.
 980
 981 =head2 Option starters
 982
 983 On the command line, options can start with B<-> (traditional), B<-->
 984 (POSIX) and B<+> (GNU, now being phased out). The latter is not
 985 allowed if the environment variable B<POSIXLY_CORRECT> has been
 986 defined.
 987
 988 Options that start with "--" may have an argument appended, separated
 989 with an "=", e.g. "--foo=bar".
 990
 991 =head2 Return values and Errors
 992
 993 Configuration errors and errors in the option definitions are
 994 signalled using C<die()> and will terminate the calling
 995 program unless the call to C<Getopt::Long::GetOptions()> was embedded
 996 in C<eval { ... }> or C<die()> was trapped using C<$SIG{__DIE__}>.
 997
 998 A return value of 1 (true) indicates success.
 999
1000 A return status of 0 (false) indicates that the function detected one
1001 or more errors during option parsing. These errors are signalled using
1002 C<warn()> and can be trapped with C<$SIG{__WARN__}>.
1003
1004 Errors that can't happen are signalled using C<Carp::croak()>.
1005
1006 =head1 COMPATIBILITY
1007
1008 Getopt::Long::GetOptions() is the successor of
1009 B<newgetopt.pl> that came with Perl 4. It is fully upward compatible.
1010 In fact, the Perl 5 version of newgetopt.pl is just a wrapper around
1011 the module.
1012
1013 If an "@" sign is appended to the argument specifier, the option is
1014 treated as an array. Value(s) are not set, but pushed into array
1015 @opt_name. If explicit linkage is supplied, this must be a reference
1016 to an ARRAY.
1017
1018 If an "%" sign is appended to the argument specifier, the option is
1019 treated as a hash. Value(s) of the form "name=value" are set by
1020 setting the element of the hash %opt_name with key "name" to "value"
1021 (if the "=value" portion is omitted it defaults to 1). If explicit
1022 linkage is supplied, this must be a reference to a HASH.
1023
1024 If configuration option B<getopt_compat> is set (see section
1025 CONFIGURATION OPTIONS), options that start with "+" or "-" may also
1026 include their arguments, e.g. "+foo=bar". This is for compatiblity
1027 with older implementations of the GNU "getopt" routine.
1028
1029 If the first argument to GetOptions is a string consisting of only
1030 non-alphanumeric characters, it is taken to specify the option starter
1031 characters. Everything starting with one of these characters from the
1032 starter will be considered an option. B<Using a starter argument is
1033 strongly deprecated.>
1034
1035 For convenience, option specifiers may have a leading B<-> or B<-->,
1036 so it is possible to write:
1037
1038    GetOptions qw(-foo=s --bar=i --ar=s);
1039
1040 =head1 EXAMPLES
1041
1042 If the option specifier is "one:i" (i.e. takes an optional integer
1043 argument), then the following situations are handled:
1044
1045    -one -two            -> $opt_one = '', -two is next option
1046    -one -2              -> $opt_one = -2
1047
1048 Also, assume specifiers "foo=s" and "bar:s" :
1049
1050    -bar -xxx            -> $opt_bar = '', '-xxx' is next option
1051    -foo -bar            -> $opt_foo = '-bar'
1052    -foo --              -> $opt_foo = '--'
1053
1054 In GNU or POSIX format, option names and values can be combined:
1055
1056    +foo=blech           -> $opt_foo = 'blech'
1057    --bar=               -> $opt_bar = ''
1058    --bar=--             -> $opt_bar = '--'
1059
1060 Example of using variable references:
1061
1062    $ret = GetOptions ('foo=s', \$foo, 'bar=i', 'ar=s', \@ar);
1063
1064 With command line options "-foo blech -bar 24 -ar xx -ar yy"
1065 this will result in:
1066
1067    $foo = 'blech'
1068    $opt_bar = 24
1069    @ar = ('xx','yy')
1070
1071 Example of using the E<lt>E<gt> option specifier:
1072
1073    @ARGV = qw(-foo 1 bar -foo 2 blech);
1074    GetOptions("foo=i", \$myfoo, "<>", \&mysub);
1075
1076 Results:
1077
1078    mysub("bar") will be called (with $myfoo being 1)
1079    mysub("blech") will be called (with $myfoo being 2)
1080
1081 Compare this with:
1082
1083    @ARGV = qw(-foo 1 bar -foo 2 blech);
1084    GetOptions("foo=i", \$myfoo);
1085
1086 This will leave the non-options in @ARGV:
1087
1088    $myfoo -> 2
1089    @ARGV -> qw(bar blech)
1090
1091 =head1 CONFIGURATION OPTIONS
1092
1093 B<GetOptions> can be configured by calling subroutine
1094 B<Getopt::Long::config>. This subroutine takes a list of quoted
1095 strings, each specifying a configuration option to be set, e.g.
1096 B<ignore_case>. Options can be reset by prefixing with B<no_>, e.g.
1097 B<no_ignore_case>. Case does not matter. Multiple calls to B<config>
1098 are possible.
1099
1100 Previous versions of Getopt::Long used variables for the purpose of
1101 configuring. Although manipulating these variables still work, it
1102 is strongly encouraged to use the new B<config> routine. Besides, it
1103 is much easier.
1104
1105 The following options are available:
1106
1107 =over 12
1108
1109 =item default
1110
1111 This option causes all configuration options to be reset to their
1112 default values.
1113
1114 =item auto_abbrev
1115
1116 Allow option names to be abbreviated to uniqueness.
1117 Default is set unless environment variable
1118 POSIXLY_CORRECT has been set, in which case B<auto_abbrev> is reset.
1119
1120 =item getopt_compat
1121
1122 Allow '+' to start options.
1123 Default is set unless environment variable
1124 POSIXLY_CORRECT has been set, in which case B<getopt_compat> is reset.
1125
1126 =item require_order
1127
1128 Whether non-options are allowed to be mixed with
1129 options.
1130 Default is set unless environment variable
1131 POSIXLY_CORRECT has been set, in which case b<require_order> is reset.
1132
1133 See also B<permute>, which is the opposite of B<require_order>.
1134
1135 =item permute
1136
1137 Whether non-options are allowed to be mixed with
1138 options.
1139 Default is set unless environment variable
1140 POSIXLY_CORRECT has been set, in which case B<permute> is reset.
1141 Note that B<permute> is the opposite of B<require_order>.
1142
1143 If B<permute> is set, this means that
1144
1145     -foo arg1 -bar arg2 arg3
1146
1147 is equivalent to
1148
1149     -foo -bar arg1 arg2 arg3
1150
1151 If a non-option call-back routine is specified, @ARGV will always be
1152 empty upon succesful return of GetOptions since all options have been
1153 processed, except when B<--> is used:
1154
1155     -foo arg1 -bar arg2 -- arg3
1156
1157 will call the call-back routine for arg1 and arg2, and terminate
1158 leaving arg2 in @ARGV.
1159
1160 If B<require_order> is set, options processing
1161 terminates when the first non-option is encountered.
1162
1163     -foo arg1 -bar arg2 arg3
1164
1165 is equivalent to
1166
1167     -foo -- arg1 -bar arg2 arg3
1168
1169 =item bundling (default: reset)
1170
1171 Setting this variable to a non-zero value will allow single-character
1172 options to be bundled. To distinguish bundles from long option names,
1173 long options must be introduced with B<--> and single-character
1174 options (and bundles) with B<->. For example,
1175
1176     ps -vax --vax
1177
1178 would be equivalent to
1179
1180     ps -v -a -x --vax
1181
1182 provided "vax", "v", "a" and "x" have been defined to be valid
1183 options.
1184
1185 Bundled options can also include a value in the bundle; for strings
1186 this value is the rest of the bundle, but integer and floating values
1187 may be combined in the bundle, e.g.
1188
1189     scale -h24w80
1190
1191 is equivalent to
1192
1193     scale -h 24 -w 80
1194
1195 Note: resetting B<bundling> also resets B<bundling_override>.
1196
1197 =item bundling_override (default: reset)
1198
1199 If B<bundling_override> is set, bundling is enabled as with
1200 B<bundling> but now long option names override option bundles. In the
1201 above example, B<-vax> would be interpreted as the option "vax", not
1202 the bundle "v", "a", "x".
1203
1204 Note: resetting B<bundling_override> also resets B<bundling>.
1205
1206 B<Note:> Using option bundling can easily lead to unexpected results,
1207 especially when mixing long options and bundles. Caveat emptor.
1208
1209 =item ignore_case  (default: set)
1210
1211 If set, case is ignored when matching options.
1212
1213 Note: resetting B<ignore_case> also resets B<ignore_case_always>.
1214
1215 =item ignore_case_always (default: reset)
1216
1217 When bundling is in effect, case is ignored on single-character
1218 options also.
1219
1220 Note: resetting B<ignore_case_always> also resets B<ignore_case>.
1221
1222 =item pass_through (default: reset)
1223
1224 Unknown options are passed through in @ARGV instead of being flagged
1225 as errors. This makes it possible to write wrapper scripts that
1226 process only part of the user supplied options, and passes the
1227 remaining options to some other program.
1228
1229 This can be very confusing, especially when B<permute> is also set.
1230
1231 =item debug (default: reset)
1232
1233 Enable copious debugging output.
1234
1235 =back
1236
1237 =head1 OTHER USEFUL VARIABLES
1238
1239 =over 12
1240
1241 =item $Getopt::Long::VERSION
1242
1243 The version number of this Getopt::Long implementation in the format
1244 C<major>.C<minor>. This can be used to have Exporter check the
1245 version, e.g.
1246
1247     use Getopt::Long 3.00;
1248
1249 You can inspect $Getopt::Long::major_version and
1250 $Getopt::Long::minor_version for the individual components.
1251
1252 =item $Getopt::Long::error
1253
1254 Internal error flag. May be incremented from a call-back routine to
1255 cause options parsing to fail.
1256
1257 =back
1258
1259 =head1 AUTHOR
1260
1261 Johan Vromans E<lt>jvromans@squirrel.nlE<gt>
1262
1263 =head1 COPYRIGHT AND DISCLAIMER
1264
1265 This program is Copyright 1990,1997 by Johan Vromans.
1266 This program is free software; you can redistribute it and/or
1267 modify it under the terms of the GNU General Public License
1268 as published by the Free Software Foundation; either version 2
1269 of the License, or (at your option) any later version.
1270
1271 This program is distributed in the hope that it will be useful,
1272 but WITHOUT ANY WARRANTY; without even the implied warranty of
1273 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
1274 GNU General Public License for more details.
1275
1276 If you do not have a copy of the GNU General Public License write to
1277 the Free Software Foundation, Inc., 675 Mass Ave, Cambridge,
1278 MA 02139, USA.
1279
1280 =cut