-package Getopt::Long;
-require 5.000;
-require Exporter;
-
-@ISA = qw(Exporter);
-@EXPORT = qw(GetOptions);
-
+# GetOpt::Long.pm -- Universal options parsing
-# newgetopt.pl -- new options parsing
+package Getopt::Long;
-# SCCS Status : @(#)@ newgetopt.pl 1.14
+# RCS Status : $Id: GetoptLong.pl,v 2.26 2001-01-31 10:20:29+01 jv Exp $
# Author : Johan Vromans
# Created On : Tue Sep 11 15:00:12 1990
# Last Modified By: Johan Vromans
-# Last Modified On: Sat Feb 12 18:24:02 1994
-# Update Count : 138
-# Status : Okay
+# Last Modified On: Sat Jan 6 17:12:27 2001
+# Update Count : 748
+# Status : Released
-################ Introduction ################
-#
-# This package implements an extended getopt function. This function adheres
-# to the new syntax (long option names, no bundling).
-# It tries to implement the better functionality of traditional, GNU and
-# POSIX getopt functions.
-#
-# This program is Copyright 1990,1994 by Johan Vromans.
+################ Copyright ################
+
+# This program is Copyright 1990,2001 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
-# of the License, or (at your option) any later version.
-#
+# modify it under the terms of the Perl Artistic License or the
+# GNU General Public License as published by the Free Software
+# Foundation; either version 2 of the License, or (at your option) any
+# later version.
+#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
# 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,
+# the Free Software Foundation, Inc., 675 Mass Ave, Cambridge,
# MA 02139, USA.
-################ Description ################
-#
-# Usage:
-#
-# require "newgetopt.pl";
-# ...change configuration values, if needed...
-# $result = &NGetOpt (...option-descriptions...);
-#
-# Each description should designate a valid perl identifier, optionally
-# followed by an argument specifier.
-#
-# Values for argument specifiers are:
-#
-# <none> option does not take an argument
-# ! option does not take an argument and may be negated
-# =s :s option takes a mandatory (=) or optional (:) string argument
-# =i :i option takes a mandatory (=) or optional (:) integer argument
-# =f :f option takes a mandatory (=) or optional (:) real number argument
-#
-# If option "name" is set, it will cause the perl variable $opt_name to
-# be set to the specified value. The calling program can use this
-# variable to detect whether the option has been set. Options that do
-# not take an argument will be set to 1 (one).
-#
-# Options that take an optional argument will be defined, but set to ''
-# if no actual argument has been supplied.
-#
-# If an "@" sign is appended to the argument specifier, the option is
-# treated as an array. Value(s) are not set, but pushed into array
-# @opt_name.
-#
-# Options that do not take a value may have an "!" argument spacifier to
-# indicate that they may be negated. E.g. "foo!" will allow -foo (which
-# sets $opt_foo to 1) and -nofoo (which will set $opt_foo to 0).
-#
-# The option name may actually be a list of option names, separated by
-# '|'s, e.g. "foo|bar|blech=s". In this example, options 'bar' and
-# 'blech' will set $opt_foo instead.
-#
-# Option names may be abbreviated to uniqueness, depending on
-# configuration variable $autoabbrev.
-#
-# Dashes in option names are allowed (e.g. pcc-struct-return) and will
-# be translated to underscores in the corresponding perl variable (e.g.
-# $opt_pcc_struct_return). Note that a lone dash "-" is considered an
-# option, corresponding perl identifier is $opt_ .
-#
-# A double dash "--" signals end of the options list.
-#
-# If the first option of the list consists of non-alphanumeric
-# characters only, it is interpreted as a generic option starter.
-# Everything starting with one of the characters from the starter will
-# be considered an option.
-#
-# The default values for the option starters are "-" (traditional), "--"
-# (POSIX) and "+" (GNU, being phased out).
-#
-# Options that start with "--" may have an argument appended, separated
-# with an "=", e.g. "--foo=bar".
-#
-# If configuration varaible $getopt_compat is set to a non-zero value,
-# options that start with "+" may also include their arguments,
-# e.g. "+foo=bar".
-#
-# A return status of 0 (false) indicates that the function detected
-# one or more errors.
-#
-################ Some examples ################
-#
-# If option "one:i" (i.e. takes an optional integer argument), then
-# the following situations are handled:
-#
-# -one -two -> $opt_one = '', -two is next option
-# -one -2 -> $opt_one = -2
-#
-# Also, assume "foo=s" and "bar:s" :
-#
-# -bar -xxx -> $opt_bar = '', '-xxx' is next option
-# -foo -bar -> $opt_foo = '-bar'
-# -foo -- -> $opt_foo = '--'
-#
-# In GNU or POSIX format, option names and values can be combined:
-#
-# +foo=blech -> $opt_foo = 'blech'
-# --bar= -> $opt_bar = ''
-# --bar=-- -> $opt_bar = '--'
-#
-################ Configuration values ################
-#
-# $autoabbrev Allow option names to be abbreviated to uniqueness.
-# Default is 1 unless environment variable
-# POSIXLY_CORRECT has been set.
-#
-# $getopt_compat Allow '+' to start options.
-# Default is 1 unless environment variable
-# POSIXLY_CORRECT has been set.
-#
-# $option_start Regexp with option starters.
-# Default is (--|-) if environment variable
-# POSIXLY_CORRECT has been set, (--|-|\+) otherwise.
-#
-# $order Whether non-options are allowed to be mixed with
-# options.
-# Default is $REQUIRE_ORDER if environment variable
-# POSIXLY_CORRECT has been set, $PERMUTE otherwise.
-#
-# $ignorecase Ignore case when matching options. Default is 1.
-#
-# $debug Enable debugging output. Default is 0.
-
-################ History ################
-#
-# 12-Feb-1994 Johan Vromans
-# Added "!" for negation.
-# Released to the net.
-#
-# 26-Aug-1992 Johan Vromans
-# More POSIX/GNU compliance.
-# Lone dash and double-dash are now independent of the option prefix
-# that is used.
-# Make errors in NGetOpt parameters fatal.
-# Allow options to be mixed with arguments.
-# Check $ENV{"POSIXLY_CORRECT"} to suppress this.
-# Allow --foo=bar and +foo=bar (but not -foo=bar).
-# Allow options to be abbreviated to minimum needed for uniqueness.
-# (Controlled by configuration variable $autoabbrev.)
-# Allow alias names for options (e.g. "foo|bar=s").
-# Allow "-" in option names (e.g. --pcc-struct-return). Dashes are
-# translated to "_" to form valid perl identifiers
-# (e.g. $opt_pcc_struct_return).
-#
-# 2-Jun-1992 Johan Vromans
-# Do not use //o to allow multiple NGetOpt calls with different delimeters.
-# Prevent typeless option from using previous $array state.
-# Prevent empty option from being eaten as a (negative) number.
-#
-# 25-May-1992 Johan Vromans
-# Add array options. "foo=s@" will return an array @opt_foo that
-# contains all values that were supplied. E.g. "-foo one -foo -two" will
-# return @opt_foo = ("one", "-two");
-# Correct bug in handling options that allow for a argument when followed
-# by another option.
-#
-# 4-May-1992 Johan Vromans
-# Add $ignorecase to match options in either case.
-# Allow '' option.
-#
-# 19-Mar-1992 Johan Vromans
-# Allow require from packages.
-# NGetOpt is now defined in the package that requires it.
-# @ARGV and $opt_... are taken from the package that calls it.
-# Use standard (?) option prefixes: -, -- and +.
-#
-# 20-Sep-1990 Johan Vromans
-# Set options w/o argument to 1.
-# Correct the dreadful semicolon/require bug.
+################ Module Preamble ################
+
+use 5.004;
+
+use strict;
+
+use vars qw($VERSION $VERSION_STRING);
+$VERSION = 2.25;
+$VERSION_STRING = "2.25";
+
+use Exporter;
+use AutoLoader qw(AUTOLOAD);
+
+use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
+@ISA = qw(Exporter);
+%EXPORT_TAGS = qw();
+BEGIN {
+ # Init immediately so their contents can be used in the 'use vars' below.
+ @EXPORT = qw(&GetOptions $REQUIRE_ORDER $PERMUTE $RETURN_IN_ORDER);
+ @EXPORT_OK = qw();
+}
-################ Configuration Section ################
+# 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 $caller $gnu_compat);
-{
+# Public subroutines.
+sub Configure (@);
+sub config (@); # deprecated name
+sub GetOptions;
- # Values for $order. See GNU getopt.c for details.
- $REQUIRE_ORDER = 0;
- $PERMUTE = 1;
- $RETURN_IN_ORDER = 2;
+# Private subroutines.
+sub ConfigDefaults ();
+sub FindOption ($$$$$$$);
+sub Croak (@); # demand loading the real Croak
+################ Local Variables ################
+
+################ Resident subroutines ################
+
+sub ConfigDefaults () {
# Handle POSIX compliancy.
if ( defined $ENV{"POSIXLY_CORRECT"} ) {
- $autoabbrev = 0; # no automatic abbrev of options (???)
- $getopt_compat = 0; # disallow '+' to start options
- $option_start = "(--|-)";
+ $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 {
- $autoabbrev = 1; # automatic abbrev of options
- $getopt_compat = 1; # allow '+' to start options
- $option_start = "(--|-|\\+)";
+ $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
- $argv_end = "--"; # don't change this!
+ $passthrough = 0; # leave unrecognized options alone
+ $gnu_compat = 0; # require --opt=val if value is optional
+}
+
+# Override import.
+sub import {
+ my $pkg = shift; # package
+ my @syms = (); # symbols to import
+ my @config = (); # configuration
+ my $dest = \@syms; # symbols first
+ for ( @_ ) {
+ if ( $_ eq ':config' ) {
+ $dest = \@config; # config next
+ next;
+ }
+ push (@$dest, $_); # push
+ }
+ # Hide one level and call super.
+ local $Exporter::ExportLevel = 1;
+ $pkg->SUPER::import(@syms);
+ # And configure.
+ Configure (@config) if @config;
}
-################ Subroutines ################
+################ 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+)/;
+
+ConfigDefaults();
+
+################ OO Interface ################
+
+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 ()
+};
+
+sub new {
+ my $that = shift;
+ my $class = ref($that) || $that;
+ my %atts = @_;
+
+ # Register the callers package.
+ my $self = { caller_pkg => (caller)[0] };
+
+ bless ($self, $class);
+
+ # 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});
+ }
+ # Else use default config.
+ else {
+ $self->{settings} = $default_config;
+ }
+
+ if ( %atts ) { # Oops
+ Getopt::Long::Croak(__PACKAGE__.": unhandled attributes: ".
+ join(" ", sort(keys(%atts))));
+ }
+
+ $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);
+}
+
+sub getoptions {
+ my ($self) = shift;
+
+ &$_lock;
+
+ # Restore config settings.
+ my $save = Getopt::Long::Configure ($self->{settings});
+
+ # Call main routine.
+ my $ret = 0;
+ $Getopt::Long::caller = $self->{caller_pkg};
+ eval { $ret = Getopt::Long::GetOptions (@_); };
+
+ # Restore saved settings.
+ Getopt::Long::Configure ($save);
+
+ # Handle errors and return value.
+ die ($@) if $@;
+ return $ret;
+}
+
+package Getopt::Long;
+
+################ Package return ################
+
+1;
+
+__END__
+
+################ AutoLoading subroutines ################
+
+# RCS Status : $Id: GetoptLongAl.pl,v 2.30 2001-01-31 10:21:11+01 jv Exp $
+# Author : Johan Vromans
+# Created On : Fri Mar 27 11:50:30 1998
+# Last Modified By: Johan Vromans
+# Last Modified On: Tue Dec 26 18:01:16 2000
+# Update Count : 98
+# Status : Released
sub GetOptions {
- @optionlist = @_; #';
+ my @optionlist = @_; # local copy of the option descriptions
+ my $argend = '--'; # option list terminator
+ my %opctl = (); # table of arg.specs (long and abbrevs)
+ my %bopctl = (); # table of arg.specs (bundles)
+ my $pkg = $caller || (caller)[0]; # current context
+ # Needed if linkage is omitted.
+ my %aliases= (); # alias table
+ my @ret = (); # accum for non-options
+ my %linkage; # linkage
+ my $userlinkage; # user supplied HASH
+ my $opt; # current option
+ my $genprefix = $genprefix; # so we can call the same module many times
+ my @opctl; # the possible long option names
- local ($[) = 0;
- local ($genprefix) = $option_start;
- local ($argend) = $argv_end;
- local ($error) = 0;
- local ($opt, $optx, $arg, $type, $mand, %opctl);
- local ($pkg) = (caller)[0];
- local ($optarg);
- local (%aliases);
- local (@ret) = ();
+ $error = '';
- print STDERR "NGetOpt 1.14 -- called from $pkg\n" if $debug;
+ print STDERR ("GetOpt::Long $Getopt::Long::VERSION ",
+ "called from package \"$pkg\".",
+ "\n ",
+ 'GetOptionsAl $Revision: 2.30 $ ',
+ "\n ",
+ "ARGV: (@ARGV)",
+ "\n ",
+ "autoabbrev=$autoabbrev,".
+ "bundling=$bundling,",
+ "getopt_compat=$getopt_compat,",
+ "gnu_compat=$gnu_compat,",
+ "order=$order,",
+ "\n ",
+ "ignorecase=$ignorecase,",
+ "passthrough=$passthrough,",
+ "genprefix=\"$genprefix\".",
+ "\n")
+ if $debug;
+
+ # Check for ref HASH as first argument.
+ # First argument may be an object. It's OK to use this as long
+ # as it is really a hash underneath.
+ $userlinkage = undef;
+ if ( ref($optionlist[0]) and
+ "$optionlist[0]" =~ /^(?:.*\=)?HASH\([^\(]*\)$/ ) {
+ $userlinkage = shift (@optionlist);
+ print STDERR ("=> user linkage: $userlinkage\n") if $debug;
+ }
# See if the first element of the optionlist contains option
# starter characters.
- if ( $optionlist[0] =~ /^\W+$/ ) {
+ # Be careful not to interpret '<>' as option starters.
+ if ( $optionlist[0] =~ /^\W+$/
+ && !($optionlist[0] eq '<>'
+ && @optionlist > 0
+ && ref($optionlist[1])) ) {
$genprefix = shift (@optionlist);
- # Turn into regexp.
+ # Turn into regexp. Needs to be parenthesized!
$genprefix =~ s/(\W)/\\$1/g;
- $genprefix = "[" . $genprefix . "]";
+ $genprefix = "([" . $genprefix . "])";
}
# Verify correctness of optionlist.
%opctl = ();
- foreach $opt ( @optionlist ) {
- $opt =~ tr/A-Z/a-z/ if $ignorecase;
- if ( $opt !~ /^(\w+[-\w|]*)?(!|[=:][infse]@?)?$/ ) {
- die ("Error in option spec: \"", $opt, "\"\n");
- $error++;
+ %bopctl = ();
+ while ( @optionlist > 0 ) {
+ my $opt = shift (@optionlist);
+
+ # Strip leading prefix so people can specify "--foo=i" if they like.
+ $opt = $+ if $opt =~ /^$genprefix+(.*)$/s;
+
+ if ( $opt eq '<>' ) {
+ if ( (defined $userlinkage)
+ && !(@optionlist > 0 && ref($optionlist[0]))
+ && (exists $userlinkage->{$opt})
+ && ref($userlinkage->{$opt}) ) {
+ unshift (@optionlist, $userlinkage->{$opt});
+ }
+ unless ( @optionlist > 0
+ && ref($optionlist[0]) && ref($optionlist[0]) eq 'CODE' ) {
+ $error .= "Option spec <> requires a reference to a subroutine\n";
+ next;
+ }
+ $linkage{'<>'} = shift (@optionlist);
next;
}
- local ($o, $c, $a) = ($1, $2);
+
+ # Match option spec. Allow '?' as an alias only.
+ if ( $opt !~ /^((\w+[-\w]*)(\|(\?|\w[-\w]*)?)*)?([!~+]|[=:][infse][@%]?)?$/ ) {
+ $error .= "Error in option spec: \"$opt\"\n";
+ next;
+ }
+ my ($o, $c, $a) = ($1, $5);
+ $c = '' unless defined $c;
+
+ # $linko keeps track of the primary name the user specified.
+ # This name will be used for the internal or external linkage.
+ # In other words, if the user specifies "FoO|BaR", it will
+ # match any case combinations of 'foo' and 'bar', but if a global
+ # variable needs to be set, it will be $opt_FoO in the exact case
+ # as specified.
+ my $linko;
if ( ! defined $o ) {
- $opctl{''} = defined $c ? $c : '';
+ # empty -> '-' option
+ $linko = $o = '';
+ $opctl{''} = $c;
+ $bopctl{''} = $c if $bundling;
}
else {
# Handle alias names
- foreach ( split (/\|/, $o)) {
- if ( defined $c && $c eq '!' ) {
- $opctl{"no$_"} = $c;
- $c = '';
+ my @o = split (/\|/, $o);
+ $linko = $o = $o[0];
+ # Force an alias if the option name is not locase.
+ $a = $o unless $o eq lc($o);
+ $o = lc ($o)
+ if $ignorecase > 1
+ || ($ignorecase
+ && ($bundling ? length($o) > 1 : 1));
+
+ foreach ( @o ) {
+ if ( $bundling && length($_) == 1 ) {
+ $_ = lc ($_) if $ignorecase > 1;
+ if ( $c eq '!' ) {
+ $opctl{"no$_"} = $c;
+ warn ("Ignoring '!' modifier for short option $_\n");
+ $opctl{$_} = $bopctl{$_} = '';
+ }
+ else {
+ $opctl{$_} = $bopctl{$_} = $c;
+ }
+ }
+ else {
+ $_ = lc ($_) if $ignorecase;
+ if ( $c eq '!' ) {
+ $opctl{"no$_"} = $c;
+ $opctl{$_} = ''
+ }
+ else {
+ $opctl{$_} = $c;
+ }
}
- $opctl{$_} = defined $c ? $c : '';
if ( defined $a ) {
# Note alias.
$aliases{$_} = $a;
}
}
}
+
+ # If no linkage is supplied in the @optionlist, copy it from
+ # the userlinkage if available.
+ if ( defined $userlinkage ) {
+ unless ( @optionlist > 0 && ref($optionlist[0]) ) {
+ if ( exists $userlinkage->{$linko} &&
+ ref($userlinkage->{$linko}) ) {
+ print STDERR ("=> found userlinkage for \"$linko\": ",
+ "$userlinkage->{$linko}\n")
+ if $debug;
+ unshift (@optionlist, $userlinkage->{$linko});
+ }
+ else {
+ # Do nothing. Being undefined will be handled later.
+ next;
+ }
+ }
+ }
+
+ # Copy the linkage. If omitted, link to global variable.
+ if ( @optionlist > 0 && ref($optionlist[0]) ) {
+ print STDERR ("=> link \"$linko\" to $optionlist[0]\n")
+ if $debug;
+ if ( ref($optionlist[0]) =~ /^(SCALAR|CODE)$/ ) {
+ $linkage{$linko} = shift (@optionlist);
+ }
+ elsif ( ref($optionlist[0]) =~ /^(ARRAY)$/ ) {
+ $linkage{$linko} = shift (@optionlist);
+ $opctl{$o} .= '@'
+ if $opctl{$o} ne '' and $opctl{$o} !~ /\@$/;
+ $bopctl{$o} .= '@'
+ if $bundling and defined $bopctl{$o} and
+ $bopctl{$o} ne '' and $bopctl{$o} !~ /\@$/;
+ }
+ elsif ( ref($optionlist[0]) =~ /^(HASH)$/ ) {
+ $linkage{$linko} = shift (@optionlist);
+ $opctl{$o} .= '%'
+ if $opctl{$o} ne '' and $opctl{$o} !~ /\%$/;
+ $bopctl{$o} .= '%'
+ if $bundling and defined $bopctl{$o} and
+ $bopctl{$o} ne '' and $bopctl{$o} !~ /\%$/;
+ }
+ else {
+ $error .= "Invalid option linkage for \"$opt\"\n";
+ }
+ }
+ else {
+ # Link to global $opt_XXX variable.
+ # Make sure a valid perl identifier results.
+ my $ov = $linko;
+ $ov =~ s/\W/_/g;
+ if ( $c =~ /@/ ) {
+ print STDERR ("=> link \"$linko\" to \@$pkg","::opt_$ov\n")
+ if $debug;
+ eval ("\$linkage{\$linko} = \\\@".$pkg."::opt_$ov;");
+ }
+ elsif ( $c =~ /%/ ) {
+ print STDERR ("=> link \"$linko\" to \%$pkg","::opt_$ov\n")
+ if $debug;
+ eval ("\$linkage{\$linko} = \\\%".$pkg."::opt_$ov;");
+ }
+ else {
+ print STDERR ("=> link \"$linko\" to \$$pkg","::opt_$ov\n")
+ if $debug;
+ eval ("\$linkage{\$linko} = \\\$".$pkg."::opt_$ov;");
+ }
+ }
}
- @opctl = sort(keys (%opctl)) if $autoabbrev;
- return 0 if $error;
+ # Bail out if errors found.
+ die ($error) if $error;
+ $error = 0;
+ # Sort the possible long option names.
+ @opctl = sort(keys (%opctl)) if $autoabbrev;
+
+ # Show the options tables if debugging.
if ( $debug ) {
- local ($arrow, $k, $v);
+ my ($arrow, $k, $v);
$arrow = "=> ";
while ( ($k,$v) = each(%opctl) ) {
print STDERR ($arrow, "\$opctl{\"$k\"} = \"$v\"\n");
$arrow = " ";
}
+ $arrow = "=> ";
+ while ( ($k,$v) = each(%bopctl) ) {
+ print STDERR ($arrow, "\$bopctl{\"$k\"} = \"$v\"\n");
+ $arrow = " ";
+ }
}
# Process argument list
-
- while ( $#ARGV >= 0 ) {
-
- # >>> See also the continue block <<<
+ my $goon = 1;
+ while ( $goon && @ARGV > 0 ) {
#### Get next argument ####
$opt = shift (@ARGV);
print STDERR ("=> option \"", $opt, "\"\n") if $debug;
- $arg = undef;
- $optarg = undef;
- $array = 0;
#### Determine what we have ####
# Double dash is option list terminator.
if ( $opt eq $argend ) {
- unshift (@ret, @ARGV) if $order == $PERMUTE;
+ # Finish. Push back accumulated arguments and return.
+ unshift (@ARGV, @ret)
+ if $order == $PERMUTE;
return ($error == 0);
}
- elsif ( $opt =~ /^$genprefix/ ) {
- # Looks like an option.
- $opt = $'; # option name (w/o prefix)
- # If it is a long opt, it may include the value.
- if (($+ eq "--" || ($getopt_compat && $+ eq "+")) &&
- $opt =~ /^([^=]+)=/ ) {
- $opt = $1;
- $optarg = $';
- print STDERR ("=> option \"", $opt,
- "\", optarg = \"$optarg\"\n")
- if $debug;
- }
+ 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);
+
+ if ( $found ) {
+
+ # FindOption undefines $opt in case of errors.
+ next unless defined $opt;
+
+ if ( defined $arg ) {
+ if ( defined $aliases{$opt} ) {
+ print STDERR ("=> alias \"$opt\" -> \"$aliases{$opt}\"\n")
+ if $debug;
+ $opt = $aliases{$opt};
+ }
+
+ if ( defined $linkage{$opt} ) {
+ print STDERR ("=> ref(\$L{$opt}) -> ",
+ ref($linkage{$opt}), "\n") if $debug;
+
+ if ( ref($linkage{$opt}) eq 'SCALAR' ) {
+ 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")
+ if $debug;
+ push (@{$linkage{$opt}}, $arg);
+ }
+ elsif ( ref($linkage{$opt}) eq 'HASH' ) {
+ print STDERR ("=> \$\$L{$opt}->{$key} = \"$arg\"\n")
+ if $debug;
+ $linkage{$opt}->{$key} = $arg;
+ }
+ elsif ( ref($linkage{$opt}) eq 'CODE' ) {
+ print STDERR ("=> &L{$opt}(\"$opt\", \"$arg\")\n")
+ if $debug;
+ local ($@);
+ eval {
+ &{$linkage{$opt}}($opt, $arg);
+ };
+ print STDERR ("=> die($@)\n") if $debug && $@ ne '';
+ if ( $@ =~ /^!/ ) {
+ if ( $@ =~ /^!FINISH\b/ ) {
+ $goon = 0;
+ }
+ }
+ elsif ( $@ ne '' ) {
+ warn ($@);
+ $error++;
+ }
+ }
+ else {
+ print STDERR ("Invalid REF type \"", ref($linkage{$opt}),
+ "\" in linkage\n");
+ Croak ("Getopt::Long -- internal error!\n");
+ }
+ }
+ # No entry in linkage means entry in userlinkage.
+ elsif ( $dsttype eq '@' ) {
+ if ( defined $userlinkage->{$opt} ) {
+ print STDERR ("=> push(\@{\$L{$opt}}, \"$arg\")\n")
+ if $debug;
+ push (@{$userlinkage->{$opt}}, $arg);
+ }
+ else {
+ print STDERR ("=>\$L{$opt} = [\"$arg\"]\n")
+ if $debug;
+ $userlinkage->{$opt} = [$arg];
+ }
+ }
+ elsif ( $dsttype eq '%' ) {
+ if ( defined $userlinkage->{$opt} ) {
+ print STDERR ("=> \$L{$opt}->{$key} = \"$arg\"\n")
+ if $debug;
+ $userlinkage->{$opt}->{$key} = $arg;
+ }
+ else {
+ print STDERR ("=>\$L{$opt} = {$key => \"$arg\"}\n")
+ if $debug;
+ $userlinkage->{$opt} = {$key => $arg};
+ }
+ }
+ else {
+ 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;
+ }
+ }
+ }
}
- # Not an option. Save it if we may permute...
+
+ # Not an option. Save it if we $PERMUTE and don't have a <>.
elsif ( $order == $PERMUTE ) {
- push (@ret, $opt);
+ # Try non-options call-back.
+ my $cb;
+ if ( (defined ($cb = $linkage{'<>'})) ) {
+ local ($@);
+ eval {
+ &$cb ($tryopt);
+ };
+ print STDERR ("=> die($@)\n") if $debug && $@ ne '';
+ if ( $@ =~ /^!/ ) {
+ if ( $@ =~ /^!FINISH\b/ ) {
+ $goon = 0;
+ }
+ }
+ elsif ( $@ ne '' ) {
+ warn ($@);
+ $error++;
+ }
+ }
+ else {
+ print STDERR ("=> saving \"$tryopt\" ",
+ "(not an option, may permute)\n") if $debug;
+ push (@ret, $tryopt);
+ }
next;
}
+
# ...otherwise, terminate.
else {
- # Push back and exit.
- unshift (@ARGV, $opt);
+ # Push this one back and exit.
+ unshift (@ARGV, $tryopt);
return ($error == 0);
}
- #### Look it up ###
+ }
+
+ # Finish.
+ if ( $order == $PERMUTE ) {
+ # Push back accumulated arguments
+ print STDERR ("=> restoring \"", join('" "', @ret), "\"\n")
+ if $debug && @ret > 0;
+ unshift (@ARGV, @ret) if @ret > 0;
+ }
- $opt =~ tr/A-Z/a-z/ if $ignorecase;
+ return ($error == 0);
+}
- local ($tryopt) = $opt;
- if ( $autoabbrev ) {
- local ($pat, @hits);
+# Option lookup.
+sub FindOption ($$$$$$$) {
- # Turn option name into pattern.
- ($pat = $opt) =~ s/(\W)/\\$1/g;
- # Look up in option names.
- @hits = grep (/^$pat/, @opctl);
- print STDERR ("=> ", 0+@hits, " hits (@hits) with \"$pat\" ",
- "out of ", 0+@opctl, "\n")
- if $debug;
+ # returns (1, $opt, $arg, $dsttype, $incr, $key) if okay,
+ # returns (0) otherwise.
- # Check for ambiguous results.
- unless ( (@hits <= 1) || (grep ($_ eq $opt, @hits) == 1) ) {
- print STDERR ("Option ", $opt, " is ambiguous (",
- join(", ", @hits), ")\n");
- $error++;
- next;
- }
+ my ($prefix, $argend, $opt, $opctl, $bopctl, $names, $aliases) = @_;
+ my $key; # hash key for a hash option
+ my $arg;
- # Complete the option name, if appropriate.
- if ( @hits == 1 && $hits[0] ne $opt ) {
- $tryopt = $hits[0];
- print STDERR ("=> option \"$opt\" -> \"$tryopt\"\n")
- if $debug;
- }
- }
+ print STDERR ("=> find \"$opt\", prefix=\"$prefix\"\n") if $debug;
- unless ( defined ( $type = $opctl{$tryopt} ) ) {
- print STDERR ("Unknown option: ", $opt, "\n");
- $error++;
- next;
+ return 0 unless $opt =~ /^$prefix(.*)$/s;
+ return 0 if $opt eq "-" && !defined $opctl->{""};
+
+ $opt = $+;
+ my ($starter) = $1;
+
+ print STDERR ("=> split \"$starter\"+\"$opt\"\n") if $debug;
+
+ my $optarg = undef; # value supplied with --opt=value
+ my $rest = undef; # remainder from unbundling
+
+ # If it is a long option, it may include the value.
+ if (($starter eq "--" || ($getopt_compat && !$bundling))
+ && $opt =~ /^([^=]+)=(.*)$/s ) {
+ $opt = $1;
+ $optarg = $2;
+ print STDERR ("=> option \"", $opt,
+ "\", optarg = \"$optarg\"\n") if $debug;
+ }
+
+ #### Look it up ###
+
+ my $tryopt = $opt; # option to try
+ 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.
+ $rest = length ($tryopt) > 0 ? substr ($tryopt, 1) : "";
+ $tryopt = substr ($tryopt, 0, 1);
+ $tryopt = lc ($tryopt) if $ignorecase > 1;
+ 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
+
+ # If bundling == 2, long options can override bundles.
+ if ( $bundling == 2 and
+ defined ($rest) and
+ defined ($type = $opctl->{$tryopt.$rest}) ) {
+ print STDERR ("=> $starter$tryopt rebundled to ",
+ "$starter$tryopt$rest\n") if $debug;
+ $tryopt .= $rest;
+ undef $rest;
}
- $opt = $tryopt;
- print STDERR ("=> found \"$type\" for ", $opt, "\n") if $debug;
+ }
- #### Determine argument status ####
+ # Try auto-abbreviation.
+ elsif ( $autoabbrev ) {
+ # Downcase if allowed.
+ $tryopt = $opt = lc ($opt) if $ignorecase;
+ # Turn option name into pattern.
+ my $pat = quotemeta ($opt);
+ # Look up in option names.
+ my @hits = grep (/^$pat/, @{$names});
+ print STDERR ("=> ", scalar(@hits), " hits (@hits) with \"$pat\" ",
+ "out of ", scalar(@{$names}), "\n") if $debug;
- # If it is an option w/o argument, we're almost finished with it.
- if ( $type eq '' || $type eq '!' ) {
- if ( defined $optarg ) {
- print STDERR ("Option ", $opt, " does not take an argument\n");
- $error++;
- }
- elsif ( $type eq '' ) {
- $arg = 1; # supply explicit value
+ # 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->{$_};
+ $hit{$_} = 1;
}
- else {
- substr ($opt, 0, 2) = ''; # strip NO prefix
- $arg = 0; # supply explicit value
+ # Now see if it really is ambiguous.
+ unless ( keys(%hit) == 1 ) {
+ return (0) if $passthrough;
+ warn ("Option ", $opt, " is ambiguous (",
+ join(", ", @hits), ")\n");
+ $error++;
+ undef $opt;
+ return (1, $opt,$arg,$dsttype,$incr,$key);
}
- next;
+ @hits = keys(%hit);
}
- # Get mandatory status and type info.
- ($mand, $type, $array) = $type =~ /^(.)(.)(@?)$/;
+ # Complete the option name, if appropriate.
+ if ( @hits == 1 && $hits[0] ne $opt ) {
+ $tryopt = $hits[0];
+ $tryopt = lc ($tryopt) if $ignorecase;
+ print STDERR ("=> option \"$opt\" -> \"$tryopt\"\n")
+ if $debug;
+ }
+ }
- # Check if there is an option argument available.
- if ( defined $optarg ? ($optarg eq '') : ($#ARGV < 0) ) {
+ # Map to all lowercase if ignoring case.
+ elsif ( $ignorecase ) {
+ $tryopt = lc ($opt);
+ }
- # Complain if this option needs an argument.
- if ( $mand eq "=" ) {
- print STDERR ("Option ", $opt, " requires an argument\n");
- $error++;
- }
- if ( $mand eq ":" ) {
- $arg = $type eq "s" ? '' : 0;
- }
- next;
+ # Check validity by fetching the info.
+ $type = $optbl->{$tryopt} unless defined $type;
+ unless ( defined $type ) {
+ return (0) if $passthrough;
+ warn ("Unknown option: ", $opt, "\n");
+ $error++;
+ return (1, $opt,$arg,$dsttype,$incr,$key);
+ }
+ # Apparently valid.
+ $opt = $tryopt;
+ print STDERR ("=> found \"$type\" for \"", $opt, "\"\n") if $debug;
+
+ #### Determine argument status ####
+
+ # If it is an option w/o argument, we're almost finished with it.
+ if ( $type eq '' || $type eq '!' || $type eq '+' ) {
+ if ( defined $optarg ) {
+ return (0) if $passthrough;
+ warn ("Option ", $opt, " does not take an argument\n");
+ $error++;
+ undef $opt;
+ }
+ 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, $opt,$arg,$dsttype,$incr,$key);
+ }
- # Get (possibly optional) argument.
- $arg = defined $optarg ? $optarg : shift (@ARGV);
+ # Get mandatory status and type info.
+ my $mand;
+ ($mand, $type, $dsttype, $key) = $type =~ /^(.)(.)([@%]?)$/;
- #### Check if the argument is valid for this option ####
+ # Check if there is an option argument available.
+ if ( $gnu_compat ) {
+ return (1, $opt, $optarg, $dsttype, $incr, $key)
+ if defined $optarg;
+ return (1, $opt, $type eq "s" ? '' : 0, $dsttype, $incr, $key)
+ if $mand eq ':';
+ }
- if ( $type eq "s" ) { # string
- # A mandatory string takes anything.
- next if $mand eq "=";
+ # 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;
+ warn ("Option ", $opt, " requires an argument\n");
+ $error++;
+ undef $opt;
+ }
+ return (1, $opt, $type eq "s" ? '' : 0, $dsttype, $incr, $key);
+ }
- # An optional string takes almost anything.
- next if defined $optarg;
- next if $arg eq "-";
+ # Get (possibly optional) argument.
+ $arg = (defined $rest ? $rest
+ : (defined $optarg ? $optarg : shift (@ARGV)));
- # Check for option or option list terminator.
- if ($arg eq $argend ||
- $arg =~ /^$genprefix.+/) {
- # Push back.
- unshift (@ARGV, $arg);
- # Supply empty value.
- $arg = '';
- }
- next;
+ # Get key if this is a "name=value" pair for a hash option.
+ $key = undef;
+ 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, $opt,$arg,$dsttype,$incr,$key) if $mand eq "=";
+
+ # An optional string takes almost anything.
+ 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 =~ /^$prefix.+/) {
+ # Push back.
+ unshift (@ARGV, $arg);
+ # Supply empty value.
+ $arg = '';
}
+ }
- if ( $type eq "n" || $type eq "i" ) { # numeric/integer
- if ( $arg !~ /^-?[0-9]+$/ ) {
- if ( defined $optarg || $mand eq "=" ) {
- print STDERR ("Value \"", $arg, "\" invalid for option ",
- $opt, " (number expected)\n");
- $error++;
- undef $arg; # don't assign it
- }
- else {
- # Push back.
- unshift (@ARGV, $arg);
- # Supply default value.
- $arg = 0;
+ elsif ( $type eq "n" || $type eq "i" ) { # numeric/integer
+ if ( $bundling && defined $rest && $rest =~ /^([-+]?[0-9]+)(.*)$/s ) {
+ $arg = $1;
+ $rest = $2;
+ unshift (@ARGV, $starter.$rest) if defined $rest && $rest ne '';
+ }
+ elsif ( $arg !~ /^[-+]?[0-9]+$/ ) {
+ if ( defined $optarg || $mand eq "=" ) {
+ if ( $passthrough ) {
+ unshift (@ARGV, defined $rest ? $starter.$rest : $arg)
+ unless defined $optarg;
+ return (0);
}
+ warn ("Value \"", $arg, "\" invalid for option ",
+ $opt, " (number expected)\n");
+ $error++;
+ undef $opt;
+ # Push back.
+ unshift (@ARGV, $starter.$rest) if defined $rest;
+ }
+ else {
+ # Push back.
+ unshift (@ARGV, defined $rest ? $starter.$rest : $arg);
+ # Supply default value.
+ $arg = 0;
}
- next;
}
+ }
- if ( $type eq "f" ) { # fixed real number, int is also ok
- if ( $arg !~ /^-?[0-9.]+$/ ) {
- if ( defined $optarg || $mand eq "=" ) {
- print STDERR ("Value \"", $arg, "\" invalid for option ",
- $opt, " (real number expected)\n");
- $error++;
- undef $arg; # don't assign it
- }
- else {
- # Push back.
- unshift (@ARGV, $arg);
- # Supply default value.
- $arg = 0.0;
+ 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]
+ if ( $bundling && defined $rest &&
+ $rest =~ /^([-+]?[0-9]+(\.[0-9]+)?([eE][-+]?[0-9]+)?)(.*)$/s ) {
+ $arg = $1;
+ $rest = $+;
+ unshift (@ARGV, $starter.$rest) if defined $rest && $rest ne '';
+ }
+ elsif ( $arg !~ /^[-+]?[0-9.]+(\.[0-9]+)?([eE][-+]?[0-9]+)?$/ ) {
+ if ( defined $optarg || $mand eq "=" ) {
+ if ( $passthrough ) {
+ unshift (@ARGV, defined $rest ? $starter.$rest : $arg)
+ unless defined $optarg;
+ return (0);
}
+ warn ("Value \"", $arg, "\" invalid for option ",
+ $opt, " (real number expected)\n");
+ $error++;
+ undef $opt;
+ # Push back.
+ unshift (@ARGV, $starter.$rest) if defined $rest;
+ }
+ else {
+ # Push back.
+ unshift (@ARGV, defined $rest ? $starter.$rest : $arg);
+ # Supply default value.
+ $arg = 0.0;
}
- next;
}
+ }
+ else {
+ Croak ("GetOpt::Long internal error (Can't happen)\n");
+ }
+ return (1, $opt, $arg, $dsttype, $incr, $key);
+}
+
+# Getopt::Long Configuration.
+sub Configure (@) {
+ my (@options) = @_;
- die ("NGetOpt internal error (Can't happen)\n");
+ my $prevconfig =
+ [ $error, $debug, $major_version, $minor_version,
+ $autoabbrev, $getopt_compat, $ignorecase, $bundling, $order,
+ $gnu_compat, $passthrough, $genprefix ];
+
+ if ( ref($options[0]) eq 'ARRAY' ) {
+ ( $error, $debug, $major_version, $minor_version,
+ $autoabbrev, $getopt_compat, $ignorecase, $bundling, $order,
+ $gnu_compat, $passthrough, $genprefix ) = @{shift(@options)};
}
- continue {
- if ( defined $arg ) {
- $opt = $aliases{$opt} if defined $aliases{$opt};
- # Make sure a valid perl identifier results.
- $opt =~ s/\W/_/g;
- if ( $array ) {
- print STDERR ('=> push (@', $pkg, '\'opt_', $opt, ", \"$arg\")\n")
- if $debug;
- eval ('push(@' . $pkg . '\'opt_' . $opt . ", \$arg);");
- }
- else {
- print STDERR ('=> $', $pkg, '\'opt_', $opt, " = \"$arg\"\n")
- if $debug;
- eval ('$' . $pkg . '\'opt_' . $opt . " = \$arg;");
+ 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') && $action ) {
+ ConfigDefaults ();
+ }
+ elsif ( ($try eq 'posix_default' or $try eq 'posix_defaults') ) {
+ local $ENV{POSIXLY_CORRECT};
+ $ENV{POSIXLY_CORRECT} = 1 if $action;
+ ConfigDefaults ();
+ }
+ elsif ( $try eq 'auto_abbrev' or $try eq 'autoabbrev' ) {
+ $autoabbrev = $action;
+ }
+ elsif ( $try eq 'getopt_compat' ) {
+ $getopt_compat = $action;
+ }
+ elsif ( $try eq 'gnu_getopt' ) {
+ if ( $action ) {
+ $gnu_compat = 1;
+ $bundling = 1;
+ $getopt_compat = 0;
+ $permute = 1;
}
}
+ elsif ( $try eq 'gnu_compat' ) {
+ $gnu_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=(.+)$/ && $action ) {
+ $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=(.+)$/ && $action ) {
+ $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\"")
+ }
}
+ $prevconfig;
+}
- if ( $order == $PERMUTE && @ret > 0 ) {
- unshift (@ARGV, @ret);
- }
- return ($error == 0);
+# Deprecated name.
+sub config (@) {
+ Configure (@_);
}
-################ Package return ################
+# To prevent Carp from being loaded unnecessarily.
+sub Croak (@) {
+ require 'Carp.pm';
+ $Carp::CarpLevel = 1;
+ Carp::croak(@_);
+};
-1;
+################ Documentation ################
+
+=head1 NAME
+
+Getopt::Long - Extended processing of command line options
+
+=head1 SYNOPSIS
+
+ use Getopt::Long;
+ $result = GetOptions (...option-descriptions...);
+
+=head1 DESCRIPTION
+
+The Getopt::Long module implements an extended getopt function called
+GetOptions(). This function adheres to the POSIX syntax for command
+line options, with GNU extensions. In general, this means that options
+have long names instead of single letters, and are introduced with a
+double dash "--". Support for bundling of command line options, as was
+the case with the more traditional single-letter approach, is provided
+but not enabled by default.
+
+=head1 Command Line Options, an Introduction
+
+Command line operated programs traditionally take their arguments from
+the command line, for example filenames or other information that the
+program needs to know. Besides arguments, these programs often take
+command line I<options> as well. Options are not necessary for the
+program to work, hence the name 'option', but are used to modify its
+default behaviour. For example, a program could do its job quietly,
+but with a suitable option it could provide verbose information about
+what it did.
+
+Command line options come in several flavours. Historically, they are
+preceded by a single dash C<->, and consist of a single letter.
+
+ -l -a -c
+
+Usually, these single-character options can be bundled:
+
+ -lac
+
+Options can have values, the value is placed after the option
+character. Sometimes with whitespace in between, sometimes not:
+
+ -s 24 -s24
+
+Due to the very cryptic nature of these options, another style was
+developed that used long names. So instead of a cryptic C<-l> one
+could use the more descriptive C<--long>. To distinguish between a
+bundle of single-character options and a long one, two dashes are used
+to precede the option name. Early implementations of long options used
+a plus C<+> instead. Also, option values could be specified either
+like
+
+ --size=24
+
+or
+
+ --size 24
+
+The C<+> form is now obsolete and strongly deprecated.
+
+=head1 Getting Started with Getopt::Long
+
+Getopt::Long is the Perl5 successor of C<newgetopt.pl>. This was
+the first Perl module that provided support for handling the new style
+of command line options, hence the name Getopt::Long. This module
+also supports single-character options and bundling. In this case, the
+options are restricted to alphabetic characters only, and the
+characters C<?> and C<->.
+
+To use Getopt::Long from a Perl program, you must include the
+following line in your Perl program:
+
+ use Getopt::Long;
+
+This will load the core of the Getopt::Long module and prepare your
+program for using it. Most of the actual Getopt::Long code is not
+loaded until you really call one of its functions.
+
+In the default configuration, options names may be abbreviated to
+uniqueness, case does not matter, and a single dash is sufficient,
+even for long option names. Also, options may be placed between
+non-option arguments. See L<Configuring Getopt::Long> for more
+details on how to configure Getopt::Long.
+
+=head2 Simple options
+
+The most simple options are the ones that take no values. Their mere
+presence on the command line enables the option. Popular examples are:
+
+ --all --verbose --quiet --debug
+
+Handling simple options is straightforward:
+
+ my $verbose = ''; # option variable with default value (false)
+ my $all = ''; # option variable with default value (false)
+ GetOptions ('verbose' => \$verbose, 'all' => \$all);
+
+The call to GetOptions() parses the command line arguments that are
+present in C<@ARGV> and sets the option variable to the value C<1> if
+the option did occur on the command line. Otherwise, the option
+variable is not touched. Setting the option value to true is often
+called I<enabling> the option.
+
+The option name as specified to the GetOptions() function is called
+the option I<specification>. Later we'll see that this specification
+can contain more than just the option name. The reference to the
+variable is called the option I<destination>.
+
+GetOptions() will return a true value if the command line could be
+processed successfully. Otherwise, it will write error messages to
+STDERR, and return a false result.
+
+=head2 A little bit less simple options
+
+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
+option name:
+
+ my $verbose = ''; # option variable with default value (false)
+ GetOptions ('verbose!' => \$verbose);
+
+Now, using C<--verbose> on the command line will enable C<$verbose>,
+as expected. But it is also allowed to use C<--noverbose>, which will
+disable C<$verbose> by setting its value to C<0>. Using a suitable
+default value, the program can find out whether C<$verbose> is false
+by default, or disabled by using C<--noverbose>.
+
+An incremental option is specified with a plus C<+> after the
+option name:
+
+ my $verbose = ''; # option variable with default value (false)
+ GetOptions ('verbose+' => \$verbose);
+
+Using C<--verbose> on the command line will increment the value of
+C<$verbose>. This way the program can keep track of how many times the
+option occurred on the command line. For example, each occurrence of
+C<--verbose> could increase the verbosity level of the program.
+
+=head2 Mixing command line option with other arguments
+
+Usually programs take command line options as well as other arguments,
+for example, file names. It is good practice to always specify the
+options first, and the other arguments last. Getopt::Long will,
+however, allow the options and arguments to be mixed and 'filter out'
+all the options before passing the rest of the arguments to the
+program. To stop Getopt::Long from processing further arguments,
+insert a double dash C<--> on the command line:
+
+ --size 24 -- --all
+
+In this example, C<--all> will I<not> be treated as an option, but
+passed to the program unharmed, in C<@ARGV>.
+
+=head2 Options with values
+
+For options that take values it must be specified whether the option
+value is required or not, and what kind of value the option expects.
+
+Three kinds of values are supported: integer numbers, floating point
+numbers, and strings.
+
+If the option value is required, Getopt::Long will take the
+command line argument that follows the option and assign this to the
+option variable. If, however, the option value is specified as
+optional, this will only be done if that value does not look like a
+valid command line option itself.
+
+ my $tag = ''; # option variable with default value
+ GetOptions ('tag=s' => \$tag);
+
+In the option specification, the option name is followed by an equals
+sign C<=> and the letter C<s>. The equals sign indicates that this
+option requires a value. The letter C<s> indicates that this value is
+an arbitrary string. Other possible value types are C<i> for integer
+values, and C<f> for floating point values. Using a colon C<:> instead
+of the equals sign indicates that the option value is optional. In
+this case, if no suitable value is supplied, string valued options get
+an empty string C<''> assigned, while numeric options are set to C<0>.
+
+=head2 Options with multiple values
+
+Options sometimes take several values. For example, a program could
+use multiple directories to search for library files:
+
+ --library lib/stdlib --library lib/extlib
+
+To accomplish this behaviour, simply specify an array reference as the
+destination for the option:
+
+ my @libfiles = ();
+ GetOptions ("library=s" => \@libfiles);
+
+Used with the example above, 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 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()
+and join() operators:
+
+ my @libfiles = ();
+ GetOptions ("library=s" => \@libfiles);
+ @libfiles = split(/,/,join(',',@libfiles));
+
+Of course, it is important to choose the right separator string for
+each purpose.
+
+=head2 Options with hash values
+
+If the option destination is a reference to a hash, the option will
+take, as value, strings of the form I<key>C<=>I<value>. The value will
+be stored with the specified key in the hash.
+
+ my %defines = ();
+ GetOptions ("define=s" => \%defines);
+
+When used with command line options:
+
+ --define os=linux --define vendor=redhat
+
+the hash 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 acceptible values. The keys are always taken to be strings.
+
+=head2 User-defined subroutines to handle options
+
+Ultimate control over what should be done when (actually: each time)
+an option is encountered on the command line can be achieved by
+designating a reference to a subroutine (or an anonymous subroutine)
+as the option destination. When GetOptions() encounters the option, it
+will call the subroutine with two arguments: the name of the option,
+and the value to be assigned. It is up to the subroutine to store the
+value, or do whatever it thinks is appropriate.
+
+A trivial application of this mechanism is to implement options that
+are related to each other. For example:
+
+ my $verbose = ''; # option variable with default value (false)
+ GetOptions ('verbose' => \$verbose,
+ 'quiet' => sub { $verbose = 0 });
+
+Here C<--verbose> and C<--quiet> control the same variable
+C<$verbose>, but with opposite values.
+
+If the subroutine needs to signal an error, it should call die() with
+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 exclamantion mark C<!>
+it is interpreted specially by GetOptions(). There is currently one
+special command implemented: C<die("!FINISH")> will cause GetOptions()
+to stop processing options, as if it encountered a double dash C<-->.
+
+=head2 Options with multiple names
+
+Often it is user friendly to supply alternate mnemonic names for
+options. For example C<--height> could be an alternate name for
+C<--length>. Alternate names can be included in the option
+specification, separated by vertical bar C<|> characters. To implement
+the above example:
+
+ GetOptions ('length|height=f' => \$length);
+
+The first name is called the I<primary> name, the other names are
+called I<aliases>.
+
+Multiple alternate names are possible.
+
+=head2 Case and abbreviations
+
+Without additional configuration, GetOptions() will ignore the case of
+option names, and allow the options to be abbreviated to uniqueness.
+
+ GetOptions ('length|height=f' => \$length, "head" => \$head);
+
+This call will allow C<--l> and C<--L> for the length option, but
+requires a least C<--hea> and C<--hei> for the head and height options.
+
+=head2 Summary of Option Specifications
+
+Each option specifier consists of two parts: the name specification
+and the argument specification.
+
+The name specification contains the name of the option, optionally
+followed by a list of alternative names separated by vertical bar
+characters.
+
+ length option name is "length"
+ length|size|l name is "length", aliases are "size" and "l"
+
+The argument specification is optional. If omitted, the option is
+considered boolean, a value of 1 will be assigned when the option is
+used on the command line.
+
+The argument specification can be
+
+=over 4
+
+=item !
+
+The option does not take an argument and may be negated, i.e. prefixed
+by "no". E.g. C<"foo!"> will allow C<--foo> (a value of 1 will be
+assigned) and C<--nofoo> (a value of 0 will be assigned). If the
+option has aliases, this applies to the aliases as well.
+
+Using negation on a single letter option when bundling is in effect is
+pointless and will result in a warning.
+
+=item +
+
+The option does not take an argument and will be incremented by 1
+every time it appears on the command line. E.g. C<"more+">, when used
+with C<--more --more --more>, will increment the value three times,
+resulting in a value of 3 (provided it was 0 or undefined at first).
+
+The C<+> specifier is ignored if the option destination is not a scalar.
+
+=item = I<type> [ I<desttype> ]
+
+The option requires an argument of the given type. Supported types
+are:
+
+=over 4
+
+=item s
+
+String. An arbitrary sequence of characters. It is valid for the
+argument to start with C<-> or C<-->.
+
+=item i
+
+Integer. An optional leading plus or minus sign, followed by a
+sequence of digits.
+
+=item f
+
+Real number. For example C<3.14>, C<-6.23E24> and so on.
+
+=back
+
+The I<desttype> can be C<@> or C<%> to specify that the option is
+list or a hash valued. This is only needed when the destination for
+the option value is not otherwise specified. It should be omitted when
+not needed.
+
+=item : I<type> [ I<desttype> ]
+
+Like C<=>, but designates the argument as optional.
+If omitted, an empty string will be assigned to string values options,
+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.
+
+=back
+
+=head1 Advanced Possibilities
+
+=head2 Object oriented interface
+
+Getopt::Long can be used in an object oriented way as well:
+
+ use Getopt::Long;
+ $p = new Getopt::Long::Parser;
+ $p->configure(...configuration options...);
+ if ($p->getoptions(...options descriptions...)) ...
+
+Configuration options can be passed to the constructor:
+
+ $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 Documentation and help texts
+
+Getopt::Long encourages the use of Pod::Usage to produce help
+messages. For example:
+
+ use Getopt::Long;
+ use Pod::Usage;
+
+ my $man = 0;
+ my $help = 0;
+
+ GetOptions('help|?' => \$help, man => \$man) or pod2usage(2);
+ pod2usage(1) if $help;
+ pod2usage(-exitstatus => 0, -verbose => 2) if $man;
+
+ __END__
+
+ =head1 NAME
+
+ sample - Using GetOpt::Long and Pod::Usage
+
+ =head1 SYNOPSIS
+
+ sample [options] [file ...]
+
+ Options:
+ -help brief help message
+ -man full documentation
+
+ =head1 OPTIONS
+
+ =over 8
+
+ =item B<-help>
+
+ Print a brief help message and exits.
+
+ =item B<-man>
+
+ Prints the manual page and exits.
+
+ =back
+
+ =head1 DESCRIPTION
+
+ B<This program> will read the given input file(s) and do someting
+ useful with the contents thereof.
+
+ =cut
+
+See L<Pod::Usage> for details.
+
+=head2 Storing options in a hash
+
+Sometimes, for example when there are a lot of options, having a
+separate variable for each of them can be cumbersome. GetOptions()
+supports, as an alternative mechanism, storing options in a hash.
+
+To obtain this, a reference to a hash must be passed I<as the first
+argument> to GetOptions(). For each option that is specified on the
+command line, the option value will be stored in the hash with the
+option name as key. Options that are not actually used on the command
+line will not be put in the hash, on other words,
+C<exists($h{option})> (or defined()) can be used to test if an option
+was used. The drawback is that warnings will be issued if the program
+runs under C<use strict> and uses C<$h{option}> without testing with
+exists() or defined() first.
+
+ my %h = ();
+ GetOptions (\%h, 'length=i'); # will store in $h{length}
+
+For options that take list or hash values, it is necessary to indicate
+this by appending an C<@> or C<%> sign after the type:
+
+ GetOptions (\%h, 'colours=s@'); # will push to @{$h{colours}}
+
+To make things more complicated, the hash may contain references to
+the actual destinations, for example:
+
+ my $len = 0;
+ my %h = ('length' => \$len);
+ GetOptions (\%h, 'length=i'); # will store in $len
+
+This example is fully equivalent with:
+
+ my $len = 0;
+ GetOptions ('length=i' => \$len); # will store in $len
+
+Any mixture is possible. For example, the most frequently used options
+could be stored in variables while all other options get stored in the
+hash:
+
+ my $verbose = 0; # frequently referred
+ my $debug = 0; # frequently referred
+ my %h = ('verbose' => \$verbose, 'debug' => \$debug);
+ GetOptions (\%h, 'verbose', 'debug', 'filter', 'size=i');
+ if ( $verbose ) { ... }
+ if ( exists $h{filter} ) { ... option 'filter' was specified ... }
+
+=head2 Bundling
+
+With bundling it is possible to set several single-character options
+at once. For example if C<a>, C<v> and C<x> are all valid options,
+
+ -vax
+
+would set all three.
+
+Getopt::Long supports two levels of bundling. To enable bundling, a
+call to Getopt::Long::Configure is required.
+
+The first level of bundling can be enabled with:
+
+ Getopt::Long::Configure ("bundling");
+
+Configured this way, single-character options can be bundled but long
+options B<must> always start with a double dash C<--> to avoid
+abiguity. For example, when C<vax>, C<a>, C<v> and C<x> are all valid
+options,
+
+ -vax
+
+would set C<a>, C<v> and C<x>, but
+
+ --vax
+
+would set C<vax>.
+
+The second level of bundling lifts this restriction. It can be enabled
+with:
+
+ Getopt::Long::Configure ("bundling_override");
+
+Now, C<-vax> would set the option C<vax>.
+
+When any level of bundling is enabled, option values may be inserted
+in the bundle. For example:
+
+ -h24w80
+
+is equivalent to
+
+ -h 24 -w 80
+
+When configured for bundling, single-character options are matched
+case sensitive while long options are matched case insensitive. To
+have the single-character options matched case insensitive as well,
+use:
+
+ Getopt::Long::Configure ("bundling", "ignorecase_always");
+
+It goes without saying that bundling can be quite confusing.
+
+=head2 The lonesome dash
+
+Normally, a lone dash C<-> on the command line will not be considered
+an option. Option processing will terminate (unless "permute" is
+configured) and the dash will be left in C<@ARGV>.
+
+It is possible to get special treatment for a lone dash. This can be
+achieved by adding an option specification with an empty name, for
+example:
+
+ GetOptions ('' => \$stdio);
+
+A lone dash on the command line will now be a legal option, and using
+it will set variable C<$stdio>.
+
+=head2 Argument call-back
+
+A special option 'name' C<<>> can be used to designate a subroutine
+to handle non-option arguments. When GetOptions() encounters an
+argument that does not look like an option, it will immediately call this
+subroutine and passes it the argument as a parameter.
+
+For example:
+
+ my $width = 80;
+ sub process { ... }
+ GetOptions ('width=i' => \$width, '<>' => \&process);
+
+When applied to the following command line:
+
+ arg1 --width=72 arg2 --width=60 arg3
+
+This will call
+C<process("arg1")> while C<$width> is C<80>,
+C<process("arg2")> while C<$width> is C<72>, and
+C<process("arg3")> while C<$width> is C<60>.
+
+This feature requires configuration option B<permute>, see section
+L<Configuring Getopt::Long>.
+
+
+=head1 Configuring Getopt::Long
+
+Getopt::Long can be configured by calling subroutine
+Getopt::Long::Configure(). This subroutine takes a list of quoted
+strings, each specifying a configuration option to be enabled, e.g.
+C<ignore_case>, or disabled, e.g. C<no_ignore_case>. Case does not
+matter. Multiple calls to Configure() are possible.
+
+Alternatively, as of version 2.24, the configuration options may be
+passed together with the C<use> statement:
+
+ use Getopt::Long qw(:config no_ignore_case bundling);
+
+The following options are available:
+
+=over 12
+
+=item default
+
+This option causes all configuration options to be reset to their
+default values.
+
+=item posix_default
+
+This option causes all configuration options to be reset to their
+default values as if the environment variable POSIXLY_CORRECT had
+been set.
+
+=item auto_abbrev
+
+Allow option names to be abbreviated to uniqueness.
+Default is enabled unless environment variable
+POSIXLY_CORRECT has been set, in which case C<auto_abbrev> is disabled.
+
+=item getopt_compat
+
+Allow C<+> to start options.
+Default is enabled unless environment variable
+POSIXLY_CORRECT has been set, in which case C<getopt_compat> is disabled.
+
+=item gnu_compat
+
+C<gnu_compat> controls whether C<--opt=> is allowed, and what it should
+do. Without C<gnu_compat>, C<--opt=> gives an error. With C<gnu_compat>,
+C<--opt=> will give option C<opt> and empty value.
+This is the way GNU getopt_long() does it.
+
+=item gnu_getopt
+
+This is a short way of setting C<gnu_compat> C<bundling> C<permute>
+C<no_getopt_compat>. With C<gnu_getopt>, command line handling should be
+fully compatible with GNU getopt_long().
+
+=item require_order
+
+Whether command line arguments are allowed to be mixed with options.
+Default is disabled unless environment variable
+POSIXLY_CORRECT has been set, in which case C<require_order> is enabled.
+
+See also C<permute>, which is the opposite of C<require_order>.
+
+=item permute
+
+Whether command line arguments are allowed to be mixed with options.
+Default is enabled unless environment variable
+POSIXLY_CORRECT has been set, in which case C<permute> is disabled.
+Note that C<permute> is the opposite of C<require_order>.
+
+If C<permute> is enabled, this means that
+
+ --foo arg1 --bar arg2 arg3
+
+is equivalent to
+
+ --foo --bar arg1 arg2 arg3
+
+If an argument call-back routine is specified, C<@ARGV> will always be
+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
+
+will call the call-back routine for arg1 and arg2, and terminate
+GetOptions() leaving C<"arg2"> in C<@ARGV>.
+
+If C<require_order> is enabled, options processing
+terminates when the first non-option is encountered.
+
+ --foo arg1 --bar arg2 arg3
+
+is equivalent to
+
+ --foo -- arg1 --bar arg2 arg3
+
+If C<pass_through> is also enabled, options processing will terminate
+at the first unrecognized option, or non-option, whichever comes
+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<must> be
+introduced with C<--> and single-character options (and bundles) with
+C<->.
+
+Note: disabling C<bundling> also disables C<bundling_override>.
+
+=item bundling_override (default: disabled)
+
+If C<bundling_override> is enabled, bundling is enabled as with
+C<bundling> but now long option names override option bundles.
+
+Note: disabling C<bundling_override> also disables C<bundling>.
+
+B<Note:> Using option bundling can easily lead to unexpected results,
+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.
+
+Note: disabling C<ignore_case> also disables C<ignore_case_always>.
+
+=item ignore_case_always (default: disabled)
+
+When bundling is in effect, case is ignored on single-character
+options also.
+
+Note: disabling C<ignore_case_always> also disables C<ignore_case>.
+
+=item pass_through (default: disabled)
+
+Options that are unknown, ambiguous or supplied with an invalid option
+value are passed through in C<@ARGV> instead of being flagged as
+errors. This makes it possible to write wrapper scripts that process
+only part of the user supplied command line arguments, and pass the
+remaining options to some other program.
+
+If C<require_order> is enabled, options processing will terminate at
+the first unrecognized option, or non-option, whichever comes first.
+However, if C<permute> is enabled instead, results can become confusing.
+
+=item prefix
+
+The string that starts options. If a constant string is not
+sufficient, see C<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: disabled)
+
+Enable debugging output.
+
+=back
+
+=head1 Return values and Errors
+
+Configuration errors and errors in the option definitions are
+signalled using die() and will terminate the calling program unless
+the call to Getopt::Long::GetOptions() was embedded in C<eval { ...
+}>, or die() was trapped using C<$SIG{__DIE__}>.
+
+GetOptions returns true to indicate success.
+It returns false when the function detected one or more errors during
+option parsing. These errors are signalled using warn() and can be
+trapped with C<$SIG{__WARN__}>.
+
+Errors that can't happen are signalled using Carp::croak().
+
+=head1 Legacy
+
+The earliest development of C<newgetopt.pl> started in 1990, with Perl
+version 4. As a result, its development, and the development of
+Getopt::Long, has gone through several stages. Since backward
+compatibility has always been extremely important, the current version
+of Getopt::Long still supports a lot of constructs that nowadays are
+no longer necessary or otherwise unwanted. This section describes
+briefly some of these 'features'.
+
+=head2 Default destinations
+
+When no destination is specified for an option, GetOptions will store
+the resultant value in a global variable named C<opt_>I<XXX>, where
+I<XXX> is the primary name of this option. When a progam executes
+under C<use strict> (recommended), these variables must be
+pre-declared with our() or C<use vars>.
+
+ our $opt_length = 0;
+ GetOptions ('length=i'); # will store in $opt_length
+
+To yield a usable Perl variable, characters that are not part of the
+syntax for variables are translated to underscores. For example,
+C<--fpp-struct-return> will set the variable
+C<$opt_fpp_struct_return>. Note that this variable resides in the
+namespace of the calling program, not necessarily C<main>. For
+example:
+
+ GetOptions ("size=i", "sizes=i@");
+
+with command line "-size 10 -sizes 24 -sizes 48" will perform the
+equivalent of the assignments
+
+ $opt_size = 10;
+ @opt_sizes = (24, 48);
+
+=head2 Alternative option starters
+
+A string of alternative option starter characters may be passed as the
+first argument (or the first argument after a leading hash reference
+argument).
+
+ my $len = 0;
+ GetOptions ('/', 'length=i' => $len);
+
+Now the command line may look like:
+
+ /length 24 -- arg
+
+Note that to terminate options processing still requires a double dash
+C<-->.
+
+GetOptions() will not interpret a leading C<< "<>" >> as option starters
+if the next argument is a reference. To force C<< "<" >> and C<< ">" >> as
+option starters, use C<< "><" >>. Confusing? Well, B<using a starter
+argument is strongly deprecated> anyway.
+
+=head2 Configuration variables
+
+Previous versions of Getopt::Long used variables for the purpose of
+configuring. Although manipulating these variables still work, it is
+strongly encouraged to use the C<Configure> routine that was introduced
+in version 2.17. Besides, it is much easier.
+
+=head1 Trouble Shooting
+
+=head2 Warning: Ignoring '!' modifier for short option
+
+This warning is issued when the '!' modifier is applied to a short
+(one-character) option and bundling is in effect. E.g.,
+
+ Getopt::Long::Configure("bundling");
+ GetOptions("foo|f!" => \$foo);
+
+Note that older Getopt::Long versions did not issue a warning, because
+the '!' modifier was applied to the first name only. This bug was
+fixed in 2.22.
+
+Solution: separate the long and short names and apply the '!' to the
+long names only, e.g.,
+
+ GetOptions("foo!" => \$foo, "f" => \$foo);
+
+=head2 GetOptions does not return a false result when an option is not supplied
+
+That's why they're called 'options'.
+
+=head1 AUTHOR
+
+Johan Vromans <jvromans@squirrel.nl>
+
+=head1 COPYRIGHT AND DISCLAIMER
+
+This program is Copyright 2000,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
+Foundation; either version 2 of the License, or (at your option) any
+later version.
+
+This program is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+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.
+=cut
+# Local Variables:
+# eval: (load-file "pod.el")
+# End:
projects / p5sagit/p5-mst-13.2.git / blobdiff