X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/385588b3949e695a02c8ea1dd00fe789d6044de3..e6d5c5302bca4863c13ae11aa5ed04b35c9d89f5:/lib/Getopt/Long.pm

diff --git a/lib/Getopt/Long.pm b/lib/Getopt/Long.pm
index 221cc54..b580459 100644
--- a/lib/Getopt/Long.pm
+++ b/lib/Getopt/Long.pm
@@ -1,25 +1,836 @@
-# 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.pl,v 2.18 1998-06-14 15:02:19+02 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 Jun 14 13:17:22 1998
+# Update Count    : 705
+# Status          : Released
+
+################ Copyright ################
+
+# This program is Copyright 1990,1998 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
+# of the License, or (at your option) any later version.
+# 
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+# GNU General Public License for more details.
+# 
+# If you do not have a copy of the GNU General Public License write to
+# the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, 
+# MA 02139, USA.
+
+################ Module Preamble ################
+
+use strict;
+
+BEGIN {
+    require 5.004;
+    use Exporter ();
+    use vars     qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
+#   $VERSION     = sprintf("%d.%02d", q$Revision: 2.18 $ =~ /(\d+)\.(\d+)/);
+    $VERSION     = "2.17";
+
+    @ISA         = qw(Exporter);
+    @EXPORT      = qw(&GetOptions $REQUIRE_ORDER $PERMUTE $RETURN_IN_ORDER);
+    %EXPORT_TAGS = qw();
+    @EXPORT_OK   = qw();
+    use AutoLoader qw(AUTOLOAD);
+}
+
+# User visible variables.
+use vars @EXPORT, @EXPORT_OK;
+use vars qw($error $debug $major_version $minor_version);
+# Deprecated visible variables.
+use vars qw($autoabbrev $getopt_compat $ignorecase $bundling $order
+	    $passthrough);
+# Official invisible variables.
+use vars qw($genprefix);
+
+# Public subroutines. 
+sub Configure (@);
+sub config (@);			# deprecated name
+sub GetOptions;
+
+# Private subroutines. 
+sub ConfigDefaults ();
+sub FindOption ($$$$$$$);
+sub Croak (@);			# demand loading the real Croak
+
+################ Local Variables ################
+
+################ Resident subroutines ################
+
+sub ConfigDefaults () {
+    # Handle POSIX compliancy.
+    if ( defined $ENV{"POSIXLY_CORRECT"} ) {
+	$genprefix = "(--|-)";
+	$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 {
+	$genprefix = "(--|-|\\+)";
+	$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.
+ConfigDefaults ();
+
+################ Package return ################
+
+1;
+
+__END__
+
+################ AutoLoading subroutines ################
+
+# RCS Status      : $Id: GetoptLongAl.pl,v 2.20 1998-06-14 15:02:19+02 jv Exp $
+# Author          : Johan Vromans
+# Created On      : Fri Mar 27 11:50:30 1998
+# Last Modified By: Johan Vromans
+# Last Modified On: Sun Jun 14 13:54:35 1998
+# Update Count    : 24
 # Status          : Released
 
-package Getopt::Long;
-require 5.000;
-require Exporter;
+sub GetOptions {
+
+    my @optionlist = @_;	# local copy of the option descriptions
+    my $argend = '--';		# option list terminator
+    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 $opt;			# current option
+    my $genprefix = $genprefix;	# so we can call the same module many times
+    my @opctl;			# the possible long option names
+
+    $error = '';
+
+    print STDERR ("GetOpt::Long $Getopt::Long::VERSION ",
+		  "called from package \"$pkg\".",
+		  "\n  ",
+		  'GetOptionsAl $Revision: 2.20 $ ',
+		  "\n  ",
+		  "ARGV: (@ARGV)",
+		  "\n  ",
+		  "autoabbrev=$autoabbrev,".
+		  "bundling=$bundling,",
+		  "getopt_compat=$getopt_compat,",
+		  "order=$order,",
+		  "\n  ",
+		  "ignorecase=$ignorecase,",
+		  "passthrough=$passthrough,",
+		  "genprefix=\"$genprefix\".",
+		  "\n")
+	if $debug;
+
+    # Check for ref HASH as first argument. 
+    # First argument may be an object. It's OK to use this as long
+    # as it is really a hash underneath. 
+    $userlinkage = undef;
+    if ( ref($optionlist[0]) and
+	 "$optionlist[0]" =~ /^(?:.*\=)?HASH\([^\(]*\)$/ ) {
+	$userlinkage = shift (@optionlist);
+	print STDERR ("=> user linkage: $userlinkage\n") if $debug;
+    }
+
+    # See if the first element of the optionlist contains option
+    # starter characters.
+    if ( $optionlist[0] =~ /^\W+$/ ) {
+	$genprefix = shift (@optionlist);
+	# Turn into regexp. Needs to be parenthesized!
+	$genprefix =~ s/(\W)/\\$1/g;
+	$genprefix = "([" . $genprefix . "])";
+    }
+
+    # 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+(.*)$/s;
+
+	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' ) {
+		$error .= "Option spec <> requires a reference to a subroutine\n";
+		next;
+	    }
+	    $linkage{'<>'} = shift (@optionlist);
+	    next;
+	}
+
+	# Match option spec. Allow '?' as an alias.
+	if ( $opt !~ /^((\w+[-\w]*)(\|(\?|\w[-\w]*)?)*)?([!~+]|[=:][infse][@%]?)?$/ ) {
+	    $error .= "Error in option spec: \"$opt\"\n";
+	    next;
+	}
+	my ($o, $c, $a) = ($1, $5);
+	$c = '' unless defined $c;
+
+	if ( ! defined $o ) {
+	    # empty -> '-' option
+	    $opctl{$o = ''} = $c;
+	}
+	else {
+	    # Handle alias names
+	    my @o =  split (/\|/, $o);
+	    my $linko = $o = $o[0];
+	    # Force an alias if the option name is not locase.
+	    $a = $o unless $o eq lc($o);
+	    $o = lc ($o)
+		if $ignorecase > 1 
+		    || ($ignorecase
+			&& ($bundling ? length($o) > 1  : 1));
+
+	    foreach ( @o ) {
+		if ( $bundling && length($_) == 1 ) {
+		    $_ = lc ($_) if $ignorecase > 1;
+		    if ( $c eq '!' ) {
+			$opctl{"no$_"} = $c;
+			warn ("Ignoring '!' modifier for short option $_\n");
+			$c = '';
+		    }
+		    $opctl{$_} = $bopctl{$_} = $c;
+		}
+		else {
+		    $_ = lc ($_) if $ignorecase;
+		    if ( $c eq '!' ) {
+			$opctl{"no$_"} = $c;
+			$c = '';
+		    }
+		    $opctl{$_} = $c;
+		}
+		if ( defined $a ) {
+		    # Note alias.
+		    $aliases{$_} = $a;
+		}
+		else {
+		    # Set primary name.
+		    $a = $_;
+		}
+	    }
+	    $o = $linko;
+	}
+
+	# 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]) =~ /^(SCALAR|CODE)$/ ) {
+		$linkage{$o} = shift (@optionlist);
+	    }
+	    elsif ( ref($optionlist[0]) =~ /^(ARRAY)$/ ) {
+		$linkage{$o} = shift (@optionlist);
+		$opctl{$o} .= '@'
+		  if $opctl{$o} ne '' and $opctl{$o} !~ /\@$/;
+		$bopctl{$o} .= '@'
+		  if $bundling and defined $bopctl{$o} and 
+		    $bopctl{$o} ne '' and $bopctl{$o} !~ /\@$/;
+	    }
+	    elsif ( ref($optionlist[0]) =~ /^(HASH)$/ ) {
+		$linkage{$o} = shift (@optionlist);
+		$opctl{$o} .= '%'
+		  if $opctl{$o} ne '' and $opctl{$o} !~ /\%$/;
+		$bopctl{$o} .= '%'
+		  if $bundling and defined $bopctl{$o} and 
+		    $bopctl{$o} ne '' and $bopctl{$o} !~ /\%$/;
+	    }
+	    else {
+		$error .= "Invalid option linkage for \"$opt\"\n";
+	    }
+	}
+	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;");
+	    }
+	    elsif ( $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;");
+	    }
+	}
+    }
+
+    # Bail out if errors found.
+    die ($error) if $error;
+    $error = 0;
+
+    # Sort the possible long option names.
+    @opctl = sort(keys (%opctl)) if $autoabbrev;
+
+    # Show the options tables if debugging.
+    if ( $debug ) {
+	my ($arrow, $k, $v);
+	$arrow = "=> ";
+	while ( ($k,$v) = each(%opctl) ) {
+	    print STDERR ($arrow, "\$opctl{\"$k\"} = \"$v\"\n");
+	    $arrow = "   ";
+	}
+	$arrow = "=> ";
+	while ( ($k,$v) = each(%bopctl) ) {
+	    print STDERR ($arrow, "\$bopctl{\"$k\"} = \"$v\"\n");
+	    $arrow = "   ";
+	}
+    }
+
+    # Process argument list
+    while ( @ARGV > 0 ) {
+
+	#### Get next argument ####
+
+	$opt = shift (@ARGV);
+	print STDERR ("=> option \"", $opt, "\"\n") if $debug;
+
+	#### Determine what we have ####
+
+	# Double dash is option list terminator.
+	if ( $opt eq $argend ) {
+	    # Finish. Push back accumulated arguments and return.
+	    unshift (@ARGV, @ret) 
+		if $order == $PERMUTE;
+	    return ($error == 0);
+	}
+
+	my $tryopt = $opt;
+	my $found;		# success status
+	my $dsttype;		# destination type ('@' or '%')
+	my $incr;		# destination increment 
+	my $key;		# key (if hash type)
+	my $arg;		# option argument
+
+	($found, $opt, $arg, $dsttype, $incr, $key) = 
+	  FindOption ($genprefix, $argend, $opt, 
+		      \%opctl, \%bopctl, \@opctl, \%aliases);
+
+	if ( $found ) {
+	    
+	    # FindOption undefines $opt in case of errors.
+	    next unless defined $opt;
+
+	    if ( defined $arg ) {
+		$opt = $aliases{$opt} if defined $aliases{$opt};
+
+		if ( defined $linkage{$opt} ) {
+		    print STDERR ("=> ref(\$L{$opt}) -> ",
+				  ref($linkage{$opt}), "\n") if $debug;
+
+		    if ( ref($linkage{$opt}) eq 'SCALAR' ) {
+			if ( $incr ) {
+			    print STDERR ("=> \$\$L{$opt} += \"$arg\"\n")
+			      if $debug;
+			    if ( defined ${$linkage{$opt}} ) {
+			        ${$linkage{$opt}} += $arg;
+			    }
+		            else {
+			        ${$linkage{$opt}} = $arg;
+			    }
+			}
+			else {
+			    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 'HASH' ) {
+			print STDERR ("=> \$\$L{$opt}->{$key} = \"$arg\"\n")
+			    if $debug;
+			$linkage{$opt}->{$key} = $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");
+			Croak ("Getopt::Long -- internal error!\n");
+		    }
+		}
+		# No entry in linkage means entry in userlinkage.
+		elsif ( $dsttype eq '@' ) {
+		    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];
+		    }
+		}
+		elsif ( $dsttype eq '%' ) {
+		    if ( defined $userlinkage->{$opt} ) {
+			print STDERR ("=> \$L{$opt}->{$key} = \"$arg\"\n")
+			    if $debug;
+			$userlinkage->{$opt}->{$key} = $arg;
+		    }
+		    else {
+			print STDERR ("=>\$L{$opt} = {$key => \"$arg\"}\n")
+			    if $debug;
+			$userlinkage->{$opt} = {$key => $arg};
+		    }
+		}
+		else {
+		    if ( $incr ) {
+			print STDERR ("=> \$L{$opt} += \"$arg\"\n")
+			  if $debug;
+			if ( defined $userlinkage->{$opt} ) {
+			    $userlinkage->{$opt} += $arg;
+			}
+			else {
+			    $userlinkage->{$opt} = $arg;
+			}
+		    }
+		    else {
+			print STDERR ("=>\$L{$opt} = \"$arg\"\n") if $debug;
+			$userlinkage->{$opt} = $arg;
+		    }
+		}
+	    }
+	}
+
+	# Not an option. Save it if we $PERMUTE and don't have a <>.
+	elsif ( $order == $PERMUTE ) {
+	    # Try non-options call-back.
+	    my $cb;
+	    if ( (defined ($cb = $linkage{'<>'})) ) {
+		&$cb ($tryopt);
+	    }
+	    else {
+		print STDERR ("=> saving \"$tryopt\" ",
+			      "(not an option, may permute)\n") if $debug;
+		push (@ret, $tryopt);
+	    }
+	    next;
+	}
+
+	# ...otherwise, terminate.
+	else {
+	    # Push this one back and exit.
+	    unshift (@ARGV, $tryopt);
+	    return ($error == 0);
+	}
+
+    }
+
+    # Finish.
+    if ( $order == $PERMUTE ) {
+	#  Push back accumulated arguments
+	print STDERR ("=> restoring \"", join('" "', @ret), "\"\n")
+	    if $debug && @ret > 0;
+	unshift (@ARGV, @ret) if @ret > 0;
+    }
+
+    return ($error == 0);
+}
+
+# Option lookup.
+sub FindOption ($$$$$$$) {
+
+    # returns (1, $opt, $arg, $dsttype, $incr, $key) if okay,
+    # returns (0) otherwise.
+
+    my ($prefix, $argend, $opt, $opctl, $bopctl, $names, $aliases) = @_;
+    my $key;			# hash key for a hash option
+    my $arg;
+
+    print STDERR ("=> find \"$opt\", prefix=\"$prefix\"\n") if $debug;
+
+    return (0) unless $opt =~ /^$prefix(.*)$/s;
+
+    $opt = $+;
+    my ($starter) = $1;
+
+    print STDERR ("=> split \"$starter\"+\"$opt\"\n") if $debug;
+
+    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 && !$bundling))
+	&& $opt =~ /^([^=]+)=(.*)$/s ) {
+	$opt = $1;
+	$optarg = $2;
+	print STDERR ("=> option \"", $opt, 
+		      "\", optarg = \"$optarg\"\n") if $debug;
+    }
+
+    #### Look it up ###
+
+    my $tryopt = $opt;		# option to try
+    my $optbl = $opctl;		# table to look it up (long names)
+    my $type;
+    my $dsttype = '';
+    my $incr = 0;
+
+    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
+
+	# 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.
+    elsif ( $autoabbrev ) {
+	# Downcase if allowed.
+	$tryopt = $opt = lc ($opt) if $ignorecase;
+	# Turn option name into pattern.
+	my $pat = quotemeta ($opt);
+	# Look up in option names.
+	my @hits = grep (/^$pat/, @{$names});
+	print STDERR ("=> ", scalar(@hits), " hits (@hits) with \"$pat\" ",
+		      "out of ", scalar(@{$names}), "\n") if $debug;
+
+	# Check for ambiguous results.
+	unless ( (@hits <= 1) || (grep ($_ eq $opt, @hits) == 1) ) {
+	    # See if all matches are for the same option.
+	    my %hit;
+	    foreach ( @hits ) {
+		$_ = $aliases->{$_} if defined $aliases->{$_};
+		$hit{$_} = 1;
+	    }
+	    # Now see if it really is ambiguous.
+	    unless ( keys(%hit) == 1 ) {
+		return (0) if $passthrough;
+		warn ("Option ", $opt, " is ambiguous (",
+		      join(", ", @hits), ")\n");
+		$error++;
+		undef $opt;
+		return (1, $opt,$arg,$dsttype,$incr,$key);
+	    }
+	    @hits = keys(%hit);
+	}
+
+	# Complete the option name, if appropriate.
+	if ( @hits == 1 && $hits[0] ne $opt ) {
+	    $tryopt = $hits[0];
+	    $tryopt = lc ($tryopt) if $ignorecase;
+	    print STDERR ("=> option \"$opt\" -> \"$tryopt\"\n")
+		if $debug;
+	}
+    }
 
