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     $RETURN_IN_ORDER = 2; # avoid typo warning with -w
 207
 208     # Handle POSIX compliancy.
 209     if ( defined $ENV{"POSIXLY_CORRECT"} ) {
 210         $autoabbrev = 0;        # no automatic abbrev of options (???)
 211         $getopt_compat = 0;     # disallow '+' to start options
 212         $option_start = "(--|-)";
 213         $order = $REQUIRE_ORDER;
 214     }
 215     else {
 216         $autoabbrev = 1;        # automatic abbrev of options
 217         $getopt_compat = 1;     # allow '+' to start options
 218         $option_start = "(--|-|\\+)";
 219         $order = $PERMUTE;
 220     }
 221
 222     # Other configurable settings.
 223     $debug = 0;                 # for debugging
 224     $ignorecase = 1;            # ignore case when matching options
 225     $argv_end = "--";           # don't change this!
 226 }
 227
 228 ################ Subroutines ################
 229
 230 sub GetOptions {
 231
 232     @optionlist = @_;   #';
 233
 234     local ($[) = 0;
 235     local ($genprefix) = $option_start;
 236     local ($argend) = $argv_end;
 237     local ($error) = 0;
 238     local ($opt, $arg, $type, $mand, %opctl);
 239     local ($pkg) = (caller)[0];
 240     local ($optarg);
 241     local (%aliases);
 242     local (@ret) = ();
 243
 244     print STDERR "NGetOpt 1.14 -- called from $pkg\n" if $debug;
 245
 246     # See if the first element of the optionlist contains option
 247     # starter characters.
 248     if ( $optionlist[0] =~ /^\W+$/ ) {
 249         $genprefix = shift (@optionlist);
 250         # Turn into regexp.
 251         $genprefix =~ s/(\W)/\\$1/g;
 252         $genprefix = "[" . $genprefix . "]";
 253     }
 254
 255     # Verify correctness of optionlist.
 256     %opctl = ();
 257     foreach $opt ( @optionlist ) {
 258         $opt =~ tr/A-Z/a-z/ if $ignorecase;
 259         if ( $opt !~ /^(\w+[-\w|]*)?(!|[=:][infse]@?)?$/ ) {
 260             die ("Error in option spec: \"", $opt, "\"\n");
 261             $error++;
 262             next;
 263         }
 264         local ($o, $c, $a) = ($1, $2);
 265
 266         if ( ! defined $o ) {
 267             $opctl{''} = defined $c ? $c : '';
 268         }
 269         else {
 270             # Handle alias names
 271             foreach ( split (/\|/, $o)) {
 272                 if ( defined $c && $c eq '!' ) {
 273                     $opctl{"no$_"} = $c;
 274                     $c = '';
 275                 }
 276                 $opctl{$_} = defined $c ? $c : '';
 277                 if ( defined $a ) {
 278                     # Note alias.
 279                     $aliases{$_} = $a;
 280                 }
 281                 else {
 282                     # Set primary name.
 283                     $a = $_;
 284                 }
 285             }
 286         }
 287     }
 288     @opctl = sort(keys (%opctl)) if $autoabbrev;
 289
 290     return 0 if $error;
 291
 292     if ( $debug ) {
 293         local ($arrow, $k, $v);
 294         $arrow = "=> ";
 295         while ( ($k,$v) = each(%opctl) ) {
 296             print STDERR ($arrow, "\$opctl{\"$k\"} = \"$v\"\n");
 297             $arrow = "   ";
 298         }
 299     }
 300
 301     # Process argument list
 302
 303     while ( $#ARGV >= 0 ) {
 304
 305         # >>> See also the continue block <<<
 306
 307         #### Get next argument ####
 308
 309         $opt = shift (@ARGV);
 310         print STDERR ("=> option \"", $opt, "\"\n") if $debug;
 311         $arg = undef;
 312         $optarg = undef;
 313         $array = 0;
 314
 315         #### Determine what we have ####
 316
 317         # Double dash is option list terminator.
 318         if ( $opt eq $argend ) {
 319             unshift (@ret, @ARGV) if $order == $PERMUTE;
 320             return ($error == 0);
 321         }
 322         elsif ( $opt =~ /^$genprefix/ ) {
 323             # Looks like an option.
 324             $opt = $';          # option name (w/o prefix)
 325             # If it is a long opt, it may include the value.
 326             if (($+ eq "--" || ($getopt_compat && $+ eq "+")) &&
 327                 $opt =~ /^([^=]+)=/ ) {
 328                 $opt = $1;
 329                 $optarg = $';
 330                 print STDERR ("=> option \"", $opt,
 331                               "\", optarg = \"$optarg\"\n")
 332                     if $debug;
 333             }
 334
 335         }
 336         # Not an option. Save it if we may permute...
 337         elsif ( $order == $PERMUTE ) {
 338             push (@ret, $opt);
 339             next;
 340         }
 341         # ...otherwise, terminate.
 342         else {
 343             # Push back and exit.
 344             unshift (@ARGV, $opt);
 345             return ($error == 0);
 346         }
 347
 348         #### Look it up ###
 349
 350         $opt =~ tr/A-Z/a-z/ if $ignorecase;
 351
 352         local ($tryopt) = $opt;
 353         if ( $autoabbrev ) {
 354             local ($pat, @hits);
 355
 356             # Turn option name into pattern.
 357             ($pat = $opt) =~ s/(\W)/\\$1/g;
 358             # Look up in option names.
 359             @hits = grep (/^$pat/, @opctl);
 360             print STDERR ("=> ", 0+@hits, " hits (@hits) with \"$pat\" ",
 361                           "out of ", 0+@opctl, "\n")
 362                 if $debug;
 363
 364             # Check for ambiguous results.
 365             unless ( (@hits <= 1) || (grep ($_ eq $opt, @hits) == 1) ) {
 366                 print STDERR ("Option ", $opt, " is ambiguous (",
 367                               join(", ", @hits), ")\n");
 368                 $error++;
 369                 next;
 370             }
 371
 372             # Complete the option name, if appropriate.
 373             if ( @hits == 1 && $hits[0] ne $opt ) {
 374                 $tryopt = $hits[0];
 375                 print STDERR ("=> option \"$opt\" -> \"$tryopt\"\n")
 376                     if $debug;
 377             }
 378         }
 379
 380         unless  ( defined ( $type = $opctl{$tryopt} ) ) {
 381             print STDERR ("Unknown option: ", $opt, "\n");
 382             $error++;
 383             next;
 384         }
 385         $opt = $tryopt;
 386         print STDERR ("=> found \"$type\" for ", $opt, "\n") if $debug;
 387
 388         #### Determine argument status ####
 389
 390         # If it is an option w/o argument, we're almost finished with it.
 391         if ( $type eq '' || $type eq '!' ) {
 392             if ( defined $optarg ) {
 393                 print STDERR ("Option ", $opt, " does not take an argument\n");
 394                 $error++;
 395             }
 396             elsif ( $type eq '' ) {
 397                 $arg = 1;               # supply explicit value
 398             }
 399             else {
 400                 substr ($opt, 0, 2) = ''; # strip NO prefix
 401                 $arg = 0;               # supply explicit value
 402             }
 403             next;
 404         }
 405
 406         # Get mandatory status and type info.
 407         ($mand, $type, $array) = $type =~ /^(.)(.)(@?)$/;
 408
 409         # Check if there is an option argument available.
 410         if ( defined $optarg ? ($optarg eq '') : ($#ARGV < 0) ) {
 411
 412             # Complain if this option needs an argument.
 413             if ( $mand eq "=" ) {
 414                 print STDERR ("Option ", $opt, " requires an argument\n");
 415                 $error++;
 416             }
 417             if ( $mand eq ":" ) {
 418                 $arg = $type eq "s" ? '' : 0;
 419             }
 420             next;
 421         }
 422
 423         # Get (possibly optional) argument.
 424         $arg = defined $optarg ? $optarg : shift (@ARGV);
 425
 426         #### Check if the argument is valid for this option ####
 427
 428         if ( $type eq "s" ) {   # string
 429             # A mandatory string takes anything.
 430             next if $mand eq "=";
 431
 432             # An optional string takes almost anything.
 433             next if defined $optarg;
 434             next if $arg eq "-";
 435
 436             # Check for option or option list terminator.
 437             if ($arg eq $argend ||
 438                 $arg =~ /^$genprefix.+/) {
 439                 # Push back.
 440                 unshift (@ARGV, $arg);
 441                 # Supply empty value.
 442                 $arg = '';
 443             }
 444             next;
 445         }
 446
 447         if ( $type eq "n" || $type eq "i" ) { # numeric/integer
 448             if ( $arg !~ /^-?[0-9]+$/ ) {
 449                 if ( defined $optarg || $mand eq "=" ) {
 450                     print STDERR ("Value \"", $arg, "\" invalid for option ",
 451                                   $opt, " (number expected)\n");
 452                     $error++;
 453                     undef $arg; # don't assign it
 454                 }
 455                 else {
 456                     # Push back.
 457                     unshift (@ARGV, $arg);
 458                     # Supply default value.
 459                     $arg = 0;
 460                 }
 461             }
 462             next;
 463         }
 464
 465         if ( $type eq "f" ) { # fixed real number, int is also ok
 466             if ( $arg !~ /^-?[0-9.]+$/ ) {
 467                 if ( defined $optarg || $mand eq "=" ) {
 468                     print STDERR ("Value \"", $arg, "\" invalid for option ",
 469                                   $opt, " (real number expected)\n");
 470                     $error++;
 471                     undef $arg; # don't assign it
 472                 }
 473                 else {
 474                     # Push back.
 475                     unshift (@ARGV, $arg);
 476                     # Supply default value.
 477                     $arg = 0.0;
 478                 }
 479             }
 480             next;
 481         }
 482
 483         die ("NGetOpt internal error (Can't happen)\n");
 484     }
 485
 486     continue {
 487         if ( defined $arg ) {
 488             $opt = $aliases{$opt} if defined $aliases{$opt};
 489             # Make sure a valid perl identifier results.
 490             $opt =~ s/\W/_/g;
 491             if ( $array ) {
 492                 print STDERR ('=> push (@', $pkg, '\'opt_', $opt, ", \"$arg\")\n")
 493                     if $debug;
 494                 eval ('push(@' . $pkg . '\'opt_' . $opt . ", \$arg);");
 495             }
 496             else {
 497                 print STDERR ('=> $', $pkg, '\'opt_', $opt, " = \"$arg\"\n")
 498                     if $debug;
 499                 eval ('$' . $pkg . '\'opt_' . $opt . " = \$arg;");
 500             }
 501         }
 502     }
 503
 504     if ( $order == $PERMUTE && @ret > 0 ) {
 505         unshift (@ARGV, @ret);
 506     }
 507     return ($error == 0);
 508 }
 509
 510 ################ Package return ################
 511
 512 1;
 513
 514