From: Jarkko Hietaniemi Date: Mon, 25 Feb 2002 21:22:32 +0000 (+0000) Subject: Upgrade to Getopt::Long 2.28. X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=bd444ebb7171fc34a9beff51d78da70a8747aa8b;p=p5sagit%2Fp5-mst-13.2.git Upgrade to Getopt::Long 2.28. p4raw-id: //depot/perl@14872 --- diff --git a/lib/Getopt/Long.pm b/lib/Getopt/Long.pm index ea5aee6..f1ac4f5 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.47 2001-11-15 18:14:22+01 jv Exp $ +# RCS Status : $Id: GetoptLong.pm,v 2.54 2002-02-20 15:00:10+01 jv Exp $ # Author : Johan Vromans # Created On : Tue Sep 11 15:00:12 1990 # Last Modified By: Johan Vromans -# Last Modified On: Thu Nov 15 18:13:36 2001 -# Update Count : 987 +# Last Modified On: Wed Feb 20 15:00:04 2002 +# Update Count : 1045 # Status : Released ################ Copyright ################ -# This program is Copyright 1990,2001 by Johan Vromans. +# This program is Copyright 1990,2002 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.26_03; +$VERSION = 2.28; # For testing versions only. use vars qw($VERSION_STRING); -$VERSION_STRING = "2.26_03"; +$VERSION_STRING = "2.28"; use Exporter; @@ -218,28 +218,32 @@ sub getoptions { package Getopt::Long; # Indices in option control info. -use constant CTL_TYPE => 0; +# Note that ParseOptions uses the fields directly. Search for 'hard-wired'. +use constant CTL_TYPE => 0; #use constant CTL_TYPE_FLAG => ''; #use constant CTL_TYPE_NEG => '!'; #use constant CTL_TYPE_INCR => '+'; #use constant CTL_TYPE_INT => 'i'; +#use constant CTL_TYPE_INTINC => 'I'; #use constant CTL_TYPE_XINT => 'o'; #use constant CTL_TYPE_FLOAT => 'f'; #use constant CTL_TYPE_STRING => 's'; -use constant CTL_MAND => 1; +use constant CTL_CNAME => 1; -use constant CTL_DEST => 2; +use constant CTL_MAND => 2; + +use constant CTL_DEST => 3; use constant CTL_DEST_SCALAR => 0; use constant CTL_DEST_ARRAY => 1; use constant CTL_DEST_HASH => 2; use constant CTL_DEST_CODE => 3; -use constant CTL_RANGE => 3; - -use constant CTL_REPEAT => 4; +use constant CTL_DEFAULT => 4; -use constant CTL_CNAME => 5; +# FFU. +#use constant CTL_RANGE => ; +#use constant CTL_REPEAT => ; sub GetOptions { @@ -257,7 +261,7 @@ sub GetOptions { $error = ''; print STDERR ("GetOpt::Long $Getopt::Long::VERSION (", - '$Revision: 2.47 $', ") ", + '$Revision: 2.54 $', ") ", "called from package \"$pkg\".", "\n ", "ARGV: (@ARGV)", @@ -316,6 +320,9 @@ sub GetOptions { unless ( @optionlist > 0 && ref($optionlist[0]) && ref($optionlist[0]) eq 'CODE' ) { $error .= "Option spec <> requires a reference to a subroutine\n"; + # Kill the linkage (to avoid another error). + shift (@optionlist) + if @optionlist && ref($optionlist[0]); next; } $linkage{'<>'} = shift (@optionlist); @@ -327,6 +334,9 @@ sub GetOptions { unless ( defined $name ) { # Failed. $orig contains the error message. Sorry for the abuse. $error .= $orig; + # Kill the linkage (to avoid another error). + shift (@optionlist) + if @optionlist && ref($optionlist[0]); next; } @@ -599,11 +609,12 @@ sub OptCtl ($) { "[". join(",", "\"$v[CTL_TYPE]\"", + "\"$v[CTL_CNAME]\"", $v[CTL_MAND] ? "O" : "M", ("\$","\@","\%","\&")[$v[CTL_DEST] || 0], - $v[CTL_RANGE] || '', - $v[CTL_REPEAT] || '', - "\"$v[CTL_CNAME]\"", + "\"$v[CTL_DEFAULT]\"", +# $v[CTL_RANGE] || '', +# $v[CTL_REPEAT] || '', ). "]"; } @@ -611,7 +622,7 @@ sub OptCtl ($) { sub ParseOptionSpec ($$) { my ($opt, $opctl) = @_; - # Match option spec. Allow '?' as an alias only. + # Match option spec. if ( $opt !~ m;^ ( # Option name @@ -623,8 +634,11 @@ sub ParseOptionSpec ($$) { # Either modifiers ... [!+] | - # ... or a value/dest specification. - [=:][ionfs][@%]? + # ... or a value/dest specification + [=:] [ionfs] [@%]? + | + # ... or an optional-with-default spec + : (?: -?\d+ | \+ ) [@%]? )? $;x ) { return (undef, "Error in option spec: \"$opt\"\n"); @@ -654,7 +668,18 @@ sub ParseOptionSpec ($$) { # Construct the opctl entries. my $entry; if ( $spec eq '' || $spec eq '+' || $spec eq '!' ) { - $entry = [$spec,0,CTL_DEST_SCALAR,undef,undef,$orig]; + # Fields are hard-wired here. + $entry = [$spec,$orig,0,CTL_DEST_SCALAR,undef]; + } + elsif ( $spec =~ /:(-?\d+|\+)([@%])?/ ) { + my $def = $1; + my $dest = $2; + my $type = $def eq '+' ? 'I' : 'i'; + $dest ||= '$'; + $dest = $dest eq '@' ? CTL_DEST_ARRAY + : $dest eq '%' ? CTL_DEST_HASH : CTL_DEST_SCALAR; + # Fields are hard-wired here. + $entry = [$type,$orig,0,$dest,$def eq '+' ? undef : $def]; } else { my ($mand, $type, $dest) = $spec =~ /([=:])([ionfs])([@%])?/; @@ -662,15 +687,21 @@ sub ParseOptionSpec ($$) { $dest ||= '$'; $dest = $dest eq '@' ? CTL_DEST_ARRAY : $dest eq '%' ? CTL_DEST_HASH : CTL_DEST_SCALAR; - $entry = [$type,$mand eq '=',$dest,undef,undef,$orig]; + # Fields are hard-wired here. + $entry = [$type,$orig,$mand eq '=',$dest,undef]; } # Process all names. First is canonical, the rest are aliases. + my $dups = ''; foreach ( @names ) { $_ = lc ($_) if $ignorecase > (($bundling && length($_) == 1) ? 1 : 0); + if ( exists $opctl->{$_} ) { + $dups .= "Duplicate specification \"$opt\" for option \"$_\"\n"; + } + if ( $spec eq '!' ) { $opctl->{"no$_"} = $entry; $opctl->{$_} = [@$entry]; @@ -681,6 +712,13 @@ sub ParseOptionSpec ($$) { } } + if ( $dups && $^W ) { + require 'Carp.pm'; + $Carp::CarpLevel = 2; + foreach ( split(/\n+/, $dups) ) { + Carp::cluck($_); + } + } ($names[0], $orig); } @@ -696,7 +734,7 @@ sub FindOption ($$$$) { print STDERR ("=> find \"$opt\"\n") if $debug; return (0) unless $opt =~ /^$prefix(.*)$/s; - return (0) if $opt eq "-" && !defined $opctl->{""}; + return (0) if $opt eq "-" && !defined $opctl->{''}; $opt = $+; my $starter = $1; @@ -735,7 +773,7 @@ sub FindOption ($$$$) { else { $tryopt = $opt; # Unbundle single letter option. - $rest = length ($tryopt) > 0 ? substr ($tryopt, 1) : ""; + $rest = length ($tryopt) > 0 ? substr ($tryopt, 1) : ''; $tryopt = substr ($tryopt, 0, 1); $tryopt = lc ($tryopt) if $ignorecase > 1; print STDERR ("=> $starter$tryopt unbundled from ", @@ -819,7 +857,8 @@ sub FindOption ($$$$) { undef $opt; } elsif ( $type eq '' || $type eq '+' ) { - $arg = 1; # supply explicit value + # Supply explicit value. + $arg = 1; } else { $opt =~ s/^no//i; # strip NO prefix @@ -833,9 +872,9 @@ sub FindOption ($$$$) { my $mand = $ctl->[CTL_MAND]; # Check if there is an option argument available. - if ( $gnu_compat && defined $optarg && $optarg eq "" ) { - return (1, $opt, $ctl, $type eq "s" ? "" : 0) unless $mand; - $optarg = 0 unless $type eq "s"; + if ( $gnu_compat && defined $optarg && $optarg eq '' ) { + return (1, $opt, $ctl, $type eq 's' ? '' : 0) unless $mand; + $optarg = 0 unless $type eq 's'; } # Check if there is an option argument available. @@ -849,7 +888,15 @@ sub FindOption ($$$$) { $error++; return (1, undef); } - return (1, $opt, $ctl, $type eq "s" ? '' : 0); + if ( $type eq 'I' ) { + # Fake incremental type. + my @c = @$ctl; + $c[CTL_TYPE] = '+'; + return (1, $opt, \@c, 1); + } + return (1, $opt, $ctl, + defined($ctl->[CTL_DEFAULT]) ? $ctl->[CTL_DEFAULT] : + $type eq 's' ? '' : 0); } # Get (possibly optional) argument. @@ -864,7 +911,7 @@ sub FindOption ($$$$) { #### Check if the argument is valid for this option #### - if ( $type eq "s" ) { # string + if ( $type eq 's' ) { # string # A mandatory string takes anything. return (1, $opt, $ctl, $arg, $key) if $mand; @@ -883,21 +930,22 @@ sub FindOption ($$$$) { } } - elsif ( $type eq "i" # numeric/integer - || $type eq "o" ) { # dec/oct/hex/bin value + elsif ( $type eq 'i' # numeric/integer + || $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]*" + $type eq 'o' ? "[-+]?[1-9][0-9]*|0x[0-9a-f]+|0b[01]+|0[0-7]*" : "[-+]?[0-9]+"; if ( $bundling && defined $rest && $rest =~ /^($o_valid)(.*)$/si ) { $arg = $1; $rest = $2; - $arg = ($type eq "o" && $arg =~ /^0/) ? oct($arg) : 0+$arg; + $arg = ($type eq 'o' && $arg =~ /^0/) ? oct($arg) : 0+$arg; unshift (@ARGV, $starter.$rest) if defined $rest && $rest ne ''; } elsif ( $arg =~ /^($o_valid)$/si ) { - $arg = ($type eq "o" && $arg =~ /^0/) ? oct($arg) : 0+$arg; + $arg = ($type eq 'o' && $arg =~ /^0/) ? oct($arg) : 0+$arg; } else { if ( defined $optarg || $mand ) { @@ -908,7 +956,7 @@ sub FindOption ($$$$) { } warn ("Value \"", $arg, "\" invalid for option ", $opt, " (", - $type eq "o" ? "extended " : "", + $type eq 'o' ? "extended " : '', "number expected)\n"); $error++; # Push back. @@ -918,13 +966,19 @@ sub FindOption ($$$$) { else { # Push back. unshift (@ARGV, defined $rest ? $starter.$rest : $arg); + if ( $type eq 'I' ) { + # Fake incremental type. + my @c = @$ctl; + $c[CTL_TYPE] = '+'; + return (1, $opt, \@c, 1); + } # Supply default value. - $arg = 0; + $arg = defined($ctl->[CTL_DEFAULT]) ? $ctl->[CTL_DEFAULT] : 0; } } } - elsif ( $type eq "f" ) { # real number, int is also ok + elsif ( $type eq 'f' ) { # real number, int is also ok # We require at least one digit before a point or 'e', # and at least one digit following the point and 'e'. # [-]NN[.NN][eNN] @@ -1446,6 +1500,15 @@ and the value zero to numeric options. Note that if a string argument starts with C<-> or C<-->, it will be considered an option on itself. +=item : I [ I ] + +Like C<:i>, but if the value is omitted, the I will be assigned. + +=item : + [ I ] + +Like C<:i>, but if the value is omitted, the current value for the +option will be incremented. + =back =head1 Advanced Possibilities @@ -1762,10 +1825,22 @@ first. =item bundling (default: disabled) -Enabling this option will allow single-character options to be bundled. -To distinguish bundles from long option names, long options I be -introduced with C<--> and single-character options (and bundles) with -C<->. +Enabling this option will allow single-character options to be +bundled. To distinguish bundles from long option names, long options +I be introduced with C<--> and bundles with C<->. + +Note that, if you have options C, C and C, and +auto_abbrev enabled, possible arguments and option settings are: + + using argument sets option(s) + ------------------------------------------ + -a, --a a + -l, --l l + -al, -la, -ala, -all,... a, l + --al, --all all + +The suprising part is that C<--a> sets option C (due to auto +completion), not C. Note: disabling C also disables C. @@ -1781,8 +1856,13 @@ especially when mixing long options and bundles. Caveat emptor. =item ignore_case (default: enabled) -If enabled, case is ignored when matching long option names. Single -character options will be treated case-sensitive. +If enabled, case is ignored when matching long option names. If, +however, bundling is enabled as well, single character options will be +treated case-sensitive. + +With C, option specifications for options that only +differ in case, e.g., C<"foo"> and C<"Foo">, will be flagged as +duplicates. Note: disabling C also disables C. @@ -1960,7 +2040,7 @@ Johan Vromans =head1 COPYRIGHT AND DISCLAIMER -This program is Copyright 2001,1990 by Johan Vromans. +This program is Copyright 2002,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/CHANGES b/lib/Getopt/Long/CHANGES index deaa472..004dfab 100644 --- a/lib/Getopt/Long/CHANGES +++ b/lib/Getopt/Long/CHANGES @@ -1,6 +1,26 @@ +Changes in version 2.28 +----------------------- + +* When an option is specified more than once, a warning is generated + if perl is run with -w. This is a correction to 2.27, where it would + unconditionally die. + + An example of duplicate specification is GetOptions('foo', 'foo'), + but also GetOptions('foo=s', 'foo') and GetOptions('Foo', 'foo') + (the latter only when ignore_case is in effect). + Changes in version 2.27 ----------------------- +* You can now specify integer options to take an optional argument. + that defaults to a specific value. E.g., GetOptions('foo:5' => \$var) + will allow $var to get the value 5 when no value was specified with + the -foo option on the command line. + + Instead of a value, a '+' may be specified. E.g., + GetOptions('foo:+' => \$var) will allow $var to be incremented when + no value was specified with the -foo option on the command line. + * Fix several problems with internal and external use of 'die' and signal handlers. @@ -14,10 +34,21 @@ Changes in version 2.27 * Eliminated the use of autoloading. Autoloading kept generating problems during development, and when using perlcc. +* Avoid errors on references when an option is found in error, e.g. + GetOptions('fo$@#' => \$var). + Thanks to Wolfgang Laun . + +* When an option is specified more than once, an error is now + generated. E.g., GetOptions('foo', 'foo'). + Thanks to Wolfgang Laun . + * Lots of internal restructoring to make room for extensions. * Redesigned the regression tests. +* Enhance the documentation to prevent common misunderstandings about + single character options. + Changes in version 2.26 ----------------------- diff --git a/lib/Getopt/Long/README b/lib/Getopt/Long/README index 1a2dc10..7870b8b 100644 --- a/lib/Getopt/Long/README +++ b/lib/Getopt/Long/README @@ -182,7 +182,7 @@ Or use the CPAN search engine: COPYRIGHT AND DISCLAIMER ======================== -Module Getopt::Long is Copyright 2001,1990 by Johan Vromans. +Module Getopt::Long is Copyright 2002,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