+# 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.
- <none> 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 <none>
+
+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<main>.
+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<POSIXLY_CORRECT> 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<newgetopt.pl> 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<Using a starter argument is
+strongly deprecated.>
+
+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'
--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<major>.C<minor>. 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
# 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:
-#
-# <none> 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.
# 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 = '';
}
}
}
+
+ # 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");
}
}
- # 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;
}
}
}
+ my $type;
unless ( defined ( $type = $opctl{$tryopt} ) ) {
print STDERR ("Unknown option: ", $opt, "\n");
- $error++;
+ $Getopt::Long::error++;
next;
}
$opt = $tryopt;
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
}
# 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;
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 {
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 {
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;
projects / p5sagit/p5-mst-13.2.git / blobdiff