Upgrade to Getopt::Long 2.36

p4raw-id: //depot/perl@30086

diff --git a/MANIFEST b/MANIFEST
index de0fe88..a795818 100644 (file)
--- a/MANIFEST
+++ b/MANIFEST
@@ -1798,6 +1798,8 @@ lib/Getopt/Long/t/gol-basic.t     See if Getopt::Long works
 lib/Getopt/Long/t/gol-compat.t See if Getopt::Long works
 lib/Getopt/Long/t/gol-linkage.t        See if Getopt::Long works
 lib/Getopt/Long/t/gol-oo.t     See if Getopt::Long works
+lib/Getopt/Long/t/gol-xargv.t  See if Getopt::Long works
+lib/Getopt/Long/t/gol-xstring.t        See if Getopt::Long works
 lib/getopt.pl                  Perl library supporting option parsing
 lib/getopts.pl                 Perl library supporting option parsing
 lib/Getopt/Std.pm              Fetch command options (getopt, getopts)

diff --git a/lib/Getopt/Long.pm b/lib/Getopt/Long.pm
index 4c2253a..77a86ad 100644 (file)
--- a/lib/Getopt/Long.pm
+++ b/lib/Getopt/Long.pm
@@ -2,17 +2,17 @@
 
 package Getopt::Long;
 
-# RCS Status      : $Id: GetoptLong.pm,v 2.72 2005-04-28 21:18:33+02 jv Exp $
+# RCS Status      : $Id: Long.pm,v 2.73 2007/01/27 20:00:34 jv Exp $
 # Author          : Johan Vromans
 # Created On      : Tue Sep 11 15:00:12 1990
 # Last Modified By: Johan Vromans
-# Last Modified On: Wed Dec 14 21:17:21 2005
-# Update Count    : 1458
+# Last Modified On: Sat Jan 27 20:59:00 2007
+# Update Count    : 1552
 # Status          : Released
 
 ################ Copyright ################
 
-# This program is Copyright 1990,2005 by Johan Vromans.
+# This program is Copyright 1990,2007 by Johan Vromans.
 # This program is free software; you can redistribute it and/or
 # modify it under the terms of the Perl Artistic License or the
 # GNU General Public License as published by the Free Software
@@ -35,10 +35,10 @@ use 5.004;
 use strict;
 
 use vars qw($VERSION);
-$VERSION        =  2.35_01;
+$VERSION        =  2.36;
 # For testing versions only.
-#use vars qw($VERSION_STRING);
-#$VERSION_STRING = "2.35";
+use vars qw($VERSION_STRING);
+$VERSION_STRING = "2.36";
 
 use Exporter;
 use vars qw(@ISA @EXPORT @EXPORT_OK);
@@ -46,6 +46,8 @@ use vars qw(@ISA @EXPORT @EXPORT_OK);
 
 # Exported subroutines.
 sub GetOptions(@);             # always
+sub GetOptionsFromArray($@);   # on demand
+sub GetOptionsFromString($@);  # on demand
 sub Configure(@);              # on demand
 sub HelpMessage(@);            # on demand
 sub VersionMessage(@);         # in demand
@@ -53,7 +55,8 @@ sub VersionMessage(@);                # in demand
 BEGIN {
     # Init immediately so their contents can be used in the 'use vars' below.
     @EXPORT    = qw(&GetOptions $REQUIRE_ORDER $PERMUTE $RETURN_IN_ORDER);
-    @EXPORT_OK = qw(&HelpMessage &VersionMessage &Configure);
+    @EXPORT_OK = qw(&HelpMessage &VersionMessage &Configure
+                   &GetOptionsFromArray &GetOptionsFromString);
 }
 
 # User visible variables.
@@ -72,7 +75,7 @@ sub config(@);                        # deprecated name
 sub ConfigDefaults();
 sub ParseOptionSpec($$);
 sub OptCtl($);
-sub FindOption($$$$);
+sub FindOption($$$$$);
 sub ValidValue ($$$$$);
 
 ################ Local Variables ################
@@ -247,9 +250,44 @@ use constant CTL_AMAX    => 5;
 #use constant CTL_RANGE   => ;
 #use constant CTL_REPEAT  => ;
 
