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
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;
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 {
$error = '';
print STDERR ("GetOpt::Long $Getopt::Long::VERSION (",
- '$Revision: 2.47 $', ") ",
+ '$Revision: 2.54 $', ") ",
"called from package \"$pkg\".",
"\n ",
"ARGV: (@ARGV)",
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);
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;
}
"[".
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] || '',
). "]";
}
sub ParseOptionSpec ($$) {
my ($opt, $opctl) = @_;
- # Match option spec. Allow '?' as an alias only.
+ # Match option spec.
if ( $opt !~ m;^
(
# Option name
# 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");
# 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])([@%])?/;
$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];
}
}
+ if ( $dups && $^W ) {
+ require 'Carp.pm';
+ $Carp::CarpLevel = 2;
+ foreach ( split(/\n+/, $dups) ) {
+ Carp::cluck($_);
+ }
+ }
($names[0], $orig);
}
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;
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 ",
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
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.
$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.
#### 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;
}
}
- 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 ) {
}
warn ("Value \"", $arg, "\" invalid for option ",
$opt, " (",
- $type eq "o" ? "extended " : "",
+ $type eq 'o' ? "extended " : '',
"number expected)\n");
$error++;
# Push back.
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]
Note that if a string argument starts with C<-> or C<-->, it will be
considered an option on itself.
+=item : I<number> [ I<desttype> ]
+
+Like C<:i>, but if the value is omitted, the I<number> will be assigned.
+
+=item : + [ I<desttype> ]
+
+Like C<:i>, but if the value is omitted, the current value for the
+option will be incremented.
+
=back
=head1 Advanced Possibilities
=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<must> 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<must> be introduced with C<--> and bundles with C<->.
+
+Note that, if you have options C<a>, C<l> and C<all>, 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<a> (due to auto
+completion), not C<all>.
Note: disabling C<bundling> also disables C<bundling_override>.
=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<ignore_case>, option specifications for options that only
+differ in case, e.g., C<"foo"> and C<"Foo">, will be flagged as
+duplicates.
Note: disabling C<ignore_case> also disables C<ignore_case_always>.
=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
projects / p5sagit/p5-mst-13.2.git / commitdiff