From: Rafael Garcia-Suarez Date: Tue, 31 Mar 2009 13:37:03 +0000 (+0200) Subject: Upgrade to Getopt::Long 2.38 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=a19443d4be3894faa115fcf4f652a54645eb94b2;p=p5sagit%2Fp5-mst-13.2.git Upgrade to Getopt::Long 2.38 --- diff --git a/lib/Getopt/Long.pm b/lib/Getopt/Long.pm index f44e615..c827d3c 100644 --- a/lib/Getopt/Long.pm +++ b/lib/Getopt/Long.pm @@ -2,32 +2,14 @@ package Getopt::Long; -# RCS Status : $Id: Long.pm,v 2.74 2007/09/29 13:40:13 jv Exp $ +# RCS Status : $Id: Long.pm,v 2.76 2009/03/30 20:54:30 jv Exp $ # Author : Johan Vromans # Created On : Tue Sep 11 15:00:12 1990 # Last Modified By: Johan Vromans -# Last Modified On: Sat Sep 29 15:38:55 2007 -# Update Count : 1571 +# Last Modified On: Mon Mar 30 22:51:17 2009 +# Update Count : 1601 # Status : Released -################ Copyright ################ - -# 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 -# Foundation; either version 2 of the License, or (at your option) any -# later version. -# -# This program is distributed in the hope that it will be useful, -# but WITHOUT ANY WARRANTY; without even the implied warranty of -# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -# GNU General Public License for more details. -# -# If you do not have a copy of the GNU General Public License write to -# the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, -# MA 02139, USA. - ################ Module Preamble ################ use 5.004; @@ -35,10 +17,10 @@ use 5.004; use strict; use vars qw($VERSION); -$VERSION = 2.37; +$VERSION = 2.38; # For testing versions only. -use vars qw($VERSION_STRING); -$VERSION_STRING = "2.37"; +#use vars qw($VERSION_STRING); +#$VERSION_STRING = "2.38"; use Exporter; use vars qw(@ISA @EXPORT @EXPORT_OK); @@ -46,8 +28,8 @@ use vars qw(@ISA @EXPORT @EXPORT_OK); # Exported subroutines. sub GetOptions(@); # always -sub GetOptionsFromArray($@); # on demand -sub GetOptionsFromString($@); # on demand +sub GetOptionsFromArray(@); # on demand +sub GetOptionsFromString(@); # on demand sub Configure(@); # on demand sub HelpMessage(@); # on demand sub VersionMessage(@); # in demand @@ -205,7 +187,7 @@ sub getoptions { # Locally set exception handler to default, otherwise it will # be called implicitly here, and again explicitly when we try # to deliver the messages. - local ($SIG{__DIE__}) = '__DEFAULT__'; + local ($SIG{__DIE__}) = 'DEFAULT'; $ret = Getopt::Long::GetOptions (@_); }; @@ -271,7 +253,7 @@ sub GetOptions(@) { goto &GetOptionsFromArray; } -sub GetOptionsFromString($@) { +sub GetOptionsFromString(@) { my ($string) = shift; require Text::ParseWords; my $args = [ Text::ParseWords::shellwords($string) ]; @@ -285,7 +267,7 @@ sub GetOptionsFromString($@) { $ret; } -sub GetOptionsFromArray($@) { +sub GetOptionsFromArray(@) { my ($argv, @optionlist) = @_; # local copy of the option descriptions my $argend = '--'; # option list terminator @@ -305,7 +287,7 @@ sub GetOptionsFromArray($@) { local ($^W) = 0; print STDERR ("Getopt::Long $Getopt::Long::VERSION (", - '$Revision: 2.74 $', ") ", + '$Revision: 2.76 $', ") ", "called from package \"$pkg\".", "\n ", "argv: (@$argv)", @@ -460,6 +442,14 @@ sub GetOptionsFromArray($@) { eval ("\$linkage{\$orig} = \\\$".$pkg."::opt_$ov;"); } } + + if ( $opctl{$name}[CTL_TYPE] eq 'I' + && ( $opctl{$name}[CTL_DEST] == CTL_DEST_ARRAY + || $opctl{$name}[CTL_DEST] == CTL_DEST_HASH ) + ) { + $error .= "Invalid option linkage for \"$opt\"\n"; + } + } # Bail out if errors found. @@ -588,7 +578,7 @@ sub GetOptionsFromArray($@) { if $debug; my $eval_error = do { local $@; - local $SIG{__DIE__} = '__DEFAULT__'; + local $SIG{__DIE__} = 'DEFAULT'; eval { &{$linkage{$opt}} (Getopt::Long::CallBack->new @@ -706,8 +696,17 @@ sub GetOptionsFromArray($@) { if $debug; my $eval_error = do { local $@; - local $SIG{__DIE__} = '__DEFAULT__'; - eval { &$cb ($tryopt) }; + local $SIG{__DIE__} = 'DEFAULT'; + eval { + &$cb + (Getopt::Long::CallBack->new + (name => $tryopt, + ctl => $ctl, + opctl => \%opctl, + linkage => \%linkage, + prefix => $prefix, + )); + }; $@; }; print STDERR ("=> die($eval_error)\n") @@ -777,7 +776,7 @@ sub ParseOptionSpec ($$) { # Option name (?: \w+[-\w]* ) # Alias names, or "?" - (?: \| (?: \? | \w[-\w]* )? )* + (?: \| (?: \? | \w[-\w]* ) )* )? ( # Either modifiers ... @@ -950,7 +949,7 @@ sub FindOption ($$$$$) { } # Try auto-abbreviation. - elsif ( $autoabbrev ) { + elsif ( $autoabbrev && $opt ne "" ) { # Sort the possible long option names. my @names = sort(keys (%$opctl)); # Downcase if allowed. @@ -1016,7 +1015,12 @@ sub FindOption ($$$$$) { $opt = substr($opt,0,1); unshift (@$argv, $starter.$rest) if defined $rest; } - warn ("Unknown option: ", $opt, "\n"); + if ( $opt eq "" ) { + warn ("Missing option after ", $starter, "\n"); + } + else { + warn ("Unknown option: ", $opt, "\n"); + } $error++; return (1, undef); } @@ -1481,9 +1485,8 @@ sub name { } use overload - # Treat this object as an oridinary string for legacy API. + # Treat this object as an ordinary string for legacy API. '""' => \&name, - '0+' => sub { 0 }, fallback => 1; 1; @@ -1749,7 +1752,7 @@ When used with command line options: --define os=linux --define vendor=redhat the hash C<%defines> (or C<%$defines>) will contain two keys, C<"os"> -with value C<"linux> and C<"vendor"> with value C<"redhat">. It is +with value C<"linux"> and C<"vendor"> with value C<"redhat">. It is also possible to specify that only integer or floating point numbers are acceptable values. The keys are always taken to be strings. @@ -1760,7 +1763,8 @@ an option is encountered on the command line can be achieved by designating a reference to a subroutine (or an anonymous subroutine) as the option destination. When GetOptions() encounters the option, it will call the subroutine with two or three arguments. The first -argument is the name of the option. For a scalar or array destination, +argument is the name of the option. (Actually, it is an object that +stringifies to the name of the option.) For a scalar or array destination, the second argument is the value to be stored. For a hash destination, the second arguments is the key to the hash, and the third argument the value to be stored. It is up to the subroutine to store the value, @@ -1786,6 +1790,12 @@ it is interpreted specially by GetOptions(). There is currently one special command implemented: C will cause GetOptions() to stop processing options, as if it encountered a double dash C<-->. +In version 2.37 the first argument to the callback function was +changed from string to object. This was done to make room for +extensions and more detailed control. The object stringifies to the +option name so this change should not introduce compatibility +problems. + =head2 Options with multiple names Often it is user friendly to supply alternate mnemonic names for @@ -2155,7 +2165,8 @@ it will set variable C<$stdio>. A special option 'name' C<< <> >> can be used to designate a subroutine to handle non-option arguments. When GetOptions() encounters an argument that does not look like an option, it will immediately call this -subroutine and passes it one parameter: the argument name. +subroutine and passes it one parameter: the argument name. Well, actually +it is an object that stringifies to the argument name. For example: @@ -2567,7 +2578,7 @@ This can be accomplished with a destination routine: GetOptions('list=s%' => sub { push(@{$list{$_[1]}}, $_[2]) }); -=head1 Trouble Shooting +=head1 Troubleshooting =head2 GetOptions does not return a false result when an option is not supplied @@ -2618,7 +2629,7 @@ Johan Vromans =head1 COPYRIGHT AND DISCLAIMER -This program is Copyright 1990,2007 by Johan Vromans. +This program is Copyright 1990,2009 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 071deb3..679da2a 100644 --- a/lib/Getopt/Long/CHANGES +++ b/lib/Getopt/Long/CHANGES @@ -1,6 +1,22 @@ +Changes in version 2.38 +----------------------- + +* Bugfix for Ticket 35759: First arg to callback function evaluates + to false when used in bool context. + +* Fix problem with prototypes of GetOptionsFrom* functions. + +* Fix restoring default die handler. + +* Bugfix for Ticket 24941: Autoabbrev with + incorrect. + Changes in version 2.37 ----------------------- +* The first argument to callback function is now an object and will + get methods for finer control in the future. The object stringifies + to the option name, so current code should not notice a difference. + * Bugfix: With gnu_compat, --foo= will no longer trigger "Option requires an argument" but return the empty string. diff --git a/lib/Getopt/Long/README b/lib/Getopt/Long/README index fb653f3..b1b8e2a 100644 --- a/lib/Getopt/Long/README +++ b/lib/Getopt/Long/README @@ -200,7 +200,7 @@ Or use the CPAN search engine: COPYRIGHT AND DISCLAIMER ======================== -Module Getopt::Long is Copyright 2006,1990 by Johan Vromans. +Module Getopt::Long is Copyright 2009,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/newgetopt.pl b/lib/newgetopt.pl index 95eef22..1de6a6e 100644 --- a/lib/newgetopt.pl +++ b/lib/newgetopt.pl @@ -1,4 +1,4 @@ -# $Id: newgetopt.pl,v 1.18 2001-09-21 15:34:59+02 jv Exp $ +# $Id: newgetopt.pl,v 1.18 2001/09/21 13:34:59 jv Exp $ # This library is no longer being maintained, and is included for backward # compatibility with Perl 4 programs which may require it.