package Getopt::Long;
-# RCS Status : $Id: GetoptLong.pm,v 2.13 1997-12-25 16:20:17+01 jv Exp $
+# RCS Status : $Id: GetoptLong.pl,v 2.18 1998-06-14 15:02:19+02 jv Exp $
# Author : Johan Vromans
# Created On : Tue Sep 11 15:00:12 1990
# Last Modified By: Johan Vromans
-# Last Modified On: Thu Dec 25 16:18:08 1997
-# Update Count : 647
+# Last Modified On: Sun Jun 14 13:17:22 1998
+# Update Count : 705
# Status : Released
################ Copyright ################
-# This program is Copyright 1990,1997 by Johan Vromans.
+# This program is Copyright 1990,1998 by Johan Vromans.
# This program is free software; you can redistribute it and/or
# modify it under the terms of the GNU General Public License
# as published by the Free Software Foundation; either version 2
# 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.
+# the Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston,
+# MA 02111-1307, USA.
################ Module Preamble ################
use strict;
BEGIN {
- require 5.003;
+ require 5.004;
use Exporter ();
- use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
- $VERSION = sprintf("%d.%02d", q$Revision: 2.13 $ =~ /(\d+)\.(\d+)/);
-
- @ISA = qw(Exporter);
- @EXPORT = qw(&GetOptions $REQUIRE_ORDER $PERMUTE $RETURN_IN_ORDER);
- %EXPORT_TAGS = ();
- @EXPORT_OK = qw();
+ use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
+ $VERSION = "2.17";
+
+ @ISA = qw(Exporter);
+ @EXPORT = qw(&GetOptions $REQUIRE_ORDER $PERMUTE $RETURN_IN_ORDER);
+ %EXPORT_TAGS = qw();
+ @EXPORT_OK = qw();
+ use AutoLoader qw(AUTOLOAD);
}
-use vars @EXPORT, @EXPORT_OK;
# User visible variables.
+use vars @EXPORT, @EXPORT_OK;
use vars qw($error $debug $major_version $minor_version);
# Deprecated visible variables.
use vars qw($autoabbrev $getopt_compat $ignorecase $bundling $order
$passthrough);
+# Official invisible variables.
+use vars qw($genprefix);
+
+# Public subroutines.
+sub Configure (@);
+sub config (@); # deprecated name
+sub GetOptions;
+
+# Private subroutines.
+sub ConfigDefaults ();
+sub FindOption ($$$$$$$);
+sub Croak (@); # demand loading the real Croak
################ Local Variables ################
-my $gen_prefix; # generic prefix (option starters)
-my $argend; # option list terminator
-my %opctl; # table of arg.specs (long and abbrevs)
-my %bopctl; # table of arg.specs (bundles)
-my @opctl; # the possible long option names
-my $pkg; # current context. Needed if no linkage.
-my %aliases; # alias table
-my $genprefix; # so we can call the same module more
-my $opt; # current option
-my $arg; # current option value, if any
-my $array; # current option is array typed
-my $hash; # current option is hash typed
-my $key; # hash key for a hash option
- # than once in differing environments
-my $config_defaults; # set config defaults
-my $find_option; # helper routine
-my $croak; # helper routine
-
-################ Subroutines ################
+################ Resident subroutines ################
+
+sub ConfigDefaults () {
+ # Handle POSIX compliancy.
+ if ( defined $ENV{"POSIXLY_CORRECT"} ) {
+ $genprefix = "(--|-)";
+ $autoabbrev = 0; # no automatic abbrev of options
+ $bundling = 0; # no bundling of single letter switches
+ $getopt_compat = 0; # disallow '+' to start options
+ $order = $REQUIRE_ORDER;
+ }
+ else {
+ $genprefix = "(--|-|\\+)";
+ $autoabbrev = 1; # automatic abbrev of options
+ $bundling = 0; # bundling off by default
+ $getopt_compat = 1; # allow '+' to start options
+ $order = $PERMUTE;
+ }
+ # Other configurable settings.
+ $debug = 0; # for debugging
+ $error = 0; # error tally
+ $ignorecase = 1; # ignore case when matching options
+ $passthrough = 0; # leave unrecognized options alone
+}
+
+################ Initialization ################
+
+# Values for $order. See GNU getopt.c for details.
+($REQUIRE_ORDER, $PERMUTE, $RETURN_IN_ORDER) = (0..2);
+# Version major/minor numbers.
+($major_version, $minor_version) = $VERSION =~ /^(\d+)\.(\d+)/;
+
+# Set defaults.
+ConfigDefaults ();
+
+################ Package return ################
+
+1;
+
+__END__
+
+################ AutoLoading subroutines ################
+
+# RCS Status : $Id: GetoptLongAl.pl,v 2.20 1998-06-14 15:02:19+02 jv Exp $
+# Author : Johan Vromans
+# Created On : Fri Mar 27 11:50:30 1998
+# Last Modified By: Johan Vromans
+# Last Modified On: Sun Jun 14 13:54:35 1998
+# Update Count : 24
+# Status : Released
sub GetOptions {
my @optionlist = @_; # local copy of the option descriptions
- $argend = '--'; # option list terminator
- %opctl = (); # table of arg.specs (long and abbrevs)
- %bopctl = (); # table of arg.specs (bundles)
- $pkg = (caller)[0]; # current context
+ my $argend = '--'; # option list terminator
+ my %opctl = (); # table of arg.specs (long and abbrevs)
+ my %bopctl = (); # table of arg.specs (bundles)
+ my $pkg = (caller)[0]; # current context
# Needed if linkage is omitted.
- %aliases= (); # alias table
+ my %aliases= (); # alias table
my @ret = (); # accum for non-options
my %linkage; # linkage
my $userlinkage; # user supplied HASH
- $genprefix = $gen_prefix; # so we can call the same module many times
+ my $opt; # current option
+ my $genprefix = $genprefix; # so we can call the same module many times
+ my @opctl; # the possible long option names
+
$error = '';
- print STDERR ('GetOptions $Revision: 2.13 $ ',
- "[GetOpt::Long $Getopt::Long::VERSION] -- ",
- "called from package \"$pkg\".\n",
- " (@ARGV)\n",
- " autoabbrev=$autoabbrev".
- ",bundling=$bundling",
- ",getopt_compat=$getopt_compat",
- ",order=$order",
- ",\n ignorecase=$ignorecase",
- ",passthrough=$passthrough",
- ",genprefix=\"$genprefix\"",
- ".\n")
+ print STDERR ("GetOpt::Long $Getopt::Long::VERSION ",
+ "called from package \"$pkg\".",
+ "\n ",
+ 'GetOptionsAl $Revision: 2.20 $ ',
+ "\n ",
+ "ARGV: (@ARGV)",
+ "\n ",
+ "autoabbrev=$autoabbrev,".
+ "bundling=$bundling,",
+ "getopt_compat=$getopt_compat,",
+ "order=$order,",
+ "\n ",
+ "ignorecase=$ignorecase,",
+ "passthrough=$passthrough,",
+ "genprefix=\"$genprefix\".",
+ "\n")
if $debug;
# Check for ref HASH as first argument.
my $opt = shift (@optionlist);
# Strip leading prefix so people can specify "--foo=i" if they like.
- $opt = $2 if $opt =~ /^$genprefix+(.*)$/;
+ $opt = $+ if $opt =~ /^$genprefix+(.*)$/s;
if ( $opt eq '<>' ) {
if ( (defined $userlinkage)
}
# Match option spec. Allow '?' as an alias.
- if ( $opt !~ /^((\w+[-\w]*)(\|(\?|\w[-\w]*)?)*)?(!|[=:][infse][@%]?)?$/ ) {
+ if ( $opt !~ /^((\w+[-\w]*)(\|(\?|\w[-\w]*)?)*)?([!~+]|[=:][infse][@%]?)?$/ ) {
$error .= "Error in option spec: \"$opt\"\n";
next;
}
#### Get next argument ####
$opt = shift (@ARGV);
- $arg = undef;
- $array = $hash = 0;
print STDERR ("=> option \"", $opt, "\"\n") if $debug;
#### Determine what we have ####
}
my $tryopt = $opt;
+ my $found; # success status
+ my $dsttype; # destination type ('@' or '%')
+ my $incr; # destination increment
+ my $key; # key (if hash type)
+ my $arg; # option argument
+
+ ($found, $opt, $arg, $dsttype, $incr, $key) =
+ FindOption ($genprefix, $argend, $opt,
+ \%opctl, \%bopctl, \@opctl, \%aliases);
- # find_option operates on the GLOBAL $opt and $arg!
- if ( &$find_option () ) {
+ if ( $found ) {
- # find_option undefines $opt in case of errors.
+ # FindOption undefines $opt in case of errors.
next unless defined $opt;
if ( defined $arg ) {
ref($linkage{$opt}), "\n") if $debug;
if ( ref($linkage{$opt}) eq 'SCALAR' ) {
- print STDERR ("=> \$\$L{$opt} = \"$arg\"\n") if $debug;
- ${$linkage{$opt}} = $arg;
+ if ( $incr ) {
+ print STDERR ("=> \$\$L{$opt} += \"$arg\"\n")
+ if $debug;
+ if ( defined ${$linkage{$opt}} ) {
+ ${$linkage{$opt}} += $arg;
+ }
+ else {
+ ${$linkage{$opt}} = $arg;
+ }
+ }
+ else {
+ print STDERR ("=> \$\$L{$opt} = \"$arg\"\n")
+ if $debug;
+ ${$linkage{$opt}} = $arg;
+ }
}
elsif ( ref($linkage{$opt}) eq 'ARRAY' ) {
print STDERR ("=> push(\@{\$L{$opt}, \"$arg\")\n")
else {
print STDERR ("Invalid REF type \"", ref($linkage{$opt}),
"\" in linkage\n");
- &$croak ("Getopt::Long -- internal error!\n");
+ Croak ("Getopt::Long -- internal error!\n");
}
}
# No entry in linkage means entry in userlinkage.
- elsif ( $array ) {
+ elsif ( $dsttype eq '@' ) {
if ( defined $userlinkage->{$opt} ) {
print STDERR ("=> push(\@{\$L{$opt}}, \"$arg\")\n")
if $debug;
$userlinkage->{$opt} = [$arg];
}
}
- elsif ( $hash ) {
+ elsif ( $dsttype eq '%' ) {
if ( defined $userlinkage->{$opt} ) {
print STDERR ("=> \$L{$opt}->{$key} = \"$arg\"\n")
if $debug;
}
}
else {
- print STDERR ("=>\$L{$opt} = \"$arg\"\n") if $debug;
- $userlinkage->{$opt} = $arg;
+ if ( $incr ) {
+ print STDERR ("=> \$L{$opt} += \"$arg\"\n")
+ if $debug;
+ if ( defined $userlinkage->{$opt} ) {
+ $userlinkage->{$opt} += $arg;
+ }
+ else {
+ $userlinkage->{$opt} = $arg;
+ }
+ }
+ else {
+ print STDERR ("=>\$L{$opt} = \"$arg\"\n") if $debug;
+ $userlinkage->{$opt} = $arg;
+ }
}
}
}
return ($error == 0);
}
-sub config (@) {
- my (@options) = @_;
- my $opt;
- foreach $opt ( @options ) {
- my $try = lc ($opt);
- my $action = 1;
- if ( $try =~ /^no_?(.*)$/ ) {
- $action = 0;
- $try = $1;
- }
- if ( $try eq 'default' or $try eq 'defaults' ) {
- &$config_defaults () if $action;
- }
- elsif ( $try eq 'auto_abbrev' or $try eq 'autoabbrev' ) {
- $autoabbrev = $action;
- }
- elsif ( $try eq 'getopt_compat' ) {
- $getopt_compat = $action;
- }
- elsif ( $try eq 'ignorecase' or $try eq 'ignore_case' ) {
- $ignorecase = $action;
- }
- elsif ( $try eq 'ignore_case_always' ) {
- $ignorecase = $action ? 2 : 0;
- }
- elsif ( $try eq 'bundling' ) {
- $bundling = $action;
- }
- elsif ( $try eq 'bundling_override' ) {
- $bundling = $action ? 2 : 0;
- }
- elsif ( $try eq 'require_order' ) {
- $order = $action ? $REQUIRE_ORDER : $PERMUTE;
- }
- elsif ( $try eq 'permute' ) {
- $order = $action ? $PERMUTE : $REQUIRE_ORDER;
- }
- elsif ( $try eq 'pass_through' or $try eq 'passthrough' ) {
- $passthrough = $action;
- }
- elsif ( $try eq 'debug' ) {
- $debug = $action;
- }
- else {
- &$croak ("Getopt::Long: unknown config parameter \"$opt\"")
- }
- }
-}
-
-# To prevent Carp from being loaded unnecessarily.
-$croak = sub {
- require 'Carp.pm';
- $Carp::CarpLevel = 1;
- Carp::croak(@_);
-};
+# Option lookup.
+sub FindOption ($$$$$$$) {
-################ Private Subroutines ################
+ # returns (1, $opt, $arg, $dsttype, $incr, $key) if okay,
+ # returns (0) otherwise.
-$find_option = sub {
+ my ($prefix, $argend, $opt, $opctl, $bopctl, $names, $aliases) = @_;
+ my $key; # hash key for a hash option
+ my $arg;
- print STDERR ("=> find \"$opt\", genprefix=\"$genprefix\"\n") if $debug;
+ print STDERR ("=> find \"$opt\", prefix=\"$prefix\"\n") if $debug;
- return 0 unless $opt =~ /^$genprefix(.*)$/;
+ return (0) unless $opt =~ /^$prefix(.*)$/s;
- $opt = $2;
+ $opt = $+;
my ($starter) = $1;
print STDERR ("=> split \"$starter\"+\"$opt\"\n") if $debug;
# If it is a long option, it may include the value.
if (($starter eq "--" || ($getopt_compat && !$bundling))
- && $opt =~ /^([^=]+)=(.*)$/ ) {
+ && $opt =~ /^([^=]+)=(.*)$/s ) {
$opt = $1;
$optarg = $2;
print STDERR ("=> option \"", $opt,
#### Look it up ###
my $tryopt = $opt; # option to try
- my $optbl = \%opctl; # table to look it up (long names)
+ my $optbl = $opctl; # table to look it up (long names)
my $type;
+ my $dsttype = '';
+ my $incr = 0;
if ( $bundling && $starter eq '-' ) {
# Unbundle single letter option.
print STDERR ("=> $starter$tryopt unbundled from ",
"$starter$tryopt$rest\n") if $debug;
$rest = undef unless $rest ne '';
- $optbl = \%bopctl; # look it up in the short names table
+ $optbl = $bopctl; # look it up in the short names table
# If bundling == 2, long options can override bundles.
if ( $bundling == 2 and
- defined ($type = $opctl{$tryopt.$rest}) ) {
+ defined ($type = $opctl->{$tryopt.$rest}) ) {
print STDERR ("=> $starter$tryopt rebundled to ",
"$starter$tryopt$rest\n") if $debug;
$tryopt .= $rest;
# Turn option name into pattern.
my $pat = quotemeta ($opt);
# Look up in option names.
- my @hits = grep (/^$pat/, @opctl);
+ my @hits = grep (/^$pat/, @{$names});
print STDERR ("=> ", scalar(@hits), " hits (@hits) with \"$pat\" ",
- "out of ", scalar(@opctl), "\n") if $debug;
+ "out of ", scalar(@{$names}), "\n") if $debug;
# Check for ambiguous results.
unless ( (@hits <= 1) || (grep ($_ eq $opt, @hits) == 1) ) {
# See if all matches are for the same option.
my %hit;
foreach ( @hits ) {
- $_ = $aliases{$_} if defined $aliases{$_};
+ $_ = $aliases->{$_} if defined $aliases->{$_};
$hit{$_} = 1;
}
# Now see if it really is ambiguous.
unless ( keys(%hit) == 1 ) {
- return 0 if $passthrough;
+ return (0) if $passthrough;
warn ("Option ", $opt, " is ambiguous (",
join(", ", @hits), ")\n");
$error++;
undef $opt;
- return 1;
+ return (1, $opt,$arg,$dsttype,$incr,$key);
}
@hits = keys(%hit);
}
# Check validity by fetching the info.
$type = $optbl->{$tryopt} unless defined $type;
unless ( defined $type ) {
- return 0 if $passthrough;
+ return (0) if $passthrough;
warn ("Unknown option: ", $opt, "\n");
$error++;
- return 1;
+ return (1, $opt,$arg,$dsttype,$incr,$key);
}
# Apparently valid.
$opt = $tryopt;
#### Determine argument status ####
# If it is an option w/o argument, we're almost finished with it.
- if ( $type eq '' || $type eq '!' ) {
+ if ( $type eq '' || $type eq '!' || $type eq '+' ) {
if ( defined $optarg ) {
- return 0 if $passthrough;
+ return (0) if $passthrough;
warn ("Option ", $opt, " does not take an argument\n");
$error++;
undef $opt;
}
- elsif ( $type eq '' ) {
+ elsif ( $type eq '' || $type eq '+' ) {
$arg = 1; # supply explicit value
+ $incr = $type eq '+';
}
else {
substr ($opt, 0, 2) = ''; # strip NO prefix
$arg = 0; # supply explicit value
}
unshift (@ARGV, $starter.$rest) if defined $rest;
- return 1;
+ return (1, $opt,$arg,$dsttype,$incr,$key);
}
# Get mandatory status and type info.
my $mand;
- ($mand, $type, $array, $hash) = $type =~ /^(.)(.)(@?)(%?)$/;
+ ($mand, $type, $dsttype, $key) = $type =~ /^(.)(.)([@%]?)$/;
# Check if there is an option argument available.
if ( defined $optarg ? ($optarg eq '')
: !(defined $rest || @ARGV > 0) ) {
# Complain if this option needs an argument.
if ( $mand eq "=" ) {
- return 0 if $passthrough;
+ return (0) if $passthrough;
warn ("Option ", $opt, " requires an argument\n");
$error++;
undef $opt;
if ( $mand eq ":" ) {
$arg = $type eq "s" ? '' : 0;
}
- return 1;
+ return (1, $opt,$arg,$dsttype,$incr,$key);
}
# Get (possibly optional) argument.
# Get key if this is a "name=value" pair for a hash option.
$key = undef;
- if ($hash && defined $arg) {
- ($key, $arg) = ($arg =~ /^(.*)=(.*)$/o) ? ($1, $2) : ($arg, 1);
+ if ($dsttype eq '%' && defined $arg) {
+ ($key, $arg) = ($arg =~ /^(.*)=(.*)$/s) ? ($1, $2) : ($arg, 1);
}
#### Check if the argument is valid for this option ####
if ( $type eq "s" ) { # string
# A mandatory string takes anything.
- return 1 if $mand eq "=";
+ return (1, $opt,$arg,$dsttype,$incr,$key) if $mand eq "=";
# An optional string takes almost anything.
- return 1 if defined $optarg || defined $rest;
- return 1 if $arg eq "-"; # ??
+ return (1, $opt,$arg,$dsttype,$incr,$key)
+ if defined $optarg || defined $rest;
+ return (1, $opt,$arg,$dsttype,$incr,$key) if $arg eq "-"; # ??
# Check for option or option list terminator.
if ($arg eq $argend ||
- $arg =~ /^$genprefix.+/) {
+ $arg =~ /^$prefix.+/) {
# Push back.
unshift (@ARGV, $arg);
# Supply empty value.
}
elsif ( $type eq "n" || $type eq "i" ) { # numeric/integer
- if ( $bundling && defined $rest && $rest =~ /^(-?[0-9]+)(.*)$/ ) {
+ if ( $bundling && defined $rest && $rest =~ /^(-?[0-9]+)(.*)$/s ) {
$arg = $1;
$rest = $2;
unshift (@ARGV, $starter.$rest) if defined $rest && $rest ne '';
if ( $passthrough ) {
unshift (@ARGV, defined $rest ? $starter.$rest : $arg)
unless defined $optarg;
- return 0;
+ return (0);
}
warn ("Value \"", $arg, "\" invalid for option ",
$opt, " (number expected)\n");
# and at least one digit following the point and 'e'.
# [-]NN[.NN][eNN]
if ( $bundling && defined $rest &&
- $rest =~ /^(-?[0-9]+(\.[0-9]+)?([eE]-?[0-9]+)?)(.*)$/ ) {
+ $rest =~ /^(-?[0-9]+(\.[0-9]+)?([eE]-?[0-9]+)?)(.*)$/s ) {
$arg = $1;
- $rest = $4;
+ $rest = $+;
unshift (@ARGV, $starter.$rest) if defined $rest && $rest ne '';
}
elsif ( $arg !~ /^-?[0-9.]+(\.[0-9]+)?([eE]-?[0-9]+)?$/ ) {
if ( $passthrough ) {
unshift (@ARGV, defined $rest ? $starter.$rest : $arg)
unless defined $optarg;
- return 0;
+ return (0);
}
warn ("Value \"", $arg, "\" invalid for option ",
$opt, " (real number expected)\n");
}
}
else {
- &$croak ("GetOpt::Long internal error (Can't happen)\n");
+ Croak ("GetOpt::Long internal error (Can't happen)\n");
}
- return 1;
-};
+ return (1, $opt, $arg, $dsttype, $incr, $key);
+}
-$config_defaults = sub {
- # Handle POSIX compliancy.
- if ( defined $ENV{"POSIXLY_CORRECT"} ) {
- $gen_prefix = "(--|-)";
- $autoabbrev = 0; # no automatic abbrev of options
- $bundling = 0; # no bundling of single letter switches
- $getopt_compat = 0; # disallow '+' to start options
- $order = $REQUIRE_ORDER;
- }
- else {
- $gen_prefix = "(--|-|\\+)";
- $autoabbrev = 1; # automatic abbrev of options
- $bundling = 0; # bundling off by default
- $getopt_compat = 1; # allow '+' to start options
- $order = $PERMUTE;
+# Getopt::Long Configuration.
+sub Configure (@) {
+ my (@options) = @_;
+ my $opt;
+ foreach $opt ( @options ) {
+ my $try = lc ($opt);
+ my $action = 1;
+ if ( $try =~ /^no_?(.*)$/s ) {
+ $action = 0;
+ $try = $+;
+ }
+ if ( $try eq 'default' or $try eq 'defaults' ) {
+ ConfigDefaults () if $action;
+ }
+ elsif ( $try eq 'auto_abbrev' or $try eq 'autoabbrev' ) {
+ $autoabbrev = $action;
+ }
+ elsif ( $try eq 'getopt_compat' ) {
+ $getopt_compat = $action;
+ }
+ elsif ( $try eq 'ignorecase' or $try eq 'ignore_case' ) {
+ $ignorecase = $action;
+ }
+ elsif ( $try eq 'ignore_case_always' ) {
+ $ignorecase = $action ? 2 : 0;
+ }
+ elsif ( $try eq 'bundling' ) {
+ $bundling = $action;
+ }
+ elsif ( $try eq 'bundling_override' ) {
+ $bundling = $action ? 2 : 0;
+ }
+ elsif ( $try eq 'require_order' ) {
+ $order = $action ? $REQUIRE_ORDER : $PERMUTE;
+ }
+ elsif ( $try eq 'permute' ) {
+ $order = $action ? $PERMUTE : $REQUIRE_ORDER;
+ }
+ elsif ( $try eq 'pass_through' or $try eq 'passthrough' ) {
+ $passthrough = $action;
+ }
+ elsif ( $try =~ /^prefix=(.+)$/ ) {
+ $genprefix = $1;
+ # Turn into regexp. Needs to be parenthesized!
+ $genprefix = "(" . quotemeta($genprefix) . ")";
+ eval { '' =~ /$genprefix/; };
+ Croak ("Getopt::Long: invalid pattern \"$genprefix\"") if $@;
+ }
+ elsif ( $try =~ /^prefix_pattern=(.+)$/ ) {
+ $genprefix = $1;
+ # Parenthesize if needed.
+ $genprefix = "(" . $genprefix . ")"
+ unless $genprefix =~ /^\(.*\)$/;
+ eval { '' =~ /$genprefix/; };
+ Croak ("Getopt::Long: invalid pattern \"$genprefix\"") if $@;
+ }
+ elsif ( $try eq 'debug' ) {
+ $debug = $action;
+ }
+ else {
+ Croak ("Getopt::Long: unknown config parameter \"$opt\"")
+ }
}
- # Other configurable settings.
- $debug = 0; # for debugging
- $error = 0; # error tally
- $ignorecase = 1; # ignore case when matching options
- $passthrough = 0; # leave unrecognized options alone
-};
-
-################ Initialization ################
-
-# Values for $order. See GNU getopt.c for details.
-($REQUIRE_ORDER, $PERMUTE, $RETURN_IN_ORDER) = (0..2);
-# Version major/minor numbers.
-($major_version, $minor_version) = $VERSION =~ /^(\d+)\.(\d+)/;
-
-# Set defaults.
-&$config_defaults ();
+}
-################ Package return ################
+# Deprecated name.
+sub config (@) {
+ Configure (@_);
+}
-1;
+# To prevent Carp from being loaded unnecessarily.
+sub Croak (@) {
+ require 'Carp.pm';
+ $Carp::CarpLevel = 1;
+ Carp::croak(@_);
+};
-__END__
+################ Documentation ################
=head1 NAME
(with value 0).
The option variable will be set to 1, or 0 if negated.
+=item +
+
+Option does not take an argument and will be incremented by 1 every
+time it appears on the command line. E.g. "more+", when used with
+B<--more --more --more>, will set the option variable to 3 (provided
+it was 0 or undefined at first).
+
+The B<+> specifier is ignored if the option destination is not a SCALAR.
+
=item =s
Option takes a mandatory string argument.
The linkage specifier can be a reference to a scalar, a reference to
an array, a reference to a hash or a reference to a subroutine.
+Note that, if your code is running under the recommended C<use strict
+'vars'> pragma, it may be helpful to declare these package variables
+via C<use vars> perhaps something like this:
+
+ use vars qw/ $opt_size @opt_sizes $opt_bar /;
+
If a REF SCALAR is supplied, the new value is stored in the referenced
variable. If the option occurs more than once, the previous value is
overwritten.
=head1 CONFIGURATION OPTIONS
B<GetOptions> can be configured by calling subroutine
-B<Getopt::Long::config>. This subroutine takes a list of quoted
+B<Getopt::Long::Configure>. This subroutine takes a list of quoted
strings, each specifying a configuration option to be set, e.g.
B<ignore_case>. Options can be reset by prefixing with B<no_>, e.g.
B<no_ignore_case>. Case does not matter. Multiple calls to B<config>
This can be very confusing, especially when B<permute> is also set.
+=item prefix
+
+The string that starts options. See also B<prefix_pattern>.
+
+=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<(--|-)>.
+
=item debug (default: reset)
Enable copious debugging output.
=head1 COPYRIGHT AND DISCLAIMER
-This program is Copyright 1990,1997 by Johan Vromans.
+This program is Copyright 1990,1998 by Johan Vromans.
This program is free software; you can redistribute it and/or
modify it under the terms of the GNU General Public License
as published by the Free Software Foundation; either version 2
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.
+the Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston,
+MA 02111-1307, USA.
=cut