| Commit | Line | Data |
|---|
| a0d0e21e |
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; |
| 75f92628 |
206 | $RETURN_IN_ORDER = 2; # avoid typo warning with -w |
| a0d0e21e |
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; |
| 75f92628 |
238 | local ($opt, $arg, $type, $mand, %opctl); |
| a0d0e21e |
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 | |
projects / p5sagit/p5-mst-13.2.git / blame