Upgrade to Getopt::Long 2.28.

p4raw-id: //depot/perl@14872

3 files changed, 157 insertions, 46 deletions

diff --git a/lib/Getopt/Long.pm b/lib/Getopt/Long.pm
index ea5aee6b30..f1ac4f554f 100644
--- a/lib/Getopt/Long.pm
+++ b/lib/Getopt/Long.pm
@@ -2,17 +2,17 @@
 
 package Getopt::Long;
 
-# RCS Status      : $Id: GetoptLong.pm,v 2.47 2001-11-15 18:14:22+01 jv Exp $
+# RCS Status      : $Id: GetoptLong.pm,v 2.54 2002-02-20 15:00:10+01 jv Exp $
 # Author          : Johan Vromans
 # Created On      : Tue Sep 11 15:00:12 1990
 # Last Modified By: Johan Vromans
-# Last Modified On: Thu Nov 15 18:13:36 2001
-# Update Count    : 987
+# Last Modified On: Wed Feb 20 15:00:04 2002
+# Update Count    : 1045
 # Status          : Released
 
 ################ Copyright ################
 
-# This program is Copyright 1990,2001 by Johan Vromans.
+# This program is Copyright 1990,2002 by Johan Vromans.
 # This program is free software; you can redistribute it and/or
 # modify it under the terms of the Perl Artistic License or the
 # GNU General Public License as published by the Free Software
@@ -35,10 +35,10 @@ use 5.004;
 use strict;
 
 use vars qw($VERSION);
-$VERSION        =  2.26_03;
+$VERSION        =  2.28;
 # For testing versions only.
 use vars qw($VERSION_STRING);
-$VERSION_STRING = "2.26_03";
+$VERSION_STRING = "2.28";
 
 use Exporter;
 