-@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;
+    # Map to all lowercase if ignoring case.
+    elsif ( $ignorecase ) {
+	$tryopt = lc ($opt);
+    }
+
+    # Check validity by fetching the info.
+    $type = $optbl->{$tryopt} unless defined $type;
+    unless  ( defined $type ) {
+	return (0) if $passthrough;
+	warn ("Unknown option: ", $opt, "\n");
+	$error++;
+	return (1, $opt,$arg,$dsttype,$incr,$key);
+    }
+    # Apparently valid.
+    $opt = $tryopt;
+    print STDERR ("=> found \"$type\" for ", $opt, "\n") if $debug;
+
+    #### Determine argument status ####
+
+    # If it is an option w/o argument, we're almost finished with it.
+    if ( $type eq '' || $type eq '!' || $type eq '+' ) {
+	if ( defined $optarg ) {
+	    return (0) if $passthrough;
+	    warn ("Option ", $opt, " does not take an argument\n");
+	    $error++;
+	    undef $opt;
+	}
+	elsif ( $type eq '' || $type eq '+' ) {
+	    $arg = 1;		# supply explicit value
+	    $incr = $type eq '+';
+	}
+	else {
+	    substr ($opt, 0, 2) = ''; # strip NO prefix
+	    $arg = 0;		# supply explicit value
+	}
+	unshift (@ARGV, $starter.$rest) if defined $rest;
+	return (1, $opt,$arg,$dsttype,$incr,$key);
+    }
+
+    # Get mandatory status and type info.
+    my $mand;
+    ($mand, $type, $dsttype, $key) = $type =~ /^(.)(.)([@%]?)$/;
+
+    # Check if there is an option argument available.
+    if ( defined $optarg ? ($optarg eq '') 
+	 : !(defined $rest || @ARGV > 0) ) {
+	# Complain if this option needs an argument.
+	if ( $mand eq "=" ) {
+	    return (0) if $passthrough;
+	    warn ("Option ", $opt, " requires an argument\n");
+	    $error++;
+	    undef $opt;
+	}
+	if ( $mand eq ":" ) {
+	    $arg = $type eq "s" ? '' : 0;
+	}
+	return (1, $opt,$arg,$dsttype,$incr,$key);
+    }
+
+    # Get (possibly optional) argument.
+    $arg = (defined $rest ? $rest
+	    : (defined $optarg ? $optarg : shift (@ARGV)));
+
+    # Get key if this is a "name=value" pair for a hash option.
+    $key = undef;
+    if ($dsttype eq '%' && defined $arg) {
+	($key, $arg) = ($arg =~ /^(.*)=(.*)$/s) ? ($1, $2) : ($arg, 1);
+    }
+
+    #### Check if the argument is valid for this option ####
+
+    if ( $type eq "s" ) {	# string
+	# A mandatory string takes anything. 
+	return (1, $opt,$arg,$dsttype,$incr,$key) if $mand eq "=";
+
+	# An optional string takes almost anything. 
+	return (1, $opt,$arg,$dsttype,$incr,$key) 
+	  if defined $optarg || defined $rest;
+	return (1, $opt,$arg,$dsttype,$incr,$key) if $arg eq "-"; # ??
+
+	# Check for option or option list terminator.
+	if ($arg eq $argend ||
+	    $arg =~ /^$prefix.+/) {
+	    # Push back.
+	    unshift (@ARGV, $arg);
+	    # Supply empty value.
+	    $arg = '';
+	}
+    }
+
+    elsif ( $type eq "n" || $type eq "i" ) { # numeric/integer
+	if ( $bundling && defined $rest && $rest =~ /^(-?[0-9]+)(.*)$/s ) {
+	    $arg = $1;
+	    $rest = $2;
+	    unshift (@ARGV, $starter.$rest) if defined $rest && $rest ne '';
+	}
+	elsif ( $arg !~ /^-?[0-9]+$/ ) {
+	    if ( defined $optarg || $mand eq "=" ) {
+		if ( $passthrough ) {
+		    unshift (@ARGV, defined $rest ? $starter.$rest : $arg)
+		      unless defined $optarg;
+		    return (0);
+		}
+		warn ("Value \"", $arg, "\" invalid for option ",
+		      $opt, " (number expected)\n");
+		$error++;
+		undef $opt;
+		# Push back.
+		unshift (@ARGV, $starter.$rest) if defined $rest;
+	    }
+	    else {
+		# Push back.
+		unshift (@ARGV, defined $rest ? $starter.$rest : $arg);
+		# Supply default value.
+		$arg = 0;
+	    }
+	}
+    }
+
+    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]
+	if ( $bundling && defined $rest &&
+	     $rest =~ /^(-?[0-9]+(\.[0-9]+)?([eE]-?[0-9]+)?)(.*)$/s ) {
+	    $arg = $1;
+	    $rest = $+;
+	    unshift (@ARGV, $starter.$rest) if defined $rest && $rest ne '';
+	}
+	elsif ( $arg !~ /^-?[0-9.]+(\.[0-9]+)?([eE]-?[0-9]+)?$/ ) {
+	    if ( defined $optarg || $mand eq "=" ) {
+		if ( $passthrough ) {
+		    unshift (@ARGV, defined $rest ? $starter.$rest : $arg)
+		      unless defined $optarg;
+		    return (0);
+		}
+		warn ("Value \"", $arg, "\" invalid for option ",
+		      $opt, " (real number expected)\n");
+		$error++;
+		undef $opt;
+		# Push back.
+		unshift (@ARGV, $starter.$rest) if defined $rest;
+	    }
+	    else {
+		# Push back.
+		unshift (@ARGV, defined $rest ? $starter.$rest : $arg);
+		# Supply default value.
+		$arg = 0.0;
+	    }
+	}
+    }
+    else {
+	Croak ("GetOpt::Long internal error (Can't happen)\n");
+    }
+    return (1, $opt, $arg, $dsttype, $incr, $key);
+}
+
+# Getopt::Long Configuration.
+sub Configure (@) {
+    my (@options) = @_;
+    my $opt;
+    foreach $opt ( @options ) {
+	my $try = lc ($opt);
+	my $action = 1;
+	if ( $try =~ /^no_?(.*)$/s ) {
+	    $action = 0;
+	    $try = $+;
+	}
+	if ( $try eq 'default' or $try eq 'defaults' ) {
+	    ConfigDefaults () 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 =~ /^prefix=(.+)$/ ) {
+	    $genprefix = $1;
+	    # Turn into regexp. Needs to be parenthesized!
+	    $genprefix = "(" . quotemeta($genprefix) . ")";
+	    eval { '' =~ /$genprefix/; };
+	    Croak ("Getopt::Long: invalid pattern \"$genprefix\"") if $@;
+	}
+	elsif ( $try =~ /^prefix_pattern=(.+)$/ ) {
+	    $genprefix = $1;
+	    # Parenthesize if needed.
+	    $genprefix = "(" . $genprefix . ")" 
+	      unless $genprefix =~ /^\(.*\)$/;
+	    eval { '' =~ /$genprefix/; };
+	    Croak ("Getopt::Long: invalid pattern \"$genprefix\"") if $@;
+	}
+	elsif ( $try eq 'debug' ) {
+	    $debug = $action;
+	}
+	else {
+	    Croak ("Getopt::Long: unknown config parameter \"$opt\"")
+	}
+    }
+}
+
+# Deprecated name.
+sub config (@) {
+    Configure (@_);
+}
+
+# To prevent Carp from being loaded unnecessarily.
+sub Croak (@) {
+    require 'Carp.pm';
+    $Carp::CarpLevel = 1;
+    Carp::croak(@_);
+};
+
+################ Documentation ################
 
 =head1 NAME
 
