From: Rafael Garcia-Suarez <rgarciasuarez@gmail.com>
Date: Wed, 31 Jan 2007 13:58:40 +0000 (+0000)
Subject: Upgrade to Getopt::Long 2.36
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=8de02997ac38b64dd5d3d654b85f7d29a1fc56af;p=p5sagit%2Fp5-mst-13.2.git
Upgrade to Getopt::Long 2.36
p4raw-id: //depot/perl@30086
---
diff --git a/MANIFEST b/MANIFEST
index de0fe88..a795818 100644
--- 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
--- 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
--- 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
--- 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
--- 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
--- 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
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
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");