diff options
Diffstat (limited to 'lib/Getopt/Long.pm')
| -rw-r--r-- | lib/Getopt/Long.pm | 1006 |
1 files changed, 670 insertions, 336 deletions
diff --git a/lib/Getopt/Long.pm b/lib/Getopt/Long.pm index 5dd5d16b25..b0bcf6b810 100644 --- a/lib/Getopt/Long.pm +++ b/lib/Getopt/Long.pm @@ -1,22 +1,15 @@ -# GetOpt::Long.pm -- POSIX compatible options parsing +# GetOpt::Long.pm -- Universal options parsing -# RCS Status : $Id: GetoptLong.pm,v 2.1 1996/02/02 20:24:35 jv Exp $ +package Getopt::Long; + +# RCS Status : $Id: GetoptLong.pm,v 2.10 1997-04-18 22:21:10+02 jv Exp $ # Author : Johan Vromans # Created On : Tue Sep 11 15:00:12 1990 # Last Modified By: Johan Vromans -# Last Modified On: Fri Feb 2 21:24:32 1996 -# Update Count : 347 +# Last Modified On: Wed Apr 16 16:27:33 1997 +# Update Count : 597 # Status : Released -package Getopt::Long; -require 5.000; -require Exporter; - -@ISA = qw(Exporter); -@EXPORT = qw(&GetOptions $REQUIRE_ORDER $PERMUTE $RETURN_IN_ORDER); -$VERSION = sprintf("%d.%02d", q$Revision: 2.1 $ =~ /(\d+)\.(\d+)/); -use strict; - =head1 NAME GetOptions - extended processing of command line options @@ -32,9 +25,10 @@ The Getopt::Long module implements an extended getopt function called GetOptions(). This function adheres to the POSIX syntax for command line options, with GNU extensions. In general, this means that options have long names instead of single letters, and are introduced with a -double dash "--". There is no bundling of command line options, as was -the case with the more traditional single-letter approach. For -example, the UNIX "ps" command can be given the command line "option" +double dash "--". Support for bundling of command line options, as was +the case with the more traditional single-letter approach, is provided +but not enabled by default. For example, the UNIX "ps" command can be +given the command line "option" -vax @@ -55,7 +49,7 @@ the value it can take. The option linkage is usually a reference to a variable that will be set when the option is used. For example, the following call to GetOptions: - &GetOptions("size=i" => \$offset); + GetOptions("size=i" => \$offset); will accept a command line option "size" that must have an integer value. With a command line of "--size 24" this will cause the variable @@ -66,7 +60,7 @@ a HASH describing the linkage for the options. The following call is equivalent to the example above: %optctl = ("size" => \$offset); - &GetOptions(\%optctl, "size=i"); + GetOptions(\%optctl, "size=i"); Linkage may be specified using either of the above methods, or both. Linkage specified in the argument list takes precedence over the @@ -81,7 +75,7 @@ followed by an argument specifier. Values for argument specifiers are: =over 8 -=item <none> +=item E<lt>noneE<gt> Option does not take an argument. The option variable will be set to 1. @@ -150,7 +144,7 @@ specified but a ref HASH is passed, GetOptions will place the value in the HASH. For example: %optctl = (); - &GetOptions (\%optctl, "size=i"); + GetOptions (\%optctl, "size=i"); will perform the equivalent of the assignment @@ -159,13 +153,24 @@ will perform the equivalent of the assignment For array options, a reference to an array is used, e.g.: %optctl = (); - &GetOptions (\%optctl, "sizes=i@"); + GetOptions (\%optctl, "sizes=i@"); with command line "-sizes 24 -sizes 48" will perform the equivalent of 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, @@ -175,7 +180,7 @@ the variable $opt_fpp_struct_return. Note that this variable resides in the namespace of the calling program, not necessarily B<main>. For example: - &GetOptions ("size=i", "sizes=i@"); + GetOptions ("size=i", "sizes=i@"); with command line "-size 10 -sizes 24 -sizes 48" will perform the equivalent of the assignments @@ -187,7 +192,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 @@ -196,6 +201,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. @@ -204,19 +214,21 @@ 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 -op this option. If no linkage is specified, options "foo", "bar" and +of 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 -configuration variable $Getopt::Long::autoabbrev. +configuration option B<auto_abbrev>. =head2 Non-option call-back routine -A special option specifier, <>, can be used to designate a subroutine +A special option specifier, E<lt>E<gt>, 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. -This feature requires $Getopt::Long::order to have the value $PERMUTE. +This feature requires configuration option B<permute>, see section +CONFIGURATION OPTIONS. + See also the examples. =head2 Option starters @@ -242,13 +254,20 @@ 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 configuration variable $Getopt::Long::getopt_compat is set to a -non-zero value, options that start with "+" may also include their -arguments, e.g. "+foo=bar". This is for compatiblity with older -implementations of the GNU "getopt" routine. +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 option B<getopt_compat> is set (see section +CONFIGURATION OPTIONS), 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. If the first argument to GetOptions is a string consisting of only non-alphanumeric characters, it is taken to specify the option starter @@ -281,64 +300,90 @@ In GNU or POSIX format, option names and values can be combined: --bar= -> $opt_bar = '' --bar=-- -> $opt_bar = '--' -Example of using variabel references: +Example of using variable references: - $ret = &GetOptions ('foo=s', \$foo, 'bar=i', 'ar=s', \@ar); + $ret = GetOptions ('foo=s', \$foo, 'bar=i', 'ar=s', \@ar); With command line options "-foo blech -bar 24 -ar xx -ar yy" this will result in: - $bar = 'blech' + $foo = 'blech' $opt_bar = 24 @ar = ('xx','yy') -Example of using the <> option specifier: +Example of using the E<lt>E<gt> option specifier: @ARGV = qw(-foo 1 bar -foo 2 blech); - &GetOptions("foo=i", \$myfoo, "<>", \&mysub); + GetOptions("foo=i", \$myfoo, "<>", \&mysub); Results: - &mysub("bar") will be called (with $myfoo being 1) - &mysub("blech") will be called (with $myfoo being 2) + mysub("bar") will be called (with $myfoo being 1) + mysub("blech") will be called (with $myfoo being 2) Compare this with: @ARGV = qw(-foo 1 bar -foo 2 blech); - &GetOptions("foo=i", \$myfoo); + GetOptions("foo=i", \$myfoo); This will leave the non-options in @ARGV: $myfoo -> 2 @ARGV -> qw(bar blech) -=head1 CONFIGURATION VARIABLES +=head1 CONFIGURATION OPTIONS + +B<GetOptions> can be configured by calling subroutine +B<Getopt::Long::config>. This subroutine takes a list of quoted +strings, each specifying a configuration option to be set, e.g. +B<ignore_case>. Options can be reset by prefixing with B<no_>, e.g. +B<no_ignore_case>. Case does not matter. Multiple calls to B<config> +are possible. + +Previous versions of Getopt::Long used variables for the purpose of +configuring. Although manipulating these variables still work, it +is strongly encouraged to use the new B<config> routine. Besides, it +is much easier. -The following variables can be set to change the default behaviour of -GetOptions(): +The following options are available: =over 12 -=item $Getopt::Long::autoabbrev +=item default + +This option causes all configuration options to be reset to their +default values. + +=item auto_abbrev Allow option names to be abbreviated to uniqueness. -Default is 1 unless environment variable -POSIXLY_CORRECT has been set. +Default is set unless environment variable +POSIXLY_CORRECT has been set, in which case B<auto_abbrev> is reset. -=item $Getopt::Long::getopt_compat +=item getopt_compat Allow '+' to start options. -Default is 1 unless environment variable -POSIXLY_CORRECT has been set. +Default is set unless environment variable +POSIXLY_CORRECT has been set, in which case B<getopt_compat> is reset. + +=item require_order -=item $Getopt::Long::order +Whether non-options are allowed to be mixed with +options. +Default is set unless environment variable +POSIXLY_CORRECT has been set, in which case b<require_order> is reset. + +See also B<permute>, which is the opposite of B<require_order>. + +=item permute Whether non-options are allowed to be mixed with options. -Default is $REQUIRE_ORDER if environment variable -POSIXLY_CORRECT has been set, $PERMUTE otherwise. +Default is set unless environment variable +POSIXLY_CORRECT has been set, in which case B<permute> is reset. +Note that B<permute> is the opposite of B<require_order>. -$PERMUTE means that +If B<permute> is set, this means that -foo arg1 -bar arg2 arg3 @@ -355,7 +400,7 @@ processed, except when B<--> is used: will call the call-back routine for arg1 and arg2, and terminate leaving arg2 in @ARGV. -If $Getopt::Long::order is $REQUIRE_ORDER, options processing +If B<require_order> is set, options processing terminates when the first non-option is encountered. -foo arg1 -bar arg2 arg3 @@ -364,11 +409,76 @@ is equivalent to -foo -- arg1 -bar arg2 arg3 -$RETURN_IN_ORDER is not supported by GetOptions(). +=item bundling (default: reset) + +Setting this variable to a non-zero value will allow single-character +options to be bundled. To distinguish bundles from long option names, +long options must be introduced with B<--> and single-character +options (and bundles) with B<->. For example, + + ps -vax --vax + +would be equivalent to + + ps -v -a -x --vax + +provided "vax", "v", "a" and "x" have been defined to be valid +options. + +Bundled options can also include a value in the bundle; this value has +to be the last part of the bundle, e.g. + + scale -h24 -w80 + +is equivalent to + + scale -h 24 -w 80 + +Note: resetting B<bundling> also resets B<bundling_override>. + +=item bundling_override (default: reset) + +If B<bundling_override> is set, bundling is enabled as with +B<bundling> but now long option names override option bundles. In the +above example, B<-vax> would be interpreted as the option "vax", not +the bundle "v", "a", "x". + +Note: resetting B<bundling_override> also resets B<bundling>. + +B<Note:> Using option bundling can easily lead to unexpected results, +especially when mixing long options and bundles. Caveat emptor. + +=item ignore_case (default: set) + +If set, case is ignored when matching options. + +Note: resetting B<ignore_case> also resets B<ignore_case_always>. + +=item ignore_case_always (default: reset) + +When bundling is in effect, case is ignored on single-character +options also. + +Note: resetting B<ignore_case_always> also resets B<ignore_case>. + +=item pass_through (default: reset) + +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 B<permute> is also set. + +=item debug (default: reset) + +Enable copious debugging output. + +=back -=item $Getopt::Long::ignorecase +=head1 OTHER USEFUL VARIABLES -Ignore case when matching options. Default is 1. +=over 12 =item $Getopt::Long::VERSION @@ -376,7 +486,7 @@ The version number of this Getopt::Long implementation in the format C<major>.C<minor>. This can be used to have Exporter check the version, e.g. - use Getopt::Long 2.00; + use Getopt::Long 3.00; You can inspect $Getopt::Long::major_version and $Getopt::Long::minor_version for the individual components. @@ -386,22 +496,13 @@ $Getopt::Long::minor_version for the individual components. Internal error flag. May be incremented from a call-back routine to cause options parsing to fail. -=item $Getopt::Long::debug - -Enable copious debugging output. Default is 0. - =back =cut -################ Introduction ################ -# -# This package implements an extended getopt function. This function -# adheres to the new syntax (long option names, no bundling). It tries -# to implement the better functionality of traditional, GNU and POSIX -# getopt functions. -# -# This program is Copyright 1990,1996 by Johan Vromans. +################ Copyright ################ + +# This program is Copyright 1990,1997 by Johan Vromans. # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License # as published by the Free Software Foundation; either version 2 @@ -416,77 +517,76 @@ Enable copious debugging output. Default is 0. # the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, # MA 02139, USA. -################ History ################ -# -# 13-Jan-1996 Johan Vromans -# Generalized the linkage interface. -# Eliminated the linkage argument. -# Add code references as a possible value for the option linkage. -# Add option specifier <> to have a call-back for non-options. -# -# 26-Dec-1995 Johan Vromans -# Import from netgetopt.pl. -# Turned into a decent module. -# Added linkage argument. - -################ Configuration Section ################ +################ Module Preamble ################ -# Values for $order. See GNU getopt.c for details. -($Getopt::Long::REQUIRE_ORDER, - $Getopt::Long::PERMUTE, - $Getopt::Long::RETURN_IN_ORDER) = (0..2); +use strict; -my $gen_prefix; # generic prefix (option starters) +BEGIN { + require 5.003; + use Exporter (); + use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS); + $VERSION = sprintf("%d.%02d", q$Revision: 2.10 $ =~ /(\d+)\.(\d+)/); -# Handle POSIX compliancy. -if ( defined $ENV{"POSIXLY_CORRECT"} ) { - $gen_prefix = "(--|-)"; - $Getopt::Long::autoabbrev = 0; # no automatic abbrev of options - $Getopt::Long::getopt_compat = 0; # disallow '+' to start options - $Getopt::Long::order = $Getopt::Long::REQUIRE_ORDER; -} -else { - $gen_prefix = "(--|-|\\+)"; - $Getopt::Long::autoabbrev = 1; # automatic abbrev of options - $Getopt::Long::getopt_compat = 1; # allow '+' to start options - $Getopt::Long::order = $Getopt::Long::PERMUTE; + @ISA = qw(Exporter); + @EXPORT = qw(&GetOptions $REQUIRE_ORDER $PERMUTE $RETURN_IN_ORDER); + %EXPORT_TAGS = (); + @EXPORT_OK = qw(); } -# Other configurable settings. -$Getopt::Long::debug = 0; # for debugging -$Getopt::Long::error = 0; # error tally -$Getopt::Long::ignorecase = 1; # ignore case when matching options -($Getopt::Long::version, - $Getopt::Long::major_version, - $Getopt::Long::minor_version) = '$Revision: 2.1 $ ' =~ /: ((\d+)\.(\d+))/; -$Getopt::Long::version .= '*' if length('$Locker: $ ') > 12; +use vars @EXPORT, @EXPORT_OK; +# User visible variables. +use vars qw($error $debug $major_version $minor_version); +# Deprecated visible variables. +use vars qw($autoabbrev $getopt_compat $ignorecase $bundling $order + $passthrough); + +################ Local Variables ################ + +my $gen_prefix; # generic prefix (option starters) +my $argend; # option list terminator +my %opctl; # table of arg.specs (long and abbrevs) +my %bopctl; # table of arg.specs (bundles) +my @opctl; # the possible long option names +my $pkg; # current context. Needed if no linkage. +my %aliases; # alias table +my $genprefix; # so we can call the same module more +my $opt; # current option +my $arg; # current option value, if any +my $array; # current option is array typed +my $hash; # current option is hash typed +my $key; # hash key for a hash option + # than once in differing environments +my $config_defaults; # set config defaults +my $find_option; # helper routine ################ Subroutines ################ sub GetOptions { my @optionlist = @_; # local copy of the option descriptions - my $argend = '--'; # option list terminator - my %opctl; # table of arg.specs - my $pkg = (caller)[0]; # current context + $argend = '--'; # option list terminator + %opctl = (); # table of arg.specs (long and abbrevs) + %bopctl = (); # table of arg.specs (bundles) + $pkg = (caller)[0]; # current context # Needed if linkage is omitted. - my %aliases; # alias table + %aliases= (); # alias table my @ret = (); # accum for non-options my %linkage; # linkage my $userlinkage; # user supplied HASH - my $debug = $Getopt::Long::debug; # convenience - my $genprefix = $gen_prefix; # so we can call the same module more - # than once in differing environments - $Getopt::Long::error = 0; + $genprefix = $gen_prefix; # so we can call the same module many times + $error = 0; - print STDERR ("GetOptions $Getopt::Long::version", - " [GetOpt::Long $Getopt::Long::VERSION] -- ", + print STDERR ('GetOptions $Revision: 2.10 $ ', + "[GetOpt::Long $Getopt::Long::VERSION] -- ", "called from package \"$pkg\".\n", - " autoabbrev=$Getopt::Long::autoabbrev". - ",getopt_compat=$Getopt::Long::getopt_compat", + " (@ARGV)\n", + " autoabbrev=$autoabbrev". + ",bundling=$bundling", + ",getopt_compat=$getopt_compat", + ",order=$order", + ",\n ignorecase=$ignorecase", + ",passthrough=$passthrough", ",genprefix=\"$genprefix\"", - ",order=$Getopt::Long::order", - ",ignorecase=$Getopt::Long::ignorecase", ".\n") if $debug; @@ -507,10 +607,11 @@ sub GetOptions { # Verify correctness of optionlist. %opctl = (); + %bopctl = (); while ( @optionlist > 0 ) { my $opt = shift (@optionlist); - # Strip leading prefix so people can specify "-foo=i" if they like. + # Strip leading prefix so people can specify "--foo=i" if they like. $opt = $' if $opt =~ /^($genprefix)+/; if ( $opt eq '<>' ) { @@ -523,35 +624,54 @@ sub GetOptions { unless ( @optionlist > 0 && ref($optionlist[0]) && ref($optionlist[0]) eq 'CODE' ) { warn ("Option spec <> requires a reference to a subroutine\n"); - $Getopt::Long::error++; + $error++; next; } $linkage{'<>'} = shift (@optionlist); next; } - $opt =~ tr/A-Z/a-z/ if $Getopt::Long::ignorecase; - if ( $opt !~ /^(\w+[-\w|]*)?(!|[=:][infse]@?)?$/ ) { + if ( $opt !~ /^(\w+[-\w|]*)?(!|[=:][infse][@%]?)?$/ ) { warn ("Error in option spec: \"", $opt, "\"\n"); - $Getopt::Long::error++; + $error++; next; } my ($o, $c, $a) = ($1, $2); + $c = '' unless defined $c; if ( ! defined $o ) { # empty -> '-' option - $opctl{$o = ''} = defined $c ? $c : ''; + $opctl{$o = ''} = $c; } 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 + && ($bundling ? length($o) > 1 : 1)); + foreach ( @o ) { - if ( defined $c && $c eq '!' ) { - $opctl{"no$_"} = $c; - $c = ''; + if ( $bundling && length($_) == 1 ) { + $_ = lc ($_) if $ignorecase > 1; + if ( $c eq '!' ) { + $opctl{"no$_"} = $c; + warn ("Ignoring '!' modifier for short option $_\n"); + $c = ''; + } + $opctl{$_} = $bopctl{$_} = $c; + } + else { + $_ = lc ($_) if $ignorecase; + if ( $c eq '!' ) { + $opctl{"no$_"} = $c; + $c = ''; + } + $opctl{$_} = $c; } - $opctl{$_} = defined $c ? $c : ''; if ( defined $a ) { # Note alias. $aliases{$_} = $a; @@ -561,6 +681,7 @@ sub GetOptions { $a = $_; } } + $o = $linko; } # If no linkage is supplied in the @optionlist, copy it from @@ -584,14 +705,26 @@ sub GetOptions { if ( @optionlist > 0 && ref($optionlist[0]) ) { print STDERR ("=> link \"$o\" to $optionlist[0]\n") if $debug; - if ( ref($optionlist[0]) eq 'SCALAR' - || ref($optionlist[0]) eq 'ARRAY' - || ref($optionlist[0]) eq 'CODE' ) { + if ( ref($optionlist[0]) =~ /^(SCALAR|CODE)$/ ) { $linkage{$o} = shift (@optionlist); } + elsif ( ref($optionlist[0]) =~ /^(ARRAY)$/ ) { + $linkage{$o} = shift (@optionlist); + $opctl{$o} .= '@' + if $opctl{$o} ne '' and $opctl{$o} !~ /\@$/; + $bopctl{$o} .= '@' + if $bundling and $bopctl{$o} ne '' and $bopctl{$o} !~ /\@$/; + } + elsif ( ref($optionlist[0]) =~ /^(HASH)$/ ) { + $linkage{$o} = shift (@optionlist); + $opctl{$o} .= '%' + if $opctl{$o} ne '' and $opctl{$o} !~ /\%$/; + $bopctl{$o} .= '%' + if $bundling and $bopctl{$o} ne '' and $bopctl{$o} !~ /\%$/; + } else { warn ("Invalid option linkage for \"", $opt, "\"\n"); - $Getopt::Long::error++; + $error++; } } else { @@ -599,11 +732,16 @@ sub GetOptions { # Make sure a valid perl identifier results. my $ov = $o; $ov =~ s/\W/_/g; - if ( $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; @@ -613,12 +751,12 @@ sub GetOptions { } # Bail out if errors found. - return 0 if $Getopt::Long::error; + return 0 if $error; - # Sort the possible option names. - my @opctl = sort(keys (%opctl)) if $Getopt::Long::autoabbrev; + # Sort the possible long option names. + @opctl = sort(keys (%opctl)) if $autoabbrev; - # Show if debugging. + # Show the options tables if debugging. if ( $debug ) { my ($arrow, $k, $v); $arrow = "=> "; @@ -626,23 +764,21 @@ sub GetOptions { print STDERR ($arrow, "\$opctl{\"$k\"} = \"$v\"\n"); $arrow = " "; } + $arrow = "=> "; + while ( ($k,$v) = each(%bopctl) ) { + print STDERR ($arrow, "\$bopctl{\"$k\"} = \"$v\"\n"); + $arrow = " "; + } } - my $opt; # current option - my $arg; # current option value - my $array; # current option is array typed - # Process argument list while ( @ARGV > 0 ) { - # >>> See also the continue block <<< - #### Get next argument #### $opt = shift (@ARGV); $arg = undef; - my $optarg = undef; - $array = 0; + $array = $hash = 0; print STDERR ("=> option \"", $opt, "\"\n") if $debug; #### Determine what we have #### @@ -651,33 +787,93 @@ sub GetOptions { if ( $opt eq $argend ) { # Finish. Push back accumulated arguments and return. unshift (@ARGV, @ret) - if $Getopt::Long::order == $Getopt::Long::PERMUTE; - return ($Getopt::Long::error == 0); - } - - if ( $opt =~ /^$genprefix/ ) { - # Looks like an option. - $opt = $'; # option name (w/o prefix) - # If it is a long opt, it may include the value. - if (($& eq "--" || ($Getopt::Long::getopt_compat && $& eq "+")) - && $opt =~ /^([^=]+)=/ ) { - $opt = $1; - $optarg = $'; - print STDERR ("=> option \"", $opt, - "\", optarg = \"$optarg\"\n") if $debug; - } + if $order == $PERMUTE; + return ($error == 0); + } + 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 <>. - elsif ( $Getopt::Long::order == $Getopt::Long::PERMUTE ) { + elsif ( $order == $PERMUTE ) { # Try non-options call-back. my $cb; if ( (defined ($cb = $linkage{'<>'})) ) { - &$cb($opt); + &$cb($tryopt); } else { - push (@ret, $opt); + print STDERR ("=> saving \"$tryopt\" ", + "(not an option, may permute)\n") if $debug; + push (@ret, $tryopt); } next; } @@ -685,207 +881,345 @@ sub GetOptions { # ...otherwise, terminate. else { # Push this one back and exit. - unshift (@ARGV, $opt); - return ($Getopt::Long::error == 0); + unshift (@ARGV, $tryopt); + return ($error == 0); } - #### Look it up ### + } - $opt =~ tr/A-Z/a-z/ if $Getopt::Long::ignorecase; + # Finish. + if ( $order == $PERMUTE ) { + # Push back accumulated arguments + print STDERR ("=> restoring \"", join('" "', @ret), "\"\n") + if $debug && @ret > 0; + unshift (@ARGV, @ret) if @ret > 0; + } - my $tryopt = $opt; - if ( $Getopt::Long::autoabbrev ) { - my $pat; - - # Turn option name into pattern. - ($pat = $opt) =~ s/(\W)/\\$1/g; - # Look up in option names. - my @hits = grep (/^$pat/, @opctl); - print STDERR ("=> ", 0+@hits, " hits (@hits) with \"$pat\" ", - "out of ", 0+@opctl, "\n") if $debug; - - # Check for ambiguous results. - unless ( (@hits <= 1) || (grep ($_ eq $opt, @hits) == 1) ) { - print STDERR ("Option ", $opt, " is ambiguous (", - join(", ", @hits), ")\n"); - $Getopt::Long::error++; - next; - } + return ($error == 0); +} - # Complete the option name, if appropriate. - if ( @hits == 1 && $hits[0] ne $opt ) { - $tryopt = $hits[0]; - print STDERR ("=> option \"$opt\" -> \"$tryopt\"\n") - if $debug; - } +sub config (@) { + my (@options) = @_; + my $opt; + foreach $opt ( @options ) { + my $try = lc ($opt); + my $action = 1; + if ( $try =~ /^no_?/ ) { + $action = 0; + $try = $'; } - - my $type; - unless ( defined ( $type = $opctl{$tryopt} ) ) { - print STDERR ("Unknown option: ", $opt, "\n"); - $Getopt::Long::error++; - next; + if ( $try eq 'default' or $try eq 'defaults' ) { + &$config_defaults () if $action; } - $opt = $tryopt; - print STDERR ("=> found \"$type\" for ", $opt, "\n") if $debug; - - #### Determine argument status #### - - # 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"); - $Getopt::Long::error++; - } - elsif ( $type eq '' ) { - $arg = 1; # supply explicit value - } - else { - substr ($opt, 0, 2) = ''; # strip NO prefix - $arg = 0; # supply explicit value - } - next; + elsif ( $try eq 'auto_abbrev' or $try eq 'autoabbrev' ) { + $autoabbrev = $action; + } + elsif ( $try eq 'getopt_compat' ) { + $getopt_compat = $action; } + elsif ( $try eq 'ignorecase' or $try eq 'ignore_case' ) { + $ignorecase = $action; + } + elsif ( $try eq 'ignore_case_always' ) { + $ignorecase = $action ? 2 : 0; + } + elsif ( $try eq 'bundling' ) { + $bundling = $action; + } + elsif ( $try eq 'bundling_override' ) { + $bundling = $action ? 2 : 0; + } + elsif ( $try eq 'require_order' ) { + $order = $action ? $REQUIRE_ORDER : $PERMUTE; + } + elsif ( $try eq 'permute' ) { + $order = $action ? $PERMUTE : $REQUIRE_ORDER; + } + elsif ( $try eq 'pass_through' or $try eq 'passthrough' ) { + $passthrough = $action; + } + elsif ( $try eq 'debug' ) { + $debug = $action; + } + else { + $Carp::CarpLevel = 1; + Carp::croak("Getopt::Long: unknown config parameter \"$opt\"") + } + } +} - # Get mandatory status and type info. - my $mand; - ($mand, $type, $array) = $type =~ /^(.)(.)(@?)$/; +# Modified from Exporter. This one handles 2.001 and 2.01 etc just like 2.1. +sub require_version { + no strict; + my ($self, $wanted) = @_; + my $pkg = ref $self || $self; + my $version = $ {"${pkg}::VERSION"} || "(undef)"; + + $wanted .= '.0' unless $wanted =~ /\./; + $wanted = $1 * 1000 + $2 if $wanted =~ /^(\d+)\.(\d+)$/; + $version = $1 * 1000 + $2 if $version =~ /^(\d+)\.(\d+)$/; + if ( $version < $wanted ) { + $version =~ s/^(\d+)(\d\d\d)$/$1.'.'.(0+$2)/e; + $wanted =~ s/^(\d+)(\d\d\d)$/$1.'.'.(0+$2)/e; + $Carp::CarpLevel = 1; + Carp::croak("$pkg $wanted required--this is only version $version") + } + $version; +} - # Check if there is an option argument available. - if ( defined $optarg ? ($optarg eq '') : (@ARGV <= 0) ) { +################ Private Subroutines ################ - # Complain if this option needs an argument. - if ( $mand eq "=" ) { - print STDERR ("Option ", $opt, " requires an argument\n"); - $Getopt::Long::error++; - } - if ( $mand eq ":" ) { - $arg = $type eq "s" ? '' : 0; - } - next; - } +$find_option = sub { - # Get (possibly optional) argument. - $arg = defined $optarg ? $optarg : shift (@ARGV); + return 0 unless $opt =~ /^$genprefix/; - #### Check if the argument is valid for this option #### + $opt = $'; + my ($starter) = $&; - if ( $type eq "s" ) { # string - # A mandatory string takes anything. - next if $mand eq "="; + my $optarg = undef; # value supplied with --opt=value + my $rest = undef; # remainder from unbundling - # An optional string takes almost anything. - next if defined $optarg; - next if $arg eq "-"; + # 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; + } - # Check for option or option list terminator. - if ($arg eq $argend || - $arg =~ /^$genprefix.+/) { - # Push back. - unshift (@ARGV, $arg); - # Supply empty value. - $arg = ''; + #### Look it up ### + + my $tryopt = $opt; # option to try + my $optbl = \%opctl; # table to look it up (long names) + my $type; + + 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 + + # If bundling == 2, long options can override bundles. + if ( $bundling == 2 and + defined ($type = $opctl{$tryopt.$rest}) ) { + print STDERR ("=> $starter$tryopt rebundled to ", + "$starter$tryopt$rest\n") if $debug; + $tryopt .= $rest; + undef $rest; + } + } + + # 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; } - next; + # 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++; + undef $opt; + return 1; + } + @hits = keys(%hit); } - 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"); - $Getopt::Long::error++; - undef $arg; # don't assign it - } - else { - # Push back. - unshift (@ARGV, $arg); - # Supply default value. - $arg = 0; - } - } - 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; } + } - 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"); - $Getopt::Long::error++; - undef $arg; # don't assign it - } - else { - # Push back. - unshift (@ARGV, $arg); - # Supply default value. - $arg = 0.0; - } - } - next; + # Map to all lowercase if ignoring case. + elsif ( $ignorecase ) { + $tryopt = lc ($opt); + } + + # Check validity by fetching the info. + $type = $optbl->{$tryopt} unless defined $type; + 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; + + #### Determine argument status #### + + # 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; + } - die ("GetOpt::Long internal error (Can't happen)\n"); + # 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; } - continue { - if ( defined $arg ) { - $opt = $aliases{$opt} if defined $aliases{$opt}; + # Get (possibly optional) argument. + $arg = (defined $rest ? $rest + : (defined $optarg ? $optarg : shift (@ARGV))); - if ( defined $linkage{$opt} ) { - print STDERR ("=> ref(\$L{$opt}) -> ", - ref($linkage{$opt}), "\n") if $debug; + # 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 ( 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]; - } + #### Check if the argument is valid for this option #### + + if ( $type eq "s" ) { # string + # A mandatory string takes anything. + return 1 if $mand eq "="; + + # An optional string takes almost anything. + return 1 if defined $optarg || defined $rest; + return 1 if $arg eq "-"; # ?? + + # Check for option or option list terminator. + if ($arg eq $argend || + $arg =~ /^$genprefix.+/) { + # Push back. + unshift (@ARGV, $arg); + # Supply empty value. + $arg = ''; + } + } + + 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 { - 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; } } } - # Finish. - if ( $Getopt::Long::order == $Getopt::Long::PERMUTE ) { - # Push back accumulated arguments - unshift (@ARGV, @ret) if @ret > 0; + 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 { + # Push back. + unshift (@ARGV, defined $rest ? $starter.$rest : $arg); + # Supply default value. + $arg = 0.0; + } + } + } + else { + die ("GetOpt::Long internal error (Can't happen)\n"); } + return 1; +}; + +$config_defaults = sub { + # Handle POSIX compliancy. + if ( defined $ENV{"POSIXLY_CORRECT"} ) { + $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 = "(--|-|\\+)"; + $autoabbrev = 1; # automatic abbrev of options + $bundling = 0; # bundling off by default + $getopt_compat = 1; # allow '+' to start options + $order = $PERMUTE; + } + # Other configurable settings. + $debug = 0; # for debugging + $error = 0; # error tally + $ignorecase = 1; # ignore case when matching options + $passthrough = 0; # leave unrecognized options alone +}; - return ($Getopt::Long::error == 0); -} +################ Initialization ################ + +# Values for $order. See GNU getopt.c for details. +($REQUIRE_ORDER, $PERMUTE, $RETURN_IN_ORDER) = (0..2); +# Version major/minor numbers. +($major_version, $minor_version) = $VERSION =~ /^(\d+)\.(\d+)/; + +# Set defaults. +&$config_defaults (); ################ Package return ################ -# Returning 1 is so boring... -$Getopt::Long::major_version * 1000 + $Getopt::Long::minor_version; +1; |