+# Rather liberal patterns to match numbers.
+use constant PAT_INT   => "[-+]?_*[0-9][0-9_]*";
+use constant PAT_XINT  =>
+  "(?:".
+         "[-+]?_*[1-9][0-9_]*".
+  "|".
+         "0x_*[0-9a-f][0-9a-f_]*".
+  "|".
+         "0b_*[01][01_]*".
+  "|".
+         "0[0-7_]*".
+  ")";
+use constant PAT_FLOAT => "[-+]?[0-9._]+(\.[0-9_]+)?([eE][-+]?[0-9_]+)?";
+
 sub GetOptions(@) {
+    # Shift in default array.
+    unshift(@_, \@ARGV);
+    # Try to keep caller() and Carp consitent.
+    goto &GetOptionsFromArray;
+}
+
+sub GetOptionsFromString($@) {
+    my ($string) = shift;
+    require Text::ParseWords;
+    my $args = [ Text::ParseWords::shellwords($string) ];
+    $caller ||= (caller)[0];   # current context
+    my $ret = GetOptionsFromArray($args, @_);
+    return ( $ret, $args ) if wantarray;
+    if ( @$args ) {
+       $ret = 0;
+       warn("GetOptionsFromString: Excess data \"@$args\" in string \"$string\"\n");
+    }
+    $ret;
+}
 