@@ -60,18 +871,19 @@ 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:
 
-  &GetOptions("size=i" => \$offset);
+  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:
+a HASH describing the linkage for the options, or an object whose
+class is based on a HASH. The following call is equivalent to the
+example above:
 
   %optctl = ("size" => \$offset);
-  &GetOptions(\%optctl, "size=i");
+  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
@@ -82,14 +894,14 @@ 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:
+followed by an argument specifier.
 
-=over 8
+Options that do not take arguments will have no argument specifier. 
+The option variable will be set to 1 if the option is used.
 
-=item E<lt>noneE<gt>
+For the other options, the values for argument specifiers are:
 
-Option does not take an argument. 
-The option variable will be set to 1.
+=over 8
 
 =item !
 
@@ -98,6 +910,15 @@ Option does not take an argument and may be negated, i.e. prefixed by
 (with value 0).
 The option variable will be set to 1, or 0 if negated.
 
+=item +
+
+Option does not take an argument and will be incremented by 1 every
+time it appears on the command line. E.g. "more+", when used with
+B<--more --more --more>, will set the option variable to 3 (provided
+it was 0 or undefined at first).
+
+The B<+> specifier is ignored if the option destination is not a SCALAR.
+
 =item =s
 
 Option takes a mandatory string argument.
@@ -155,7 +976,7 @@ specified but a ref HASH is passed, GetOptions will place the value in
 the HASH. For example:
 
   %optctl = ();
