Refresh Getopt::Long to 2.9

1 files changed, 261 insertions, 107 deletions

diff --git a/lib/Getopt/Long.pm b/lib/Getopt/Long.pm
index 221cc54b39..ec4ccd98e9 100644
--- a/lib/Getopt/Long.pm
+++ b/lib/Getopt/Long.pm
@@ -1,26 +1,15 @@
-# GetOpt::Long.pm -- POSIX compatible options parsing
+# GetOpt::Long.pm -- Universal options parsing
 
-# RCS Status      : $Id: GetoptLong.pm,v 2.6 1997-01-11 13:12:01+01 jv Exp $
+package Getopt::Long;
+
+# RCS Status      : $Id: GetoptLong.pm,v 2.9 1997-03-02 15:00:05+01 jv Exp $
 # Author          : Johan Vromans
 # Created On      : Tue Sep 11 15:00:12 1990
 # Last Modified By: Johan Vromans
-# Last Modified On: Sat Jan 11 13:11:35 1997
-# Update Count    : 506
+# Last Modified On: Sun Mar  2 14:59:41 1997
+# Update Count    : 586
 # Status          : Released
 
-package Getopt::Long;
-require 5.000;
-require Exporter;
-
-@ISA = qw(Exporter);
-@EXPORT = qw(&GetOptions $REQUIRE_ORDER $PERMUTE $RETURN_IN_ORDER);
-$VERSION = sprintf("%d.%02d", '$Revision: 2.6002 $ ' =~ /(\d+)\.(\d+)/);
-use vars qw($autoabbrev $getopt_compat $ignorecase $bundling $order
-	    $passthrough $error $debug 
-	    $REQUIRE_ORDER $PERMUTE $RETURN_IN_ORDER
-	    $VERSION $major_version $minor_version);
-use strict;
-
 =head1 NAME
 
 GetOptions - extended processing of command line options
@@ -229,7 +218,7 @@ of this option. If no linkage is specified, options "foo", "bar" and
 "blech" all will set $opt_foo.
 
 Option names may be abbreviated to uniqueness, depending on
-configuration variable $Getopt::Long::autoabbrev.
+configuration option B<auto_abbrev>.
 
 =head2 Non-option call-back routine
 
@@ -237,7 +226,9 @@ A special option specifier, E<lt>E<gt>, can be used to designate a subroutine
 to handle non-option arguments. GetOptions will immediately call this
 subroutine for every non-option it encounters in the options list.
 This subroutine gets the name of the non-option passed.
-This feature requires $Getopt::Long::order to have the value $PERMUTE.
+This feature requires configuration option B<permute>, see section
+CONFIGURATION OPTIONS.
+
 See also the examples.
 
 =head2 Option starters
@@ -273,10 +264,10 @@ setting the element of the hash %opt_name with key "name" to "value"
 (if the "=value" portion is omitted it defaults to 1). If explicit
 linkage is supplied, this must be a reference to a HASH.
 
-If configuration variable $Getopt::Long::getopt_compat is set to a
-non-zero value, options that start with "+" or "-" may also include their
-arguments, e.g. "+foo=bar". This is for compatiblity with older
-implementations of the GNU "getopt" routine.
+If configuration option B<getopt_compat> is set (see section
+CONFIGURATION OPTIONS), options that start with "+" or "-" may also
+include their arguments, e.g. "+foo=bar". This is for compatiblity
+with older implementations of the GNU "getopt" routine.
 
 If the first argument to GetOptions is a string consisting of only
 non-alphanumeric characters, it is taken to specify the option starter
@@ -340,33 +331,59 @@ This will leave the non-options in @ARGV:
    $myfoo -> 2
    @ARGV -> qw(bar blech)
 
-=head1 CONFIGURATION VARIABLES
+=head1 CONFIGURATION OPTIONS
+
+B<GetOptions> can be configured by calling subroutine
+B<Getopt::Long::config>. This subroutine takes a list of quoted
+strings, each specifying a configuration option to be set, e.g.
+B<ignore_case>. Options can be reset by prefixing with B<no_>, e.g.
+B<no_ignore_case>. Case does not matter. Multiple calls to B<config>
+are possible.
 
-The following variables can be set to change the default behaviour of
-GetOptions():
+Previous versions of Getopt::Long used variables for the purpose of
+configuring. Although manipulating these variables still work, it
+is strongly encouraged to use the new B<config> routine. Besides, it
+is much easier.
+
+The following options are available:
 
 =over 12
 
