From: Perl 5 Porters Date: Wed, 9 Oct 1996 01:46:20 +0000 (+0000) Subject: Update to version 2.4. X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=381319f7a4cfe77209fc10d28af463f6969064fa;p=p5sagit%2Fp5-mst-13.2.git Update to version 2.4. --- diff --git a/lib/Getopt/Long.pm b/lib/Getopt/Long.pm index 190b609..11d10f8 100644 --- a/lib/Getopt/Long.pm +++ b/lib/Getopt/Long.pm @@ -1,11 +1,11 @@ # GetOpt::Long.pm -- POSIX compatible options parsing -# RCS Status : $Id: GetoptLong.pm,v 2.3 1996-04-05 21:03:05+02 jv Exp $ +# RCS Status : $Id: GetoptLong.pm,v 2.4 1996-10-02 11:16:26+02 jv Exp $ # Author : Johan Vromans # Created On : Tue Sep 11 15:00:12 1990 # Last Modified By: Johan Vromans -# Last Modified On: Fri Apr 5 21:02:52 1996 -# Update Count : 433 +# Last Modified On: Wed Oct 2 11:13:12 1996 +# Update Count : 500 # Status : Released package Getopt::Long; @@ -14,9 +14,10 @@ require Exporter; @ISA = qw(Exporter); @EXPORT = qw(&GetOptions $REQUIRE_ORDER $PERMUTE $RETURN_IN_ORDER); -$VERSION = sprintf("%d.%02d", '$Revision: 2.3 $ ' =~ /(\d+)\.(\d+)/); +$VERSION = sprintf("%d.%02d", '$Revision: 2.4 $ ' =~ /(\d+)\.(\d+)/); use vars qw($autoabbrev $getopt_compat $ignorecase $bundling $order - $error $debug $REQUIRE_ORDER $PERMUTE $RETURN_IN_ORDER + $passthrough $error $debug + $REQUIRE_ORDER $PERMUTE $RETURN_IN_ORDER $VERSION $major_version $minor_version); use strict; @@ -85,7 +86,7 @@ followed by an argument specifier. Values for argument specifiers are: =over 8 -=item EnoneE +=item Option does not take an argument. The option variable will be set to 1. @@ -170,6 +171,17 @@ the assignment $optctl{"sizes"} = [24, 48]; +For hash options (an option whose argument looks like "name=value"), +a reference to a hash is used, e.g.: + + %optctl = (); + &GetOptions (\%optctl, "define=s%"); + +with command line "--define foo=hello --define bar=world" will perform the +equivalent of the assignment + + $optctl{"define"} = {foo=>'hello', bar=>'world') + If no linkage is explicitly specified and no ref HASH is passed, GetOptions will put the value in a global variable named after the option, prefixed by "opt_". To yield a usable Perl variable, @@ -191,7 +203,7 @@ A lone dash B<-> is considered an option, the corresponding Perl identifier is $opt_ . The linkage specifier can be a reference to a scalar, a reference to -an array or a reference to a subroutine. +an array, a reference to a hash or a reference to a subroutine. If a REF SCALAR is supplied, the new value is stored in the referenced variable. If the option occurs more than once, the previous value is @@ -200,6 +212,11 @@ overwritten. If a REF ARRAY is supplied, the new value is appended (pushed) to the referenced array. +If a REF HASH is supplied, the option value should look like "key" or +"key=value" (if the "=value" is omitted then a value of 1 is implied). +In this case, the element of the referenced hash with the key "key" +is assigned "value". + If a REF CODE is supplied, the referenced subroutine is called with two arguments: the option name and the option value. The option name is always the true name, not an abbreviation or alias. @@ -208,7 +225,7 @@ The option name is always the true name, not an abbreviation or alias. The option name may actually be a list of option names, separated by "|"s, e.g. "foo|bar|blech=s". In this example, "foo" is the true name -of this option. If no linkage is specified, options "foo", "bar" and +op this option. If no linkage is specified, options "foo", "bar" and "blech" all will set $opt_foo. Option names may be abbreviated to uniqueness, depending on @@ -216,7 +233,7 @@ configuration variable $Getopt::Long::autoabbrev. =head2 Non-option call-back routine -A special option specifier, EE, can be used to designate a subroutine +A special option specifier, <>, can be used to designate a subroutine to handle non-option arguments. GetOptions will immediately call this subroutine for every non-option it encounters in the options list. This subroutine gets the name of the non-option passed. @@ -246,11 +263,18 @@ In fact, the Perl 5 version of newgetopt.pl is just a wrapper around the module. If an "@" sign is appended to the argument specifier, the option is -treated as an array. Value(s) are not set, but pushed into array -@opt_name. This only applies if no linkage is supplied. +treated as an array. Value(s) are not set, but pushed into array +@opt_name. If explicit linkage is supplied, this must be a reference +to an ARRAY. + +If an "%" sign is appended to the argument specifier, the option is +treated as a hash. Value(s) of the form "name=value" are set by +setting the element of the hash %opt_name with key "name" to "value" +(if the "=value" portion is omitted it defaults to 1). If explicit +linkage is supplied, this must be a reference to a HASH. If configuration variable $Getopt::Long::getopt_compat is set to a -non-zero value, options that start with "+" may also include their +non-zero value, options that start with "+" or "-" may also include their arguments, e.g. "+foo=bar". This is for compatiblity with older implementations of the GNU "getopt" routine. @@ -292,11 +316,11 @@ Example of using variable references: With command line options "-foo blech -bar 24 -ar xx -ar yy" this will result in: - $foo = 'blech' + $bar = 'blech' $opt_bar = 24 @ar = ('xx','yy') -Example of using the EE option specifier: +Example of using the <> option specifier: @ARGV = qw(-foo 1 bar -foo 2 blech); &GetOptions("foo=i", \$myfoo, "<>", \&mysub); @@ -404,6 +428,16 @@ Ignore case when matching options. Default is 1. When bundling is in effect, case is ignored on single-character options only if $Getopt::Long::ignorecase is greater than 1. +=item $Getopt::Long::passthrough + +Unknown options are passed through in @ARGV instead of being flagged +as errors. This makes it possible to write wrapper scripts that +process only part of the user supplied options, and passes the +remaining options to some other program. + +This can be very confusing, especially when $Getopt::Long::order is +set to $PERMUTE. + =item $Getopt::Long::VERSION The version number of this Getopt::Long implementation in the format @@ -454,14 +488,14 @@ my $gen_prefix; # generic prefix (option starters) # Handle POSIX compliancy. if ( defined $ENV{"POSIXLY_CORRECT"} ) { - $gen_prefix = "--|-"; + $gen_prefix = "(--|-)"; $autoabbrev = 0; # no automatic abbrev of options $bundling = 0; # no bundling of single letter switches $getopt_compat = 0; # disallow '+' to start options $order = $REQUIRE_ORDER; } else { - $gen_prefix = "--|-|\\+"; + $gen_prefix = "(--|-|\\+)"; $autoabbrev = 1; # automatic abbrev of options $bundling = 0; # bundling off by default $getopt_compat = 1; # allow '+' to start options @@ -472,35 +506,41 @@ else { $debug = 0; # for debugging $error = 0; # error tally $ignorecase = 1; # ignore case when matching options +$passthrough = 0; # leave unrecognized options alone ($major_version, $minor_version) = $VERSION =~ /^(\d+)\.(\d+)/; +use vars qw($genprefix %opctl @opctl %bopctl $opt $arg $argend $array); +use vars qw(%aliases $hash $key); + ################ Subroutines ################ sub GetOptions { my @optionlist = @_; # local copy of the option descriptions - my $argend = '--'; # option list terminator - my %opctl; # table of arg.specs (long and abbrevs) - my %bopctl; # table of arg.specs (bundles) + local ($argend) = '--'; # option list terminator + local (%opctl); # table of arg.specs (long and abbrevs) + local (%bopctl); # table of arg.specs (bundles) my $pkg = (caller)[0]; # current context # Needed if linkage is omitted. - my %aliases; # alias table + local (%aliases); # alias table my @ret = (); # accum for non-options my %linkage; # linkage my $userlinkage; # user supplied HASH - my $genprefix = $gen_prefix; # so we can call the same module more + local ($genprefix) = $gen_prefix; # so we can call the same module more # than once in differing environments $error = 0; - print STDERR ('GetOptions $Revision: 2.3 $ ', + print STDERR ('GetOptions $Revision: 2.4 $ ', "[GetOpt::Long $Getopt::Long::VERSION] -- ", "called from package \"$pkg\".\n", + " (@ARGV)\n", " autoabbrev=$autoabbrev". ",bundling=$bundling", ",getopt_compat=$getopt_compat", - ",genprefix=\"$genprefix\"", ",order=$order", - ",ignorecase=$ignorecase", + ",\n ignorecase=$ignorecase", + ",passthrough=$passthrough", + ",genprefix=\"$genprefix\"", ".\n") if $debug; @@ -525,8 +565,8 @@ sub GetOptions { while ( @optionlist > 0 ) { my $opt = shift (@optionlist); - # Strip leading prefix so people can specify "-foo=i" if they like. - $opt = $2 if $opt =~ /^($genprefix)+([\x00-\xff]*)/; + # Strip leading prefix so people can specify "--foo=i" if they like. + $opt = $' if $opt =~ /^($genprefix)+/; if ( $opt eq '<>' ) { if ( (defined $userlinkage) @@ -545,7 +585,7 @@ sub GetOptions { next; } - if ( $opt !~ /^(\w+[-\w|]*)?(!|[=:][infse]@?)?$/ ) { + if ( $opt !~ /^(\w+[-\w|]*)?(!|[=:][infse][@%]?)?$/ ) { warn ("Error in option spec: \"", $opt, "\"\n"); $error++; next; @@ -560,7 +600,9 @@ sub GetOptions { else { # Handle alias names my @o = split (/\|/, $o); - $o = $o[0]; + my $linko = $o = $o[0]; + # Force an alias if the option name is not locase. + $a = $o unless $o eq lc($o); $o = lc ($o) if $ignorecase > 1 || ($ignorecase @@ -593,6 +635,7 @@ sub GetOptions { $a = $_; } } + $o = $linko; } # If no linkage is supplied in the @optionlist, copy it from @@ -616,9 +659,17 @@ sub GetOptions { if ( @optionlist > 0 && ref($optionlist[0]) ) { print STDERR ("=> link \"$o\" to $optionlist[0]\n") if $debug; - if ( ref($optionlist[0]) =~ /^(SCALAR|ARRAY|CODE)$/ ) { + if ( ref($optionlist[0]) =~ /^(SCALAR|CODE)$/ ) { $linkage{$o} = shift (@optionlist); } + elsif ( ref($optionlist[0]) =~ /^(ARRAY)$/ ) { + $linkage{$o} = shift (@optionlist); + $opctl{$o} .= '@' unless $opctl{$o} =~ /\@$/; + } + elsif ( ref($optionlist[0]) =~ /^(HASH)$/ ) { + $linkage{$o} = shift (@optionlist); + $opctl{$o} .= '%' unless $opctl{$o} =~ /\%$/; + } else { warn ("Invalid option linkage for \"", $opt, "\"\n"); $error++; @@ -629,11 +680,16 @@ sub GetOptions { # Make sure a valid perl identifier results. my $ov = $o; $ov =~ s/\W/_/g; - if ( defined($c) && $c =~ /@/ ) { + if ( $c =~ /@/ ) { print STDERR ("=> link \"$o\" to \@$pkg","::opt_$ov\n") if $debug; eval ("\$linkage{\$o} = \\\@".$pkg."::opt_$ov;"); } + elsif ( $c =~ /%/ ) { + print STDERR ("=> link \"$o\" to \%$pkg","::opt_$ov\n") + if $debug; + eval ("\$linkage{\$o} = \\\%".$pkg."::opt_$ov;"); + } else { print STDERR ("=> link \"$o\" to \$$pkg","::opt_$ov\n") if $debug; @@ -646,7 +702,7 @@ sub GetOptions { return 0 if $error; # Sort the possible long option names. - my @opctl = sort(keys (%opctl)) if $autoabbrev; + local (@opctl) = sort(keys (%opctl)) if $autoabbrev; # Show the options tables if debugging. if ( $debug ) { @@ -663,24 +719,20 @@ sub GetOptions { } } - my $opt; # current option - my $arg; # current option value, if any - my $array; # current option is array typed + local ($opt); # current option + local ($arg); # current option value, if any + local ($array); # current option is array typed + local ($hash); # current option is hash typed + local ($key); # hash key for a hash option # Process argument list while ( @ARGV > 0 ) { - # >>> See also the continue block <<< - #### Get next argument #### - my $starter; # option starter string, e.g. '-' or '--' - my $rest = undef; # remainder from unbundling - my $optarg = undef; # value supplied with --opt=value - $opt = shift (@ARGV); $arg = undef; - $array = 0; + $array = $hash = 0; print STDERR ("=> option \"", $opt, "\"\n") if $debug; #### Determine what we have #### @@ -693,21 +745,76 @@ sub GetOptions { return ($error == 0); } - if ( $opt =~ /^($genprefix)([\x00-\xff]*)/ ) { - # Looks like an option. - $opt = $2; # option name (w/o prefix) - $starter = $1; # option starter - - # If it is a long option, it may include the value. - if (($starter eq "--" - || ($getopt_compat && $starter eq "+")) - && $opt =~ /^([^=]+)=([\x00-\xff]*)/ ) { - $opt = $1; - $optarg = $2; - print STDERR ("=> option \"", $opt, - "\", optarg = \"$optarg\"\n") if $debug; - } + my $tryopt = $opt; + + # find_option operates on the GLOBAL $opt and $arg! + if ( &find_option ) { + + # find_option undefines $opt in case of errors. + next unless defined $opt; + if ( defined $arg ) { + $opt = $aliases{$opt} if defined $aliases{$opt}; + + if ( defined $linkage{$opt} ) { + print STDERR ("=> ref(\$L{$opt}) -> ", + ref($linkage{$opt}), "\n") if $debug; + + if ( ref($linkage{$opt}) eq 'SCALAR' ) { + print STDERR ("=> \$\$L{$opt} = \"$arg\"\n") if $debug; + ${$linkage{$opt}} = $arg; + } + elsif ( ref($linkage{$opt}) eq 'ARRAY' ) { + print STDERR ("=> push(\@{\$L{$opt}, \"$arg\")\n") + if $debug; + push (@{$linkage{$opt}}, $arg); + } + elsif ( ref($linkage{$opt}) eq 'HASH' ) { + print STDERR ("=> \$\$L{$opt}->{$key} = \"$arg\"\n") + if $debug; + $linkage{$opt}->{$key} = $arg; + } + elsif ( ref($linkage{$opt}) eq 'CODE' ) { + print STDERR ("=> &L{$opt}(\"$opt\", \"$arg\")\n") + if $debug; + &{$linkage{$opt}}($opt, $arg); + } + else { + print STDERR ("Invalid REF type \"", ref($linkage{$opt}), + "\" in linkage\n"); + die ("Getopt::Long -- internal error!\n"); + } + } + # No entry in linkage means entry in userlinkage. + elsif ( $array ) { + if ( defined $userlinkage->{$opt} ) { + print STDERR ("=> push(\@{\$L{$opt}}, \"$arg\")\n") + if $debug; + push (@{$userlinkage->{$opt}}, $arg); + } + else { + print STDERR ("=>\$L{$opt} = [\"$arg\"]\n") + if $debug; + $userlinkage->{$opt} = [$arg]; + } + } + elsif ( $hash ) { + if ( defined $userlinkage->{$opt} ) { + print STDERR ("=> \$L{$opt}->{$key} = \"$arg\"\n") + if $debug; + $userlinkage->{$opt}->{$key} = $arg; + } + else { + print STDERR ("=>\$L{$opt} = {$key => \"$arg\"}\n") + if $debug; + $userlinkage->{$opt} = {$key => $arg}; + } + } + else { + print STDERR ("=>\$L{$opt} = \"$arg\"\n") if $debug; + $userlinkage->{$opt} = $arg; + } + } } # Not an option. Save it if we $PERMUTE and don't have a <>. @@ -715,12 +822,12 @@ sub GetOptions { # Try non-options call-back. my $cb; if ( (defined ($cb = $linkage{'<>'})) ) { - &$cb($opt); + &$cb($tryopt); } else { - print STDERR ("=> saving \"$opt\" ", + print STDERR ("=> saving \"$tryopt\" ", "(not an option, may permute)\n") if $debug; - push (@ret, $opt); + push (@ret, $tryopt); } next; } @@ -728,227 +835,224 @@ sub GetOptions { # ...otherwise, terminate. else { # Push this one back and exit. - unshift (@ARGV, $opt); + unshift (@ARGV, $tryopt); return ($error == 0); } - #### Look it up ### - - my $tryopt = $opt; # option to try - my $optbl = \%opctl; # table to look it up (long names) - - if ( $bundling && $starter eq '-' ) { - # Unbundle single letter option. - $rest = substr ($tryopt, 1); - $tryopt = substr ($tryopt, 0, 1); - $tryopt = lc ($tryopt) if $ignorecase > 1; - print STDERR ("=> $starter$tryopt unbundled from ", - "$starter$tryopt$rest\n") if $debug; - $rest = undef unless $rest ne ''; - $optbl = \%bopctl; # look it up in the short names table - } - - # Try auto-abbreviation. - elsif ( $autoabbrev ) { - # Downcase if allowed. - $tryopt = $opt = lc ($opt) if $ignorecase; - # Turn option name into pattern. - my $pat = quotemeta ($opt); - # Look up in option names. - my @hits = grep (/^$pat/, @opctl); - print STDERR ("=> ", scalar(@hits), " hits (@hits) with \"$pat\" ", - "out of ", scalar(@opctl), "\n") if $debug; - - # Check for ambiguous results. - unless ( (@hits <= 1) || (grep ($_ eq $opt, @hits) == 1) ) { + } + + # Finish. + if ( $order == $PERMUTE ) { + # Push back accumulated arguments + print STDERR ("=> restoring \"", join('" "', @ret), "\"\n") + if $debug && @ret > 0; + unshift (@ARGV, @ret) if @ret > 0; + } + + return ($error == 0); +} + +sub find_option { + + return 0 unless $opt =~ /^$genprefix/; + + $opt = $'; + my ($starter) = $&; + + my $optarg = undef; # value supplied with --opt=value + my $rest = undef; # remainder from unbundling + + # If it is a long option, it may include the value. + if (($starter eq "--" || $getopt_compat) + && $opt =~ /^([^=]+)=/ ) { + $opt = $1; + $optarg = $'; + print STDERR ("=> option \"", $opt, + "\", optarg = \"$optarg\"\n") if $debug; + } + + #### Look it up ### + + my $tryopt = $opt; # option to try + my $optbl = \%opctl; # table to look it up (long names) + + if ( $bundling && $starter eq '-' ) { + # Unbundle single letter option. + $rest = substr ($tryopt, 1); + $tryopt = substr ($tryopt, 0, 1); + $tryopt = lc ($tryopt) if $ignorecase > 1; + print STDERR ("=> $starter$tryopt unbundled from ", + "$starter$tryopt$rest\n") if $debug; + $rest = undef unless $rest ne ''; + $optbl = \%bopctl; # look it up in the short names table + } + + # Try auto-abbreviation. + elsif ( $autoabbrev ) { + # Downcase if allowed. + $tryopt = $opt = lc ($opt) if $ignorecase; + # Turn option name into pattern. + my $pat = quotemeta ($opt); + # Look up in option names. + my @hits = grep (/^$pat/, @opctl); + print STDERR ("=> ", scalar(@hits), " hits (@hits) with \"$pat\" ", + "out of ", scalar(@opctl), "\n") if $debug; + + # Check for ambiguous results. + unless ( (@hits <= 1) || (grep ($_ eq $opt, @hits) == 1) ) { + # See if all matches are for the same option. + my %hit; + foreach ( @hits ) { + $_ = $aliases{$_} if defined $aliases{$_}; + $hit{$_} = 1; + } + # Now see if it really is ambiguous. + unless ( keys(%hit) == 1 ) { + return 0 if $passthrough; print STDERR ("Option ", $opt, " is ambiguous (", join(", ", @hits), ")\n"); $error++; - next; - } - - # Complete the option name, if appropriate. - if ( @hits == 1 && $hits[0] ne $opt ) { - $tryopt = $hits[0]; - print STDERR ("=> option \"$opt\" -> \"$tryopt\"\n") - if $debug; + undef $opt; + return 1; } + @hits = keys(%hit); } - # Check validity by fetching the info. - my $type = $optbl->{$tryopt}; - unless ( defined $type ) { - warn ("Unknown option: ", $opt, "\n"); - $error++; - next; + # Complete the option name, if appropriate. + if ( @hits == 1 && $hits[0] ne $opt ) { + $tryopt = $hits[0]; + $tryopt = lc ($tryopt) if $ignorecase; + print STDERR ("=> option \"$opt\" -> \"$tryopt\"\n") + if $debug; } - # Apparently valid. - $opt = $tryopt; - print STDERR ("=> found \"$type\" for ", $opt, "\n") if $debug; + } - #### Determine argument status #### + # Check validity by fetching the info. + my $type = $optbl->{$tryopt}; + unless ( defined $type ) { + return 0 if $passthrough; + warn ("Unknown option: ", $opt, "\n"); + $error++; + return 1; + } + # Apparently valid. + $opt = $tryopt; + print STDERR ("=> found \"$type\" for ", $opt, "\n") if $debug; - # If it is an option w/o argument, we're almost finished with it. - if ( $type eq '' || $type eq '!' ) { - if ( defined $optarg ) { - print STDERR ("Option ", $opt, " does not take an argument\n"); - $error++; - } - elsif ( $type eq '' ) { - $arg = 1; # supply explicit value - } - else { - substr ($opt, 0, 2) = ''; # strip NO prefix - $arg = 0; # supply explicit value - } - # When unbundling, unshift the rest with the starter. - unshift (@ARGV, $starter.$rest) if defined $rest; - next; - } + #### Determine argument status #### - # Get mandatory status and type info. - my $mand; - ($mand, $type, $array) = $type =~ /^(.)(.)(@?)$/; + # If it is an option w/o argument, we're almost finished with it. + if ( $type eq '' || $type eq '!' ) { + if ( defined $optarg ) { + return 0 if $passthrough; + print STDERR ("Option ", $opt, " does not take an argument\n"); + $error++; + undef $opt; + } + elsif ( $type eq '' ) { + $arg = 1; # supply explicit value + } + else { + substr ($opt, 0, 2) = ''; # strip NO prefix + $arg = 0; # supply explicit value + } + unshift (@ARGV, $starter.$rest) if defined $rest; + return 1; + } - # Check if there is an option argument available. - if ( defined $optarg ? ($optarg eq '') - : !(defined $rest || @ARGV > 0) ) { - # Complain if this option needs an argument. - if ( $mand eq "=" ) { - print STDERR ("Option ", $opt, " requires an argument\n"); - $error++; - } - if ( $mand eq ":" ) { - $arg = $type eq "s" ? '' : 0; - } - next; + # Get mandatory status and type info. + my $mand; + ($mand, $type, $array, $hash) = $type =~ /^(.)(.)(@?)(%?)$/; + + # Check if there is an option argument available. + if ( defined $optarg ? ($optarg eq '') + : !(defined $rest || @ARGV > 0) ) { + # Complain if this option needs an argument. + if ( $mand eq "=" ) { + return 0 if $passthrough; + print STDERR ("Option ", $opt, " requires an argument\n"); + $error++; + undef $opt; + } + if ( $mand eq ":" ) { + $arg = $type eq "s" ? '' : 0; } + return 1; + } - # Get (possibly optional) argument. - $arg = (defined $rest ? $rest - : (defined $optarg ? $optarg : shift (@ARGV))); + # Get (possibly optional) argument. + $arg = (defined $rest ? $rest + : (defined $optarg ? $optarg : shift (@ARGV))); - #### Check if the argument is valid for this option #### + # Get key if this is a "name=value" pair for a hash option. + $key = undef; + if ($hash && defined $arg) { + ($key, $arg) = ($arg =~ /=/o) ? ($`, $') : ($arg, 1); + } - if ( $type eq "s" ) { # string - # A mandatory string takes anything. - next if $mand eq "="; + #### Check if the argument is valid for this option #### - # An optional string takes almost anything. - next if defined $optarg || defined $rest; - next if $arg eq "-"; # ?? + if ( $type eq "s" ) { # string + # A mandatory string takes anything. + return 1 if $mand eq "="; - # Check for option or option list terminator. - if ($arg eq $argend || - $arg =~ /^$genprefix.+/) { - # Push back. - unshift (@ARGV, $arg); - # Supply empty value. - $arg = ''; - } - next; - } + # An optional string takes almost anything. + return 1 if defined $optarg || defined $rest; + return 1 if $arg eq "-"; # ?? - if ( $type eq "n" || $type eq "i" ) { # numeric/integer - if ( $arg !~ /^-?[0-9]+$/ ) { - if ( defined $optarg || $mand eq "=" ) { - print STDERR ("Value \"", $arg, "\" invalid for option ", - $opt, " (number expected)\n"); - $error++; - undef $arg; # don't assign it - # Push back. - unshift (@ARGV, $starter.$rest) if defined $rest; - } - else { - # Push back. - unshift (@ARGV, defined $rest ? $starter.$rest : $arg); - # Supply default value. - $arg = 0; - } - } - next; + # Check for option or option list terminator. + if ($arg eq $argend || + $arg =~ /^$genprefix.+/) { + # Push back. + unshift (@ARGV, $arg); + # Supply empty value. + $arg = ''; } + } - if ( $type eq "f" ) { # fixed real number, int is also ok - if ( $arg !~ /^-?[0-9.]+$/ ) { - if ( defined $optarg || $mand eq "=" ) { - print STDERR ("Value \"", $arg, "\" invalid for option ", - $opt, " (real number expected)\n"); - $error++; - undef $arg; # don't assign it - # Push back. - unshift (@ARGV, $starter.$rest) if defined $rest; - } - else { - # Push back. - unshift (@ARGV, defined $rest ? $starter.$rest : $arg); - # Supply default value. - $arg = 0.0; - } + elsif ( $type eq "n" || $type eq "i" ) { # numeric/integer + if ( $arg !~ /^-?[0-9]+$/ ) { + if ( defined $optarg || $mand eq "=" ) { + return 0 if $passthrough; + print STDERR ("Value \"", $arg, "\" invalid for option ", + $opt, " (number expected)\n"); + $error++; + undef $opt; + # Push back. + unshift (@ARGV, $starter.$rest) if defined $rest; + } + else { + # Push back. + unshift (@ARGV, defined $rest ? $starter.$rest : $arg); + # Supply default value. + $arg = 0; } - next; } - - die ("GetOpt::Long internal error (Can't happen)\n"); } - continue { - if ( defined $arg ) { - $opt = $aliases{$opt} if defined $aliases{$opt}; - - if ( defined $linkage{$opt} ) { - print STDERR ("=> ref(\$L{$opt}) -> ", - ref($linkage{$opt}), "\n") if $debug; - - if ( ref($linkage{$opt}) eq 'SCALAR' ) { - print STDERR ("=> \$\$L{$opt} = \"$arg\"\n") if $debug; - ${$linkage{$opt}} = $arg; - } - elsif ( ref($linkage{$opt}) eq 'ARRAY' ) { - print STDERR ("=> push(\@{\$L{$opt}, \"$arg\")\n") - if $debug; - push (@{$linkage{$opt}}, $arg); - } - elsif ( ref($linkage{$opt}) eq 'CODE' ) { - print STDERR ("=> &L{$opt}(\"$opt\", \"$arg\")\n") - if $debug; - &{$linkage{$opt}}($opt, $arg); - } - else { - print STDERR ("Invalid REF type \"", ref($linkage{$opt}), - "\" in linkage\n"); - die ("Getopt::Long -- internal error!\n"); - } - } - # No entry in linkage means entry in userlinkage. - elsif ( $array ) { - if ( defined $userlinkage->{$opt} ) { - print STDERR ("=> push(\@{\$L{$opt}}, \"$arg\")\n") - if $debug; - push (@{$userlinkage->{$opt}}, $arg); - } - else { - print STDERR ("=>\$L{$opt} = [\"$arg\"]\n") - if $debug; - $userlinkage->{$opt} = [$arg]; - } + elsif ( $type eq "f" ) { # real number, int is also ok + if ( $arg !~ /^-?[0-9.]+([eE]-?[0-9]+)?$/ ) { + if ( defined $optarg || $mand eq "=" ) { + return 0 if $passthrough; + print STDERR ("Value \"", $arg, "\" invalid for option ", + $opt, " (real number expected)\n"); + $error++; + undef $opt; + # Push back. + unshift (@ARGV, $starter.$rest) if defined $rest; } else { - print STDERR ("=>\$L{$opt} = \"$arg\"\n") if $debug; - $userlinkage->{$opt} = $arg; + # Push back. + unshift (@ARGV, defined $rest ? $starter.$rest : $arg); + # Supply default value. + $arg = 0.0; } } } - - # Finish. - if ( $order == $PERMUTE ) { - # Push back accumulated arguments - print STDERR ("=> restoring \"", join('" "', @ret), "\"\n") - if $debug && @ret > 0; - unshift (@ARGV, @ret) if @ret > 0; + else { + die ("GetOpt::Long internal error (Can't happen)\n"); } - - return ($error == 0); + return 1; } ################ Package return ################