-  &GetOptions (\%optctl, "size=i");
+  GetOptions (\%optctl, "size=i");
 
 will perform the equivalent of the assignment
 
@@ -164,7 +985,7 @@ will perform the equivalent of the assignment
 For array options, a reference to an array is used, e.g.:
 
   %optctl = ();
-  &GetOptions (\%optctl, "sizes=i@");
+  GetOptions (\%optctl, "sizes=i@");
 
 with command line "-sizes 24 -sizes 48" will perform the equivalent of
 the assignment
@@ -175,7 +996,7 @@ For hash options (an option whose argument looks like "name=value"),
 a reference to a hash is used, e.g.:
 
   %optctl = ();
-  &GetOptions (\%optctl, "define=s%");
+  GetOptions (\%optctl, "define=s%");
 
 with command line "--define foo=hello --define bar=world" will perform the
 equivalent of the assignment
@@ -191,7 +1012,7 @@ 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@");
+  GetOptions ("size=i", "sizes=i@");
 
 with command line "-size 10 -sizes 24 -sizes 48" will perform the
 equivalent of the assignments
@@ -205,6 +1026,12 @@ identifier is $opt_ .
 The linkage specifier can be a reference to a scalar, a reference to
 an array, a reference to a hash or a reference to a subroutine.
 