-    my @optionlist = @_;       # local copy of the option descriptions
+sub GetOptionsFromArray($@) {
+
+    my ($argv, @optionlist) = @_;      # local copy of the option descriptions
     my $argend = '--';         # option list terminator
     my %opctl = ();            # table of option specs
     my $pkg = $caller || (caller)[0];  # current context
@@ -267,10 +305,10 @@ sub GetOptions(@) {
        local ($^W) = 0;
        print STDERR
          ("Getopt::Long $Getopt::Long::VERSION (",
-          '$Revision: 2.72 $', ") ",
+          '$Revision: 2.73 $', ") ",
           "called from package \"$pkg\".",
           "\n  ",
-          "ARGV: (@ARGV)",
+          "argv: (@$argv)",
           "\n  ",
           "autoabbrev=$autoabbrev,".
           "bundling=$bundling,",
@@ -383,7 +421,7 @@ sub GetOptions(@) {
            elsif ( $rl eq "HASH" ) {
                $opctl{$name}[CTL_DEST] = CTL_DEST_HASH;
            }
-           elsif ( $rl eq "SCALAR" ) {
+           elsif ( $rl eq "SCALAR" || $rl eq "REF" ) {
 #              if ( $opctl{$name}[CTL_DEST] == CTL_DEST_ARRAY ) {
 #                  my $t = $linkage{$orig};
 #                  $$t = $linkage{$orig} = [];
@@ -456,10 +494,10 @@ sub GetOptions(@) {
 
     # Process argument list
     my $goon = 1;
-    while ( $goon && @ARGV > 0 ) {
+    while ( $goon && @$argv > 0 ) {
 
        # Get next argument.
-       $opt = shift (@ARGV);
+       $opt = shift (@$argv);
        print STDERR ("=> arg \"", $opt, "\"\n") if $debug;
 
        # Double dash is option list terminator.
@@ -476,7 +514,7 @@ sub GetOptions(@) {
        my $ctl;                # the opctl entry
 
        ($found, $opt, $ctl, $arg, $key) =
-         FindOption ($prefix, $argend, $opt, \%opctl);
+         FindOption ($argv, $prefix, $argend, $opt, \%opctl);
 
        if ( $found ) {
 
@@ -495,7 +533,8 @@ sub GetOptions(@) {
                    print STDERR ("=> ref(\$L{$opt}) -> ",
                                  ref($linkage{$opt}), "\n") if $debug;
 
-                   if ( ref($linkage{$opt}) eq 'SCALAR' ) {
+                   if ( ref($linkage{$opt}) eq 'SCALAR'
+                        || ref($linkage{$opt}) eq 'REF' ) {
                        if ( $ctl->[CTL_TYPE] eq '+' ) {
                            print STDERR ("=> \$\$L{$opt} += \"$arg\"\n")
                              if $debug;
@@ -551,9 +590,16 @@ sub GetOptions(@) {
                            local $@;
                            local $SIG{__DIE__}  = '__DEFAULT__';
                            eval {
-                               &{$linkage{$opt}}($opt,
-                                                 $ctl->[CTL_DEST] == CTL_DEST_HASH ? ($key) : (),
-                                                 $arg);
+                               &{$linkage{$opt}}
+                                 (Getopt::Long::CallBack->new
+                                  (name    => $opt,
+                                   ctl     => $ctl,
+                                   opctl   => \%opctl,
+                                   linkage => \%linkage,
+                                   prefix  => $prefix,
+                                  ),
+                                  $ctl->[CTL_DEST] == CTL_DEST_HASH ? ($key) : (),
+                                  $arg);
                            };
                            $@;
                        };
@@ -623,14 +669,15 @@ sub GetOptions(@) {
 
                # Need more args?
                if ( $argcnt < $ctl->[CTL_AMIN] ) {
-                   if ( @ARGV ) {
-                       if ( ValidValue($ctl, $ARGV[0], 1, $argend, $prefix) ) {
-                           $arg = shift(@ARGV);
+                   if ( @$argv ) {
+                       if ( ValidValue($ctl, $argv->[0], 1, $argend, $prefix) ) {
+                           $arg = shift(@$argv);
+                           $arg =~ tr/_//d if $ctl->[CTL_TYPE] =~ /^[iIo]$/;
                            ($key,$arg) = $arg =~ /^([^=]+)=(.*)/
                              if $ctl->[CTL_DEST] == CTL_DEST_HASH;
                            next;
                        }
-                       warn("Value \"$ARGV[0]\" invalid for option $opt\n");
+                       warn("Value \"$$argv[0]\" invalid for option $opt\n");
                        $error++;
                    }
                    else {
@@ -640,8 +687,9 @@ sub GetOptions(@) {
                }
 
                # Any more args?
-               if ( @ARGV && ValidValue($ctl, $ARGV[0], 0, $argend, $prefix) ) {
-                   $arg = shift(@ARGV);
+               if ( @$argv && ValidValue($ctl, $argv->[0], 0, $argend, $prefix) ) {
+                   $arg = shift(@$argv);
+                   $arg =~ tr/_//d if $ctl->[CTL_TYPE] =~ /^[iIo]$/;
                    ($key,$arg) = $arg =~ /^([^=]+)=(.*)/
                      if $ctl->[CTL_DEST] == CTL_DEST_HASH;
                    next;
@@ -685,7 +733,7 @@ sub GetOptions(@) {
        # ...otherwise, terminate.
        else {
            # Push this one back and exit.
-           unshift (@ARGV, $tryopt);
+           unshift (@$argv, $tryopt);
            return ($error == 0);
        }
 
@@ -696,7 +744,7 @@ sub GetOptions(@) {
        #  Push back accumulated arguments
        print STDERR ("=> restoring \"", join('" "', @ret), "\"\n")
            if $debug;
-       unshift (@ARGV, @ret);
+       unshift (@$argv, @ret);
     }
 
     return ($error == 0);
@@ -842,13 +890,13 @@ sub ParseOptionSpec ($$) {
 }
 
 # Option lookup.
-sub FindOption ($$$$) {
+sub FindOption ($$$$$) {
 
     # returns (1, $opt, $ctl, $arg, $key) if okay,
     # returns (1, undef) if option in error,
     # returns (0) otherwise.
 
-    my ($prefix, $argend, $opt, $opctl) = @_;
+    my ($argv, $prefix, $argend, $opt, $opctl) = @_;
 
     print STDERR ("=> find \"$opt\"\n") if $debug;
 
@@ -966,7 +1014,7 @@ sub FindOption ($$$$) {
        # Pretend one char when bundling.
        if ( $bundling == 1 && length($starter) == 1 ) {
            $opt = substr($opt,0,1);
-            unshift (@ARGV, $starter.$rest) if defined $rest;
+            unshift (@$argv, $starter.$rest) if defined $rest;
        }
        warn ("Unknown option: ", $opt, "\n");
        $error++;
@@ -998,7 +1046,7 @@ sub FindOption ($$$$) {
            $opt =~ s/^no-?//i; # strip NO prefix
            $arg = 0;           # supply explicit value
        }
-       unshift (@ARGV, $starter.$rest) if defined $rest;
+       unshift (@$argv, $starter.$rest) if defined $rest;
        return (1, $opt, $ctl, $arg);
     }
 
@@ -1014,7 +1062,7 @@ sub FindOption ($$$$) {
     # Check if there is an option argument available.
     if ( defined $optarg
         ? ($optarg eq '')
-        : !(defined $rest || @ARGV > 0) ) {
+        : !(defined $rest || @$argv > 0) ) {
        # Complain if this option needs an argument.
        if ( $mand ) {
            return (0) if $passthrough;
@@ -1035,7 +1083,7 @@ sub FindOption ($$$$) {
 
     # Get (possibly optional) argument.
     $arg = (defined $rest ? $rest
-           : (defined $optarg ? $optarg : shift (@ARGV)));
+           : (defined $optarg ? $optarg : shift (@$argv)));
 
     # Get key if this is a "name=value" pair for a hash option.
     my $key;
@@ -1047,7 +1095,7 @@ sub FindOption ($$$$) {
            warn ("Option $opt, key \"$key\", requires a value\n");
            $error++;
            # Push back.
-           unshift (@ARGV, $starter.$rest) if defined $rest;
+           unshift (@$argv, $starter.$rest) if defined $rest;
            return (1, undef);
        }
     }
@@ -1060,6 +1108,10 @@ sub FindOption ($$$$) {
        # A mandatory string takes anything.
        return (1, $opt, $ctl, $arg, $key) if $mand;
 
+       # Same for optional string as a hash value
+       return (1, $opt, $ctl, $arg, $key)
+         if $ctl->[CTL_DEST] == CTL_DEST_HASH;
+
        # An optional string takes almost anything.
        return (1, $opt, $ctl, $arg, $key)
          if defined $optarg || defined $rest;
@@ -1069,7 +1121,7 @@ sub FindOption ($$$$) {
        if ($arg eq $argend ||
            $arg =~ /^$prefix.+/) {
            # Push back.
-           unshift (@ARGV, $arg);
+           unshift (@$argv, $arg);
            # Supply empty value.
            $arg = '';
        }
@@ -1079,24 +1131,23 @@ sub FindOption ($$$$) {
             || $type eq 'I'    # numeric/integer w/ incr default
            || $type eq 'o' ) { # dec/oct/hex/bin value
 
-       my $o_valid =
-         $type eq 'o' ? "[-+]?[1-9][0-9]*|0x[0-9a-f]+|0b[01]+|0[0-7]*"
-           : "[-+]?[0-9]+";
+       my $o_valid = $type eq 'o' ? PAT_XINT : PAT_INT;
 
        if ( $bundling && defined $rest
             && $rest =~ /^($key_valid)($o_valid)(.*)$/si ) {
            ($key, $arg, $rest) = ($1, $2, $+);
            chop($key) if $key;
            $arg = ($type eq 'o' && $arg =~ /^0/) ? oct($arg) : 0+$arg;
-           unshift (@ARGV, $starter.$rest) if defined $rest && $rest ne '';
+           unshift (@$argv, $starter.$rest) if defined $rest && $rest ne '';
        }
-       elsif ( $arg =~ /^($o_valid)$/si ) {
+       elsif ( $arg =~ /^$o_valid$/si ) {
+           $arg =~ tr/_//d;
            $arg = ($type eq 'o' && $arg =~ /^0/) ? oct($arg) : 0+$arg;
        }
        else {
            if ( defined $optarg || $mand ) {
                if ( $passthrough ) {
-                   unshift (@ARGV, defined $rest ? $starter.$rest : $arg)
+                   unshift (@$argv, defined $rest ? $starter.$rest : $arg)
                      unless defined $optarg;
                    return (0);
                }
@@ -1106,12 +1157,12 @@ sub FindOption ($$$$) {
                      "number expected)\n");
                $error++;
                # Push back.
-               unshift (@ARGV, $starter.$rest) if defined $rest;
+               unshift (@$argv, $starter.$rest) if defined $rest;
                return (1, undef);
            }
            else {
                # Push back.
-               unshift (@ARGV, defined $rest ? $starter.$rest : $arg);
+               unshift (@$argv, defined $rest ? $starter.$rest : $arg);
                if ( $type eq 'I' ) {
                    # Fake incremental type.
                    my @c = @$ctl;
@@ -1128,16 +1179,21 @@ sub FindOption ($$$$) {
        # We require at least one digit before a point or 'e',
        # and at least one digit following the point and 'e'.
        # [-]NN[.NN][eNN]
+       my $o_valid = PAT_FLOAT;
        if ( $bundling && defined $rest &&
-            $rest =~ /^($key_valid)([-+]?[0-9]+(\.[0-9]+)?([eE][-+]?[0-9]+)?)(.*)$/s ) {
+            $rest =~ /^($key_valid)($o_valid)(.*)$/s ) {
+           $arg =~ tr/_//d;
            ($key, $arg, $rest) = ($1, $2, $+);
            chop($key) if $key;
-           unshift (@ARGV, $starter.$rest) if defined $rest && $rest ne '';
+           unshift (@$argv, $starter.$rest) if defined $rest && $rest ne '';
        }
-       elsif ( $arg !~ /^[-+]?[0-9.]+(\.[0-9]+)?([eE][-+]?[0-9]+)?$/ ) {
+       elsif ( $arg =~ /^$o_valid$/ ) {
+           $arg =~ tr/_//d;
+       }
+       else {
            if ( defined $optarg || $mand ) {
                if ( $passthrough ) {
-                   unshift (@ARGV, defined $rest ? $starter.$rest : $arg)
+                   unshift (@$argv, defined $rest ? $starter.$rest : $arg)
                      unless defined $optarg;
                    return (0);
                }
@@ -1145,12 +1201,12 @@ sub FindOption ($$$$) {
                      $opt, " (real number expected)\n");
                $error++;
                # Push back.
-               unshift (@ARGV, $starter.$rest) if defined $rest;
+               unshift (@$argv, $starter.$rest) if defined $rest;
                return (1, undef);
            }
            else {
                # Push back.
-               unshift (@ARGV, defined $rest ? $starter.$rest : $arg);
+               unshift (@$argv, defined $rest ? $starter.$rest : $arg);
                # Supply default value.
                $arg = 0.0;
            }
@@ -1187,10 +1243,7 @@ sub ValidValue ($$$$$) {
             || $type eq 'I'    # numeric/integer w/ incr default
            || $type eq 'o' ) { # dec/oct/hex/bin value
 
-       my $o_valid =
-         $type eq 'o' ? "[-+]?[1-9][0-9]*|0x[0-9a-f]+|0b[01]+|0[0-7]*"
-           : "[-+]?[0-9]+";
-
+       my $o_valid = $type eq 'o' ? PAT_XINT : PAT_INT;
        return $arg =~ /^$o_valid$/si;
     }
 
@@ -1198,7 +1251,8 @@ sub ValidValue ($$$$$) {
        # We require at least one digit before a point or 'e',
        # and at least one digit following the point and 'e'.
        # [-]NN[.NN][eNN]
-       return $arg =~ /^[-+]?[0-9.]+(\.[0-9]+)?([eE][-+]?[0-9]+)?$/;
+       my $o_valid = PAT_FLOAT;
+       return $arg =~ /^$o_valid$/;
     }
     die("ValidValue: Cannot happen\n");
 }
@@ -1264,7 +1318,7 @@ sub Configure (@) {
        elsif ( $try eq 'ignorecase' or $try eq 'ignore_case' ) {
            $ignorecase = $action;
        }
-       elsif ( $try eq 'ignore_case_always' ) {
+       elsif ( $try eq 'ignorecase_always' or $try eq 'ignore_case_always' ) {
            $ignorecase = $action ? 2 : 0;
        }
        elsif ( $try eq 'bundling' ) {
@@ -1413,6 +1467,24 @@ sub VERSION {
     shift->SUPER::VERSION(@_);
 }
 
+package Getopt::Long::CallBack;
+
+sub new {
+    my ($pkg, %atts) = @_;
+    bless { %atts }, $pkg;
+}
+
+sub name {
+    my $self = shift;
+    ''.$self->{name};
+}
+
+use overload
+  # Treat this object as an oridinary string for legacy API.
+  '""'    => \&name,
+  '0+'    => sub { 0 },
+  fallback => 1;
+
 1;
 
 ################ Documentation ################
@@ -1921,11 +1993,51 @@ messages. For example:
 
 See L<Pod::Usage> for details.
 
-=head2 Storing option values in a hash
+=head2 Parsing options from an arbitrary array
+
+By default, GetOptions parses the options that are present in the
+global array C<@ARGV>. A special entry C<GetOptionsFromArray> can be
+used to parse options from an arbitrary array.
+
+    use Getopt::Long qw(GetOptionsFromArray);
+    $ret = GetOptionsFromArray(\@myopts, ...);
+
+When used like this, the global C<@ARGV> is not touched at all.
+
+The following two calls behave identically:
+
+    $ret = GetOptions( ... );
+    $ret = GetOptionsFromArray(\@ARGV, ... );
+
+=head2 Parsing options from an arbitrary string
+
+A special entry C<GetOptionsFromString> can be used to parse options
+from an arbitrary string.
+
+    use Getopt::Long qw(GetOptionsFromString);
+    $ret = GetOptionsFromString($string, ...);
+
+The contents of the string are split into arguments using a call to
+C<Text::ParseWords::shellwords>. As with C<GetOptionsFromArray>, the
+global C<@ARGV> is not touched.
+
+It is possible that, upon completion, not all arguments in the string
+have been processed. C<GetOptionsFromString> will, when called in list
+context, return both the return status and an array reference to any
+remaining arguments:
+
+    ($ret, $args) = GetOptionsFromString($string, ... );
+
+If any arguments remain, and C<GetOptionsFromString> was not called in
+list context, a message will be given and C<GetOptionsFromString> will
+return failure.
+
+=head2 Storing options values in a hash
 
 Sometimes, for example when there are a lot of options, having a
 separate variable for each of them can be cumbersome. GetOptions()
-supports, as an alternative mechanism, storing options in a hash.
+supports, as an alternative mechanism, storing options values in a
+hash.
 
 To obtain this, a reference to a hash must be passed I<as the first
 argument> to GetOptions(). For each option that is specified on the
@@ -2435,6 +2547,25 @@ configuring. Although manipulating these variables still work, it is
 strongly encouraged to use the C<Configure> routine that was introduced
 in version 2.17. Besides, it is much easier.
 
+=head1 Tips and Techniques
+
+=head2 Pushing multiple values in a hash option
+
+Sometimes you want to combine the best of hashes and arrays. For
+example, the command line:
+
+  --list add=first --list add=second --list add=third
+
+where each successive 'list add' option will push the value of add
+into array ref $list->{'add'}. The result would be like
+
+  $list->{add} = [qw(first second third)];
+
+This can be accomplished with a destination routine:
+
+  GetOptions('list=s%' =>
+               sub { push(@{$list{$_[1]}}, $_[2]) });
+
 =head1 Trouble Shooting
 
 =head2 GetOptions does not return a false result when an option is not supplied
@@ -2486,7 +2617,7 @@ Johan Vromans <jvromans@squirrel.nl>
 
 =head1 COPYRIGHT AND DISCLAIMER
 
-This program is Copyright 1990,2005 by Johan Vromans.
+This program is Copyright 1990,2007 by Johan Vromans.
 This program is free software; you can redistribute it and/or
 modify it under the terms of the Perl Artistic License or the
 GNU General Public License as published by the Free Software

diff --git a/lib/Getopt/Long/CHANGES b/lib/Getopt/Long/CHANGES
index 21b5596..2a22e6d 100644 (file)
--- a/lib/Getopt/Long/CHANGES
+++ b/lib/Getopt/Long/CHANGES
@@ -1,3 +1,47 @@
+Changes in version 2.36
+-----------------------
+
+**************** WARNING -- EXPERIMENTAL CODE AHEAD ****************
+
+* Parsing options from an arbitrary array
+
+  The entry point GetOptionsFromArray (exported on demand) can be used
+  to parse command line options that are not passed in via @ARGV, but
+  using an arbitrary array.
+
+    use Getopt::Long qw(GetOptionsFromArray);
+    $ret = GetOptionsFromArray(\@myopts, ...);
+
+* Parsing options from an arbitrary string
+
+  The entry point GetOptionsFromString (exported on demand) can be
+  used to parse command line options that are not passed in via @ARGV,
+  but using an arbitrary string.
+
+    use Getopt::Long qw(GetOptionsFromString);
+    $ret = GetOptionsFromString($optstring, ...);
+
+  Note that upon completion, no arguments may remain in the string.
+  If arguments may remain, call it in list context:
+
+    ($ret, $args) = GetOptionsFromString($optstring, ...);
+
+  @$args will have the remaining arguments.
+
+**************** END EXPERIMENTAL CODE ****************
+
+* Number values for options may include underscores for readability
+  (just like Perls numbers).
+
+* Bugfix for Ticket #19432 (found and fixed by khali).
+
+* Bugfix to make it cooperate with the bignum pragma. Thanks to Merijn
+  and Yves.
+
+* Various small fixes to make the test suite run under 5.004_05.
+
+* More examples (skeletons).
+
 Changes in version 2.35
 -----------------------
 
@@ -19,9 +63,7 @@ Changes in version 2.35
 * Bugfix for Ticket #11377 (bug found and fixed by Ryan).
 * Bugfix for Ticket #12380.
 
-**************** WARNING -- EXPERIMENTAL CODE AHEAD ****************
-
-* [Experimental] Options can take multiple values at once. E.g.,
+* Options can take multiple values at once. E.g.,
 
     --coordinates 52.2 16.4 --rgbcolor 255 255 149
 
@@ -34,8 +76,6 @@ Changes in version 2.35
   The syntax for this is similar to that of regular expression
   patterns: { min , max }. 
 
-**************** END EXPERIMENTAL CODE ****************
-
 Changes in version 2.34
 -----------------------
 

diff --git a/lib/Getopt/Long/README b/lib/Getopt/Long/README
index cddaec1..fb653f3 100644 (file)
--- a/lib/Getopt/Long/README
+++ b/lib/Getopt/Long/README
@@ -11,10 +11,10 @@ instead of single letters, and are introduced with a double dash `--'.
 Optionally, Getopt::Long can support the traditional bundling of
 single-letter command line options.
 
-Getopt::Long::GetOptions() is part of the Perl 5 distribution. It is
-the successor of newgetopt.pl that came with Perl 4. It is fully
-upward compatible. In fact, the Perl 5 version of newgetopt.pl is just
-a wrapper around the module.
+Getopt::Long is part of the Perl 5 distribution. It is the successor
+of newgetopt.pl that came with Perl 4. It is fully upward compatible.
+In fact, the Perl 5 version of newgetopt.pl is just a wrapper around
+the module.
 
 For complete documentation, see the Getopt::Long POD document or use
 the command
@@ -200,7 +200,7 @@ Or use the CPAN search engine:
 COPYRIGHT AND DISCLAIMER
 ========================
 
-Module Getopt::Long is Copyright 2005,1990 by Johan Vromans.
+Module Getopt::Long is Copyright 2006,1990 by Johan Vromans.
 This program is free software; you can redistribute it and/or
 modify it under the terms of the Perl Artistic License or the
 GNU General Public License as published by the Free Software

diff --git a/lib/Getopt/Long/t/gol-basic.t b/lib/Getopt/Long/t/gol-basic.t
index 24a71db..1ad5b75 100644 (file)
--- a/lib/Getopt/Long/t/gol-basic.t
+++ b/lib/Getopt/Long/t/gol-basic.t
@@ -20,7 +20,7 @@ print "1..9\n";
 @ARGV = qw(-Foo -baR --foo bar);
 undef $opt_baR;
 undef $opt_bar;
-print "ok 1\n" if GetOptions ("foo", "Foo=s");
+print (GetOptions("foo", "Foo=s") ? "" : "not ", "ok 1\n");
 print ((defined $opt_foo)   ? "" : "not ", "ok 2\n");
 print (($opt_foo == 1)      ? "" : "not ", "ok 3\n");
 print ((defined $opt_Foo)   ? "" : "not ", "ok 4\n");

diff --git a/lib/Getopt/Long/t/gol-linkage.t b/lib/Getopt/Long/t/gol-linkage.t
index 1302471..df975c8 100644 (file)
--- a/lib/Getopt/Long/t/gol-linkage.t
+++ b/lib/Getopt/Long/t/gol-linkage.t
@@ -11,7 +11,7 @@ BEGIN {
 
 use Getopt::Long;
 
-print "1..32\n";
+print "1..33\n";
 
 @ARGV = qw(-Foo -baR --foo bar);
 Getopt::Long::Configure ("no_ignore_case");
@@ -77,3 +77,17 @@ print (!(exists $lnk{bar})   ? "" : "not ", "ok 28\n");
     print ((defined $lnk{Foo})   ? "" : "not ", "ok 31\n");
     print (($lnk{Foo} eq "-baR") ? "" : "not ", "ok 32\n");
 }
+
+{
+    # Allow hashes to overload "".
+    # This used to fail up to 2.34.
+    # Thanks to Yves Orton.
+    my $blessed = bless(\%lnk, "OverLoad::Test");
+
+    @ARGV = qw(--foo bar);
+    Getopt::Long::Configure("default");
+    print "not" unless GetOptions (\%lnk, "foo=s" => \$foo);
+    print "ok 33\n";
+    package Overload::Test;
+    use overload '""' => sub{ die "Bad mojo!" };
+}

diff --git a/lib/Getopt/Long/t/gol-xargv.t b/lib/Getopt/Long/t/gol-xargv.t
new file mode 100644 (file)
index 0000000..52294e8
--- /dev/null
+++ b/lib/Getopt/Long/t/gol-xargv.t
@@ -0,0 +1,33 @@
+#!./perl -w
+
+no strict;
+
+BEGIN {
+    if ($ENV{PERL_CORE}) {
+       @INC = '../lib';
+       chdir 't';
+    }
+}
+
+use Getopt::Long qw(GetOptionsFromArray :config no_ignore_case);
+my $want_version="2.3501";
+die("Getopt::Long version $want_version required--this is only version ".
+    $Getopt::Long::VERSION)
+  unless $Getopt::Long::VERSION ge $want_version;
+
+print "1..10\n";
+
+my @argv = qw(-Foo -baR --foo bar);
+@ARGV = qw(foo bar);
+undef $opt_baR;
+undef $opt_bar;
+print (GetOptionsFromArray(\@argv, "foo", "Foo=s") ? "" : "not ", "ok 1\n");
+print ((defined $opt_foo)   ? "" : "not ", "ok 2\n");
+print (($opt_foo == 1)      ? "" : "not ", "ok 3\n");
+print ((defined $opt_Foo)   ? "" : "not ", "ok 4\n");
+print (($opt_Foo eq "-baR") ? "" : "not ", "ok 5\n");
+print ((@argv == 1)         ? "" : "not ", "ok 6\n");
+print (($argv[0] eq "bar")  ? "" : "not ", "ok 7\n");
+print (!(defined $opt_baR)  ? "" : "not ", "ok 8\n");
+print (!(defined $opt_bar)  ? "" : "not ", "ok 9\n");
+print ("@ARGV" eq "foo bar" ? "" : "not ", "ok 10\n");

diff --git a/lib/Getopt/Long/t/gol-xstring.t b/lib/Getopt/Long/t/gol-xstring.t
new file mode 100644 (file)
index 0000000..0d63191
--- /dev/null
+++ b/lib/Getopt/Long/t/gol-xstring.t
@@ -0,0 +1,54 @@
+#!./perl -w
+
+no strict;
+
+BEGIN {
+    if ($ENV{PERL_CORE}) {
+       @INC = '../lib';
+       chdir 't';
+    }
+}
+
+use Getopt::Long qw(GetOptionsFromString :config no_ignore_case);
+my $want_version="2.3501";
+die("Getopt::Long version $want_version required--this is only version ".
+    $Getopt::Long::VERSION)
+  unless $Getopt::Long::VERSION ge $want_version;
+
+print "1..14\n";
+
+my $args = "-Foo -baR --foo";
+@ARGV = qw(foo bar);
+undef $opt_baR;
+undef $opt_bar;
+print (GetOptionsFromString($args, "foo", "Foo=s") ? "" : "not ", "ok 1\n");
+print ((defined $opt_foo)   ? "" : "not ", "ok 2\n");
+print (($opt_foo == 1)      ? "" : "not ", "ok 3\n");
+print ((defined $opt_Foo)   ? "" : "not ", "ok 4\n");
+print (($opt_Foo eq "-baR") ? "" : "not ", "ok 5\n");
+print (!(defined $opt_baR)  ? "" : "not ", "ok 6\n");
+print (!(defined $opt_bar)  ? "" : "not ", "ok 7\n");
+print ("@ARGV" eq "foo bar" ? "" : "not ", "ok 8\n");
+
+$args = "-Foo -baR blech --foo bar";
+@ARGV = qw(foo bar);
+undef $opt_baR;
+undef $opt_bar;
+{ my $msg = "";
+  local $SIG{__WARN__} = sub { $msg .= "@_" };
+  my $ret = GetOptionsFromString($args, "foo", "Foo=s");
+  print ($ret ? "not " : "ok 9\n");
+  print ($msg =~ /^GetOptionsFromString: Excess data / ? "" : "$msg\nnot ", "ok 10\n");
+}
+print ("@ARGV" eq "foo bar" ? "" : "not ", "ok 11\n");
+
+$args = "-Foo -baR blech --foo bar";
+@ARGV = qw(foo bar);
+undef $opt_baR;
+undef $opt_bar;
+{ my $ret;
+  ($ret, $args) = GetOptionsFromString($args, "foo", "Foo=s");
+  print ($ret ? "" : "not ", "ok 12\n");
+  print ("@$args" eq "blech bar" ? "" : "@$args\nnot ", "ok 13\n");
+}
+print ("@ARGV" eq "foo bar" ? "" : "not ", "ok 14\n");