From: Perl 5 Porters Date: Wed, 7 Feb 1996 02:11:59 +0000 (+0000) Subject: perl 5.002gamma: lib/Getopt/Long.pm X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=404cbe937976a65d045dee723fafc71fd5b9e051;p=p5sagit%2Fp5-mst-13.2.git perl 5.002gamma: lib/Getopt/Long.pm I have replaced the version in 5.002 beta 3 with GetoptLong-2.1. This has some nice new features and has been extensively tested. --- diff --git a/lib/Getopt/Long.pm b/lib/Getopt/Long.pm index a3bd4fb..25bf704 100644 --- a/lib/Getopt/Long.pm +++ b/lib/Getopt/Long.pm @@ -1,94 +1,275 @@ +# GetOpt::Long.pm -- POSIX compatible options parsing + +# RCS Status : $Id: GetoptLong.pm,v 2.1 1996/02/02 20:24:35 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 +# Status : Released + package Getopt::Long; require 5.000; require Exporter; @ISA = qw(Exporter); -@EXPORT = qw(GetOptions); +@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 getopt processing +GetOptions - extended processing of command line options =head1 SYNOPSIS - use Getopt::Long; - $result = GetOptions (...option-descriptions...); + use Getopt::Long; + $result = GetOptions (...option-descriptions...); =head1 DESCRIPTION The Getopt::Long module implements an extended getopt function called -GetOptions(). 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. +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" -Each description should designate a valid Perl identifier, optionally -followed by an argument specifier. + -vax -Values for argument specifiers are: +which means the combination of B<-v>, B<-a> and B<-x>. With the new +syntax B<--vax> would be a single option, probably indicating a +computer architecture. - option does not take an argument - ! option does not take an argument and may be negated - =s :s option takes a mandatory (=) or optional (:) string argument - =i :i option takes a mandatory (=) or optional (:) integer argument - =f :f option takes a mandatory (=) or optional (:) real number argument +Command line options can be used to set values. These values can be +specified in one of two ways: -If option "name" is set, it will cause the Perl variable $opt_name to -be set to the specified value. The calling program can use this -variable to detect whether the option has been set. Options that do -not take an argument will be set to 1 (one). + --size 24 + --size=24 -Options that take an optional argument will be defined, but set to '' -if no actual argument has been supplied. +GetOptions is called with a list of option-descriptions, each of which +consists of two elements: the option specifier and the option linkage. +The option specifier defines the name of the option and, optionally, +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: -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. + &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 +$offset to get the value 24. + +Alternatively, the first argument to GetOptions may be a reference to +a HASH describing the linkage for the options. The following call is +equivalent to the example above: + + %optctl = ("size" => \$offset); + &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 +linkage specified in the HASH. + +The command line options are taken from array @ARGV. Upon completion +of GetOptions, @ARGV will contain the rest (i.e. the non-options) of +the command line. + +Each option specifier designates the name of the option, optionally +followed by an argument specifier. Values for argument specifiers are: + +=over 8 + +=item + +Option does not take an argument. +The option variable will be set to 1. + +=item ! + +Option does not take an argument and may be negated, i.e. prefixed by +"no". E.g. "foo!" will allow B<--foo> (with value 1) and B<-nofoo> +(with value 0). +The option variable will be set to 1, or 0 if negated. + +=item =s + +Option takes a mandatory string argument. +This string will be assigned to the option variable. +Note that even if the string argument starts with B<-> or B<-->, it +will not be considered an option on itself. + +=item :s + +Option takes an optional string argument. +This string will be assigned to the option variable. +If omitted, it will be assigned "" (an empty string). +If the string argument starts with B<-> or B<-->, it +will be considered an option on itself. + +=item =i + +Option takes a mandatory integer argument. +This value will be assigned to the option variable. +Note that the value may start with B<-> to indicate a negative +value. + +=item :i + +Option takes an optional integer argument. +This value will be assigned to the option variable. +If omitted, the value 0 will be assigned. +Note that the value may start with B<-> to indicate a negative +value. + +=item =f + +Option takes a mandatory real number argument. +This value will be assigned to the option variable. +Note that the value may start with B<-> to indicate a negative +value. + +=item :f + +Option takes an optional real number argument. +This value will be assigned to the option variable. +If omitted, the value 0 will be assigned. + +=back + +A lone dash B<-> is considered an option, the corresponding option +name is the empty string. + +A double dash on itself B<--> signals end of the options list. + +=head2 Linkage specification + +The linkage specifier is optional. If no linkage is explicitly +specified but a ref HASH is passed, GetOptions will place the value in +the HASH. For example: + + %optctl = (); + &GetOptions (\%optctl, "size=i"); + +will perform the equivalent of the assignment + + $optctl{"size"} = 24; + +For array options, a reference to an array is used, e.g.: + + %optctl = (); + &GetOptions (\%optctl, "sizes=i@"); + +with command line "-sizes 24 -sizes 48" will perform the equivalent of +the assignment + + $optctl{"sizes"} = [24, 48]; + +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, +characters that are not part of the syntax for variables are +translated to underscores. For example, "--fpp-struct-return" will set +the variable $opt_fpp_struct_return. Note that this variable resides +in the namespace of the calling program, not necessarily B
. +For example: + + &GetOptions ("size=i", "sizes=i@"); + +with command line "-size 10 -sizes 24 -sizes 48" will perform the +equivalent of the assignments + + $opt_size = 10; + @opt_sizes = (24, 48); + +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. + +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 +overwritten. + +If a REF ARRAY is supplied, the new value is appended (pushed) to the +referenced array. + +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. -Options that do not take a value may have an "!" argument specifier to -indicate that they may be negated. E.g. "foo!" will allow B<-foo> (which -sets $opt_foo to 1) and B<-nofoo> (which will set $opt_foo to 0). +=head2 Aliases and abbreviations The option name may actually be a list of option names, separated by -'|'s, e.g. B<"foo|bar|blech=s". In this example, options 'bar' and -'blech' will set $opt_foo instead. +"|"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 +"blech" all will set $opt_foo. Option names may be abbreviated to uniqueness, depending on -configuration variable $autoabbrev. +configuration variable $Getopt::Long::autoabbrev. -Dashes in option names are allowed (e.g. pcc-struct-return) and will -be translated to underscores in the corresponding Perl variable (e.g. -$opt_pcc_struct_return). Note that a lone dash "-" is considered an -option, corresponding Perl identifier is $opt_ . +=head2 Non-option call-back routine -A double dash "--" signals end of the options list. +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. +This feature requires $Getopt::Long::order to have the value $PERMUTE. +See also the examples. -If the first option of the list consists of non-alphanumeric -characters only, it is interpreted as a generic option starter. -Everything starting with one of the characters from the starter will -be considered an option. +=head2 Option starters -The default values for the option starters are "-" (traditional), "--" -(POSIX) and "+" (GNU, being phased out). +On the command line, options can start with B<-> (traditional), B<--> +(POSIX) and B<+> (GNU, now being phased out). The latter is not +allowed if the environment variable B has been +defined. Options that start with "--" may have an argument appended, separated with an "=", e.g. "--foo=bar". -If configuration variable $getopt_compat is set to a non-zero value, -options that start with "+" may also include their arguments, -e.g. "+foo=bar". +=head2 Return value A return status of 0 (false) indicates that the function detected one or more errors. +=head1 COMPATIBILITY + +Getopt::Long::GetOptions() is the successor of +B that came with Perl 4. It is fully upward compatible. +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. + +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 the first argument to GetOptions is a string consisting of only +non-alphanumeric characters, it is taken to specify the option starter +characters. Everything starting with one of these characters from the +starter will be considered an option. B + +For convenience, option specifiers may have a leading B<-> or B<-->, +so it is possible to write: + + GetOptions qw(-foo=s --bar=i --ar=s); + =head1 EXAMPLES -If option "one:i" (i.e. takes an optional integer argument), then -the following situations are handled: +If the option specifier is "one:i" (i.e. takes an optional integer +argument), then the following situations are handled: -one -two -> $opt_one = '', -two is next option -one -2 -> $opt_one = -2 -Also, assume "foo=s" and "bar:s" : +Also, assume specifiers "foo=s" and "bar:s" : -bar -xxx -> $opt_bar = '', '-xxx' is next option -foo -bar -> $opt_foo = '-bar' @@ -100,63 +281,127 @@ In GNU or POSIX format, option names and values can be combined: --bar= -> $opt_bar = '' --bar=-- -> $opt_bar = '--' +Example of using variabel references: + + $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' + $opt_bar = 24 + @ar = ('xx','yy') + +Example of using the <> option specifier: + + @ARGV = qw(-foo 1 bar -foo 2 blech); + &GetOptions("foo=i", \$myfoo, "<>", \&mysub); + +Results: + + &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); + +This will leave the non-options in @ARGV: + + $myfoo -> 2 + @ARGV -> qw(bar blech) + +=head1 CONFIGURATION VARIABLES + +The following variables can be set to change the default behaviour of +GetOptions(): + =over 12 -=item $autoabbrev +=item $Getopt::Long::autoabbrev Allow option names to be abbreviated to uniqueness. Default is 1 unless environment variable POSIXLY_CORRECT has been set. -=item $getopt_compat +=item $Getopt::Long::getopt_compat Allow '+' to start options. Default is 1 unless environment variable POSIXLY_CORRECT has been set. -=item $option_start - -Regexp with option starters. -Default is (--|-) if environment variable -POSIXLY_CORRECT has been set, (--|-|\+) otherwise. - -=item $order +=item $Getopt::Long::order Whether non-options are allowed to be mixed with options. Default is $REQUIRE_ORDER if environment variable POSIXLY_CORRECT has been set, $PERMUTE otherwise. -=item $ignorecase +$PERMUTE means that + + -foo arg1 -bar arg2 arg3 + +is equivalent to + + -foo -bar arg1 arg2 arg3 + +If a non-option call-back routine is specified, @ARGV will always be +empty upon succesful return of GetOptions since all options have been +processed, except when B<--> is used: + + -foo arg1 -bar arg2 -- arg3 + +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 +terminates when the first non-option is encountered. + + -foo arg1 -bar arg2 arg3 + +is equivalent to + + -foo -- arg1 -bar arg2 arg3 + +$RETURN_IN_ORDER is not supported by GetOptions(). + +=item $Getopt::Long::ignorecase Ignore case when matching options. Default is 1. -=item $debug +=item $Getopt::Long::VERSION -Enable debugging output. Default is 0. +The version number of this Getopt::Long implementation in the format +C.C. This can be used to have Exporter check the +version, e.g. -=back + use Getopt::Long 2.00; -=cut +You can inspect $Getopt::Long::major_version and +$Getopt::Long::minor_version for the individual components. -# newgetopt.pl -- new options parsing +=item $Getopt::Long::error -# SCCS Status : @(#)@ newgetopt.pl 1.14 -# Author : Johan Vromans -# Created On : Tue Sep 11 15:00:12 1990 -# Last Modified By: Johan Vromans -# Last Modified On: Sat Feb 12 18:24:02 1994 -# Update Count : 138 -# Status : Okay +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 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,1994 by Johan Vromans. +# This program is Copyright 1990,1996 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 @@ -171,210 +416,85 @@ Enable debugging output. Default is 0. # the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, # MA 02139, USA. -################ Description ################ -# -# Usage: -# -# require "newgetopt.pl"; -# ...change configuration values, if needed... -# $result = &NGetOpt (...option-descriptions...); -# -# Each description should designate a valid perl identifier, optionally -# followed by an argument specifier. -# -# Values for argument specifiers are: -# -# option does not take an argument -# ! option does not take an argument and may be negated -# =s :s option takes a mandatory (=) or optional (:) string argument -# =i :i option takes a mandatory (=) or optional (:) integer argument -# =f :f option takes a mandatory (=) or optional (:) real number argument -# -# If option "name" is set, it will cause the perl variable $opt_name to -# be set to the specified value. The calling program can use this -# variable to detect whether the option has been set. Options that do -# not take an argument will be set to 1 (one). -# -# Options that take an optional argument will be defined, but set to '' -# if no actual argument has been supplied. -# -# 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. -# -# Options that do not take a value may have an "!" argument spacifier to -# indicate that they may be negated. E.g. "foo!" will allow -foo (which -# sets $opt_foo to 1) and -nofoo (which will set $opt_foo to 0). -# -# The option name may actually be a list of option names, separated by -# '|'s, e.g. "foo|bar|blech=s". In this example, options 'bar' and -# 'blech' will set $opt_foo instead. -# -# Option names may be abbreviated to uniqueness, depending on -# configuration variable $autoabbrev. -# -# Dashes in option names are allowed (e.g. pcc-struct-return) and will -# be translated to underscores in the corresponding perl variable (e.g. -# $opt_pcc_struct_return). Note that a lone dash "-" is considered an -# option, corresponding perl identifier is $opt_ . -# -# A double dash "--" signals end of the options list. -# -# If the first option of the list consists of non-alphanumeric -# characters only, it is interpreted as a generic option starter. -# Everything starting with one of the characters from the starter will -# be considered an option. -# -# The default values for the option starters are "-" (traditional), "--" -# (POSIX) and "+" (GNU, being phased out). -# -# Options that start with "--" may have an argument appended, separated -# with an "=", e.g. "--foo=bar". -# -# If configuration varaible $getopt_compat is set to a non-zero value, -# options that start with "+" may also include their arguments, -# e.g. "+foo=bar". -# -# A return status of 0 (false) indicates that the function detected -# one or more errors. -# -################ Some examples ################ -# -# If option "one:i" (i.e. takes an optional integer argument), then -# the following situations are handled: -# -# -one -two -> $opt_one = '', -two is next option -# -one -2 -> $opt_one = -2 -# -# Also, assume "foo=s" and "bar:s" : -# -# -bar -xxx -> $opt_bar = '', '-xxx' is next option -# -foo -bar -> $opt_foo = '-bar' -# -foo -- -> $opt_foo = '--' -# -# In GNU or POSIX format, option names and values can be combined: -# -# +foo=blech -> $opt_foo = 'blech' -# --bar= -> $opt_bar = '' -# --bar=-- -> $opt_bar = '--' -# -################ Configuration values ################ -# -# $autoabbrev Allow option names to be abbreviated to uniqueness. -# Default is 1 unless environment variable -# POSIXLY_CORRECT has been set. -# -# $getopt_compat Allow '+' to start options. -# Default is 1 unless environment variable -# POSIXLY_CORRECT has been set. -# -# $option_start Regexp with option starters. -# Default is (--|-) if environment variable -# POSIXLY_CORRECT has been set, (--|-|\+) otherwise. -# -# $order Whether non-options are allowed to be mixed with -# options. -# Default is $REQUIRE_ORDER if environment variable -# POSIXLY_CORRECT has been set, $PERMUTE otherwise. -# -# $ignorecase Ignore case when matching options. Default is 1. -# -# $debug Enable debugging output. Default is 0. - ################ History ################ # -# 12-Feb-1994 Johan Vromans -# Added "!" for negation. -# Released to the net. -# -# 26-Aug-1992 Johan Vromans -# More POSIX/GNU compliance. -# Lone dash and double-dash are now independent of the option prefix -# that is used. -# Make errors in NGetOpt parameters fatal. -# Allow options to be mixed with arguments. -# Check $ENV{"POSIXLY_CORRECT"} to suppress this. -# Allow --foo=bar and +foo=bar (but not -foo=bar). -# Allow options to be abbreviated to minimum needed for uniqueness. -# (Controlled by configuration variable $autoabbrev.) -# Allow alias names for options (e.g. "foo|bar=s"). -# Allow "-" in option names (e.g. --pcc-struct-return). Dashes are -# translated to "_" to form valid perl identifiers -# (e.g. $opt_pcc_struct_return). +# 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. # -# 2-Jun-1992 Johan Vromans -# Do not use //o to allow multiple NGetOpt calls with different delimeters. -# Prevent typeless option from using previous $array state. -# Prevent empty option from being eaten as a (negative) number. -# -# 25-May-1992 Johan Vromans -# Add array options. "foo=s@" will return an array @opt_foo that -# contains all values that were supplied. E.g. "-foo one -foo -two" will -# return @opt_foo = ("one", "-two"); -# Correct bug in handling options that allow for a argument when followed -# by another option. -# -# 4-May-1992 Johan Vromans -# Add $ignorecase to match options in either case. -# Allow '' option. -# -# 19-Mar-1992 Johan Vromans -# Allow require from packages. -# NGetOpt is now defined in the package that requires it. -# @ARGV and $opt_... are taken from the package that calls it. -# Use standard (?) option prefixes: -, -- and +. -# -# 20-Sep-1990 Johan Vromans -# Set options w/o argument to 1. -# Correct the dreadful semicolon/require bug. +# 26-Dec-1995 Johan Vromans +# Import from netgetopt.pl. +# Turned into a decent module. +# Added linkage argument. ################ Configuration Section ################ -{ +# Values for $order. See GNU getopt.c for details. +($Getopt::Long::REQUIRE_ORDER, + $Getopt::Long::PERMUTE, + $Getopt::Long::RETURN_IN_ORDER) = (0..2); - # Values for $order. See GNU getopt.c for details. - $REQUIRE_ORDER = 0; - $PERMUTE = 1; - $RETURN_IN_ORDER = 2; - $RETURN_IN_ORDER = 2; # avoid typo warning with -w +my $gen_prefix; # generic prefix (option starters) - # Handle POSIX compliancy. - if ( defined $ENV{"POSIXLY_CORRECT"} ) { - $autoabbrev = 0; # no automatic abbrev of options (???) - $getopt_compat = 0; # disallow '+' to start options - $option_start = "(--|-)"; - $order = $REQUIRE_ORDER; - } - else { - $autoabbrev = 1; # automatic abbrev of options - $getopt_compat = 1; # allow '+' to start options - $option_start = "(--|-|\\+)"; - $order = $PERMUTE; - } - - # Other configurable settings. - $debug = 0; # for debugging - $ignorecase = 1; # ignore case when matching options - $argv_end = "--"; # don't change this! +# 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; } +# 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; + ################ Subroutines ################ sub GetOptions { - @optionlist = @_; #'; - - local ($[) = 0; - local ($genprefix) = $option_start; - local ($argend) = $argv_end; - local ($error) = 0; - local ($opt, $arg, $type, $mand, %opctl); - local ($pkg) = (caller)[0]; - local ($optarg); - local (%aliases); - local (@ret) = (); - - print STDERR "NGetOpt 1.14 -- called from $pkg\n" if $debug; + 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 + # Needed if linkage is omitted. + my %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; + + print STDERR ("GetOptions $Getopt::Long::version", + " [GetOpt::Long $Getopt::Long::VERSION] -- ", + "called from package \"$pkg\".\n", + " autoabbrev=$Getopt::Long::autoabbrev". + ",getopt_compat=$Getopt::Long::getopt_compat", + ",genprefix=\"$genprefix\"", + ",order=$Getopt::Long::order", + ",ignorecase=$Getopt::Long::ignorecase", + ".\n") + if $debug; + + # Check for ref HASH as first argument. + $userlinkage = undef; + if ( ref($optionlist[0]) && ref($optionlist[0]) eq 'HASH' ) { + $userlinkage = shift (@optionlist); + } # See if the first element of the optionlist contains option # starter characters. @@ -387,21 +507,46 @@ sub GetOptions { # Verify correctness of optionlist. %opctl = (); - foreach $opt ( @optionlist ) { - $opt =~ tr/A-Z/a-z/ if $ignorecase; + while ( @optionlist > 0 ) { + my $opt = shift (@optionlist); + + # Strip leading prefix so people can specify "-foo=i" if they like. + $opt = $' if $opt =~ /^($genprefix)+/; + + if ( $opt eq '<>' ) { + if ( (defined $userlinkage) + && !(@optionlist > 0 && ref($optionlist[0])) + && (exists $userlinkage->{$opt}) + && ref($userlinkage->{$opt}) ) { + unshift (@optionlist, $userlinkage->{$opt}); + } + unless ( @optionlist > 0 + && ref($optionlist[0]) && ref($optionlist[0]) eq 'CODE' ) { + warn ("Option spec <> requires a reference to a subroutine\n"); + $Getopt::Long::error++; + next; + } + $linkage{'<>'} = shift (@optionlist); + next; + } + + $opt =~ tr/A-Z/a-z/ if $Getopt::Long::ignorecase; if ( $opt !~ /^(\w+[-\w|]*)?(!|[=:][infse]@?)?$/ ) { - die ("Error in option spec: \"", $opt, "\"\n"); - $error++; + warn ("Error in option spec: \"", $opt, "\"\n"); + $Getopt::Long::error++; next; } - local ($o, $c, $a) = ($1, $2); + my ($o, $c, $a) = ($1, $2); if ( ! defined $o ) { - $opctl{''} = defined $c ? $c : ''; + # empty -> '-' option + $opctl{$o = ''} = defined $c ? $c : ''; } else { # Handle alias names - foreach ( split (/\|/, $o)) { + my @o = split (/\|/, $o); + $o = $o[0]; + foreach ( @o ) { if ( defined $c && $c eq '!' ) { $opctl{"no$_"} = $c; $c = ''; @@ -417,13 +562,65 @@ sub GetOptions { } } } + + # If no linkage is supplied in the @optionlist, copy it from + # the userlinkage if available. + if ( defined $userlinkage ) { + unless ( @optionlist > 0 && ref($optionlist[0]) ) { + if ( exists $userlinkage->{$o} && ref($userlinkage->{$o}) ) { + print STDERR ("=> found userlinkage for \"$o\": ", + "$userlinkage->{$o}\n") + if $debug; + unshift (@optionlist, $userlinkage->{$o}); + } + else { + # Do nothing. Being undefined will be handled later. + next; + } + } + } + + # Copy the linkage. If omitted, link to global variable. + 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' ) { + $linkage{$o} = shift (@optionlist); + } + else { + warn ("Invalid option linkage for \"", $opt, "\"\n"); + $Getopt::Long::error++; + } + } + else { + # Link to global $opt_XXX variable. + # Make sure a valid perl identifier results. + my $ov = $o; + $ov =~ s/\W/_/g; + if ( $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; + eval ("\$linkage{\$o} = \\\$".$pkg."::opt_$ov;"); + } + } } - @opctl = sort(keys (%opctl)) if $autoabbrev; - return 0 if $error; + # Bail out if errors found. + return 0 if $Getopt::Long::error; + + # Sort the possible option names. + my @opctl = sort(keys (%opctl)) if $Getopt::Long::autoabbrev; + # Show if debugging. if ( $debug ) { - local ($arrow, $k, $v); + my ($arrow, $k, $v); $arrow = "=> "; while ( ($k,$v) = each(%opctl) ) { print STDERR ($arrow, "\$opctl{\"$k\"} = \"$v\"\n"); @@ -431,74 +628,87 @@ sub GetOptions { } } - # Process argument list + my $opt; # current option + my $arg; # current option value + my $array; # current option is array typed - while ( $#ARGV >= 0 ) { + # Process argument list + while ( @ARGV > 0 ) { # >>> See also the continue block <<< #### Get next argument #### $opt = shift (@ARGV); - print STDERR ("=> option \"", $opt, "\"\n") if $debug; $arg = undef; - $optarg = undef; + my $optarg = undef; $array = 0; + print STDERR ("=> option \"", $opt, "\"\n") if $debug; #### Determine what we have #### # Double dash is option list terminator. if ( $opt eq $argend ) { - unshift (@ARGV, @ret) if $order == $PERMUTE; - return ($error == 0); + # Finish. Push back accumulated arguments and return. + unshift (@ARGV, @ret) + if $Getopt::Long::order == $Getopt::Long::PERMUTE; + return ($Getopt::Long::error == 0); } - elsif ( $opt =~ /^$genprefix/ ) { + + 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_compat && $+ eq "+")) && - $opt =~ /^([^=]+)=/ ) { + if (($& eq "--" || ($Getopt::Long::getopt_compat && $& eq "+")) + && $opt =~ /^([^=]+)=/ ) { $opt = $1; $optarg = $'; print STDERR ("=> option \"", $opt, - "\", optarg = \"$optarg\"\n") - if $debug; + "\", optarg = \"$optarg\"\n") if $debug; } } - # Not an option. Save it if we may permute... - elsif ( $order == $PERMUTE ) { - push (@ret, $opt); + + # Not an option. Save it if we $PERMUTE and don't have a <>. + elsif ( $Getopt::Long::order == $Getopt::Long::PERMUTE ) { + # Try non-options call-back. + my $cb; + if ( (defined ($cb = $linkage{'<>'})) ) { + &$cb($opt); + } + else { + push (@ret, $opt); + } next; } + # ...otherwise, terminate. else { - # Push back and exit. + # Push this one back and exit. unshift (@ARGV, $opt); - return ($error == 0); + return ($Getopt::Long::error == 0); } #### Look it up ### - $opt =~ tr/A-Z/a-z/ if $ignorecase; + $opt =~ tr/A-Z/a-z/ if $Getopt::Long::ignorecase; - local ($tryopt) = $opt; - if ( $autoabbrev ) { - local ($pat, @hits); + 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. - @hits = grep (/^$pat/, @opctl); + my @hits = grep (/^$pat/, @opctl); print STDERR ("=> ", 0+@hits, " hits (@hits) with \"$pat\" ", - "out of ", 0+@opctl, "\n") - if $debug; + "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"); - $error++; + $Getopt::Long::error++; next; } @@ -510,9 +720,10 @@ sub GetOptions { } } + my $type; unless ( defined ( $type = $opctl{$tryopt} ) ) { print STDERR ("Unknown option: ", $opt, "\n"); - $error++; + $Getopt::Long::error++; next; } $opt = $tryopt; @@ -524,7 +735,7 @@ sub GetOptions { if ( $type eq '' || $type eq '!' ) { if ( defined $optarg ) { print STDERR ("Option ", $opt, " does not take an argument\n"); - $error++; + $Getopt::Long::error++; } elsif ( $type eq '' ) { $arg = 1; # supply explicit value @@ -537,15 +748,16 @@ sub GetOptions { } # Get mandatory status and type info. + my $mand; ($mand, $type, $array) = $type =~ /^(.)(.)(@?)$/; # Check if there is an option argument available. - if ( defined $optarg ? ($optarg eq '') : ($#ARGV < 0) ) { + if ( defined $optarg ? ($optarg eq '') : (@ARGV <= 0) ) { # Complain if this option needs an argument. if ( $mand eq "=" ) { print STDERR ("Option ", $opt, " requires an argument\n"); - $error++; + $Getopt::Long::error++; } if ( $mand eq ":" ) { $arg = $type eq "s" ? '' : 0; @@ -582,7 +794,7 @@ sub GetOptions { if ( defined $optarg || $mand eq "=" ) { print STDERR ("Value \"", $arg, "\" invalid for option ", $opt, " (number expected)\n"); - $error++; + $Getopt::Long::error++; undef $arg; # don't assign it } else { @@ -600,7 +812,7 @@ sub GetOptions { if ( defined $optarg || $mand eq "=" ) { print STDERR ("Value \"", $arg, "\" invalid for option ", $opt, " (real number expected)\n"); - $error++; + $Getopt::Long::error++; undef $arg; # don't assign it } else { @@ -613,35 +825,67 @@ sub GetOptions { next; } - die ("NGetOpt internal error (Can't happen)\n"); + die ("GetOpt::Long internal error (Can't happen)\n"); } continue { if ( defined $arg ) { $opt = $aliases{$opt} if defined $aliases{$opt}; - # Make sure a valid perl identifier results. - $opt =~ s/\W/_/g; - if ( $array ) { - print STDERR ('=> push (@', $pkg, '\'opt_', $opt, ", \"$arg\")\n") - if $debug; - eval ('push(@' . $pkg . '\'opt_' . $opt . ", \$arg);"); + + 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]; + } } else { - print STDERR ('=> $', $pkg, '\'opt_', $opt, " = \"$arg\"\n") - if $debug; - eval ('$' . $pkg . '\'opt_' . $opt . " = \$arg;"); + print STDERR ("=>\$L{$opt} = \"$arg\"\n") if $debug; + $userlinkage->{$opt} = $arg; } } } - if ( $order == $PERMUTE && @ret > 0 ) { - unshift (@ARGV, @ret); + # Finish. + if ( $Getopt::Long::order == $Getopt::Long::PERMUTE ) { + # Push back accumulated arguments + unshift (@ARGV, @ret) if @ret > 0; } - return ($error == 0); + + return ($Getopt::Long::error == 0); } ################ Package return ################ -1; - - +# Returning 1 is so boring... +$Getopt::Long::major_version * 1000 + $Getopt::Long::minor_version;