+Note that, if your code is running under the recommended C<use strict
+'vars'> pragma, it may be helpful to declare these package variables
+via C<use vars> perhaps something like this:
+
+  use vars qw/ $opt_size @opt_sizes $opt_bar /;
+
 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. 
@@ -226,10 +1053,11 @@ The option name is always the true name, not an abbreviation or alias.
 The option name may actually be a list of option names, separated by
 "|"s, e.g. "foo|bar|blech=s". In this example, "foo" is the true name
 of this option. If no linkage is specified, options "foo", "bar" and
-"blech" all will set $opt_foo.
+"blech" all will set $opt_foo. For convenience, the single character
+"?" is allowed as an alias, e.g. "help|?".
 
 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 +1065,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
@@ -250,10 +1080,20 @@ defined.
 Options that start with "--" may have an argument appended, separated
 with an "=", e.g. "--foo=bar".
 
-=head2 Return value
+=head2 Return values and Errors
+
+Configuration errors and errors in the option definitions are
+signalled using C<die()> and will terminate the calling
+program unless the call to C<Getopt::Long::GetOptions()> was embedded
+in C<eval { ... }> or C<die()> was trapped using C<$SIG{__DIE__}>.
+
+A return value of 1 (true) indicates success.
+
+A return status of 0 (false) indicates that the function detected one
+or more errors during option parsing. These errors are signalled using
+C<warn()> and can be trapped with C<$SIG{__WARN__}>.
 
-A return status of 0 (false) indicates that the function detected
-one or more errors.
+Errors that can't happen are signalled using C<Carp::croak()>.
 
 =head1 COMPATIBILITY
 
@@ -273,10 +1113,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
@@ -299,767 +1139,244 @@ argument), then the following situations are handled:
 
 Also, assume specifiers "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 = '--'
-
-Example of using variable 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:
-
-   $foo = 'blech'
-   $opt_bar = 24
-   @ar = ('xx','yy')
-
-Example of using the E<lt>E<gt> 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 $Getopt::Long::autoabbrev      
-
-Allow option names to be abbreviated to uniqueness.
-Default is 1 unless environment variable
-POSIXLY_CORRECT has been set.
-
-=item $Getopt::Long::getopt_compat   
-
-Allow '+' to start options.
-Default is 1 unless environment variable
-POSIXLY_CORRECT has been set.
-
-=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.
-
-$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::bundling
-
-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
+   -bar -xxx		-> $opt_bar = '', '-xxx' is next option
+   -foo -bar		-> $opt_foo = '-bar'
+   -foo --		-> $opt_foo = '--'
 
-    scale -h 24 -w 80
+In GNU or POSIX format, option names and values can be combined:
 
-B<Note:> Using option bundling can easily lead to unexpected results,
-especially when mixing long options and bundles. Caveat emptor.
+   +foo=blech		-> $opt_foo = 'blech'
+   --bar=		-> $opt_bar = ''
+   --bar=--		-> $opt_bar = '--'
 
-=item $Getopt::Long::ignorecase
+Example of using variable references:
 
-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.
+   $ret = GetOptions ('foo=s', \$foo, 'bar=i', 'ar=s', \@ar);
 
-=item $Getopt::Long::passthrough
+With command line options "-foo blech -bar 24 -ar xx -ar yy" 
+this will result in:
 
-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.
+   $foo = 'blech'
+   $opt_bar = 24
+   @ar = ('xx','yy')
 
-This can be very confusing, especially when $Getopt::Long::order is
-set to $PERMUTE.
+Example of using the E<lt>E<gt> option specifier:
 
-=item $Getopt::Long::VERSION
+   @ARGV = qw(-foo 1 bar -foo 2 blech);
+   GetOptions("foo=i", \$myfoo, "<>", \&mysub);
 
-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.
+Results:
 
-    use Getopt::Long 2.00;
+   mysub("bar") will be called (with $myfoo being 1)
+   mysub("blech") will be called (with $myfoo being 2)
 
-You can inspect $Getopt::Long::major_version and
-$Getopt::Long::minor_version for the individual components.
+Compare this with:
 
-=item $Getopt::Long::error
+   @ARGV = qw(-foo 1 bar -foo 2 blech);
+   GetOptions("foo=i", \$myfoo);
 
-Internal error flag. May be incremented from a call-back routine to
-cause options parsing to fail.
+This will leave the non-options in @ARGV:
 
-=item $Getopt::Long::debug           
+   $myfoo -> 2
+   @ARGV -> qw(bar blech)
 
-Enable copious debugging output. Default is 0.
+=head1 CONFIGURATION OPTIONS
 
-=back
+B<GetOptions> can be configured by calling subroutine
+B<Getopt::Long::Configure>. 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.
 