-=item $Getopt::Long::autoabbrev      
+=item default
+
+This option causes all configuration options to be reset to their
+default values.
+
+=item auto_abbrev
 
 Allow option names to be abbreviated to uniqueness.
-Default is 1 unless environment variable
-POSIXLY_CORRECT has been set.
+Default is set unless environment variable
+POSIXLY_CORRECT has been set, in which case B<auto_abbrev> is reset.
 
-=item $Getopt::Long::getopt_compat   
+=item getopt_compat   
 
 Allow '+' to start options.
-Default is 1 unless environment variable
-POSIXLY_CORRECT has been set.
+Default is set unless environment variable
+POSIXLY_CORRECT has been set, in which case B<getopt_compat> is reset.
+
+=item require_order
+
+Whether non-options are allowed to be mixed with
+options.
+Default is set unless environment variable
+POSIXLY_CORRECT has been set, in which case b<require_order> is reset.
 
-=item $Getopt::Long::order           
+See also B<permute>, which is the opposite of B<require_order>.
+
+=item permute
 
 Whether non-options are allowed to be mixed with
 options.
-Default is $REQUIRE_ORDER if environment variable
-POSIXLY_CORRECT has been set, $PERMUTE otherwise.
+Default is set unless environment variable
+POSIXLY_CORRECT has been set, in which case B<permute> is reset.
+Note that B<permute> is the opposite of B<require_order>.
 
-$PERMUTE means that 
+If B<permute> is set, this means that 
 
     -foo arg1 -bar arg2 arg3
 
@@ -383,7 +400,7 @@ processed, except when B<--> is used:
 will call the call-back routine for arg1 and arg2, and terminate
 leaving arg2 in @ARGV.
 
-If $Getopt::Long::order is $REQUIRE_ORDER, options processing
+If B<require_order> is set, options processing
 terminates when the first non-option is encountered.
 
     -foo arg1 -bar arg2 arg3
@@ -392,9 +409,7 @@ is equivalent to
 
     -foo -- arg1 -bar arg2 arg3
 
-$RETURN_IN_ORDER is not supported by GetOptions().
-
-=item $Getopt::Long::bundling
+=item bundling (default: reset)
 
 Setting this variable to a non-zero value will allow single-character
 options to be bundled. To distinguish bundles from long option names,
@@ -419,24 +434,51 @@ is equivalent to
 
     scale -h 24 -w 80
 
+Note: resetting B<bundling> also resets B<bundling_override>.
+
+=item bundling_override (default: reset)
+
+If B<bundling_override> is set, bundling is enabled as with
+B<bundling> but now long option names override option bundles. In the
+above example, B<-vax> would be interpreted as the option "vax", not
+the bundle "v", "a", "x".
+
+Note: resetting B<bundling_override> also resets B<bundling>.
+
 B<Note:> Using option bundling can easily lead to unexpected results,
 especially when mixing long options and bundles. Caveat emptor.
 
-=item $Getopt::Long::ignorecase
+=item ignore_case  (default: set)
+
+If set, case is ignored when matching options.
+
+Note: resetting B<ignore_case> also resets B<ignore_case_always>.
+
+=item ignore_case_always (default: reset)
+
+When bundling is in effect, case is ignored on single-character
+options also. 
 
-Ignore case when matching options. Default is 1. When bundling is in
-effect, case is ignored on single-character options only if
-$Getopt::Long::ignorecase is greater than 1.
+Note: resetting B<ignore_case_always> also resets B<ignore_case>.
 
-=item $Getopt::Long::passthrough
+=item pass_through (default: reset)
 
 Unknown options are passed through in @ARGV instead of being flagged
 as errors. This makes it possible to write wrapper scripts that
 process only part of the user supplied options, and passes the
 remaining options to some other program.
 
-This can be very confusing, especially when $Getopt::Long::order is
-set to $PERMUTE.
+This can be very confusing, especially when B<permute> is also set.
+
+=item debug (default: reset)
+
+Enable copious debugging output.
+
+=back
+
+=head1 OTHER USEFUL VARIABLES
+
+=over 12
 
 =item $Getopt::Long::VERSION
 
@@ -444,7 +486,7 @@ The version number of this Getopt::Long implementation in the format
 C<major>.C<minor>. This can be used to have Exporter check the
 version, e.g.
 
-    use Getopt::Long 2.00;
+    use Getopt::Long 3.00;
 
 You can inspect $Getopt::Long::major_version and
 $Getopt::Long::minor_version for the individual components.
