lib/Getopt/Long.pm

   1 package Getopt::Long;
   2 require 5.000;
   3 require Exporter;
   4
   5 @ISA = qw(Exporter);
   6 @EXPORT = qw(GetOptions);
   7
   8
   9 # newgetopt.pl -- new options parsing
  10
  11 # SCCS Status     : @(#)@ newgetopt.pl  1.14
  12 # Author          : Johan Vromans
  13 # Created On      : Tue Sep 11 15:00:12 1990
  14 # Last Modified By: Johan Vromans
  15 # Last Modified On: Sat Feb 12 18:24:02 1994
  16 # Update Count    : 138
  17 # Status          : Okay
  18
  19 ################ Introduction ################
  20 #
  21 # This package implements an extended getopt function. This function adheres
  22 # to the new syntax (long option names, no bundling).
  23 # It tries to implement the better functionality of traditional, GNU and
  24 # POSIX getopt functions.
  25 #
  26 # This program is Copyright 1990,1994 by Johan Vromans.
  27 # This program is free software; you can redistribute it and/or
  28 # modify it under the terms of the GNU General Public License
  29 # as published by the Free Software Foundation; either version 2
  30 # of the License, or (at your option) any later version.
  31 #
  32 # This program is distributed in the hope that it will be useful,
  33 # but WITHOUT ANY WARRANTY; without even the implied warranty of
  34 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  35 # GNU General Public License for more details.
  36 #
  37 # If you do not have a copy of the GNU General Public License write to
  38 # the Free Software Foundation, Inc., 675 Mass Ave, Cambridge,
  39 # MA 02139, USA.
  40
  41 ################ Description ################
  42 #
  43 # Usage:
  44 #
  45 #    require "newgetopt.pl";
  46 #    ...change configuration values, if needed...
  47 #    $result = &NGetOpt (...option-descriptions...);
  48 #
  49 # Each description should designate a valid perl identifier, optionally
  50 # followed by an argument specifier.
  51 #
  52 # Values for argument specifiers are:
  53 #
  54 #   <none>   option does not take an argument
  55 #   !        option does not take an argument and may be negated
  56 #   =s :s    option takes a mandatory (=) or optional (:) string argument
  57 #   =i :i    option takes a mandatory (=) or optional (:) integer argument
  58 #   =f :f    option takes a mandatory (=) or optional (:) real number argument
  59 #
  60 # If option "name" is set, it will cause the perl variable $opt_name to
  61 # be set to the specified value. The calling program can use this
  62 # variable to detect whether the option has been set. Options that do
  63 # not take an argument will be set to 1 (one).
  64 #
  65 # Options that take an optional argument will be defined, but set to ''
  66 # if no actual argument has been supplied.
  67 #
  68 # If an "@" sign is appended to the argument specifier, the option is
  69 # treated as an array. Value(s) are not set, but pushed into array
  70 # @opt_name.
  71 #
  72 # Options that do not take a value may have an "!" argument spacifier to
  73 # indicate that they may be negated. E.g. "foo!" will allow -foo (which
  74 # sets $opt_foo to 1) and -nofoo (which will set $opt_foo to 0).
  75 #
  76 # The option name may actually be a list of option names, separated by
  77 # '|'s, e.g. "foo|bar|blech=s". In this example, options 'bar' and
  78 # 'blech' will set $opt_foo instead.
  79 #
  80 # Option names may be abbreviated to uniqueness, depending on
  81 # configuration variable $autoabbrev.
  82 #
  83 # Dashes in option names are allowed (e.g. pcc-struct-return) and will
  84 # be translated to underscores in the corresponding perl variable (e.g.
  85 # $opt_pcc_struct_return).  Note that a lone dash "-" is considered an
  86 # option, corresponding perl identifier is $opt_ .
  87 #
  88 # A double dash "--" signals end of the options list.
  89 #
  90 # If the first option of the list consists of non-alphanumeric
  91 # characters only, it is interpreted as a generic option starter.
  92 # Everything starting with one of the characters from the starter will
  93 # be considered an option.
  94 #
  95 # The default values for the option starters are "-" (traditional), "--"
  96 # (POSIX) and "+" (GNU, being phased out).
  97 #
  98 # Options that start with "--" may have an argument appended, separated
  99 # with an "=", e.g. "--foo=bar".
 100 #
 101 # If configuration varaible $getopt_compat is set to a non-zero value,
 102 # options that start with "+" may also include their arguments,
 103 # e.g. "+foo=bar".
 104 #
 105 # A return status of 0 (false) indicates that the function detected
 106 # one or more errors.
 107 #
 108 ################ Some examples ################
 109 #
 110 # If option "one:i" (i.e. takes an optional integer argument), then
 111 # the following situations are handled:
 112 #
 113 #    -one -two          -> $opt_one = '', -two is next option
 114 #    -one -2            -> $opt_one = -2
 115 #
 116 # Also, assume "foo=s" and "bar:s" :
 117 #
 118 #    -bar -xxx          -> $opt_bar = '', '-xxx' is next option
 119 #    -foo -bar          -> $opt_foo = '-bar'
 120 #    -foo --            -> $opt_foo = '--'
 121 #
 122 # In GNU or POSIX format, option names and values can be combined:
 123 #
 124 #    +foo=blech         -> $opt_foo = 'blech'
 125 #    --bar=             -> $opt_bar = ''
 126 #    --bar=--           -> $opt_bar = '--'
 127 #
 128 ################ Configuration values ################
 129 #
 130 #   $autoabbrev      Allow option names to be abbreviated to uniqueness.
 131 #                    Default is 1 unless environment variable
 132 #                    POSIXLY_CORRECT has been set.
 133 #
 134 #   $getopt_compat   Allow '+' to start options.
 135 #                    Default is 1 unless environment variable
 136 #                    POSIXLY_CORRECT has been set.
 137 #
 138 #   $option_start    Regexp with option starters.
 139 #                    Default is (--|-) if environment variable
 140 #                    POSIXLY_CORRECT has been set, (--|-|\+) otherwise.
 141 #
 142 #   $order           Whether non-options are allowed to be mixed with
 143 #                    options.
 144 #                    Default is $REQUIRE_ORDER if environment variable
 145 #                    POSIXLY_CORRECT has been set, $PERMUTE otherwise.
 146 #
 147 #   $ignorecase      Ignore case when matching options. Default is 1.
 148 #
 149 #   $debug           Enable debugging output. Default is 0.
 150
 151 ################ History ################
 152 #
 153 # 12-Feb-1994           Johan Vromans
 154 #    Added "!" for negation.
 155 #    Released to the net.
 156 #
 157 # 26-Aug-1992           Johan Vromans
 158 #    More POSIX/GNU compliance.
 159 #    Lone dash and double-dash are now independent of the option prefix
 160 #      that is used.
 161 #    Make errors in NGetOpt parameters fatal.
 162 #    Allow options to be mixed with arguments.
 163 #      Check $ENV{"POSIXLY_CORRECT"} to suppress this.
 164 #    Allow --foo=bar and +foo=bar (but not -foo=bar).
 165 #    Allow options to be abbreviated to minimum needed for uniqueness.
 166 #      (Controlled by configuration variable $autoabbrev.)
 167 #    Allow alias names for options (e.g. "foo|bar=s").
 168 #    Allow "-" in option names (e.g. --pcc-struct-return). Dashes are
 169 #      translated to "_" to form valid perl identifiers
 170 #      (e.g. $opt_pcc_struct_return).
 171 #
 172 # 2-Jun-1992            Johan Vromans
 173 #    Do not use //o to allow multiple NGetOpt calls with different delimeters.
 174 #    Prevent typeless option from using previous $array state.
 175 #    Prevent empty option from being eaten as a (negative) number.
 176 #
 177 # 25-May-1992           Johan Vromans
 178 #    Add array options. "foo=s@" will return an array @opt_foo that
 179 #    contains all values that were supplied. E.g. "-foo one -foo -two" will
 180 #    return @opt_foo = ("one", "-two");
 181 #    Correct bug in handling options that allow for a argument when followed
 182 #    by another option.
 183 #
 184 # 4-May-1992            Johan Vromans
 185 #    Add $ignorecase to match options in either case.
 186 #    Allow '' option.
 187 #
 188 # 19-Mar-1992           Johan Vromans
 189 #    Allow require from packages.
 190 #    NGetOpt is now defined in the package that requires it.
 191 #    @ARGV and $opt_... are taken from the package that calls it.
 192 #    Use standard (?) option prefixes: -, -- and +.
 193 #
 194 # 20-Sep-1990           Johan Vromans
 195 #    Set options w/o argument to 1.
 196 #    Correct the dreadful semicolon/require bug.
 197
 198 ################ Configuration Section ################
 199
 200 {
 201
 202     # Values for $order. See GNU getopt.c for details.
 203     $REQUIRE_ORDER = 0;
 204     $PERMUTE = 1;
 205     $RETURN_IN_ORDER = 2;
 206
 207     # Handle POSIX compliancy.
 208     if ( defined $ENV{"POSIXLY_CORRECT"} ) {
 209         $autoabbrev = 0;        # no automatic abbrev of options (???)
 210         $getopt_compat = 0;     # disallow '+' to start options
 211         $option_start = "(--|-)";
 212         $order = $REQUIRE_ORDER;
 213     }
 214     else {
 215         $autoabbrev = 1;        # automatic abbrev of options
 216         $getopt_compat = 1;     # allow '+' to start options
 217         $option_start = "(--|-|\\+)";
 218         $order = $PERMUTE;
 219     }
 220
 221     # Other configurable settings.
 222     $debug = 0;                 # for debugging
 223     $ignorecase = 1;            # ignore case when matching options
 224     $argv_end = "--";           # don't change this!
 225 }
 226
 227 ################ Subroutines ################
 228
 229 sub GetOptions {
 230
 231     @optionlist = @_;   #';
 232
 233     local ($[) = 0;
 234     local ($genprefix) = $option_start;
 235     local ($argend) = $argv_end;
 236     local ($error) = 0;
 237     local ($opt, $optx, $arg, $type, $mand, %opctl);
 238     local ($pkg) = (caller)[0];
 239     local ($optarg);
 240     local (%aliases);
 241     local (@ret) = ();
 242
 243     print STDERR "NGetOpt 1.14 -- called from $pkg\n" if $debug;
 244
 245     # See if the first element of the optionlist contains option
 246     # starter characters.
 247     if ( $optionlist[0] =~ /^\W+$/ ) {
 248         $genprefix = shift (@optionlist);
 249         # Turn into regexp.
 250         $genprefix =~ s/(\W)/\\$1/g;
 251         $genprefix = "[" . $genprefix . "]";
 252     }
 253
 254     # Verify correctness of optionlist.
 255     %opctl = ();
 256     foreach $opt ( @optionlist ) {
 257         $opt =~ tr/A-Z/a-z/ if $ignorecase;
 258         if ( $opt !~ /^(\w+[-\w|]*)?(!|[=:][infse]@?)?$/ ) {
 259             die ("Error in option spec: \"", $opt, "\"\n");
 260             $error++;
 261             next;
 262         }
 263         local ($o, $c, $a) = ($1, $2);
 264
 265         if ( ! defined $o ) {
 266             $opctl{''} = defined $c ? $c : '';
 267         }
 268         else {
 269             # Handle alias names
 270             foreach ( split (/\|/, $o)) {
 271                 if ( defined $c && $c eq '!' ) {
 272                     $opctl{"no$_"} = $c;
 273                     $c = '';
 274                 }
 275                 $opctl{$_} = defined $c ? $c : '';
 276                 if ( defined $a ) {
 277                     # Note alias.
 278                     $aliases{$_} = $a;
 279                 }
 280                 else {
 281                     # Set primary name.
 282                     $a = $_;
 283                 }
 284             }
 285         }
 286     }
 287     @opctl = sort(keys (%opctl)) if $autoabbrev;
 288
 289     return 0 if $error;
 290
 291     if ( $debug ) {
 292         local ($arrow, $k, $v);
 293         $arrow = "=> ";
 294         while ( ($k,$v) = each(%opctl) ) {
 295             print STDERR ($arrow, "\$opctl{\"$k\"} = \"$v\"\n");
 296             $arrow = "   ";
 297         }
 298     }
 299
 300     # Process argument list
 301
 302     while ( $#ARGV >= 0 ) {
 303
 304         # >>> See also the continue block <<<
 305
 306         #### Get next argument ####
 307
 308         $opt = shift (@ARGV);
 309         print STDERR ("=> option \"", $opt, "\"\n") if $debug;
 310         $arg = undef;
 311         $optarg = undef;
 312         $array = 0;
 313
 314         #### Determine what we have ####
 315
 316         # Double dash is option list terminator.
 317         if ( $opt eq $argend ) {
 318             unshift (@ret, @ARGV) if $order == $PERMUTE;
 319             return ($error == 0);
 320         }
 321         elsif ( $opt =~ /^$genprefix/ ) {
 322             # Looks like an option.
 323             $opt = $';          # option name (w/o prefix)
 324             # If it is a long opt, it may include the value.
 325             if (($+ eq "--" || ($getopt_compat && $+ eq "+")) &&
 326                 $opt =~ /^([^=]+)=/ ) {
 327                 $opt = $1;
 328                 $optarg = $';
 329                 print STDERR ("=> option \"", $opt,
 330                               "\", optarg = \"$optarg\"\n")
 331                     if $debug;
 332             }
 333
 334         }
 335         # Not an option. Save it if we may permute...
 336         elsif ( $order == $PERMUTE ) {
 337             push (@ret, $opt);
 338             next;
 339         }
 340         # ...otherwise, terminate.
 341         else {
 342             # Push back and exit.
 343             unshift (@ARGV, $opt);
 344             return ($error == 0);
 345         }
 346
 347         #### Look it up ###
 348
 349         $opt =~ tr/A-Z/a-z/ if $ignorecase;
 350
 351         local ($tryopt) = $opt;
 352         if ( $autoabbrev ) {
 353             local ($pat, @hits);
 354
 355             # Turn option name into pattern.
 356             ($pat = $opt) =~ s/(\W)/\\$1/g;
 357             # Look up in option names.
 358             @hits = grep (/^$pat/, @opctl);
 359             print STDERR ("=> ", 0+@hits, " hits (@hits) with \"$pat\" ",
 360                           "out of ", 0+@opctl, "\n")
 361                 if $debug;
 362
 363             # Check for ambiguous results.
 364             unless ( (@hits <= 1) || (grep ($_ eq $opt, @hits) == 1) ) {
 365                 print STDERR ("Option ", $opt, " is ambiguous (",
 366                               join(", ", @hits), ")\n");
 367                 $error++;
 368                 next;
 369             }
 370
 371             # Complete the option name, if appropriate.
 372             if ( @hits == 1 && $hits[0] ne $opt ) {
 373                 $tryopt = $hits[0];
 374                 print STDERR ("=> option \"$opt\" -> \"$tryopt\"\n")
 375                     if $debug;
 376             }
 377         }
 378
 379         unless  ( defined ( $type = $opctl{$tryopt} ) ) {
 380             print STDERR ("Unknown option: ", $opt, "\n");
 381             $error++;
 382             next;
 383         }
 384         $opt = $tryopt;
 385         print STDERR ("=> found \"$type\" for ", $opt, "\n") if $debug;
 386
 387         #### Determine argument status ####
 388
 389         # If it is an option w/o argument, we're almost finished with it.
 390         if ( $type eq '' || $type eq '!' ) {
 391             if ( defined $optarg ) {
 392                 print STDERR ("Option ", $opt, " does not take an argument\n");
 393                 $error++;
 394             }
 395             elsif ( $type eq '' ) {
 396                 $arg = 1;               # supply explicit value
 397             }
 398             else {
 399                 substr ($opt, 0, 2) = ''; # strip NO prefix
 400                 $arg = 0;               # supply explicit value
 401             }
 402             next;
 403         }
 404
 405         # Get mandatory status and type info.
 406         ($mand, $type, $array) = $type =~ /^(.)(.)(@?)$/;
 407
 408         # Check if there is an option argument available.
 409         if ( defined $optarg ? ($optarg eq '') : ($#ARGV < 0) ) {
 410
 411             # Complain if this option needs an argument.
 412             if ( $mand eq "=" ) {
 413                 print STDERR ("Option ", $opt, " requires an argument\n");
 414                 $error++;
 415             }
 416             if ( $mand eq ":" ) {
 417                 $arg = $type eq "s" ? '' : 0;
 418             }
 419             next;
 420         }
 421
 422         # Get (possibly optional) argument.
 423         $arg = defined $optarg ? $optarg : shift (@ARGV);
 424
 425         #### Check if the argument is valid for this option ####
 426
 427         if ( $type eq "s" ) {   # string
 428             # A mandatory string takes anything.
 429             next if $mand eq "=";
 430
 431             # An optional string takes almost anything.
 432             next if defined $optarg;
 433             next if $arg eq "-";
 434
 435             # Check for option or option list terminator.
 436             if ($arg eq $argend ||
 437                 $arg =~ /^$genprefix.+/) {
 438                 # Push back.
 439                 unshift (@ARGV, $arg);
 440                 # Supply empty value.
 441                 $arg = '';
 442             }
 443             next;
 444         }
 445
 446         if ( $type eq "n" || $type eq "i" ) { # numeric/integer
 447             if ( $arg !~ /^-?[0-9]+$/ ) {
 448                 if ( defined $optarg || $mand eq "=" ) {
 449                     print STDERR ("Value \"", $arg, "\" invalid for option ",
 450                                   $opt, " (number expected)\n");
 451                     $error++;
 452                     undef $arg; # don't assign it
 453                 }
 454                 else {
 455                     # Push back.
 456                     unshift (@ARGV, $arg);
 457                     # Supply default value.
 458                     $arg = 0;
 459                 }
 460             }
 461             next;
 462         }
 463
 464         if ( $type eq "f" ) { # fixed real number, int is also ok
 465             if ( $arg !~ /^-?[0-9.]+$/ ) {
 466                 if ( defined $optarg || $mand eq "=" ) {
 467                     print STDERR ("Value \"", $arg, "\" invalid for option ",
 468                                   $opt, " (real number expected)\n");
 469                     $error++;
 470                     undef $arg; # don't assign it
 471                 }
 472                 else {
 473                     # Push back.
 474                     unshift (@ARGV, $arg);
 475                     # Supply default value.
 476                     $arg = 0.0;
 477                 }
 478             }
 479             next;
 480         }
 481
 482         die ("NGetOpt internal error (Can't happen)\n");
 483     }
 484
 485     continue {
 486         if ( defined $arg ) {
 487             $opt = $aliases{$opt} if defined $aliases{$opt};
 488             # Make sure a valid perl identifier results.
 489             $opt =~ s/\W/_/g;
 490             if ( $array ) {
 491                 print STDERR ('=> push (@', $pkg, '\'opt_', $opt, ", \"$arg\")\n")
 492                     if $debug;
 493                 eval ('push(@' . $pkg . '\'opt_' . $opt . ", \$arg);");
 494             }
 495             else {
 496                 print STDERR ('=> $', $pkg, '\'opt_', $opt, " = \"$arg\"\n")
 497                     if $debug;
 498                 eval ('$' . $pkg . '\'opt_' . $opt . " = \$arg;");
 499             }
 500         }
 501     }
 502
 503     if ( $order == $PERMUTE && @ret > 0 ) {
 504         unshift (@ARGV, @ret);
 505     }
 506     return ($error == 0);
 507 }
 508
 509 ################ Package return ################
 510
 511 1;
 512
 513