-=cut
+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.
 
-################ Introduction ################
-#
-# 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
-# of the License, or (at your option) any later version.
-# 
-# This program is distributed in the hope that it will be useful,
-# but WITHOUT ANY WARRANTY; without even the implied warranty of
-# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-# GNU General Public License for more details.
-# 
-# If you do not have a copy of the GNU General Public License write to
-# the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, 
-# MA 02139, USA.
+The following options are available:
 
-################ Configuration Section ################
+=over 12
 
-# Values for $order. See GNU getopt.c for details.
-($REQUIRE_ORDER, $PERMUTE, $RETURN_IN_ORDER) = (0..2);
+=item default
 
-my $gen_prefix;			# generic prefix (option starters)
+This option causes all configuration options to be reset to their
+default values.
 
-# 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;
-}
+=item auto_abbrev
 
-# 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+)/;
+Allow option names to be abbreviated to uniqueness.
+Default is set unless environment variable
+POSIXLY_CORRECT has been set, in which case B<auto_abbrev> is reset.
 
-use vars qw($genprefix %opctl @opctl %bopctl $opt $arg $argend $array);
-use vars qw(%aliases $hash $key);
+=item getopt_compat   
 
-################ Subroutines ################
+Allow '+' to start options.
+Default is set unless environment variable
+POSIXLY_CORRECT has been set, in which case B<getopt_compat> is reset.
 
-sub GetOptions {
+=item require_order
 
-    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
-				# Needed if linkage is omitted.
-    local (%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
-    $error = 0;
+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.
 
-    print STDERR ('GetOptions $Revision: 2.6001 $ ',
-		  "[GetOpt::Long $Getopt::Long::VERSION] -- ",
-		  "called from package \"$pkg\".\n",
-		  "  (@ARGV)\n",
-		  "  autoabbrev=$autoabbrev".
-		  ",bundling=$bundling",
-		  ",getopt_compat=$getopt_compat",
-		  ",order=$order",
-		  ",\n  ignorecase=$ignorecase",
-		  ",passthrough=$passthrough",
-		  ",genprefix=\"$genprefix\"",
-		  ".\n")
-	if $debug;
+See also B<permute>, which is the opposite of B<require_order>.
 
-    # Check for ref HASH as first argument. 
-    $userlinkage = undef;
-    if ( ref($optionlist[0]) && ref($optionlist[0]) eq 'HASH' ) {
-	$userlinkage = shift (@optionlist);
-    }
+=item permute
 
-    # See if the first element of the optionlist contains option
-    # starter characters.
-    if ( $optionlist[0] =~ /^\W+$/ ) {
-	$genprefix = shift (@optionlist);
-	# Turn into regexp.
-	$genprefix =~ s/(\W)/\\$1/g;
-	$genprefix = "[" . $genprefix . "]";
-    }
+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<permute> is reset.
+Note that B<permute> is the opposite of B<require_order>.
 
-    # Verify correctness of optionlist.
-    %opctl = ();
-    %bopctl = ();
-    while ( @optionlist > 0 ) {
-	my $opt = shift (@optionlist);
+If B<permute> is set, this means that 
 
-	# Strip leading prefix so people can specify "--foo=i" if they like.
-	$opt =~ s/^(?:$genprefix)+//s;
+    -foo arg1 -bar arg2 arg3
 
-	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");
-		$error++;
-		next;
-	    }
-	    $linkage{'<>'} = shift (@optionlist);
-	    next;
-	}
+is equivalent to
 
-	if ( $opt !~ /^(\w+[-\w|]*)?(!|[=:][infse][@%]?)?$/ ) {
-	    warn ("Error in option spec: \"", $opt, "\"\n");
-	    $error++;
-	    next;
-	}
-	my ($o, $c, $a) = ($1, $2);
-	$c = '' unless defined $c;
+    -foo -bar arg1 arg2 arg3
 
-	if ( ! defined $o ) {
-	    # empty -> '-' option
-	    $opctl{$o = ''} = $c;
-	}
-	else {
-	    # Handle alias names
-	    my @o =  split (/\|/, $o);
-	    my $linko = $o = $o[0];
-	    # Force an alias if the option name is not locase.
-	    $a = $o unless $o eq lc($o);
-	    $o = lc ($o)
-		if $ignorecase > 1 
-		    || ($ignorecase
-			&& ($bundling ? length($o) > 1  : 1));
+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:
 
-	    foreach ( @o ) {
-		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;
-		}
-		if ( defined $a ) {
-		    # Note alias.
-		    $aliases{$_} = $a;
-		}
-		else {
-		    # Set primary name.
-		    $a = $_;
-		}
-	    }
-	    $o = $linko;
-	}
+    -foo arg1 -bar arg2 -- arg3
 
-	# 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;
-		}
-	    }
-	}
+will call the call-back routine for arg1 and arg2, and terminate
+leaving arg2 in @ARGV.
 
-	# 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]) =~ /^(SCALAR|CODE)$/ ) {
-		$linkage{$o} = shift (@optionlist);
-	    }
-	    elsif ( ref($optionlist[0]) =~ /^(ARRAY)$/ ) {
-		$linkage{$o} = shift (@optionlist);
-		$opctl{$o} .= '@' unless $opctl{$o} =~ /\@$/;
-	    }
-	    elsif ( ref($optionlist[0]) =~ /^(HASH)$/ ) {
-		$linkage{$o} = shift (@optionlist);
-		$opctl{$o} .= '%' unless $opctl{$o} =~ /\%$/;
-	    }
-	    else {
-		warn ("Invalid option linkage for \"", $opt, "\"\n");
-		$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;");
-	    }
-	    elsif ( $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;");
-	    }
-	}
-    }
+If B<require_order> is set, options processing
+terminates when the first non-option is encountered.
 
-    # Bail out if errors found.
-    return 0 if $error;
+    -foo arg1 -bar arg2 arg3
 
-    # Sort the possible long option names.
-    local (@opctl) = sort(keys (%opctl)) if $autoabbrev;
+is equivalent to
 