@@ -454,17 +496,13 @@ $Getopt::Long::minor_version for the individual components.
 Internal error flag. May be incremented from a call-back routine to
 cause options parsing to fail.
 
-=item $Getopt::Long::debug           
-
-Enable copious debugging output. Default is 0.
-
 =back
 
 =cut
 
-################ Introduction ################
-#
-# This program is Copyright 1990,1996 by Johan Vromans.
+################ Copyright ################
+
+# This program is Copyright 1990,1997 by Johan Vromans.
 # This program is free software; you can redistribute it and/or
 # modify it under the terms of the GNU General Public License
 # as published by the Free Software Foundation; either version 2
@@ -479,58 +517,66 @@ Enable copious debugging output. Default is 0.
 # the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, 
 # MA 02139, USA.
 
-################ Configuration Section ################
+################ Module Preamble ################
 
-# Values for $order. See GNU getopt.c for details.
-($REQUIRE_ORDER, $PERMUTE, $RETURN_IN_ORDER) = (0..2);
+use strict;
 
-my $gen_prefix;			# generic prefix (option starters)
+BEGIN {
+    require 5.00327;
+    use Exporter ();
+    use vars   qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
+    $VERSION   = sprintf("%d.%02d", q$Revision: 2.9 $ =~ /(\d+)\.(\d+)/);
 
-# Handle POSIX compliancy.
-if ( defined $ENV{"POSIXLY_CORRECT"} ) {
-    $gen_prefix = "(--|-)";
-    $autoabbrev = 0;		# no automatic abbrev of options
-    $bundling = 0;		# no bundling of single letter switches
-    $getopt_compat = 0;		# disallow '+' to start options
-    $order = $REQUIRE_ORDER;
-}
-else {
-    $gen_prefix = "(--|-|\\+)";
-    $autoabbrev = 1;		# automatic abbrev of options
-    $bundling = 0;		# bundling off by default
-    $getopt_compat = 1;		# allow '+' to start options
-    $order = $PERMUTE;
+    @ISA       = qw(Exporter);
+    @EXPORT    = qw(&GetOptions $REQUIRE_ORDER $PERMUTE $RETURN_IN_ORDER);
+    %EXPORT_TAGS = ();
+    @EXPORT_OK = qw();
 }
 
-# Other configurable settings.
-$debug = 0;			# for debugging
-$error = 0;			# error tally
-$ignorecase = 1;		# ignore case when matching options
-$passthrough = 0;		# leave unrecognized options alone
-($major_version, $minor_version) = $VERSION =~ /^(\d+)\.(\d+)/;
+use vars @EXPORT, @EXPORT_OK;
+# User visible variables.
+use vars qw(&config $error $debug $major_version $minor_version);
+# Deprecated visible variables.
+use vars qw($autoabbrev $getopt_compat $ignorecase $bundling $order
+	    $passthrough);
+
+################ Local Variables ################
 
-use vars qw($genprefix %opctl @opctl %bopctl $opt $arg $argend $array);
-use vars qw(%aliases $hash $key);
+my $gen_prefix;			# generic prefix (option starters)
+my $argend;			# option list terminator
+my %opctl;			# table of arg.specs (long and abbrevs)
+my %bopctl;			# table of arg.specs (bundles)
+my @opctl;			# the possible long option names
+my $pkg;			# current context. Needed if no linkage.
+my %aliases;			# alias table
+my $genprefix;			# so we can call the same module more 
+my $opt;			# current option
+my $arg;			# current option value, if any
+my $array;			# current option is array typed
+my $hash;			# current option is hash typed
+my $key;			# hash key for a hash option
+				# than once in differing environments
+my $config_defaults;		# set config defaults
+my $find_option;		# helper routine
 
 ################ Subroutines ################
 
 sub GetOptions {
 
     my @optionlist = @_;	# local copy of the option descriptions
-    local ($argend) = '--';		# option list terminator
-    local (%opctl);			# table of arg.specs (long and abbrevs)
-    local (%bopctl);			# table of arg.specs (bundles)
-    my $pkg = (caller)[0];	# current context
+    $argend = '--';		# option list terminator
+    %opctl = ();		# table of arg.specs (long and abbrevs)
+    %bopctl = ();		# table of arg.specs (bundles)
+    $pkg = (caller)[0];		# current context
 				# Needed if linkage is omitted.
-    local (%aliases);		# alias table
+    %aliases= ();		# alias table
     my @ret = ();		# accum for non-options
     my %linkage;		# linkage
     my $userlinkage;		# user supplied HASH
-    local ($genprefix) = $gen_prefix; # so we can call the same module more 
-				# than once in differing environments
+    $genprefix = $gen_prefix;	# so we can call the same module many times
     $error = 0;
 
-    print STDERR ('GetOptions $Revision: 2.6001 $ ',
+    print STDERR ('GetOptions $Revision: 2.9 $ ',
 		  "[GetOpt::Long $Getopt::Long::VERSION] -- ",
 		  "called from package \"$pkg\".\n",
 		  "  (@ARGV)\n",
@@ -566,7 +612,7 @@ sub GetOptions {
 	my $opt = shift (@optionlist);
 
 	# Strip leading prefix so people can specify "--foo=i" if they like.
-	$opt =~ s/^(?:$genprefix)+//s;
+	$opt = $' if $opt =~ /^($genprefix)+/;
 
 	if ( $opt eq '<>' ) {
 	    if ( (defined $userlinkage)
@@ -702,7 +748,7 @@ sub GetOptions {
     return 0 if $error;
 
     # Sort the possible long option names.
-    local (@opctl) = sort(keys (%opctl)) if $autoabbrev;
+    @opctl = sort(keys (%opctl)) if $autoabbrev;
 
     # Show the options tables if debugging.
     if ( $debug ) {
@@ -719,12 +765,6 @@ sub GetOptions {
 	}
     }
 
-    local ($opt);			# current option
-    local ($arg);			# current option value, if any
-    local ($array);			# current option is array typed
-    local ($hash);			# current option is hash typed
-    local ($key);			# hash key for a hash option
-
     # Process argument list
     while ( @ARGV > 0 ) {
 
@@ -748,7 +788,7 @@ sub GetOptions {
 	my $tryopt = $opt;
 
 	# find_option operates on the GLOBAL $opt and $arg!
-	if ( &find_option ) {
+	if ( &$find_option () ) {
 	    
 	    # find_option undefines $opt in case of errors.
 	    next unless defined $opt;
@@ -852,21 +892,92 @@ sub GetOptions {
     return ($error == 0);
 }
 
-sub find_option {
+sub config (@) {
+    my (@options) = @_;
+    my $opt;
+    foreach $opt ( @options ) {
+	my $try = lc ($opt);
+	my $action = 1;
+	if ( $try =~ /^no_?/ ) {
+	    $action = 0;
+	    $try = $';
+	}
+	if ( $try eq 'default' or $try eq 'defaults' ) {
+	    &$config_defaults () if $action;
+	}
+	elsif ( $try eq 'auto_abbrev' or $try eq 'autoabbrev' ) {
+	    $autoabbrev = $action;
+	}
+	elsif ( $try eq 'getopt_compat' ) {
+	    $getopt_compat = $action;
+	}
+	elsif ( $try eq 'ignorecase' or $try eq 'ignore_case' ) {
+	    $ignorecase = $action;
+	}
+	elsif ( $try eq 'ignore_case_always' ) {
+	    $ignorecase = $action ? 2 : 0;
+	}
+	elsif ( $try eq 'bundling' ) {
+	    $bundling = $action;
+	}
+	elsif ( $try eq 'bundling_override' ) {
+	    $bundling = $action ? 2 : 0;
+	}
+	elsif ( $try eq 'require_order' ) {
+	    $order = $action ? $REQUIRE_ORDER : $PERMUTE;
+	}
+	elsif ( $try eq 'permute' ) {
+	    $order = $action ? $PERMUTE : $REQUIRE_ORDER;
+	}
+	elsif ( $try eq 'pass_through' or $try eq 'passthrough' ) {
+	    $passthrough = $action;
+	}
+	elsif ( $try eq 'debug' ) {
+	    $debug = $action;
+	}
+	else {
+	    $Carp::CarpLevel = 1;
+	    Carp::croak("Getopt::Long: unknown config parameter \"$opt\"")
+	}
+    }
+}
+
+# Modified from Exporter. This one handles 2.001 and 2.01 etc just like 2.1.
+sub require_version {
+    no strict;
+    my ($self, $wanted) = @_;
+    my $pkg = ref $self || $self;
+    my $version = $ {"${pkg}::VERSION"} || "(undef)";
+
+    $wanted .= '.0' unless $wanted =~ /\./;
+    $wanted = $1 * 1000 + $2 if $wanted =~ /^(\d+)\.(\d+)$/;
+    $version = $1 * 1000 + $2 if $version =~ /^(\d+)\.(\d+)$/;
+    if ( $version < $wanted ) {
+	$version =~ s/^(\d+)(\d\d\d)$/$1.'.'.(0+$2)/e;
+	$wanted =~ s/^(\d+)(\d\d\d)$/$1.'.'.(0+$2)/e;
+	$Carp::CarpLevel = 1;
+	Carp::croak("$pkg $wanted required--this is only version $version")
+    }
+    $version;
+}
+
+################ Private Subroutines ################
+
+$find_option = sub {
 
-    return 0 unless $opt =~ /^($genprefix)(.*)/s;
+    return 0 unless $opt =~ /^$genprefix/;
 
-    $opt = $+;
-    my ($starter) = $1;
+    $opt = $';
+    my ($starter) = $&;
 
     my $optarg = undef;	# value supplied with --opt=value
     my $rest = undef;	# remainder from unbundling
 
     # If it is a long option, it may include the value.
     if (($starter eq "--" || $getopt_compat)
-	&& $opt =~ /^([^=]+)=(.*)/s ) {
+	&& $opt =~ /^([^=]+)=/ ) {
 	$opt = $1;
-	$optarg = $2;
+	$optarg = $';
 	print STDERR ("=> option \"", $opt, 
 		      "\", optarg = \"$optarg\"\n") if $debug;
     }
@@ -875,6 +986,7 @@ sub find_option {
 
     my $tryopt = $opt;		# option to try
     my $optbl = \%opctl;	# table to look it up (long names)
+    my $type;
 
     if ( $bundling && $starter eq '-' ) {
 	# Unbundle single letter option.
@@ -885,6 +997,15 @@ sub find_option {
 		      "$starter$tryopt$rest\n") if $debug;
 	$rest = undef unless $rest ne '';
 	$optbl = \%bopctl;	# look it up in the short names table
+
+	# If bundling == 2, long options can override bundles.
+	if ( $bundling == 2 and
+	     defined ($type = $opctl{$tryopt.$rest}) ) {
+	    print STDERR ("=> $starter$tryopt rebundled to ",
+			  "$starter$tryopt$rest\n") if $debug;
+	    $tryopt .= $rest;
+	    undef $rest;
+	}
     } 
 
     # Try auto-abbreviation.
@@ -933,7 +1054,7 @@ sub find_option {
     }
 
     # Check validity by fetching the info.
-    my $type = $optbl->{$tryopt};
+    $type = $optbl->{$tryopt} unless defined $type;
     unless  ( defined $type ) {
 	return 0 if $passthrough;
 	warn ("Unknown option: ", $opt, "\n");
@@ -992,7 +1113,7 @@ sub find_option {
     # Get key if this is a "name=value" pair for a hash option.
     $key = undef;
     if ($hash && defined $arg) {
-	($key, $arg) = ($arg =~ /(.*?)=(.*)/s) ? ($1, $2) : ($arg, 1);
+	($key, $arg) = ($arg =~ /=/o) ? ($`, $') : ($arg, 1);
     }
 
     #### Check if the argument is valid for this option ####
@@ -1058,7 +1179,40 @@ sub find_option {
 	die ("GetOpt::Long internal error (Can't happen)\n");
     }
     return 1;
-}
+};
+
+$config_defaults = sub {
+    # Handle POSIX compliancy.
+    if ( defined $ENV{"POSIXLY_CORRECT"} ) {
+	$gen_prefix = "(--|-)";
+	$autoabbrev = 0;		# no automatic abbrev of options
+	$bundling = 0;			# no bundling of single letter switches
+	$getopt_compat = 0;		# disallow '+' to start options
+	$order = $REQUIRE_ORDER;
+    }
+    else {
+	$gen_prefix = "(--|-|\\+)";
+	$autoabbrev = 1;		# automatic abbrev of options
+	$bundling = 0;			# bundling off by default
+	$getopt_compat = 1;		# allow '+' to start options
+	$order = $PERMUTE;
+    }
+    # Other configurable settings.
+    $debug = 0;			# for debugging
+    $error = 0;			# error tally
+    $ignorecase = 1;		# ignore case when matching options
+    $passthrough = 0;		# leave unrecognized options alone
+};
+
+################ Initialization ################
+
+# Values for $order. See GNU getopt.c for details.
+($REQUIRE_ORDER, $PERMUTE, $RETURN_IN_ORDER) = (0..2);
+# Version major/minor numbers.
+($major_version, $minor_version) = $VERSION =~ /^(\d+)\.(\d+)/;
+
+# Set defaults.
+&$config_defaults ();
 
 ################ Package return ################