newer Getopt/Long.pm from public distribution cited in:
[p5sagit/p5-mst-13.2.git] / lib / Getopt / Long.pm
index fe7e12f..b580459 100644 (file)
@@ -2,12 +2,12 @@
 
 package Getopt::Long;
 
-# RCS Status      : $Id: GetoptLong.pm,v 2.16 1998-03-13 11:05:29+01 jv Exp $
+# 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: Fri Mar 13 11:05:28 1998
-# Update Count    : 659
+# Last Modified On: Sun Jun 14 13:17:22 1998
+# Update Count    : 705
 # Status          : Released
 
 ################ Copyright ################
@@ -34,71 +34,123 @@ 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.16 $ =~ /(\d+)\.(\d+)/);
-
-    @ISA       = qw(Exporter);
-    @EXPORT    = qw(&GetOptions $REQUIRE_ORDER $PERMUTE $RETURN_IN_ORDER);
-    %EXPORT_TAGS = ();
-    @EXPORT_OK = qw();
+    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);
 }
 
-use vars @EXPORT, @EXPORT_OK;
 # 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 ################
 
-my $gen_prefix;                        # generic prefix (option starters)
-my $argend;                    # option list terminator
-my %opctl;                     # table of arg.specs (long and abbrevs)
-my %bopctl;                    # table of arg.specs (bundles)
-my @opctl;                     # the possible long option names
-my $pkg;                       # current context. Needed if no linkage.
-my %aliases;                   # alias table
-my $genprefix;                 # so we can call the same module more 
-my $opt;                       # current option
-my $arg;                       # current option value, if any
-my $array;                     # current option is array typed
-my $hash;                      # current option is hash typed
-my $key;                       # hash key for a hash option
-                               # than once in differing environments
-my $config_defaults;           # set config defaults
-my $find_option;               # helper routine
-my $croak;                     # helper routine
-
-################ Subroutines ################
+################ 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
 
 sub GetOptions {
 
     my @optionlist = @_;       # local copy of the option descriptions
-    $argend = '--';            # option list terminator
-    %opctl = ();               # table of arg.specs (long and abbrevs)
-    %bopctl = ();              # table of arg.specs (bundles)
-    $pkg = (caller)[0];                # current context
+    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.
-    %aliases= ();              # alias table
+    my %aliases= ();           # alias table
     my @ret = ();              # accum for non-options
     my %linkage;               # linkage
     my $userlinkage;           # user supplied HASH
-    $genprefix = $gen_prefix;  # so we can call the same module many times
+    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 ('GetOptions $Revision: 2.16 $ ',
-                 "[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")
+    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. 
@@ -146,7 +198,7 @@ sub GetOptions {
        }
 
        # Match option spec. Allow '?' as an alias.
-       if ( $opt !~ /^((\w+[-\w]*)(\|(\?|\w[-\w]*)?)*)?(!|[=:][infse][@%]?)?$/ ) {
+       if ( $opt !~ /^((\w+[-\w]*)(\|(\?|\w[-\w]*)?)*)?([!~+]|[=:][infse][@%]?)?$/ ) {
            $error .= "Error in option spec: \"$opt\"\n";
            next;
        }
@@ -293,8 +345,6 @@ sub GetOptions {
        #### Get next argument ####
 
        $opt = shift (@ARGV);
-       $arg = undef;
-       $array = $hash = 0;
        print STDERR ("=> option \"", $opt, "\"\n") if $debug;
 
        #### Determine what we have ####
@@ -308,11 +358,19 @@ sub GetOptions {
        }
 
        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);
 
-       # find_option operates on the GLOBAL $opt and $arg!
-       if ( &$find_option () ) {
+       if ( $found ) {
            
-           # find_option undefines $opt in case of errors.
+           # FindOption undefines $opt in case of errors.
            next unless defined $opt;
 
            if ( defined $arg ) {
@@ -323,8 +381,21 @@ sub GetOptions {
                                  ref($linkage{$opt}), "\n") if $debug;
 
                    if ( ref($linkage{$opt}) eq 'SCALAR' ) {
-                       print STDERR ("=> \$\$L{$opt} = \"$arg\"\n") if $debug;
-                       ${$linkage{$opt}} = $arg;
+                       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")
@@ -344,11 +415,11 @@ sub GetOptions {
                    else {
                        print STDERR ("Invalid REF type \"", ref($linkage{$opt}),
                                      "\" in linkage\n");
-                       &$croak ("Getopt::Long -- internal error!\n");
+                       Croak ("Getopt::Long -- internal error!\n");
                    }
                }
                # No entry in linkage means entry in userlinkage.
-               elsif ( $array ) {
+               elsif ( $dsttype eq '@' ) {
                    if ( defined $userlinkage->{$opt} ) {
                        print STDERR ("=> push(\@{\$L{$opt}}, \"$arg\")\n")
                            if $debug;
@@ -360,7 +431,7 @@ sub GetOptions {
                        $userlinkage->{$opt} = [$arg];
                    }
                }
-               elsif ( $hash ) {
+               elsif ( $dsttype eq '%' ) {
                    if ( defined $userlinkage->{$opt} ) {
                        print STDERR ("=> \$L{$opt}->{$key} = \"$arg\"\n")
                            if $debug;
@@ -373,8 +444,20 @@ sub GetOptions {
                    }
                }
                else {
-                   print STDERR ("=>\$L{$opt} = \"$arg\"\n") if $debug;
-                   $userlinkage->{$opt} = $arg;
+                   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;
+                   }
                }
            }
        }
@@ -414,84 +497,19 @@ sub GetOptions {
     return ($error == 0);
 }
 
-sub config (@) {
-    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' ) {
-           &$config_defaults () if $action;
-       }
-       elsif ( $try eq 'auto_abbrev' or $try eq 'autoabbrev' ) {
-           $autoabbrev = $action;
-       }
-       elsif ( $try eq 'getopt_compat' ) {
-           $getopt_compat = $action;
-       }
-       elsif ( $try eq 'ignorecase' or $try eq 'ignore_case' ) {
-           $ignorecase = $action;
-       }
-       elsif ( $try eq 'ignore_case_always' ) {
-           $ignorecase = $action ? 2 : 0;
-       }
-       elsif ( $try eq 'bundling' ) {
-           $bundling = $action;
-       }
-       elsif ( $try eq 'bundling_override' ) {
-           $bundling = $action ? 2 : 0;
-       }
-       elsif ( $try eq 'require_order' ) {
-           $order = $action ? $REQUIRE_ORDER : $PERMUTE;
-       }
-       elsif ( $try eq 'permute' ) {
-           $order = $action ? $PERMUTE : $REQUIRE_ORDER;
-       }
-       elsif ( $try eq 'pass_through' or $try eq 'passthrough' ) {
-           $passthrough = $action;
-       }
-       elsif ( $try =~ /^prefix=(.+)$/ ) {
-           $gen_prefix = $1;
-           # Turn into regexp. Needs to be parenthesized!
-           $gen_prefix = "(" . quotemeta($gen_prefix) . ")";
-           eval { '' =~ /$gen_prefix/; };
-           &$croak ("Getopt::Long: invalid pattern \"$gen_prefix\"") if $@;
-       }
-       elsif ( $try =~ /^prefix_pattern=(.+)$/ ) {
-           $gen_prefix = $1;
-           # Parenthesize if needed.
-           $gen_prefix = "(" . $gen_prefix . ")" 
-             unless $gen_prefix =~ /^\(.*\)$/;
-           eval { '' =~ /$gen_prefix/; };
-           &$croak ("Getopt::Long: invalid pattern \"$gen_prefix\"") if $@;
-       }
-       elsif ( $try eq 'debug' ) {
-           $debug = $action;
-       }
-       else {
-           &$croak ("Getopt::Long: unknown config parameter \"$opt\"")
-       }
-    }
-}
-
-# To prevent Carp from being loaded unnecessarily.
-$croak = sub {
-    require 'Carp.pm';
-    $Carp::CarpLevel = 1;
-    Carp::croak(@_);
-};
+# Option lookup.
+sub FindOption ($$$$$$$) {
 
-################ Private Subroutines ################
+    # returns (1, $opt, $arg, $dsttype, $incr, $key) if okay,
+    # returns (0) otherwise.
 
-$find_option = sub {
+    my ($prefix, $argend, $opt, $opctl, $bopctl, $names, $aliases) = @_;
+    my $key;                   # hash key for a hash option
+    my $arg;
 
-    print STDERR ("=> find \"$opt\", genprefix=\"$genprefix\"\n") if $debug;
+    print STDERR ("=> find \"$opt\", prefix=\"$prefix\"\n") if $debug;
 
-    return 0 unless $opt =~ /^$genprefix(.*)$/s;
+    return (0) unless $opt =~ /^$prefix(.*)$/s;
 
     $opt = $+;
     my ($starter) = $1;
@@ -513,8 +531,10 @@ $find_option = sub {
     #### Look it up ###
 
     my $tryopt = $opt;         # option to try
-    my $optbl = \%opctl;       # table to look it up (long names)
+    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.
@@ -524,11 +544,11 @@ $find_option = sub {
        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
+       $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}) ) {
+            defined ($type = $opctl->{$tryopt.$rest}) ) {
            print STDERR ("=> $starter$tryopt rebundled to ",
                          "$starter$tryopt$rest\n") if $debug;
            $tryopt .= $rest;
@@ -543,26 +563,26 @@ $find_option = sub {
        # Turn option name into pattern.
        my $pat = quotemeta ($opt);
        # Look up in option names.
-       my @hits = grep (/^$pat/, @opctl);
+       my @hits = grep (/^$pat/, @{$names});
        print STDERR ("=> ", scalar(@hits), " hits (@hits) with \"$pat\" ",
-                     "out of ", scalar(@opctl), "\n") if $debug;
+                     "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{$_};
+               $_ = $aliases->{$_} if defined $aliases->{$_};
                $hit{$_} = 1;
            }
            # Now see if it really is ambiguous.
            unless ( keys(%hit) == 1 ) {
-               return 0 if $passthrough;
+               return (0) if $passthrough;
                warn ("Option ", $opt, " is ambiguous (",
                      join(", ", @hits), ")\n");
                $error++;
                undef $opt;
-               return 1;
+               return (1, $opt,$arg,$dsttype,$incr,$key);
            }
            @hits = keys(%hit);
        }
@@ -584,10 +604,10 @@ $find_option = sub {
     # Check validity by fetching the info.
     $type = $optbl->{$tryopt} unless defined $type;
     unless  ( defined $type ) {
-       return 0 if $passthrough;
+       return (0) if $passthrough;
        warn ("Unknown option: ", $opt, "\n");
        $error++;
-       return 1;
+       return (1, $opt,$arg,$dsttype,$incr,$key);
     }
     # Apparently valid.
     $opt = $tryopt;
@@ -596,34 +616,35 @@ $find_option = sub {
     #### Determine argument status ####
 
     # If it is an option w/o argument, we're almost finished with it.
-    if ( $type eq '' || $type eq '!' ) {
+    if ( $type eq '' || $type eq '!' || $type eq '+' ) {
        if ( defined $optarg ) {
-           return 0 if $passthrough;
+           return (0) if $passthrough;
            warn ("Option ", $opt, " does not take an argument\n");
            $error++;
            undef $opt;
        }
-       elsif ( $type eq '' ) {
+       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;
+       return (1, $opt,$arg,$dsttype,$incr,$key);
     }
 
     # Get mandatory status and type info.
     my $mand;
-    ($mand, $type, $array, $hash) = $type =~ /^(.)(.)(@?)(%?)$/;
+    ($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;
+           return (0) if $passthrough;
            warn ("Option ", $opt, " requires an argument\n");
            $error++;
            undef $opt;
@@ -631,7 +652,7 @@ $find_option = sub {
        if ( $mand eq ":" ) {
            $arg = $type eq "s" ? '' : 0;
        }
-       return 1;
+       return (1, $opt,$arg,$dsttype,$incr,$key);
     }
 
     # Get (possibly optional) argument.
@@ -640,7 +661,7 @@ $find_option = sub {
 
     # Get key if this is a "name=value" pair for a hash option.
     $key = undef;
-    if ($hash && defined $arg) {
+    if ($dsttype eq '%' && defined $arg) {
        ($key, $arg) = ($arg =~ /^(.*)=(.*)$/s) ? ($1, $2) : ($arg, 1);
     }
 
@@ -648,15 +669,16 @@ $find_option = sub {
 
     if ( $type eq "s" ) {      # string
        # A mandatory string takes anything. 
-       return 1 if $mand eq "=";
+       return (1, $opt,$arg,$dsttype,$incr,$key) if $mand eq "=";
 
        # An optional string takes almost anything. 
-       return 1 if defined $optarg || defined $rest;
-       return 1 if $arg eq "-"; # ??
+       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 =~ /^$genprefix.+/) {
+           $arg =~ /^$prefix.+/) {
            # Push back.
            unshift (@ARGV, $arg);
            # Supply empty value.
@@ -675,7 +697,7 @@ $find_option = sub {
                if ( $passthrough ) {
                    unshift (@ARGV, defined $rest ? $starter.$rest : $arg)
                      unless defined $optarg;
-                   return 0;
+                   return (0);
                }
                warn ("Value \"", $arg, "\" invalid for option ",
                      $opt, " (number expected)\n");
@@ -708,7 +730,7 @@ $find_option = sub {
                if ( $passthrough ) {
                    unshift (@ARGV, defined $rest ? $starter.$rest : $arg)
                      unless defined $optarg;
-                   return 0;
+                   return (0);
                }
                warn ("Value \"", $arg, "\" invalid for option ",
                      $opt, " (real number expected)\n");
@@ -726,49 +748,89 @@ $find_option = sub {
        }
     }
     else {
-       &$croak ("GetOpt::Long internal error (Can't happen)\n");
+       Croak ("GetOpt::Long internal error (Can't happen)\n");
     }
-    return 1;
-};
+    return (1, $opt, $arg, $dsttype, $incr, $key);
+}
 
-$config_defaults = sub {
-    # Handle POSIX compliancy.
-    if ( defined $ENV{"POSIXLY_CORRECT"} ) {
-       $gen_prefix = "(--|-)";
-       $autoabbrev = 0;                # no automatic abbrev of options
-       $bundling = 0;                  # no bundling of single letter switches
-       $getopt_compat = 0;             # disallow '+' to start options
-       $order = $REQUIRE_ORDER;
-    }
-    else {
-       $gen_prefix = "(--|-|\\+)";
-       $autoabbrev = 1;                # automatic abbrev of options
-       $bundling = 0;                  # bundling off by default
-       $getopt_compat = 1;             # allow '+' to start options
-       $order = $PERMUTE;
+# 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\"")
+       }
     }
-    # Other configurable settings.
-    $debug = 0;                        # for debugging
-    $error = 0;                        # error tally
-    $ignorecase = 1;           # ignore case when matching options
-    $passthrough = 0;          # leave unrecognized options alone
-};
-
-################ Initialization ################
-
-# Values for $order. See GNU getopt.c for details.
-($REQUIRE_ORDER, $PERMUTE, $RETURN_IN_ORDER) = (0..2);
-# Version major/minor numbers.
-($major_version, $minor_version) = $VERSION =~ /^(\d+)\.(\d+)/;
-
-# Set defaults.
-&$config_defaults ();
+}
 
-################ Package return ################
+# Deprecated name.
+sub config (@) {
+    Configure (@_);
+}
 
-1;
+# To prevent Carp from being loaded unnecessarily.
+sub Croak (@) {
+    require 'Carp.pm';
+    $Carp::CarpLevel = 1;
+    Carp::croak(@_);
+};
 
-__END__
+################ Documentation ################
 
 =head1 NAME
 
@@ -848,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.
@@ -959,7 +1030,7 @@ 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 /;
+  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
@@ -1112,7 +1183,7 @@ This will leave the non-options in @ARGV:
 =head1 CONFIGURATION OPTIONS
 
 B<GetOptions> can be configured by calling subroutine
-B<Getopt::Long::config>. This subroutine takes a list of quoted
+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>