From: Rafael Garcia-Suarez 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 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 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 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. As with C, the +global C<@ARGV> is not touched. + +It is possible that, upon completion, not all arguments in the string +have been processed. C 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 was not called in +list context, a message will be given and C 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 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 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 =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");