From: Rafael Garcia-Suarez Date: Sun, 27 Nov 2005 22:42:42 +0000 (+0000) Subject: Upgrade to Getopt::Long 2.34_04 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=554627f6cca63a97a56622204edb354e6a52c0ca;p=p5sagit%2Fp5-mst-13.2.git Upgrade to Getopt::Long 2.34_04 p4raw-id: //depot/perl@26216 --- diff --git a/lib/Getopt/Long.pm b/lib/Getopt/Long.pm index ace249a..c1f64f4 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.68 2003-09-23 15:24:53+02 jv Exp jv $ +# RCS Status : $Id: GetoptLong.pm,v 2.72 2005-04-28 21:18:33+02 jv Exp $ # Author : Johan Vromans # Created On : Tue Sep 11 15:00:12 1990 # Last Modified By: Johan Vromans -# Last Modified On: Wed Dec 31 20:48:15 2003 -# Update Count : 1440 +# Last Modified On: Thu Apr 28 21:14:19 2005 +# Update Count : 1456 # Status : Released ################ Copyright ################ -# This program is Copyright 1990,2002 by Johan Vromans. +# This program is Copyright 1990,2005 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.3401; +$VERSION = 2.3404; # For testing versions only. use vars qw($VERSION_STRING); -$VERSION_STRING = "2.34_01"; +$VERSION_STRING = "2.34_04"; use Exporter; use vars qw(@ISA @EXPORT @EXPORT_OK); @@ -63,7 +63,7 @@ use vars qw($error $debug $major_version $minor_version); use vars qw($autoabbrev $getopt_compat $ignorecase $bundling $order $passthrough); # Official invisible variables. -use vars qw($genprefix $caller $gnu_compat $auto_help $auto_version); +use vars qw($genprefix $caller $gnu_compat $auto_help $auto_version $longprefix); # Public subroutines. sub config(@); # deprecated name @@ -106,6 +106,7 @@ sub ConfigDefaults() { $ignorecase = 1; # ignore case when matching options $passthrough = 0; # leave unrecognized options alone $gnu_compat = 0; # require --opt=val if value is optional + $longprefix = "(--)"; # what does a long prefix look like } # Override import. @@ -266,7 +267,7 @@ sub GetOptions(@) { local ($^W) = 0; print STDERR ("Getopt::Long $Getopt::Long::VERSION (", - '$Revision: 2.68 $', ") ", + '$Revision: 2.72 $', ") ", "called from package \"$pkg\".", "\n ", "ARGV: (@ARGV)", @@ -280,7 +281,8 @@ sub GetOptions(@) { "ignorecase=$ignorecase,", "requested_version=$requested_version,", "passthrough=$passthrough,", - "genprefix=\"$genprefix\".", + "genprefix=\"$genprefix\",", + "longprefix=\"$longprefix\".", "\n"); } @@ -611,7 +613,7 @@ sub GetOptions(@) { } $argcnt++; - last if $argcnt >= $ctl->[CTL_AMAX]; + last if $argcnt >= $ctl->[CTL_AMAX] && $ctl->[CTL_AMAX] != -1; undef($arg); # Need more args? @@ -858,7 +860,7 @@ sub FindOption ($$$$) { # If it is a long option, it may include the value. # With getopt_compat, only if not bundling. - if ( ($starter eq "--" + if ( ($starter=~/^$longprefix$/ || ($getopt_compat && ($bundling == 0 || $bundling == 2))) && $opt =~ /^([^=]+)=(.*)$/s ) { $opt = $1; @@ -913,9 +915,10 @@ sub FindOption ($$$$) { # See if all matches are for the same option. my %hit; foreach ( @hits ) { - $_ = $opctl->{$_}->[CTL_CNAME] - if defined $opctl->{$_}->[CTL_CNAME]; - $hit{$_} = 1; + my $hit = $_; + $hit = $opctl->{$hit}->[CTL_CNAME] + if defined $opctl->{$hit}->[CTL_CNAME]; + $hit{$hit} = 1; } # Remove auto-supplied options (version, help). if ( keys(%hit) == 2 ) { @@ -956,7 +959,7 @@ sub FindOption ($$$$) { unless ( defined $ctl ) { return (0) if $passthrough; # Pretend one char when bundling. - if ( $bundling == 1) { + if ( $bundling == 1 && length($starter) == 1 ) { $opt = substr($opt,0,1); unshift (@ARGV, $starter.$rest) if defined $rest; } @@ -1202,13 +1205,14 @@ sub Configure (@) { my $prevconfig = [ $error, $debug, $major_version, $minor_version, $autoabbrev, $getopt_compat, $ignorecase, $bundling, $order, - $gnu_compat, $passthrough, $genprefix, $auto_version, $auto_help ]; + $gnu_compat, $passthrough, $genprefix, $auto_version, $auto_help, + $longprefix ]; if ( ref($options[0]) eq 'ARRAY' ) { ( $error, $debug, $major_version, $minor_version, $autoabbrev, $getopt_compat, $ignorecase, $bundling, $order, - $gnu_compat, $passthrough, $genprefix, $auto_version, $auto_help ) = - @{shift(@options)}; + $gnu_compat, $passthrough, $genprefix, $auto_version, $auto_help, + $longprefix ) = @{shift(@options)}; } my $opt; @@ -1283,9 +1287,17 @@ sub Configure (@) { # Parenthesize if needed. $genprefix = "(" . $genprefix . ")" unless $genprefix =~ /^\(.*\)$/; - eval { '' =~ /$genprefix/; }; + eval { '' =~ m"$genprefix"; }; die("Getopt::Long: invalid pattern \"$genprefix\"") if $@; } + elsif ( $try =~ /^long_prefix_pattern=(.+)$/ && $action ) { + $longprefix = $1; + # Parenthesize if needed. + $longprefix = "(" . $longprefix . ")" + unless $longprefix =~ /^\(.*\)$/; + eval { '' =~ m"$longprefix"; }; + die("Getopt::Long: invalid long prefix pattern \"$longprefix\"") if $@; + } elsif ( $try eq 'debug' ) { $debug = $action; } @@ -1605,7 +1617,7 @@ destination: Used with the example above, C<@libfiles> (or C<@$libfiles>) would contain two strings upon completion: C<"lib/srdlib"> and C<"lib/extlib">, in that order. It is also possible to specify that -only integer or floating point numbers are acceptable values. +only integer or floating point numbers are acceptible values. Often it is useful to allow comma-separated lists of values as well as multiple occurrences of the options. This is easy using Perl's split() @@ -1656,7 +1668,7 @@ When used with command line options: 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 also possible to specify that only integer or floating point numbers -are acceptable values. The keys are always taken to be strings. +are acceptible values. The keys are always taken to be strings. =head2 User-defined subroutines to handle options @@ -1686,7 +1698,7 @@ the desired error message as its argument. GetOptions() will catch the die(), issue the error message, and record that an error result must be returned upon completion. -If the text of the error message starts with an exclamation mark C +If the text of the error message starts with an exclamantion mark C 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<-->. @@ -1702,7 +1714,8 @@ the above example: GetOptions ('length|height=f' => \$length); The first name is called the I name, the other names are -called I. +called I. When using a hash to store options, the key will +always be the primary name. Multiple alternate names are possible. @@ -1890,7 +1903,7 @@ messages. For example: =head1 DESCRIPTION - B will read the given input file(s) and do something + B will read the given input file(s) and do someting useful with the contents thereof. =cut @@ -1962,7 +1975,7 @@ The first level of bundling can be enabled with: Configured this way, single-character options can be bundled but long options B always start with a double dash C<--> to avoid -ambiguity. For example, when C, C, C and C are all valid +abiguity. For example, when C, C, C and C are all valid options, -vax @@ -2115,7 +2128,7 @@ is equivalent to --foo --bar arg1 arg2 arg3 If an argument callback routine is specified, C<@ARGV> will always be -empty upon successful return of GetOptions() since all options have been +empty upon succesful return of GetOptions() since all options have been processed. The only exception is when C<--> is used: --foo arg1 --bar arg2 -- arg3 @@ -2152,7 +2165,7 @@ auto_abbrev enabled, possible arguments and option settings are: -al, -la, -ala, -all,... a, l --al, --all all -The surprising part is that C<--a> sets option C (due to auto +The suprising part is that C<--a> sets option C (due to auto completion), not C. Note: disabling C also disables C. @@ -2236,8 +2249,21 @@ sufficient, see C. =item prefix_pattern A Perl pattern that identifies the strings that introduce options. -Default is C<(--|-|\+)> unless environment variable -POSIXLY_CORRECT has been set, in which case it is C<(--|-)>. +Default is C<--|-|\+> unless environment variable +POSIXLY_CORRECT has been set, in which case it is C<--|->. + +=item long_prefix_pattern + +A Perl pattern that allows the disambiguation of long and short +prefixes. Default is C<-->. + +Typically you only need to set this if you are using nonstandard +prefixes and want some or all of them to have the same semantics as +'--' does under normal circumstances. + +For example, setting prefix_pattern to C<--|-|\+|\/> and +long_prefix_pattern to C<--|\/> would add Win32 style argument +handling. =item debug (default: disabled) @@ -2449,7 +2475,7 @@ Johan Vromans =head1 COPYRIGHT AND DISCLAIMER -This program is Copyright 2003,1990 by Johan Vromans. +This program is Copyright 1990,2005 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 2c77c5e..21b5596 100644 --- a/lib/Getopt/Long/CHANGES +++ b/lib/Getopt/Long/CHANGES @@ -1,6 +1,26 @@ Changes in version 2.35 ----------------------- +* long_prefix_pattern configuration variable. + + prefix_pattern has now been complemented by a new configuration + option 'long_prefix_pattern' that allows the user to specify what + prefix patterns should have long option style sematics applied. + This will enable people to do things like + + foo.pl /option=value + + instead of forcing people to use the short option style + + foo.pl /option value + + This enhancement was suggested and implemented by Yves Orton. + +* 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., --coordinates 52.2 16.4 --rgbcolor 255 255 149 @@ -14,6 +34,8 @@ 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 ----------------------- @@ -39,8 +61,6 @@ Changes in version 2.34 Changes in version 2.33 ----------------------- -**************** WARNING -- EXPERIMENTAL CODE AHEAD **************** - The following new features are marked experimental. This means that if you are going to use them you _must_ watch out for the next release of Getopt::Long to see if the API has changed. @@ -83,8 +103,6 @@ Getopt::Long to see if the API has changed. use Getopt::Long 2.33 qw(GetOptions HelpMessage); GetOptions(...) or HelpMessage(2); -**************** END EXPERIMENTAL CODE **************** - * Subroutine Configure can now be exported on demand. * Negatable options (with "!") now also support the "no-" prefix. diff --git a/lib/Getopt/Long/README b/lib/Getopt/Long/README index 691253d..cddaec1 100644 --- a/lib/Getopt/Long/README +++ b/lib/Getopt/Long/README @@ -69,6 +69,7 @@ By default, single-letter option names are case sensitive. "nodebug" will switch it off. - options can set values, but also add values producing an array of values instead of a single scalar value, or set values in a hash. + - options can have multiple values, e.g., "--position 25 624". * Options linkage @@ -162,8 +163,15 @@ to reverse the effect: - prefix_pattern A Perl pattern that identifies the strings that introduce - options. Default is (--|-|\+) unless environment variable - POSIXLY_CORRECT has been set, in which case it is (--|-). + options. Default is --|-|\+ unless environment variable + POSIXLY_CORRECT has been set, in which case it is --|-. + + - long_prefix_pattern + + A perl pattern that is used to identify which prefixes + should be treated as long style. Any prefixes that don't + match this pattern will have short option semantics. + Defaults to --. - debug @@ -192,7 +200,7 @@ Or use the CPAN search engine: COPYRIGHT AND DISCLAIMER ======================== -Module Getopt::Long is Copyright 2003,1990 by Johan Vromans. +Module Getopt::Long is Copyright 2005,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 @@ -201,6 +209,6 @@ later version. ------------------------------------------------------------------- Johan Vromans jvromans@squirrel.nl -Squirrel Consultancy Haarlem, the Netherlands +Squirrel Consultancy Exloo, the Netherlands http://www.squirrel.nl http://www.squirrel.nl/people/jvromans ------------------ "Arms are made for hugging" -------------------- diff --git a/lib/Getopt/Long/t/gol-basic.t b/lib/Getopt/Long/t/gol-basic.t index f1916b2..24a71db 100644 --- a/lib/Getopt/Long/t/gol-basic.t +++ b/lib/Getopt/Long/t/gol-basic.t @@ -1,5 +1,7 @@ #!./perl -w +no strict; + BEGIN { if ($ENV{PERL_CORE}) { @INC = '../lib'; @@ -8,9 +10,10 @@ BEGIN { } use Getopt::Long qw(:config no_ignore_case); -die("Getopt::Long version 2.23_03 required--this is only version ". +my $want_version="2.24"; +die("Getopt::Long version $want_version required--this is only version ". $Getopt::Long::VERSION) - unless $Getopt::Long::VERSION ge "2.24"; + unless $Getopt::Long::VERSION ge $want_version; print "1..9\n"; diff --git a/lib/Getopt/Long/t/gol-compat.t b/lib/Getopt/Long/t/gol-compat.t index e211eea..c123ef2 100644 --- a/lib/Getopt/Long/t/gol-compat.t +++ b/lib/Getopt/Long/t/gol-compat.t @@ -1,5 +1,7 @@ #!./perl -w +no strict; + BEGIN { if ($ENV{PERL_CORE}) { @INC = '../lib'; diff --git a/lib/Getopt/Long/t/gol-linkage.t b/lib/Getopt/Long/t/gol-linkage.t index a3047cf..1302471 100644 --- a/lib/Getopt/Long/t/gol-linkage.t +++ b/lib/Getopt/Long/t/gol-linkage.t @@ -1,5 +1,7 @@ #!./perl -w +no strict; + BEGIN { if ($ENV{PERL_CORE}) { @INC = '../lib'; @@ -9,7 +11,7 @@ BEGIN { use Getopt::Long; -print "1..18\n"; +print "1..32\n"; @ARGV = qw(-Foo -baR --foo bar); Getopt::Long::Configure ("no_ignore_case"); @@ -37,3 +39,41 @@ print (($ARGV[0] eq "bar") ? "" : "not ", "ok 15\n"); print (!(exists $lnk{foo}) ? "" : "not ", "ok 16\n"); print (!(exists $lnk{baR}) ? "" : "not ", "ok 17\n"); print (!(exists $lnk{bar}) ? "" : "not ", "ok 18\n"); + +@ARGV = qw(/Foo=-baR --bar bar); +Getopt::Long::Configure ("default","prefix_pattern=--|/|-|\\+","long_prefix_pattern=--|/"); +%lnk = (); +my $bar; +print "ok 19\n" if GetOptions (\%lnk, "bar" => \$bar, "Foo=s"); +print ((defined $bar) ? "" : "not ", "ok 20\n"); +print (($bar == 1) ? "" : "not ", "ok 21\n"); +print ((defined $lnk{Foo}) ? "" : "not ", "ok 22\n"); +print (($lnk{Foo} eq "-baR") ? "" : "not ", "ok 23\n"); +print ((@ARGV == 1) ? "" : "not ", "ok 24\n"); +print (($ARGV[0] eq "bar") ? "" : "not ", "ok 25\n"); +print (!(exists $lnk{foo}) ? "" : "not ", "ok 26\n"); +print (!(exists $lnk{baR}) ? "" : "not ", "ok 27\n"); +print (!(exists $lnk{bar}) ? "" : "not ", "ok 28\n"); +{ + my $errors; + %lnk = (); + local $SIG{__WARN__}= sub { $errors.=join("\n",@_,'') }; + + @ARGV = qw(/Foo=-baR); + Getopt::Long::Configure ("default","bundling","ignore_case_always", + "prefix_pattern=--|/|-|\\+","long_prefix_pattern=--"); + %lnk = (); + undef $bar; + GetOptions (\%lnk, "bar" => \$bar, "Foo=s"); + print (($errors=~/Unknown option:/) ? "" : "not ", "ok 29\n"); + $errors=""; + %lnk = (); + undef $bar; + @ARGV = qw(/Foo=-baR); + Getopt::Long::Configure ("default","bundling","ignore_case_always", + "prefix_pattern=--|/|-|\\+","long_prefix_pattern=--|/"); + GetOptions (\%lnk, "bar" => \$bar, "Foo=s"); + print (($errors eq '') ? "" : "not ", "ok 30\n"); + print ((defined $lnk{Foo}) ? "" : "not ", "ok 31\n"); + print (($lnk{Foo} eq "-baR") ? "" : "not ", "ok 32\n"); +} diff --git a/lib/Getopt/Long/t/gol-oo.t b/lib/Getopt/Long/t/gol-oo.t index f8191d1..df49cb6 100644 --- a/lib/Getopt/Long/t/gol-oo.t +++ b/lib/Getopt/Long/t/gol-oo.t @@ -1,5 +1,7 @@ #!./perl -w +no strict; + BEGIN { if ($ENV{PERL_CORE}) { @INC = '../lib'; @@ -8,9 +10,10 @@ BEGIN { } use Getopt::Long; -die("Getopt::Long version 2.23_03 required--this is only version ". +my $want_version="2.24"; +die("Getopt::Long version $want_version required--this is only version ". $Getopt::Long::VERSION) - unless $Getopt::Long::VERSION ge "2.24"; + unless $Getopt::Long::VERSION ge $want_version; print "1..9\n"; @ARGV = qw(-Foo -baR --foo bar);