Update to version 2.3

1 files changed, 178 insertions, 113 deletions

diff --git a/lib/Getopt/Long.pm b/lib/Getopt/Long.pm
index 5dd5d16b25..3fa9c8b10f 100644
--- a/lib/Getopt/Long.pm
+++ b/lib/Getopt/Long.pm
@@ -1,11 +1,11 @@
 # GetOpt::Long.pm -- POSIX compatible options parsing
 
-# RCS Status      : $Id: GetoptLong.pm,v 2.1 1996/02/02 20:24:35 jv Exp $
+# RCS Status      : $Id: GetoptLong.pm,v 2.3 1996-04-05 21:03:05+02 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
+# Last Modified On: Fri Apr  5 21:02:52 1996
+# Update Count    : 433
 # Status          : Released
 
 package Getopt::Long;
@@ -14,7 +14,10 @@ require Exporter;
 
 @ISA = qw(Exporter);
 @EXPORT = qw(&GetOptions $REQUIRE_ORDER $PERMUTE $RETURN_IN_ORDER);
-$VERSION = sprintf("%d.%02d", q$Revision: 2.1 $ =~ /(\d+)\.(\d+)/);
+$VERSION = sprintf("%d.%02d", '$Revision: 2.3 $ ' =~ /(\d+)\.(\d+)/);
+use vars qw($autoabbrev $getopt_compat $ignorecase $bundling $order
+	    $error $debug $REQUIRE_ORDER $PERMUTE $RETURN_IN_ORDER
+	    $VERSION $major_version $minor_version);
 use strict;
 
 =head1 NAME
@@ -32,9 +35,10 @@ The Getopt::Long module implements an extended getopt function called
 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" 
+double dash "--". Support for bundling of command line options, as was
+the case with the more traditional single-letter approach, is provided
+but not enabled by default. For example, the UNIX "ps" command can be
+given the command line "option"
 
   -vax
 
@@ -366,9 +370,39 @@ is equivalent to
 
 $RETURN_IN_ORDER is not supported by GetOptions().
 
-=item $Getopt::Long::ignorecase      
+=item $Getopt::Long::bundling
 
-Ignore case when matching options. Default is 1.
+Setting this variable to a non-zero value will allow single-character
+options to be bundled. To distinguish bundles from long option names,
+long options must be introduced with B<--> and single-character
+options (and bundles) with B<->. For example,
+
+    ps -vax --vax
+
+would be equivalent to
+
+    ps -v -a -x --vax
+
+provided "vax", "v", "a" and "x" have been defined to be valid
+options. 
+
+Bundled options can also include a value in the bundle; this value has
+to be the last part of the bundle, e.g.
+
+    scale -h24 -w80
+
+is equivalent to
+
+    scale -h 24 -w 80
+
+B<Note:> Using option bundling can easily lead to unexpected results,
+especially when mixing long options and bundles. Caveat emptor.
+
+=item $Getopt::Long::ignorecase
+
+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.
 
 =item $Getopt::Long::VERSION
 
@@ -396,11 +430,6 @@ Enable copious debugging output. Default is 0.
 
 ################ 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 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
@@ -416,50 +445,34 @@ Enable copious debugging output. Default is 0.
 # the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, 
 # MA 02139, USA.
 
-################ History ################
-# 
-# 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.
-#
-# 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);
+($REQUIRE_ORDER, $PERMUTE, $RETURN_IN_ORDER) = (0..2);
 
 my $gen_prefix;			# generic prefix (option starters)
 
 # 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;
+    $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 = "(--|-|\\+)";
-    $Getopt::Long::autoabbrev = 1;	# automatic abbrev of options
-    $Getopt::Long::getopt_compat = 1;	# allow '+' to start options
-    $Getopt::Long::order = $Getopt::Long::PERMUTE;
+    $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.
-$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;
+$debug = 0;			# for debugging
+$error = 0;			# error tally
+$ignorecase = 1;		# ignore case when matching options
+($major_version, $minor_version) = $VERSION =~ /^(\d+)\.(\d+)/;
 
 ################ Subroutines ################
 
