You can not select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
1890 lines
57 KiB
1890 lines
57 KiB
# GetOpt::Long.pm -- Universal options parsing
|
|
|
|
package Getopt::Long;
|
|
|
|
# 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 Jan 6 17:12:27 2001
|
|
# Update Count : 748
|
|
# Status : Released
|
|
|
|
################ 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 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.
|
|
|
|
################ 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();
|
|
}
|
|
|
|
# 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;
|
|
|
|
# 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"} ) {
|
|
$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
|
|
$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;
|
|
}
|
|
|
|
################ 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 {
|
|
|
|
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
|
|
|
|
$error = '';
|
|
|
|
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.
|
|
# 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. Needs to be parenthesized!
|
|
$genprefix =~ s/(\W)/\\$1/g;
|
|
$genprefix = "([" . $genprefix . "])";
|
|
}
|
|
|
|
# Verify correctness of optionlist.
|
|
%opctl = ();
|
|
%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;
|
|
}
|
|
|
|
# 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 ) {
|
|
# empty -> '-' option
|
|
$linko = $o = '';
|
|
$opctl{''} = $c;
|
|
$bopctl{''} = $c if $bundling;
|
|
}
|
|
else {
|
|
# Handle alias names
|
|
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;
|
|
}
|
|
}
|
|
if ( defined $a ) {
|
|
# Note alias.
|
|
$aliases{$_} = $a;
|
|
}
|
|
else {
|
|
# Set primary name.
|
|
$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;");
|
|
}
|
|
}
|
|
}
|
|
|
|
# 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 ) {
|
|
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
|
|
my $goon = 1;
|
|
while ( $goon && @ARGV > 0 ) {
|
|
|
|
#### Get next argument ####
|
|
|
|
$opt = shift (@ARGV);
|
|
print STDERR ("=> option \"", $opt, "\"\n") if $debug;
|
|
|
|
#### Determine what we have ####
|
|
|
|
# Double dash is option list terminator.
|
|
if ( $opt eq $argend ) {
|
|
# Finish. Push back accumulated arguments and return.
|
|
unshift (@ARGV, @ret)
|
|
if $order == $PERMUTE;
|
|
return ($error == 0);
|
|
}
|
|
|
|
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 $PERMUTE and don't have a <>.
|
|
elsif ( $order == $PERMUTE ) {
|
|
# 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 this one back and exit.
|
|
unshift (@ARGV, $tryopt);
|
|
return ($error == 0);
|
|
}
|
|
|
|
}
|
|
|
|
# Finish.
|
|
if ( $order == $PERMUTE ) {
|
|
# Push back accumulated arguments
|
|
print STDERR ("=> restoring \"", join('" "', @ret), "\"\n")
|
|
if $debug && @ret > 0;
|
|
unshift (@ARGV, @ret) if @ret > 0;
|
|
}
|
|
|
|
return ($error == 0);
|
|
}
|
|
|
|
# Option lookup.
|
|
sub FindOption ($$$$$$$) {
|
|
|
|
# returns (1, $opt, $arg, $dsttype, $incr, $key) if okay,
|
|
# returns (0) otherwise.
|
|
|
|
my ($prefix, $argend, $opt, $opctl, $bopctl, $names, $aliases) = @_;
|
|
my $key; # hash key for a hash option
|
|
my $arg;
|
|
|
|
print STDERR ("=> find \"$opt\", prefix=\"$prefix\"\n") if $debug;
|
|
|
|
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;
|
|
}
|
|
}
|
|
|
|
# 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;
|
|
|
|
# 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;
|
|
}
|
|
# 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);
|
|
}
|
|
@hits = keys(%hit);
|
|
}
|
|
|
|
# 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;
|
|
}
|
|
}
|
|
|
|
# Map to all lowercase if ignoring case.
|
|
elsif ( $ignorecase ) {
|
|
$tryopt = lc ($opt);
|
|
}
|
|
|
|
# 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 mandatory status and type info.
|
|
my $mand;
|
|
($mand, $type, $dsttype, $key) = $type =~ /^(.)(.)([@%]?)$/;
|
|
|
|
# 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 ':';
|
|
}
|
|
|
|
# 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);
|
|
}
|
|
|
|
# Get (possibly optional) argument.
|
|
$arg = (defined $rest ? $rest
|
|
: (defined $optarg ? $optarg : shift (@ARGV)));
|
|
|
|
# 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 = '';
|
|
}
|
|
}
|
|
|
|
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;
|
|
}
|
|
}
|
|
}
|
|
|
|
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;
|
|
}
|
|
}
|
|
}
|
|
else {
|
|
Croak ("GetOpt::Long internal error (Can't happen)\n");
|
|
}
|
|
return (1, $opt, $arg, $dsttype, $incr, $key);
|
|
}
|
|
|
|
# Getopt::Long Configuration.
|
|
sub Configure (@) {
|
|
my (@options) = @_;
|
|
|
|
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)};
|
|
}
|
|
|
|
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;
|
|
}
|
|
|
|
# Deprecated name.
|
|
sub config (@) {
|
|
Configure (@_);
|
|
}
|
|
|
|
# To prevent Carp from being loaded unnecessarily.
|
|
sub Croak (@) {
|
|
require 'Carp.pm';
|
|
$Carp::CarpLevel = 1;
|
|
Carp::croak(@_);
|
|
};
|
|
|
|
################ 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
|
|
|
|
=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
|
|
|
|
=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 <[email protected]>
|
|
|
|
=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:
|