-    # Show the options tables if debugging.
-    if ( $debug ) {
-	my ($arrow, $k, $v);
-	$arrow = "=> ";
-	while ( ($k,$v) = each(%opctl) ) {
-	    print STDERR ($arrow, "\$opctl{\"$k\"} = \"$v\"\n");
-	    $arrow = "   ";
-	}
-	$arrow = "=> ";
-	while ( ($k,$v) = each(%bopctl) ) {
-	    print STDERR ($arrow, "\$bopctl{\"$k\"} = \"$v\"\n");
-	    $arrow = "   ";
-	}
-    }
+    -foo -- arg1 -bar arg2 arg3
 
-    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
+=item bundling (default: reset)
 
-    # Process argument list
-    while ( @ARGV > 0 ) {
+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,
 
-	#### Get next argument ####
+    ps -vax --vax
 
-	$opt = shift (@ARGV);
-	$arg = undef;
-	$array = $hash = 0;
-	print STDERR ("=> option \"", $opt, "\"\n") if $debug;
+would be equivalent to
 
-	#### Determine what we have ####
+    ps -v -a -x --vax
 
-	# Double dash is option list terminator.
-	if ( $opt eq $argend ) {
-	    # Finish. Push back accumulated arguments and return.
-	    unshift (@ARGV, @ret) 
-		if $order == $PERMUTE;
-	    return ($error == 0);
-	}
+provided "vax", "v", "a" and "x" have been defined to be valid
+options. 
 
-	my $tryopt = $opt;
+Bundled options can also include a value in the bundle; for strings
+this value is the rest of the bundle, but integer and floating values
+may be combined in the bundle, e.g.
 
-	# find_option operates on the GLOBAL $opt and $arg!
-	if ( &find_option ) {
-	    
-	    # find_option undefines $opt in case of errors.
-	    next unless defined $opt;
+    scale -h24w80
 
-	    if ( defined $arg ) {
-		$opt = $aliases{$opt} if defined $aliases{$opt};
+is equivalent to
 
-		if ( defined $linkage{$opt} ) {
-		    print STDERR ("=> ref(\$L{$opt}) -> ",
-				  ref($linkage{$opt}), "\n") if $debug;
+    scale -h 24 -w 80
 
-		    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 'HASH' ) {
-			print STDERR ("=> \$\$L{$opt}->{$key} = \"$arg\"\n")
-			    if $debug;
-			$linkage{$opt}->{$key} = $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];
-		    }
-		}
-		elsif ( $hash ) {
-		    if ( defined $userlinkage->{$opt} ) {
-			print STDERR ("=> \$L{$opt}->{$key} = \"$arg\"\n")
-			    if $debug;
-			$userlinkage->{$opt}->{$key} = $arg;
-		    }
-		    else {
-			print STDERR ("=>\$L{$opt} = {$key => \"$arg\"}\n")
-			    if $debug;
-			$userlinkage->{$opt} = {$key => $arg};
-		    }
-		}
-		else {
-		    print STDERR ("=>\$L{$opt} = \"$arg\"\n") if $debug;
-		    $userlinkage->{$opt} = $arg;
-		}
-	    }
-	}
+Note: resetting B<bundling> also resets B<bundling_override>.
 
-	# Not an option. Save it if we $PERMUTE and don't have a <>.
-	elsif ( $order == $PERMUTE ) {
-	    # Try non-options call-back.
-	    my $cb;
-	    if ( (defined ($cb = $linkage{'<>'})) ) {
-		&$cb($tryopt);
-	    }
-	    else {
-		print STDERR ("=> saving \"$tryopt\" ",
-			      "(not an option, may permute)\n") if $debug;
-		push (@ret, $tryopt);
-	    }
-	    next;
-	}
+=item bundling_override (default: reset)
 
-	# ...otherwise, terminate.
-	else {
-	    # Push this one back and exit.
-	    unshift (@ARGV, $tryopt);
-	    return ($error == 0);
-	}
+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>.
 
-    # Finish.
-    if ( $order == $PERMUTE ) {
-	#  Push back accumulated arguments
-	print STDERR ("=> restoring \"", join('" "', @ret), "\"\n")
-	    if $debug && @ret > 0;
-	unshift (@ARGV, @ret) if @ret > 0;
-    }
+B<Note:> Using option bundling can easily lead to unexpected results,
+especially when mixing long options and bundles. Caveat emptor.
 
-    return ($error == 0);
-}
+=item ignore_case  (default: set)
 
-sub find_option {
+If set, case is ignored when matching options.
 
-    return 0 unless $opt =~ /^($genprefix)(.*)/s;
+Note: resetting B<ignore_case> also resets B<ignore_case_always>.
 
-    $opt = $+;
-    my ($starter) = $1;
+=item ignore_case_always (default: reset)
 
-    my $optarg = undef;	# value supplied with --opt=value
-    my $rest = undef;	# remainder from unbundling
+When bundling is in effect, case is ignored on single-character
+options also. 
 
-    # If it is a long option, it may include the value.
-    if (($starter eq "--" || $getopt_compat)
-	&& $opt =~ /^([^=]+)=(.*)/s ) {
-	$opt = $1;
-	$optarg = $2;
-	print STDERR ("=> option \"", $opt, 
-		      "\", optarg = \"$optarg\"\n") if $debug;
-    }
+Note: resetting B<ignore_case_always> also resets B<ignore_case>.
 
-    #### Look it up ###
+=item pass_through (default: reset)
 
-    my $tryopt = $opt;		# option to try
-    my $optbl = \%opctl;	# table to look it up (long names)
+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.
 
-    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
-    } 
+This can be very confusing, especially when B<permute> is also set.
 
-    # Try auto-abbreviation.
-    elsif ( $autoabbrev ) {
-	# Downcase if allowed.
-	$tryopt = $opt = lc ($opt) if $ignorecase;
-	# Turn option name into pattern.
-	my $pat = quotemeta ($opt);
-	# Look up in option names.
-	my @hits = grep (/^$pat/, @opctl);
-	print STDERR ("=> ", scalar(@hits), " hits (@hits) with \"$pat\" ",
-		      "out of ", scalar(@opctl), "\n") if $debug;
+=item prefix
 
-	# Check for ambiguous results.
-	unless ( (@hits <= 1) || (grep ($_ eq $opt, @hits) == 1) ) {
-	    # See if all matches are for the same option.
-	    my %hit;
-	    foreach ( @hits ) {
-		$_ = $aliases{$_} if defined $aliases{$_};
-		$hit{$_} = 1;
-	    }
-	    # Now see if it really is ambiguous.
-	    unless ( keys(%hit) == 1 ) {
-		return 0 if $passthrough;
-		print STDERR ("Option ", $opt, " is ambiguous (",
-			      join(", ", @hits), ")\n");
-		$error++;
-		undef $opt;
-		return 1;
-	    }
-	    @hits = keys(%hit);
-	}
+The string that starts options. See also B<prefix_pattern>.
 
-	# Complete the option name, if appropriate.
-	if ( @hits == 1 && $hits[0] ne $opt ) {
-	    $tryopt = $hits[0];
-	    $tryopt = lc ($tryopt) if $ignorecase;
-	    print STDERR ("=> option \"$opt\" -> \"$tryopt\"\n")
-		if $debug;
-	}
-    }
+=item prefix_pattern
 
