package Getopt::Long;
-# RCS Status : $Id: GetoptLong.pm,v 2.45 2001-09-27 17:39:47+02 jv Exp $
+# RCS Status : $Id: GetoptLong.pm,v 2.58 2002-06-20 09:32:09+02 jv Exp $
# Author : Johan Vromans
# Created On : Tue Sep 11 15:00:12 1990
# Last Modified By: Johan Vromans
-# Last Modified On: Thu Sep 27 17:38:47 2001
-# Update Count : 980
+# Last Modified On: Thu Jun 20 07:48:05 2002
+# Update Count : 1083
# 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_02;
+$VERSION = 2.32;
# For testing versions only.
use vars qw($VERSION_STRING);
-$VERSION_STRING = "2.26_02";
+$VERSION_STRING = "2.32";
use Exporter;
sub ParseOptionSpec ($$);
sub OptCtl ($);
sub FindOption ($$$$);
-sub Croak (@); # demand loading the real Croak
################ Local Variables ################
package Getopt::Long::Parser;
-# NOTE: The object oriented routines use $error for thread locking.
-my $_lock = sub {
- lock ($Getopt::Long::error) if $] >= 5.005
-};
-
# Store a copy of the default configuration. Since ConfigDefaults has
# just been called, what we get from Configure is the default.
my $default_config = do {
- &$_lock;
Getopt::Long::Configure ()
};
# Process config attributes.
if ( defined $atts{config} ) {
- &$_lock;
my $save = Getopt::Long::Configure ($default_config, @{$atts{config}});
$self->{settings} = Getopt::Long::Configure ($save);
delete ($atts{config});
}
if ( %atts ) { # Oops
- Getopt::Long::Croak(__PACKAGE__.": unhandled attributes: ".
- join(" ", sort(keys(%atts))));
+ die(__PACKAGE__.": unhandled attributes: ".
+ join(" ", sort(keys(%atts)))."\n");
}
$self;
sub configure {
my ($self) = shift;
- &$_lock;
-
# Restore settings, merge new settings in.
my $save = Getopt::Long::Configure ($self->{settings}, @_);
# Restore orig config and save the new config.
- $self->{settings} = Configure ($save);
+ $self->{settings} = Getopt::Long::Configure ($save);
}
sub getoptions {
my ($self) = shift;
- &$_lock;
-
# Restore config settings.
my $save = Getopt::Long::Configure ($self->{settings});
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.45 $', ") ",
+ '$Revision: 2.58 $', ") ",
"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;
}
$ctl->[CTL_DEST] == CTL_DEST_HASH ? ", \"$key\"" : "",
", \"$arg\")\n")
if $debug;
- local ($@);
- eval {
+ my $eval_error = do {
+ local $@;
local $SIG{__DIE__} = '__DEFAULT__';
- &{$linkage{$opt}}($opt,
- $ctl->[CTL_DEST] == CTL_DEST_HASH ? ($key) : (),
- $arg);
+ eval {
+ &{$linkage{$opt}}($opt,
+ $ctl->[CTL_DEST] == CTL_DEST_HASH ? ($key) : (),
+ $arg);
+ };
+ $@;
};
- print STDERR ("=> die($@)\n") if $debug && $@ ne '';
- if ( $@ =~ /^!/ ) {
- if ( $@ =~ /^!FINISH\b/ ) {
+ print STDERR ("=> die($eval_error)\n")
+ if $debug && $eval_error ne '';
+ if ( $eval_error =~ /^!/ ) {
+ if ( $eval_error =~ /^!FINISH\b/ ) {
$goon = 0;
}
}
- elsif ( $@ ne '' ) {
- warn ($@);
+ elsif ( $eval_error ne '' ) {
+ warn ($eval_error);
$error++;
}
}
else {
print STDERR ("Invalid REF type \"", ref($linkage{$opt}),
"\" in linkage\n");
- Croak ("Getopt::Long -- internal error!\n");
+ die("Getopt::Long -- internal error!\n");
}
}
# No entry in linkage means entry in userlinkage.
# Try non-options call-back.
my $cb;
if ( (defined ($cb = $linkage{'<>'})) ) {
- local ($@);
print STDERR ("=> &L{$tryopt}(\"$tryopt\")\n")
if $debug;
- eval {
+ my $eval_error = do {
+ local $@;
local $SIG{__DIE__} = '__DEFAULT__';
- &$cb ($tryopt);
+ eval { &$cb ($tryopt) };
+ $@;
};
- print STDERR ("=> die($@)\n") if $debug && $@ ne '';
- if ( $@ =~ /^!/ ) {
- if ( $@ =~ /^!FINISH\b/ ) {
+ print STDERR ("=> die($eval_error)\n")
+ if $debug && $eval_error ne '';
+ if ( $eval_error =~ /^!/ ) {
+ if ( $eval_error =~ /^!FINISH\b/ ) {
$goon = 0;
}
}
- elsif ( $@ ne '' ) {
- warn ($@);
+ elsif ( $eval_error ne '' ) {
+ warn ($eval_error);
$error++;
}
}
"[".
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 ) {
+ foreach ( split(/\n+/, $dups) ) {
+ warn($_."\n");
+ }
+ }
($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;
#### Look it up ###
- my $tryopt; # option to try
+ my $tryopt = $opt; # option to try
if ( $bundling && $starter eq '-' ) {
- # To try overides, obey case ignore.
+ # To try overrides, obey case ignore.
$tryopt = $ignorecase ? lc($opt) : $opt;
# If bundling == 2, long options can override bundles.
- if ( $bundling == 2 && defined ($opctl->{$tryopt}) ) {
+ if ( $bundling == 2 && length($tryopt) > 1
+ && defined ($opctl->{$tryopt}) ) {
print STDERR ("=> $starter$tryopt overrides unbundling\n")
if $debug;
}
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 ) {
- return (1, $opt, $ctl, $optarg)
- if defined $optarg;
- return (1, $opt, $ctl, $type eq "s" ? '' : 0)
- unless $mand;
+ 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.
# Get key if this is a "name=value" pair for a hash option.
my $key;
if ($ctl->[CTL_DEST] == CTL_DEST_HASH && defined $arg) {
- ($key, $arg) = ($arg =~ /^([^=]*)=(.*)$/s) ? ($1, $2) : ($arg, 1);
+ ($key, $arg) = ($arg =~ /^([^=]*)=(.*)$/s) ? ($1, $2)
+ : ($arg, defined($ctl->[CTL_DEFAULT]) ? $ctl->[CTL_DEFAULT] : 1);
}
#### 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]
}
}
else {
- Croak ("GetOpt::Long internal error (Can't happen)\n");
+ die("GetOpt::Long internal error (Can't happen)\n");
}
return (1, $opt, $ctl, $arg, $key);
}
# Turn into regexp. Needs to be parenthesized!
$genprefix = "(" . quotemeta($genprefix) . ")";
eval { '' =~ /$genprefix/; };
- Croak ("Getopt::Long: invalid pattern \"$genprefix\"") if $@;
+ die("Getopt::Long: invalid pattern \"$genprefix\"") if $@;
}
elsif ( $try =~ /^prefix_pattern=(.+)$/ && $action ) {
$genprefix = $1;
$genprefix = "(" . $genprefix . ")"
unless $genprefix =~ /^\(.*\)$/;
eval { '' =~ /$genprefix/; };
- Croak ("Getopt::Long: invalid pattern \"$genprefix\"") if $@;
+ die("Getopt::Long: invalid pattern \"$genprefix\"") if $@;
}
elsif ( $try eq 'debug' ) {
$debug = $action;
}
else {
- Croak ("Getopt::Long: unknown config parameter \"$opt\"")
+ die("Getopt::Long: unknown config parameter \"$opt\"")
}
}
$prevconfig;
Configure (@_);
}
-# To prevent Carp from being loaded unnecessarily.
-sub Croak (@) {
- require 'Carp.pm';
- $Carp::CarpLevel = 1;
- Carp::croak(@_);
-};
-
################ Documentation ################
=head1 NAME
Getopt::Long supports two useful variants of simple options:
I<negatable> options and I<incremental> options.
-A negatable option is specified with a exclamation mark C<!> after the
+A negatable option is specified with an exclamation mark C<!> after the
option name:
my $verbose = ''; # option variable with default value (false)
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
$p = new Getopt::Long::Parser
config => [...configuration options...];
-For thread safety, each method call will acquire an exclusive lock to
-the Getopt::Long module. So don't call these methods from a callback
-routine!
+=head2 Thread Safety
+
+Getopt::Long is thread safe when using ithreads as of Perl 5.8. It is
+I<not> thread safe when using the older (experimental and now
+obsolete) threads implementation that was added to Perl 5.005.
=head2 Documentation and help texts
=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 / blobdiff