@@ -467,26 +480,27 @@ sub GetOptions {
 
     my @optionlist = @_;	# local copy of the option descriptions
     my $argend = '--';		# option list terminator
-    my %opctl;			# table of arg.specs
+    my %opctl;			# table of arg.specs (long and abbrevs)
+    my %bopctl;			# table of arg.specs (bundles)
     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;
+    $error = 0;
 
-    print STDERR ("GetOptions $Getopt::Long::version",
-		  " [GetOpt::Long $Getopt::Long::VERSION] -- ",
+    print STDERR ('GetOptions $Revision: 2.3 $ ',
+		  "[GetOpt::Long $Getopt::Long::VERSION] -- ",
 		  "called from package \"$pkg\".\n",
-		  "  autoabbrev=$Getopt::Long::autoabbrev".
-		  ",getopt_compat=$Getopt::Long::getopt_compat",
+		  "  autoabbrev=$autoabbrev".
+		  ",bundling=$bundling",
+		  ",getopt_compat=$getopt_compat",
 		  ",genprefix=\"$genprefix\"",
-		  ",order=$Getopt::Long::order",
-		  ",ignorecase=$Getopt::Long::ignorecase",
+		  ",order=$order",
+		  ",ignorecase=$ignorecase",
 		  ".\n")
 	if $debug;
 
@@ -507,11 +521,12 @@ sub GetOptions {
 
     # Verify correctness of optionlist.
     %opctl = ();
+    %bopctl = ();
     while ( @optionlist > 0 ) {
 	my $opt = shift (@optionlist);
 
 	# Strip leading prefix so people can specify "-foo=i" if they like.
-	$opt = $' if $opt =~ /^($genprefix)+/;
+	$opt = $2 if $opt =~ /^($genprefix)+([\x00-\xff]*)/;
 
 	if ( $opt eq '<>' ) {
 	    if ( (defined $userlinkage)
@@ -523,35 +538,52 @@ sub GetOptions {
 	    unless ( @optionlist > 0 
 		    && ref($optionlist[0]) && ref($optionlist[0]) eq 'CODE' ) {
 		warn ("Option spec <> requires a reference to a subroutine\n");
-		$Getopt::Long::error++;
+		$error++;
 		next;
 	    }
 	    $linkage{'<>'} = shift (@optionlist);
 	    next;
 	}
 
-	$opt =~ tr/A-Z/a-z/ if $Getopt::Long::ignorecase;
 	if ( $opt !~ /^(\w+[-\w|]*)?(!|[=:][infse]@?)?$/ ) {
 	    warn ("Error in option spec: \"", $opt, "\"\n");
-	    $Getopt::Long::error++;
+	    $error++;
 	    next;
 	}
 	my ($o, $c, $a) = ($1, $2);
+	$c = '' unless defined $c;
 
 	if ( ! defined $o ) {
 	    # empty -> '-' option
-	    $opctl{$o = ''} = defined $c ? $c : '';
+	    $opctl{$o = ''} = $c;
 	}
 	else {
 	    # Handle alias names
 	    my @o =  split (/\|/, $o);
 	    $o = $o[0];
+	    $o = lc ($o)
+		if $ignorecase > 1 
+		    || ($ignorecase
+			&& ($bundling ? length($o) > 1  : 1));
+
 	    foreach ( @o ) {
-		if ( defined $c && $c eq '!' ) {
-		    $opctl{"no$_"} = $c;
-		    $c = '';
+		if ( $bundling && length($_) == 1 ) {
+		    $_ = lc ($_) if $ignorecase > 1;
+		    if ( $c eq '!' ) {
+			$opctl{"no$_"} = $c;
+			warn ("Ignoring '!' modifier for short option $_\n");
+			$c = '';
+		    }
+		    $bopctl{$_} = $c;
+		}
+		else {
+		    $_ = lc ($_) if $ignorecase;
+		    if ( $c eq '!' ) {
+			$opctl{"no$_"} = $c;
+			$c = '';
+		    }
+		    $opctl{$_} = $c;
 		}
-		$opctl{$_} = defined $c ? $c : '';
 		if ( defined $a ) {
 		    # Note alias.
 		    $aliases{$_} = $a;
@@ -584,14 +616,12 @@ sub GetOptions {
 	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' ) {
+	    if ( ref($optionlist[0]) =~ /^(SCALAR|ARRAY|CODE)$/ ) {
 		$linkage{$o} = shift (@optionlist);
 	    }
 	    else {
 		warn ("Invalid option linkage for \"", $opt, "\"\n");
-		$Getopt::Long::error++;
+		$error++;
 	    }
 	}
 	else {
@@ -599,7 +629,7 @@ sub GetOptions {
 	    # Make sure a valid perl identifier results.
 	    my $ov = $o;
 	    $ov =~ s/\W/_/g;
-	    if ( $c && $c =~ /@/ ) {
+	    if ( defined($c) && $c =~ /@/ ) {
 		print STDERR ("=> link \"$o\" to \@$pkg","::opt_$ov\n")
 		    if $debug;
 		eval ("\$linkage{\$o} = \\\@".$pkg."::opt_$ov;");
@@ -613,12 +643,12 @@ sub GetOptions {
     }
 
     # Bail out if errors found.
-    return 0 if $Getopt::Long::error;
+    return 0 if $error;
 
-    # Sort the possible option names.
-    my @opctl = sort(keys (%opctl)) if $Getopt::Long::autoabbrev;
+    # Sort the possible long option names.
+    my @opctl = sort(keys (%opctl)) if $autoabbrev;
 
-    # Show if debugging.
+    # Show the options tables if debugging.
     if ( $debug ) {
 	my ($arrow, $k, $v);
 	$arrow = "=> ";
@@ -626,10 +656,15 @@ sub GetOptions {
 	    print STDERR ($arrow, "\$opctl{\"$k\"} = \"$v\"\n");
 	    $arrow = "   ";
 	}
+	$arrow = "=> ";
+	while ( ($k,$v) = each(%bopctl) ) {
+	    print STDERR ($arrow, "\$bopctl{\"$k\"} = \"$v\"\n");
+	    $arrow = "   ";
+	}
     }
 
     my $opt;			# current option
-    my $arg;			# current option value
+    my $arg;			# current option value, if any
     my $array;			# current option is array typed
 
     # Process argument list
@@ -639,9 +674,12 @@ sub GetOptions {
 
 	#### Get next argument ####
 
+	my $starter;		# option starter string, e.g. '-' or '--'
+	my $rest = undef;	# remainder from unbundling
+	my $optarg = undef;	# value supplied with --opt=value
+
 	$opt = shift (@ARGV);
 	$arg = undef;
-	my $optarg = undef;
 	$array = 0;
 	print STDERR ("=> option \"", $opt, "\"\n") if $debug;
 
@@ -651,18 +689,21 @@ sub GetOptions {
 	if ( $opt eq $argend ) {
 	    # Finish. Push back accumulated arguments and return.
 	    unshift (@ARGV, @ret) 
-		if $Getopt::Long::order == $Getopt::Long::PERMUTE;
-	    return ($Getopt::Long::error == 0);
+		if $order == $PERMUTE;
+	    return ($error == 0);
 	}
 
-	if ( $opt =~ /^$genprefix/ ) {
+	if ( $opt =~ /^($genprefix)([\x00-\xff]*)/ ) {
 	    # Looks like an option.
-	    $opt = $';		# option name (w/o prefix)
-	    # If it is a long opt, it may include the value.
-	    if (($& eq "--" || ($Getopt::Long::getopt_compat && $& eq "+"))
-		&& $opt =~ /^([^=]+)=/ ) {
+	    $opt = $2;		# option name (w/o prefix)
+	    $starter = $1;	# option starter
+
+	    # If it is a long option, it may include the value.
+	    if (($starter eq "--" 
+		 || ($getopt_compat && $starter eq "+"))
+		&& $opt =~ /^([^=]+)=([\x00-\xff]*)/ ) {
 		$opt = $1;
-		$optarg = $';
+		$optarg = $2;
 		print STDERR ("=> option \"", $opt, 
 			      "\", optarg = \"$optarg\"\n") if $debug;
 	    }
@@ -670,13 +711,15 @@ sub GetOptions {
 	}
 
 	# Not an option. Save it if we $PERMUTE and don't have a <>.
-	elsif ( $Getopt::Long::order == $Getopt::Long::PERMUTE ) {
+	elsif ( $order == $PERMUTE ) {
 	    # Try non-options call-back.
 	    my $cb;
 	    if ( (defined ($cb = $linkage{'<>'})) ) {
 		&$cb($opt);
 	    }
 	    else {
+		print STDERR ("=> saving \"$opt\" ",
+			      "(not an option, may permute)\n") if $debug;
 		push (@ret, $opt);
 	    }
 	    next;
@@ -686,29 +729,41 @@ sub GetOptions {
 	else {
 	    # Push this one back and exit.
 	    unshift (@ARGV, $opt);
-	    return ($Getopt::Long::error == 0);
+	    return ($error == 0);
 	}
 
 	#### Look it up ###
 
-	$opt =~ tr/A-Z/a-z/ if $Getopt::Long::ignorecase;
-
-	my $tryopt = $opt;
-	if ( $Getopt::Long::autoabbrev ) {
-	    my $pat;
-
+	my $tryopt = $opt;	# option to try
+	my $optbl = \%opctl;	# table to look it up (long names)
+
+	if ( $bundling && $starter eq '-' ) {
+	    # Unbundle single letter option.
+	    $rest = substr ($tryopt, 1);
+	    $tryopt = substr ($tryopt, 0, 1);
+	    $tryopt = lc ($tryopt) if $ignorecase > 1;
+	    print STDERR ("=> $starter$tryopt unbundled from ",
+			  "$starter$tryopt$rest\n") if $debug;
+	    $rest = undef unless $rest ne '';
+	    $optbl = \%bopctl;	# look it up in the short names table
+	} 
+
+	# Try auto-abbreviation.
+	elsif ( $autoabbrev ) {
+	    # Downcase if allowed.
+	    $tryopt = $opt = lc ($opt) if $ignorecase;
 	    # Turn option name into pattern.
-	    ($pat = $opt) =~ s/(\W)/\\$1/g;
+	    my $pat = quotemeta ($opt);
 	    # Look up in option names.
 	    my @hits = grep (/^$pat/, @opctl);
-	    print STDERR ("=> ", 0+@hits, " hits (@hits) with \"$pat\" ",
-			  "out of ", 0+@opctl, "\n") if $debug;
+	    print STDERR ("=> ", scalar(@hits), " hits (@hits) with \"$pat\" ",
+			  "out of ", scalar(@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");
-		$Getopt::Long::error++;
+		$error++;
 		next;
 	    }
 
@@ -720,12 +775,14 @@ sub GetOptions {
 	    }
 	}
 
-	my $type;
-	unless  ( defined ( $type = $opctl{$tryopt} ) ) {
-	    print STDERR ("Unknown option: ", $opt, "\n");
-	    $Getopt::Long::error++;
+	# Check validity by fetching the info.
+	my $type = $optbl->{$tryopt};
+	unless  ( defined $type ) {
+	    warn ("Unknown option: ", $opt, "\n");
+	    $error++;
 	    next;
 	}
+	# Apparently valid.
 	$opt = $tryopt;
 	print STDERR ("=> found \"$type\" for ", $opt, "\n") if $debug;
 
@@ -735,7 +792,7 @@ sub GetOptions {
 	if ( $type eq '' || $type eq '!' ) {
 	    if ( defined $optarg ) {
 		print STDERR ("Option ", $opt, " does not take an argument\n");
-		$Getopt::Long::error++;
+		$error++;
 	    }
 	    elsif ( $type eq '' ) {
 		$arg = 1;		# supply explicit value
@@ -744,6 +801,8 @@ sub GetOptions {
 		substr ($opt, 0, 2) = ''; # strip NO prefix
 		$arg = 0;		# supply explicit value
 	    }
+	    # When unbundling, unshift the rest with the starter.
+	    unshift (@ARGV, $starter.$rest) if defined $rest;
 	    next;
 	}
 
@@ -752,12 +811,12 @@ sub GetOptions {
 	($mand, $type, $array) = $type =~ /^(.)(.)(@?)$/;
 
 	# Check if there is an option argument available.
-	if ( defined $optarg ? ($optarg eq '') : (@ARGV <= 0) ) {
-
+	if ( defined $optarg ? ($optarg eq '') 
+	     : !(defined $rest || @ARGV > 0) ) {
 	    # Complain if this option needs an argument.
 	    if ( $mand eq "=" ) {
 		print STDERR ("Option ", $opt, " requires an argument\n");
-		$Getopt::Long::error++;
+		$error++;
 	    }
 	    if ( $mand eq ":" ) {
 		$arg = $type eq "s" ? '' : 0;
@@ -766,7 +825,8 @@ sub GetOptions {
 	}
 
 	# Get (possibly optional) argument.
-	$arg = defined $optarg ? $optarg : shift (@ARGV);
+	$arg = (defined $rest ? $rest
+		: (defined $optarg ? $optarg : shift (@ARGV)));
 
 	#### Check if the argument is valid for this option ####
 
@@ -775,8 +835,8 @@ sub GetOptions {
 	    next if $mand eq "=";
 
 	    # An optional string takes almost anything. 
-	    next if defined $optarg;
-	    next if $arg eq "-";
+	    next if defined $optarg || defined $rest;
+	    next if $arg eq "-"; # ??
 
 	    # Check for option or option list terminator.
 	    if ($arg eq $argend ||
@@ -794,12 +854,14 @@ sub GetOptions {
 		if ( defined $optarg || $mand eq "=" ) {
 		    print STDERR ("Value \"", $arg, "\" invalid for option ",
 				  $opt, " (number expected)\n");
-		    $Getopt::Long::error++;
+		    $error++;
 		    undef $arg;	# don't assign it
+		    # Push back.
+		    unshift (@ARGV, $starter.$rest) if defined $rest;
 		}
 		else {
 		    # Push back.
-		    unshift (@ARGV, $arg);
+		    unshift (@ARGV, defined $rest ? $starter.$rest : $arg);
 		    # Supply default value.
 		    $arg = 0;
 		}
@@ -812,12 +874,14 @@ sub GetOptions {
 		if ( defined $optarg || $mand eq "=" ) {
 		    print STDERR ("Value \"", $arg, "\" invalid for option ",
 				  $opt, " (real number expected)\n");
-		    $Getopt::Long::error++;
+		    $error++;
 		    undef $arg;	# don't assign it
+		    # Push back.
+		    unshift (@ARGV, $starter.$rest) if defined $rest;
 		}
 		else {
 		    # Push back.
-		    unshift (@ARGV, $arg);
+		    unshift (@ARGV, defined $rest ? $starter.$rest : $arg);
 		    # Supply default value.
 		    $arg = 0.0;
 		}
@@ -877,15 +941,16 @@ sub GetOptions {
     }
 
     # Finish.
-    if ( $Getopt::Long::order == $Getopt::Long::PERMUTE ) {
+    if ( $order == $PERMUTE ) {
 	#  Push back accumulated arguments
+	print STDERR ("=> restoring \"", join('" "', @ret), "\"\n")
+	    if $debug && @ret > 0;
 	unshift (@ARGV, @ret) if @ret > 0;
     }
 
-    return ($Getopt::Long::error == 0);
+    return ($error == 0);
 }
 
 ################ Package return ################
 
-# Returning 1 is so boring...
-$Getopt::Long::major_version * 1000 + $Getopt::Long::minor_version;
+1;