@@ -218,28 +218,32 @@ sub getoptions {
 package Getopt::Long;
 
 # Indices in option control info.
-use constant CTL_TYPE   => 0;
+# Note that ParseOptions uses the fields directly. Search for 'hard-wired'.
+use constant CTL_TYPE    => 0;
 #use constant   CTL_TYPE_FLAG   => '';
 #use constant   CTL_TYPE_NEG    => '!';
 #use constant   CTL_TYPE_INCR   => '+';
 #use constant   CTL_TYPE_INT    => 'i';
+#use constant   CTL_TYPE_INTINC => 'I';
 #use constant   CTL_TYPE_XINT   => 'o';
 #use constant   CTL_TYPE_FLOAT  => 'f';
 #use constant   CTL_TYPE_STRING => 's';
 
-use constant CTL_MAND   => 1;
+use constant CTL_CNAME   => 1;
 
-use constant CTL_DEST   => 2;
+use constant CTL_MAND    => 2;
+
+use constant CTL_DEST    => 3;
  use constant   CTL_DEST_SCALAR => 0;
  use constant   CTL_DEST_ARRAY  => 1;
  use constant   CTL_DEST_HASH   => 2;
  use constant   CTL_DEST_CODE   => 3;
 
-use constant CTL_RANGE  => 3;
-
-use constant CTL_REPEAT => 4;
+use constant CTL_DEFAULT => 4;
 
-use constant CTL_CNAME  => 5;
+# FFU.
+#use constant CTL_RANGE   => ;
+#use constant CTL_REPEAT  => ;
 
 sub GetOptions {
 
@@ -257,7 +261,7 @@ sub GetOptions {
     $error = '';
 
     print STDERR ("GetOpt::Long $Getopt::Long::VERSION (",
-		  '$Revision: 2.47 $', ") ",
+		  '$Revision: 2.54 $', ") ",
 		  "called from package \"$pkg\".",
 		  "\n  ",
 		  "ARGV: (@ARGV)",
@@ -316,6 +320,9 @@ sub GetOptions {
 	    unless ( @optionlist > 0
 		    && ref($optionlist[0]) && ref($optionlist[0]) eq 'CODE' ) {
 		$error .= "Option spec <> requires a reference to a subroutine\n";
+		# Kill the linkage (to avoid another error).
+		shift (@optionlist)
+		  if @optionlist && ref($optionlist[0]);
 		next;
 	    }
 	    $linkage{'<>'} = shift (@optionlist);
@@ -327,6 +334,9 @@ sub GetOptions {
 	unless ( defined $name ) {
 	    # Failed. $orig contains the error message. Sorry for the abuse.
 	    $error .= $orig;
+	    # Kill the linkage (to avoid another error).
+	    shift (@optionlist)
+	      if @optionlist && ref($optionlist[0]);
 	    next;
 	}
 
@@ -599,11 +609,12 @@ sub OptCtl ($) {
     "[".
       join(",",
 	   "\"$v[CTL_TYPE]\"",
+	   "\"$v[CTL_CNAME]\"",
 	   $v[CTL_MAND] ? "O" : "M",
 	   ("\$","\@","\%","\&")[$v[CTL_DEST] || 0],
-	   $v[CTL_RANGE] || '',
-	   $v[CTL_REPEAT] || '',
-	   "\"$v[CTL_CNAME]\"",
+	   "\"$v[CTL_DEFAULT]\"",
+#	   $v[CTL_RANGE] || '',
+#	   $v[CTL_REPEAT] || '',
 	  ). "]";
 }
 
@@ -611,7 +622,7 @@ sub OptCtl ($) {
 sub ParseOptionSpec ($$) {
     my ($opt, $opctl) = @_;
 
-    # Match option spec. Allow '?' as an alias only.
+    # Match option spec.
     if ( $opt !~ m;^
 		   (
 		     # Option name
@@ -623,8 +634,11 @@ sub ParseOptionSpec ($$) {
 		     # Either modifiers ...
 		     [!+]
 		     |
-		     # ... or a value/dest specification.
-		     [=:][ionfs][@%]?
+		     # ... or a value/dest specification
+		     [=:] [ionfs] [@%]?
+		     |
+		     # ... or an optional-with-default spec
+		     : (?: -?\d+ | \+ ) [@%]?
 		   )?
 		   $;x ) {
 	return (undef, "Error in option spec: \"$opt\"\n");
@@ -654,7 +668,18 @@ sub ParseOptionSpec ($$) {
     # Construct the opctl entries.
     my $entry;
     if ( $spec eq '' || $spec eq '+' || $spec eq '!' ) {
-	$entry = [$spec,0,CTL_DEST_SCALAR,undef,undef,$orig];
+	# Fields are hard-wired here.
+	$entry = [$spec,$orig,0,CTL_DEST_SCALAR,undef];
+    }
+    elsif ( $spec =~ /:(-?\d+|\+)([@%])?/ ) {
+	my $def = $1;
+	my $dest = $2;
+	my $type = $def eq '+' ? 'I' : 'i';
+	$dest ||= '$';
+	$dest = $dest eq '@' ? CTL_DEST_ARRAY
+	  : $dest eq '%' ? CTL_DEST_HASH : CTL_DEST_SCALAR;
+	# Fields are hard-wired here.
+	$entry = [$type,$orig,0,$dest,$def eq '+' ? undef : $def];
     }
     else {
 	my ($mand, $type, $dest) = $spec =~ /([=:])([ionfs])([@%])?/;
@@ -662,15 +687,21 @@ sub ParseOptionSpec ($$) {
 	$dest ||= '$';
 	$dest = $dest eq '@' ? CTL_DEST_ARRAY
 	  : $dest eq '%' ? CTL_DEST_HASH : CTL_DEST_SCALAR;
-	$entry = [$type,$mand eq '=',$dest,undef,undef,$orig];
+	# Fields are hard-wired here.
+	$entry = [$type,$orig,$mand eq '=',$dest,undef];
     }
 
     # Process all names. First is canonical, the rest are aliases.
+    my $dups = '';
     foreach ( @names ) {
 
 	$_ = lc ($_)
 	  if $ignorecase > (($bundling && length($_) == 1) ? 1 : 0);
 
+	if ( exists $opctl->{$_} ) {
+	    $dups .= "Duplicate specification \"$opt\" for option \"$_\"\n";
+	}
+
 	if ( $spec eq '!' ) {
 	    $opctl->{"no$_"} = $entry;
 	    $opctl->{$_} = [@$entry];
@@ -681,6 +712,13 @@ sub ParseOptionSpec ($$) {
 	}
     }
 
+    if ( $dups && $^W ) {
+	require 'Carp.pm';
+	$Carp::CarpLevel = 2;
+	foreach ( split(/\n+/, $dups) ) {
+	    Carp::cluck($_);
+	}
+    }
     ($names[0], $orig);
 }
 
@@ -696,7 +734,7 @@ sub FindOption ($$$$) {
     print STDERR ("=> find \"$opt\"\n") if $debug;
 
     return (0) unless $opt =~ /^$prefix(.*)$/s;
-    return (0) if $opt eq "-" && !defined $opctl->{""};
+    return (0) if $opt eq "-" && !defined $opctl->{''};
 
     $opt = $+;
     my $starter = $1;
@@ -735,7 +773,7 @@ sub FindOption ($$$$) {
 	else {
 	    $tryopt = $opt;
 	    # Unbundle single letter option.
-	    $rest = length ($tryopt) > 0 ? substr ($tryopt, 1) : "";
+	    $rest = length ($tryopt) > 0 ? substr ($tryopt, 1) : '';
 	    $tryopt = substr ($tryopt, 0, 1);
 	    $tryopt = lc ($tryopt) if $ignorecase > 1;
 	    print STDERR ("=> $starter$tryopt unbundled from ",
@@ -819,7 +857,8 @@ sub FindOption ($$$$) {
 	    undef $opt;
 	}
 	elsif ( $type eq '' || $type eq '+' ) {
-	    $arg = 1;		# supply explicit value
+	    # Supply explicit value.
+	    $arg = 1;
 	}
 	else {
 	    $opt =~ s/^no//i;	# strip NO prefix
@@ -833,9 +872,9 @@ sub FindOption ($$$$) {
     my $mand = $ctl->[CTL_MAND];
 
     # Check if there is an option argument available.
-    if ( $gnu_compat && defined $optarg && $optarg eq "" ) {
-	return (1, $opt, $ctl, $type eq "s" ? "" : 0) unless $mand;
-	$optarg = 0 unless $type eq "s";
+    if ( $gnu_compat && defined $optarg && $optarg eq '' ) {
+	return (1, $opt, $ctl, $type eq 's' ? '' : 0) unless $mand;
+	$optarg = 0 unless $type eq 's';
     }
 
     # Check if there is an option argument available.
@@ -849,7 +888,15 @@ sub FindOption ($$$$) {
 	    $error++;
 	    return (1, undef);
 	}
-	return (1, $opt, $ctl, $type eq "s" ? '' : 0);
+	if ( $type eq 'I' ) {
+	    # Fake incremental type.
+	    my @c = @$ctl;
+	    $c[CTL_TYPE] = '+';
+	    return (1, $opt, \@c, 1);
+	}
+	return (1, $opt, $ctl,
+		defined($ctl->[CTL_DEFAULT]) ? $ctl->[CTL_DEFAULT] :
+		$type eq 's' ? '' : 0);
     }
 
     # Get (possibly optional) argument.
@@ -864,7 +911,7 @@ sub FindOption ($$$$) {
 
     #### Check if the argument is valid for this option ####
 
-    if ( $type eq "s" ) {	# string
+    if ( $type eq 's' ) {	# string
 	# A mandatory string takes anything.
 	return (1, $opt, $ctl, $arg, $key) if $mand;
 
@@ -883,21 +930,22 @@ sub FindOption ($$$$) {
 	}
     }
 
-    elsif ( $type eq "i" # numeric/integer
-	    || $type eq "o" ) { # dec/oct/hex/bin value
+    elsif ( $type eq 'i'	# numeric/integer
+            || $type eq 'I'	# numeric/integer w/ incr default
+	    || $type eq 'o' ) { # dec/oct/hex/bin value
 
 	my $o_valid =
-	  $type eq "o" ? "[-+]?[1-9][0-9]*|0x[0-9a-f]+|0b[01]+|0[0-7]*"
+	  $type eq 'o' ? "[-+]?[1-9][0-9]*|0x[0-9a-f]+|0b[01]+|0[0-7]*"
 	    : "[-+]?[0-9]+";
 
 	if ( $bundling && defined $rest && $rest =~ /^($o_valid)(.*)$/si ) {
 	    $arg = $1;
 	    $rest = $2;
-	    $arg = ($type eq "o" && $arg =~ /^0/) ? oct($arg) : 0+$arg;
+	    $arg = ($type eq 'o' && $arg =~ /^0/) ? oct($arg) : 0+$arg;
 	    unshift (@ARGV, $starter.$rest) if defined $rest && $rest ne '';
 	}
 	elsif ( $arg =~ /^($o_valid)$/si ) {
-	    $arg = ($type eq "o" && $arg =~ /^0/) ? oct($arg) : 0+$arg;
+	    $arg = ($type eq 'o' && $arg =~ /^0/) ? oct($arg) : 0+$arg;
 	}
 	else {
 	    if ( defined $optarg || $mand ) {
@@ -908,7 +956,7 @@ sub FindOption ($$$$) {
 		}
 		warn ("Value \"", $arg, "\" invalid for option ",
 		      $opt, " (",
-		      $type eq "o" ? "extended " : "",
+		      $type eq 'o' ? "extended " : '',
 		      "number expected)\n");
 		$error++;
 		# Push back.
@@ -918,13 +966,19 @@ sub FindOption ($$$$) {
 	    else {
 		# Push back.
 		unshift (@ARGV, defined $rest ? $starter.$rest : $arg);
+		if ( $type eq 'I' ) {
+		    # Fake incremental type.
+		    my @c = @$ctl;
+		    $c[CTL_TYPE] = '+';
+		    return (1, $opt, \@c, 1);
+		}
 		# Supply default value.
-		$arg = 0;
+		$arg = defined($ctl->[CTL_DEFAULT]) ? $ctl->[CTL_DEFAULT] : 0;
 	    }
 	}
     }
 
-    elsif ( $type eq "f" ) { # real number, int is also ok
+    elsif ( $type eq 'f' ) { # real number, int is also ok
 	# We require at least one digit before a point or 'e',
 	# and at least one digit following the point and 'e'.
 	# [-]NN[.NN][eNN]
@@ -1446,6 +1500,15 @@ and the value zero to numeric options.
 Note that if a string argument starts with C<-> or C<-->, it will be
 considered an option on itself.
 
+=item : I<number> [ I<desttype> ]
+
+Like C<:i>, but if the value is omitted, the I<number> will be assigned.
+
+=item : + [ I<desttype> ]
+
+Like C<:i>, but if the value is omitted, the current value for the
+option will be incremented.
+
 =back
 
 =head1 Advanced Possibilities
@@ -1762,10 +1825,22 @@ first.
 
 =item bundling (default: disabled)
 
-Enabling this option will allow single-character options to be bundled.
-To distinguish bundles from long option names, long options I<must> be
-introduced with C<--> and single-character options (and bundles) with
-C<->.
+Enabling this option will allow single-character options to be
+bundled. To distinguish bundles from long option names, long options
+I<must> be introduced with C<--> and bundles with C<->.
+
+Note that, if you have options C<a>, C<l> and C<all>, and
+auto_abbrev enabled, possible arguments and option settings are:
+
+    using argument               sets option(s)
+    ------------------------------------------
+    -a, --a                      a
+    -l, --l                      l
+    -al, -la, -ala, -all,...     a, l
+    --al, --all                  all
+
+The suprising part is that C<--a> sets option C<a> (due to auto
+completion), not C<all>.
 
 Note: disabling C<bundling> also disables C<bundling_override>.
 
@@ -1781,8 +1856,13 @@ especially when mixing long options and bundles. Caveat emptor.
 
 =item ignore_case  (default: enabled)
 
-If enabled, case is ignored when matching long option names. Single
-character options will be treated case-sensitive.
+If enabled, case is ignored when matching long option names. If,
+however, bundling is enabled as well, single character options will be
+treated case-sensitive.
+
+With C<ignore_case>, option specifications for options that only
+differ in case, e.g., C<"foo"> and C<"Foo">, will be flagged as
+duplicates.
 
 Note: disabling C<ignore_case> also disables C<ignore_case_always>.
 
@@ -1960,7 +2040,7 @@ Johan Vromans <jvromans@squirrel.nl>
 
 =head1 COPYRIGHT AND DISCLAIMER
 
-This program is Copyright 2001,1990 by Johan Vromans.
+This program is Copyright 2002,1990 by Johan Vromans.
 This program is free software; you can redistribute it and/or
 modify it under the terms of the Perl Artistic License or the
 GNU General Public License as published by the Free Software
diff --git a/lib/Getopt/Long/CHANGES b/lib/Getopt/Long/CHANGES
index deaa472fb2..004dfab9f8 100644
--- a/lib/Getopt/Long/CHANGES
+++ b/lib/Getopt/Long/CHANGES
@@ -1,6 +1,26 @@
+Changes in version 2.28
+-----------------------
+
+* When an option is specified more than once, a warning is generated
+  if perl is run with -w. This is a correction to 2.27, where it would
+  unconditionally die.
+
+  An example of duplicate specification is GetOptions('foo', 'foo'),
+  but also GetOptions('foo=s', 'foo') and GetOptions('Foo', 'foo')
+  (the latter only when ignore_case is in effect).
+
 Changes in version 2.27
 -----------------------
 
+* You can now specify integer options to take an optional argument.
+  that defaults to a specific value. E.g.,  GetOptions('foo:5' => \$var)
+  will allow $var to get the value 5 when no value was specified with
+  the -foo option on the command line.
+
+  Instead of a value, a '+' may be specified. E.g.,
+  GetOptions('foo:+' => \$var) will allow $var to be incremented when
+  no value was specified with the -foo option on the command line.
+
 * Fix several problems with internal and external use of 'die' and
   signal handlers.
 
@@ -14,10 +34,21 @@ Changes in version 2.27
 * Eliminated the use of autoloading. Autoloading kept generating
   problems during development, and when using perlcc.
 
+* Avoid errors on references when an option is found in error, e.g.
+  GetOptions('fo$@#' => \$var).
+  Thanks to Wolfgang Laun <Wolfgang.Laun@alcatel.at>.
+
+* When an option is specified more than once, an error is now
+  generated. E.g., GetOptions('foo', 'foo').
+  Thanks to Wolfgang Laun <Wolfgang.Laun@alcatel.at>.
+
 * Lots of internal restructoring to make room for extensions.
 
 * Redesigned the regression tests.
 
+* Enhance the documentation to prevent common misunderstandings about
+  single character options.
+
 Changes in version 2.26
 -----------------------
 
diff --git a/lib/Getopt/Long/README b/lib/Getopt/Long/README
index 1a2dc10c4a..7870b8b7fc 100644
--- a/lib/Getopt/Long/README
+++ b/lib/Getopt/Long/README
@@ -182,7 +182,7 @@ Or use the CPAN search engine:
 COPYRIGHT AND DISCLAIMER
 ========================
 
-Module Getopt::Long is Copyright 2001,1990 by Johan Vromans.
+Module Getopt::Long is Copyright 2002,1990 by Johan Vromans.
 This program is free software; you can redistribute it and/or
 modify it under the terms of the Perl Artistic License or the
 GNU General Public License as published by the Free Software