This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
perl 5.002gamma: lib/Getopt/Long.pm
authorPerl 5 Porters <perl5-porters@africa.nicoh.com>
Wed, 7 Feb 1996 02:11:59 +0000 (02:11 +0000)
committerAndy Dougherty <doughera@lafcol.lafayette.edu>
Wed, 7 Feb 1996 02:11:59 +0000 (02:11 +0000)
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.

lib/Getopt/Long.pm

index a3bd4fb..25bf704 100644 (file)
+# 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'
@@ -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<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
@@ -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:
-# 
-#   <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.
@@ -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;