-    # Map to all lowercase if ignoring case.
-    elsif ( $ignorecase ) {
-	$tryopt = lc ($opt);
-    }
+A Perl pattern that identifies the strings that introduce options.
+Default is C<(--|-|\+)> unless environment variable
+POSIXLY_CORRECT has been set, in which case it is C<(--|-)>.
 
-    # Check validity by fetching the info.
-    my $type = $optbl->{$tryopt};
-    unless  ( defined $type ) {
-	return 0 if $passthrough;
-	warn ("Unknown option: ", $opt, "\n");
-	$error++;
-	return 1;
-    }
-    # Apparently valid.
-    $opt = $tryopt;
-    print STDERR ("=> found \"$type\" for ", $opt, "\n") if $debug;
+=item debug (default: reset)
 
-    #### Determine argument status ####
+Enable copious debugging output.
 
-    # If it is an option w/o argument, we're almost finished with it.
-    if ( $type eq '' || $type eq '!' ) {
-	if ( defined $optarg ) {
-	    return 0 if $passthrough;
-	    print STDERR ("Option ", $opt, " does not take an argument\n");
-	    $error++;
-	    undef $opt;
-	}
-	elsif ( $type eq '' ) {
-	    $arg = 1;		# supply explicit value
-	}
-	else {
-	    substr ($opt, 0, 2) = ''; # strip NO prefix
-	    $arg = 0;		# supply explicit value
-	}
-	unshift (@ARGV, $starter.$rest) if defined $rest;
-	return 1;
-    }
+=back
 
-    # Get mandatory status and type info.
-    my $mand;
-    ($mand, $type, $array, $hash) = $type =~ /^(.)(.)(@?)(%?)$/;
+=head1 OTHER USEFUL VARIABLES
 
-    # Check if there is an option argument available.
-    if ( defined $optarg ? ($optarg eq '') 
-	 : !(defined $rest || @ARGV > 0) ) {
-	# Complain if this option needs an argument.
-	if ( $mand eq "=" ) {
-	    return 0 if $passthrough;
-	    print STDERR ("Option ", $opt, " requires an argument\n");
-	    $error++;
-	    undef $opt;
-	}
-	if ( $mand eq ":" ) {
-	    $arg = $type eq "s" ? '' : 0;
-	}
-	return 1;
-    }
+=over 12
 
-    # Get (possibly optional) argument.
-    $arg = (defined $rest ? $rest
-	    : (defined $optarg ? $optarg : shift (@ARGV)));
+=item $Getopt::Long::VERSION
 
-    # 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);
-    }
+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.
 
-    #### Check if the argument is valid for this option ####
+    use Getopt::Long 3.00;
 
-    if ( $type eq "s" ) {	# string
-	# A mandatory string takes anything. 
-	return 1 if $mand eq "=";
+You can inspect $Getopt::Long::major_version and
+$Getopt::Long::minor_version for the individual components.
 
-	# An optional string takes almost anything. 
-	return 1 if defined $optarg || defined $rest;
-	return 1 if $arg eq "-"; # ??
+=item $Getopt::Long::error
 
-	# Check for option or option list terminator.
-	if ($arg eq $argend ||
-	    $arg =~ /^$genprefix.+/) {
-	    # Push back.
-	    unshift (@ARGV, $arg);
-	    # Supply empty value.
-	    $arg = '';
-	}
-    }
+Internal error flag. May be incremented from a call-back routine to
+cause options parsing to fail.
 
-    elsif ( $type eq "n" || $type eq "i" ) { # numeric/integer
-	if ( $arg !~ /^-?[0-9]+$/ ) {
-	    if ( defined $optarg || $mand eq "=" ) {
-		return 0 if $passthrough;
-		print STDERR ("Value \"", $arg, "\" invalid for option ",
-			      $opt, " (number expected)\n");
-		$error++;
-		undef $opt;
-		# Push back.
-		unshift (@ARGV, $starter.$rest) if defined $rest;
-	    }
-	    else {
-		# Push back.
-		unshift (@ARGV, defined $rest ? $starter.$rest : $arg);
-		# Supply default value.
-		$arg = 0;
-	    }
-	}
-    }
+=back
 
-    elsif ( $type eq "f" ) { # real number, int is also ok
-	if ( $arg !~ /^-?[0-9.]+([eE]-?[0-9]+)?$/ ) {
-	    if ( defined $optarg || $mand eq "=" ) {
-		return 0 if  $passthrough;
-		print STDERR ("Value \"", $arg, "\" invalid for option ",
-			      $opt, " (real number expected)\n");
-		$error++;
-		undef $opt;
-		# Push back.
-		unshift (@ARGV, $starter.$rest) if defined $rest;
-	    }
-	    else {
-		# Push back.
-		unshift (@ARGV, defined $rest ? $starter.$rest : $arg);
-		# Supply default value.
-		$arg = 0.0;
-	    }
-	}
-    }
-    else {
-	die ("GetOpt::Long internal error (Can't happen)\n");
-    }
-    return 1;
-}
+=head1 AUTHOR
 
-################ Package return ################
+Johan Vromans E<lt>jvromans@squirrel.nlE<gt>
 
-1;
+=head1 COPYRIGHT AND DISCLAIMER
+
+This program is Copyright 1990,1998 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
+of the License, or (at your option) any later version.
+
+This program is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+GNU General Public License for more details.
+
+If you do not have a copy of the GNU General Public License write to
+the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, 
+MA 02139, USA.
+
+=cut