-# GetOpt::Long.pm -- Universal options parsing
+# Getopt::Long.pm -- Universal options parsing
package Getopt::Long;
-# RCS Status : $Id: GetoptLong.pm,v 2.16 1998-03-13 11:05:29+01 jv Exp $
+# RCS Status : $Id: Long.pm,v 2.74 2007/09/29 13:40:13 jv Exp $
# Author : Johan Vromans
# Created On : Tue Sep 11 15:00:12 1990
# Last Modified By: Johan Vromans
-# Last Modified On: Fri Mar 13 11:05:28 1998
-# Update Count : 659
+# Last Modified On: Sat Sep 29 15:38:55 2007
+# Update Count : 1571
# Status : Released
################ Copyright ################
-# This program is Copyright 1990,1998 by Johan Vromans.
+# This program is Copyright 1990,2007 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.
################ Module Preamble ################
+use 5.004;
+
use strict;
-BEGIN {
- require 5.004;
- use Exporter ();
- use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
- $VERSION = sprintf("%d.%02d", q$Revision: 2.16 $ =~ /(\d+)\.(\d+)/);
+use vars qw($VERSION);
+$VERSION = 2.37;
+# For testing versions only.
+use vars qw($VERSION_STRING);
+$VERSION_STRING = "2.37";
+
+use Exporter;
+use vars qw(@ISA @EXPORT @EXPORT_OK);
+@ISA = qw(Exporter);
+
+# Exported subroutines.
+sub GetOptions(@); # always
+sub GetOptionsFromArray($@); # on demand
+sub GetOptionsFromString($@); # on demand
+sub Configure(@); # on demand
+sub HelpMessage(@); # on demand
+sub VersionMessage(@); # in demand
- @ISA = qw(Exporter);
+BEGIN {
+ # Init immediately so their contents can be used in the 'use vars' below.
@EXPORT = qw(&GetOptions $REQUIRE_ORDER $PERMUTE $RETURN_IN_ORDER);
- %EXPORT_TAGS = ();
- @EXPORT_OK = qw();
+ @EXPORT_OK = qw(&HelpMessage &VersionMessage &Configure
+ &GetOptionsFromArray &GetOptionsFromString);
}
-use vars @EXPORT, @EXPORT_OK;
# User visible variables.
+use vars @EXPORT, @EXPORT_OK;
use vars qw($error $debug $major_version $minor_version);
# Deprecated visible variables.
use vars qw($autoabbrev $getopt_compat $ignorecase $bundling $order
$passthrough);
+# Official invisible variables.
+use vars qw($genprefix $caller $gnu_compat $auto_help $auto_version $longprefix);
+
+# Public subroutines.
+sub config(@); # deprecated name
+
+# Private subroutines.
+sub ConfigDefaults();
+sub ParseOptionSpec($$);
+sub OptCtl($);
+sub FindOption($$$$$);
+sub ValidValue ($$$$$);
################ Local Variables ################
-my $gen_prefix; # generic prefix (option starters)
-my $argend; # option list terminator
-my %opctl; # table of arg.specs (long and abbrevs)
-my %bopctl; # table of arg.specs (bundles)
-my @opctl; # the possible long option names
-my $pkg; # current context. Needed if no linkage.
-my %aliases; # alias table
-my $genprefix; # so we can call the same module more
-my $opt; # current option
-my $arg; # current option value, if any
-my $array; # current option is array typed
-my $hash; # current option is hash typed
-my $key; # hash key for a hash option
- # than once in differing environments
-my $config_defaults; # set config defaults
-my $find_option; # helper routine
-my $croak; # helper routine
-
-################ Subroutines ################
-
-sub GetOptions {
-
- my @optionlist = @_; # local copy of the option descriptions
- $argend = '--'; # option list terminator
- %opctl = (); # table of arg.specs (long and abbrevs)
- %bopctl = (); # table of arg.specs (bundles)
- $pkg = (caller)[0]; # current context
+# $requested_version holds the version that was mentioned in the 'use'
+# or 'require', if any. It can be used to enable or disable specific
+# features.
+my $requested_version = 0;
+
+################ 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
+ $longprefix = "(--)"; # what does a long prefix look like
+}
+
+# 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;
+ push(@syms, qw(&GetOptions)) if @syms; # always export GetOptions
+ $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;
+
+# 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 {
+ 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} ) {
+ 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
+ die(__PACKAGE__.": unhandled attributes: ".
+ join(" ", sort(keys(%atts)))."\n");
+ }
+
+ $self;
+}
+
+sub configure {
+ my ($self) = shift;
+
+ # Restore settings, merge new settings in.
+ my $save = Getopt::Long::Configure ($self->{settings}, @_);
+
+ # Restore orig config and save the new config.
+ $self->{settings} = Getopt::Long::Configure ($save);
+}
+
+sub getoptions {
+ my ($self) = shift;
+
+ # Restore config settings.
+ my $save = Getopt::Long::Configure ($self->{settings});
+
+ # Call main routine.
+ my $ret = 0;
+ $Getopt::Long::caller = $self->{caller_pkg};
+
+ eval {
+ # Locally set exception handler to default, otherwise it will
+ # be called implicitly here, and again explicitly when we try
+ # to deliver the messages.
+ local ($SIG{__DIE__}) = '__DEFAULT__';
+ $ret = Getopt::Long::GetOptions (@_);
+ };
+
+ # Restore saved settings.
+ Getopt::Long::Configure ($save);
+
+ # Handle errors and return value.
+ die ($@) if $@;
+ return $ret;
+}
+
+package Getopt::Long;
+
+################ Back to Normal ################
+
+# Indices in option control info.
+# Note that ParseOptions uses the fields directly. Search for 'hard-wired'.
+use constant CTL_TYPE => 0;
+#use constant CTL_TYPE_FLAG => '';
+#use constant CTL_TYPE_NEG => '!';
+#use constant CTL_TYPE_INCR => '+';
+#use constant CTL_TYPE_INT => 'i';
+#use constant CTL_TYPE_INTINC => 'I';
+#use constant CTL_TYPE_XINT => 'o';
+#use constant CTL_TYPE_FLOAT => 'f';
+#use constant CTL_TYPE_STRING => 's';
+
+use constant CTL_CNAME => 1;
+
+use constant CTL_DEFAULT => 2;
+
+use constant CTL_DEST => 3;
+ use constant CTL_DEST_SCALAR => 0;
+ use constant CTL_DEST_ARRAY => 1;
+ use constant CTL_DEST_HASH => 2;
+ use constant CTL_DEST_CODE => 3;
+
+use constant CTL_AMIN => 4;
+use constant CTL_AMAX => 5;
+
+# FFU.
+#use constant CTL_RANGE => ;
+#use constant CTL_REPEAT => ;
+
+# Rather liberal patterns to match numbers.
+use constant PAT_INT => "[-+]?_*[0-9][0-9_]*";
+use constant PAT_XINT =>
+ "(?:".
+ "[-+]?_*[1-9][0-9_]*".
+ "|".
+ "0x_*[0-9a-f][0-9a-f_]*".
+ "|".
+ "0b_*[01][01_]*".
+ "|".
+ "0[0-7_]*".
+ ")";
+use constant PAT_FLOAT => "[-+]?[0-9._]+(\.[0-9_]+)?([eE][-+]?[0-9_]+)?";
+
+sub GetOptions(@) {
+ # Shift in default array.
+ unshift(@_, \@ARGV);
+ # Try to keep caller() and Carp consitent.
+ goto &GetOptionsFromArray;
+}
+
+sub GetOptionsFromString($@) {
+ my ($string) = shift;
+ require Text::ParseWords;
+ my $args = [ Text::ParseWords::shellwords($string) ];
+ $caller ||= (caller)[0]; # current context
+ my $ret = GetOptionsFromArray($args, @_);
+ return ( $ret, $args ) if wantarray;
+ if ( @$args ) {
+ $ret = 0;
+ warn("GetOptionsFromString: Excess data \"@$args\" in string \"$string\"\n");
+ }
+ $ret;
+}
+
+sub GetOptionsFromArray($@) {
+
+ my ($argv, @optionlist) = @_; # local copy of the option descriptions
+ my $argend = '--'; # option list terminator
+ my %opctl = (); # table of option specs
+ my $pkg = $caller || (caller)[0]; # current context
# Needed if linkage is omitted.
- %aliases= (); # alias table
my @ret = (); # accum for non-options
my %linkage; # linkage
my $userlinkage; # user supplied HASH
- $genprefix = $gen_prefix; # so we can call the same module many times
+ my $opt; # current option
+ my $prefix = $genprefix; # current prefix
+
$error = '';
- print STDERR ('GetOptions $Revision: 2.16 $ ',
- "[GetOpt::Long $Getopt::Long::VERSION] -- ",
- "called from package \"$pkg\".\n",
- " (@ARGV)\n",
- " autoabbrev=$autoabbrev".
- ",bundling=$bundling",
- ",getopt_compat=$getopt_compat",
- ",order=$order",
- ",\n ignorecase=$ignorecase",
- ",passthrough=$passthrough",
- ",genprefix=\"$genprefix\"",
- ".\n")
- if $debug;
-
- # Check for ref HASH as first argument.
+ if ( $debug ) {
+ # Avoid some warnings if debugging.
+ local ($^W) = 0;
+ print STDERR
+ ("Getopt::Long $Getopt::Long::VERSION (",
+ '$Revision: 2.74 $', ") ",
+ "called from package \"$pkg\".",
+ "\n ",
+ "argv: (@$argv)",
+ "\n ",
+ "autoabbrev=$autoabbrev,".
+ "bundling=$bundling,",
+ "getopt_compat=$getopt_compat,",
+ "gnu_compat=$gnu_compat,",
+ "order=$order,",
+ "\n ",
+ "ignorecase=$ignorecase,",
+ "requested_version=$requested_version,",
+ "passthrough=$passthrough,",
+ "genprefix=\"$genprefix\",",
+ "longprefix=\"$longprefix\".",
+ "\n");
+ }
+
+ # 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.
+ # as it is really a hash underneath.
$userlinkage = undef;
- if ( ref($optionlist[0]) and
- "$optionlist[0]" =~ /^(?:.*\=)?HASH\([^\(]*\)$/ ) {
+ if ( @optionlist && ref($optionlist[0]) and
+ UNIVERSAL::isa($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+$/ ) {
- $genprefix = shift (@optionlist);
+ # Be careful not to interpret '<>' as option starters.
+ if ( @optionlist && $optionlist[0] =~ /^\W+$/
+ && !($optionlist[0] eq '<>'
+ && @optionlist > 0
+ && ref($optionlist[1])) ) {
+ $prefix = shift (@optionlist);
# Turn into regexp. Needs to be parenthesized!
- $genprefix =~ s/(\W)/\\$1/g;
- $genprefix = "([" . $genprefix . "])";
+ $prefix =~ s/(\W)/\\$1/g;
+ $prefix = "([" . $prefix . "])";
+ print STDERR ("=> prefix=\"$prefix\"\n") if $debug;
}
# Verify correctness of optionlist.
%opctl = ();
- %bopctl = ();
- while ( @optionlist > 0 ) {
+ while ( @optionlist ) {
my $opt = shift (@optionlist);
+ unless ( defined($opt) ) {
+ $error .= "Undefined argument in option spec\n";
+ next;
+ }
+
# Strip leading prefix so people can specify "--foo=i" if they like.
- $opt = $+ if $opt =~ /^$genprefix+(.*)$/s;
+ $opt = $+ if $opt =~ /^$prefix+(.*)$/s;
if ( $opt eq '<>' ) {
if ( (defined $userlinkage)
&& ref($userlinkage->{$opt}) ) {
unshift (@optionlist, $userlinkage->{$opt});
}
- unless ( @optionlist > 0
+ unless ( @optionlist > 0
&& ref($optionlist[0]) && ref($optionlist[0]) eq 'CODE' ) {
$error .= "Option spec <> requires a reference to a subroutine\n";
+ # Kill the linkage (to avoid another error).
+ shift (@optionlist)
+ if @optionlist && ref($optionlist[0]);
next;
}
$linkage{'<>'} = shift (@optionlist);
next;
}
- # Match option spec. Allow '?' as an alias.
- if ( $opt !~ /^((\w+[-\w]*)(\|(\?|\w[-\w]*)?)*)?(!|[=:][infse][@%]?)?$/ ) {
- $error .= "Error in option spec: \"$opt\"\n";
+ # Parse option spec.
+ my ($name, $orig) = ParseOptionSpec ($opt, \%opctl);
+ unless ( defined $name ) {
+ # Failed. $orig contains the error message. Sorry for the abuse.
+ $error .= $orig;
+ # Kill the linkage (to avoid another error).
+ shift (@optionlist)
+ if @optionlist && ref($optionlist[0]);
next;
}
- my ($o, $c, $a) = ($1, $5);
- $c = '' unless defined $c;
-
- if ( ! defined $o ) {
- # empty -> '-' option
- $opctl{$o = ''} = $c;
- }
- else {
- # Handle alias names
- my @o = split (/\|/, $o);
- my $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");
- $c = '';
- }
- $opctl{$_} = $bopctl{$_} = $c;
- }
- else {
- $_ = lc ($_) if $ignorecase;
- if ( $c eq '!' ) {
- $opctl{"no$_"} = $c;
- $c = '';
- }
- $opctl{$_} = $c;
- }
- if ( defined $a ) {
- # Note alias.
- $aliases{$_} = $a;
- }
- else {
- # Set primary name.
- $a = $_;
- }
- }
- $o = $linko;
- }
# 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->{$o} && ref($userlinkage->{$o}) ) {
- print STDERR ("=> found userlinkage for \"$o\": ",
- "$userlinkage->{$o}\n")
+ if ( exists $userlinkage->{$orig} &&
+ ref($userlinkage->{$orig}) ) {
+ print STDERR ("=> found userlinkage for \"$orig\": ",
+ "$userlinkage->{$orig}\n")
if $debug;
- unshift (@optionlist, $userlinkage->{$o});
+ unshift (@optionlist, $userlinkage->{$orig});
}
else {
# Do nothing. Being undefined will be handled later.
# Copy the linkage. If omitted, link to global variable.
if ( @optionlist > 0 && ref($optionlist[0]) ) {
- print STDERR ("=> link \"$o\" to $optionlist[0]\n")
+ print STDERR ("=> link \"$orig\" to $optionlist[0]\n")
if $debug;
- if ( ref($optionlist[0]) =~ /^(SCALAR|CODE)$/ ) {
- $linkage{$o} = shift (@optionlist);
+ my $rl = ref($linkage{$orig} = shift (@optionlist));
+
+ if ( $rl eq "ARRAY" ) {
+ $opctl{$name}[CTL_DEST] = CTL_DEST_ARRAY;
+ }
+ elsif ( $rl eq "HASH" ) {
+ $opctl{$name}[CTL_DEST] = CTL_DEST_HASH;
}
- elsif ( ref($optionlist[0]) =~ /^(ARRAY)$/ ) {
- $linkage{$o} = 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 ( $rl eq "SCALAR" || $rl eq "REF" ) {
+# if ( $opctl{$name}[CTL_DEST] == CTL_DEST_ARRAY ) {
+# my $t = $linkage{$orig};
+# $$t = $linkage{$orig} = [];
+# }
+# elsif ( $opctl{$name}[CTL_DEST] == CTL_DEST_HASH ) {
+# }
+# else {
+ # Ok.
+# }
}
- elsif ( ref($optionlist[0]) =~ /^(HASH)$/ ) {
- $linkage{$o} = 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 ( $rl eq "CODE" ) {
+ # Ok.
}
else {
$error .= "Invalid option linkage for \"$opt\"\n";
else {
# Link to global $opt_XXX variable.
# Make sure a valid perl identifier results.
- my $ov = $o;
+ my $ov = $orig;
$ov =~ s/\W/_/g;
- if ( $c =~ /@/ ) {
- print STDERR ("=> link \"$o\" to \@$pkg","::opt_$ov\n")
+ if ( $opctl{$name}[CTL_DEST] == CTL_DEST_ARRAY ) {
+ print STDERR ("=> link \"$orig\" to \@$pkg","::opt_$ov\n")
if $debug;
- eval ("\$linkage{\$o} = \\\@".$pkg."::opt_$ov;");
+ eval ("\$linkage{\$orig} = \\\@".$pkg."::opt_$ov;");
}
- elsif ( $c =~ /%/ ) {
- print STDERR ("=> link \"$o\" to \%$pkg","::opt_$ov\n")
+ elsif ( $opctl{$name}[CTL_DEST] == CTL_DEST_HASH ) {
+ print STDERR ("=> link \"$orig\" to \%$pkg","::opt_$ov\n")
if $debug;
- eval ("\$linkage{\$o} = \\\%".$pkg."::opt_$ov;");
+ eval ("\$linkage{\$orig} = \\\%".$pkg."::opt_$ov;");
}
else {
- print STDERR ("=> link \"$o\" to \$$pkg","::opt_$ov\n")
+ print STDERR ("=> link \"$orig\" to \$$pkg","::opt_$ov\n")
if $debug;
- eval ("\$linkage{\$o} = \\\$".$pkg."::opt_$ov;");
+ eval ("\$linkage{\$orig} = \\\$".$pkg."::opt_$ov;");
}
}
}
die ($error) if $error;
$error = 0;
- # Sort the possible long option names.
- @opctl = sort(keys (%opctl)) if $autoabbrev;
+ # Supply --version and --help support, if needed and allowed.
+ if ( defined($auto_version) ? $auto_version : ($requested_version >= 2.3203) ) {
+ if ( !defined($opctl{version}) ) {
+ $opctl{version} = ['','version',0,CTL_DEST_CODE,undef];
+ $linkage{version} = \&VersionMessage;
+ }
+ $auto_version = 1;
+ }
+ if ( defined($auto_help) ? $auto_help : ($requested_version >= 2.3203) ) {
+ if ( !defined($opctl{help}) && !defined($opctl{'?'}) ) {
+ $opctl{help} = $opctl{'?'} = ['','help',0,CTL_DEST_CODE,undef];
+ $linkage{help} = \&HelpMessage;
+ }
+ $auto_help = 1;
+ }
# 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");
+ print STDERR ($arrow, "\$opctl{$k} = $v ", OptCtl($v), "\n");
$arrow = " ";
}
}
# Process argument list
- while ( @ARGV > 0 ) {
-
- #### Get next argument ####
+ my $goon = 1;
+ while ( $goon && @$argv > 0 ) {
- $opt = shift (@ARGV);
- $arg = undef;
- $array = $hash = 0;
- print STDERR ("=> option \"", $opt, "\"\n") if $debug;
-
- #### Determine what we have ####
+ # Get next argument.
+ $opt = shift (@$argv);
+ print STDERR ("=> arg \"", $opt, "\"\n") if $debug;
# 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);
+ push (@ret, $argend) if $passthrough;
+ last;
}
+ # Look it up.
my $tryopt = $opt;
+ my $found; # success status
+ my $key; # key (if hash type)
+ my $arg; # option argument
+ my $ctl; # the opctl entry
+
+ ($found, $opt, $ctl, $arg, $key) =
+ FindOption ($argv, $prefix, $argend, $opt, \%opctl);
+
+ if ( $found ) {
- # find_option operates on the GLOBAL $opt and $arg!
- if ( &$find_option () ) {
-
- # find_option undefines $opt in case of errors.
+ # FindOption undefines $opt in case of errors.
next unless defined $opt;
- if ( defined $arg ) {
- $opt = $aliases{$opt} if defined $aliases{$opt};
+ my $argcnt = 0;
+ while ( defined $arg ) {
+
+ # Get the canonical name.
+ print STDERR ("=> cname for \"$opt\" is ") if $debug;
+ $opt = $ctl->[CTL_CNAME];
+ print STDERR ("\"$ctl->[CTL_CNAME]\"\n") if $debug;
if ( defined $linkage{$opt} ) {
print STDERR ("=> ref(\$L{$opt}) -> ",
ref($linkage{$opt}), "\n") if $debug;
- if ( ref($linkage{$opt}) eq 'SCALAR' ) {
- print STDERR ("=> \$\$L{$opt} = \"$arg\"\n") if $debug;
- ${$linkage{$opt}} = $arg;
+ if ( ref($linkage{$opt}) eq 'SCALAR'
+ || ref($linkage{$opt}) eq 'REF' ) {
+ if ( $ctl->[CTL_TYPE] eq '+' ) {
+ print STDERR ("=> \$\$L{$opt} += \"$arg\"\n")
+ if $debug;
+ if ( defined ${$linkage{$opt}} ) {
+ ${$linkage{$opt}} += $arg;
+ }
+ else {
+ ${$linkage{$opt}} = $arg;
+ }
+ }
+ elsif ( $ctl->[CTL_DEST] == CTL_DEST_ARRAY ) {
+ print STDERR ("=> ref(\$L{$opt}) auto-vivified",
+ " to ARRAY\n")
+ if $debug;
+ my $t = $linkage{$opt};
+ $$t = $linkage{$opt} = [];
+ print STDERR ("=> push(\@{\$L{$opt}, \"$arg\")\n")
+ if $debug;
+ push (@{$linkage{$opt}}, $arg);
+ }
+ elsif ( $ctl->[CTL_DEST] == CTL_DEST_HASH ) {
+ print STDERR ("=> ref(\$L{$opt}) auto-vivified",
+ " to HASH\n")
+ if $debug;
+ my $t = $linkage{$opt};
+ $$t = $linkage{$opt} = {};
+ print STDERR ("=> \$\$L{$opt}->{$key} = \"$arg\"\n")
+ if $debug;
+ $linkage{$opt}->{$key} = $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")
$linkage{$opt}->{$key} = $arg;
}
elsif ( ref($linkage{$opt}) eq 'CODE' ) {
- print STDERR ("=> &L{$opt}(\"$opt\", \"$arg\")\n")
+ print STDERR ("=> &L{$opt}(\"$opt\"",
+ $ctl->[CTL_DEST] == CTL_DEST_HASH ? ", \"$key\"" : "",
+ ", \"$arg\")\n")
if $debug;
- &{$linkage{$opt}}($opt, $arg);
+ my $eval_error = do {
+ local $@;
+ local $SIG{__DIE__} = '__DEFAULT__';
+ eval {
+ &{$linkage{$opt}}
+ (Getopt::Long::CallBack->new
+ (name => $opt,
+ ctl => $ctl,
+ opctl => \%opctl,
+ linkage => \%linkage,
+ prefix => $prefix,
+ ),
+ $ctl->[CTL_DEST] == CTL_DEST_HASH ? ($key) : (),
+ $arg);
+ };
+ $@;
+ };
+ print STDERR ("=> die($eval_error)\n")
+ if $debug && $eval_error ne '';
+ if ( $eval_error =~ /^!/ ) {
+ if ( $eval_error =~ /^!FINISH\b/ ) {
+ $goon = 0;
+ }
+ }
+ elsif ( $eval_error ne '' ) {
+ warn ($eval_error);
+ $error++;
+ }
}
else {
print STDERR ("Invalid REF type \"", ref($linkage{$opt}),
"\" in linkage\n");
- &$croak ("Getopt::Long -- internal error!\n");
+ die("Getopt::Long -- internal error!\n");
}
}
# No entry in linkage means entry in userlinkage.
- elsif ( $array ) {
+ elsif ( $ctl->[CTL_DEST] == CTL_DEST_ARRAY ) {
if ( defined $userlinkage->{$opt} ) {
print STDERR ("=> push(\@{\$L{$opt}}, \"$arg\")\n")
if $debug;
$userlinkage->{$opt} = [$arg];
}
}
- elsif ( $hash ) {
+ elsif ( $ctl->[CTL_DEST] == CTL_DEST_HASH ) {
if ( defined $userlinkage->{$opt} ) {
print STDERR ("=> \$L{$opt}->{$key} = \"$arg\"\n")
if $debug;
}
}
else {
- print STDERR ("=>\$L{$opt} = \"$arg\"\n") if $debug;
- $userlinkage->{$opt} = $arg;
+ if ( $ctl->[CTL_TYPE] eq '+' ) {
+ 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;
+ }
+ }
+
+ $argcnt++;
+ last if $argcnt >= $ctl->[CTL_AMAX] && $ctl->[CTL_AMAX] != -1;
+ undef($arg);
+
+ # Need more args?
+ if ( $argcnt < $ctl->[CTL_AMIN] ) {
+ if ( @$argv ) {
+ if ( ValidValue($ctl, $argv->[0], 1, $argend, $prefix) ) {
+ $arg = shift(@$argv);
+ $arg =~ tr/_//d if $ctl->[CTL_TYPE] =~ /^[iIo]$/;
+ ($key,$arg) = $arg =~ /^([^=]+)=(.*)/
+ if $ctl->[CTL_DEST] == CTL_DEST_HASH;
+ next;
+ }
+ warn("Value \"$$argv[0]\" invalid for option $opt\n");
+ $error++;
+ }
+ else {
+ warn("Insufficient arguments for option $opt\n");
+ $error++;
+ }
+ }
+
+ # Any more args?
+ if ( @$argv && ValidValue($ctl, $argv->[0], 0, $argend, $prefix) ) {
+ $arg = shift(@$argv);
+ $arg =~ tr/_//d if $ctl->[CTL_TYPE] =~ /^[iIo]$/;
+ ($key,$arg) = $arg =~ /^([^=]+)=(.*)/
+ if $ctl->[CTL_DEST] == CTL_DEST_HASH;
+ next;
}
}
}
# Try non-options call-back.
my $cb;
if ( (defined ($cb = $linkage{'<>'})) ) {
- &$cb ($tryopt);
+ print STDERR ("=> &L{$tryopt}(\"$tryopt\")\n")
+ if $debug;
+ my $eval_error = do {
+ local $@;
+ local $SIG{__DIE__} = '__DEFAULT__';
+ eval { &$cb ($tryopt) };
+ $@;
+ };
+ print STDERR ("=> die($eval_error)\n")
+ if $debug && $eval_error ne '';
+ if ( $eval_error =~ /^!/ ) {
+ if ( $eval_error =~ /^!FINISH\b/ ) {
+ $goon = 0;
+ }
+ }
+ elsif ( $eval_error ne '' ) {
+ warn ($eval_error);
+ $error++;
+ }
}
else {
print STDERR ("=> saving \"$tryopt\" ",
# ...otherwise, terminate.
else {
# Push this one back and exit.
- unshift (@ARGV, $tryopt);
+ unshift (@$argv, $tryopt);
return ($error == 0);
}
}
# Finish.
- if ( $order == $PERMUTE ) {
+ if ( @ret && $order == $PERMUTE ) {
# Push back accumulated arguments
print STDERR ("=> restoring \"", join('" "', @ret), "\"\n")
- if $debug && @ret > 0;
- unshift (@ARGV, @ret) if @ret > 0;
+ if $debug;
+ unshift (@$argv, @ret);
}
return ($error == 0);
}
-sub config (@) {
- my (@options) = @_;
- my $opt;
- foreach $opt ( @options ) {
- my $try = lc ($opt);
- my $action = 1;
- if ( $try =~ /^no_?(.*)$/s ) {
- $action = 0;
- $try = $+;
- }
- if ( $try eq 'default' or $try eq 'defaults' ) {
- &$config_defaults () if $action;
- }
- elsif ( $try eq 'auto_abbrev' or $try eq 'autoabbrev' ) {
- $autoabbrev = $action;
- }
- elsif ( $try eq 'getopt_compat' ) {
- $getopt_compat = $action;
- }
- elsif ( $try eq 'ignorecase' or $try eq 'ignore_case' ) {
- $ignorecase = $action;
- }
- elsif ( $try eq 'ignore_case_always' ) {
- $ignorecase = $action ? 2 : 0;
- }
- elsif ( $try eq 'bundling' ) {
- $bundling = $action;
- }
- elsif ( $try eq 'bundling_override' ) {
- $bundling = $action ? 2 : 0;
- }
- elsif ( $try eq 'require_order' ) {
- $order = $action ? $REQUIRE_ORDER : $PERMUTE;
- }
- elsif ( $try eq 'permute' ) {
- $order = $action ? $PERMUTE : $REQUIRE_ORDER;
- }
- elsif ( $try eq 'pass_through' or $try eq 'passthrough' ) {
- $passthrough = $action;
- }
- elsif ( $try =~ /^prefix=(.+)$/ ) {
- $gen_prefix = $1;
- # Turn into regexp. Needs to be parenthesized!
- $gen_prefix = "(" . quotemeta($gen_prefix) . ")";
- eval { '' =~ /$gen_prefix/; };
- &$croak ("Getopt::Long: invalid pattern \"$gen_prefix\"") if $@;
- }
- elsif ( $try =~ /^prefix_pattern=(.+)$/ ) {
- $gen_prefix = $1;
- # Parenthesize if needed.
- $gen_prefix = "(" . $gen_prefix . ")"
- unless $gen_prefix =~ /^\(.*\)$/;
- eval { '' =~ /$gen_prefix/; };
- &$croak ("Getopt::Long: invalid pattern \"$gen_prefix\"") if $@;
+# A readable representation of what's in an optbl.
+sub OptCtl ($) {
+ my ($v) = @_;
+ my @v = map { defined($_) ? ($_) : ("<undef>") } @$v;
+ "[".
+ join(",",
+ "\"$v[CTL_TYPE]\"",
+ "\"$v[CTL_CNAME]\"",
+ "\"$v[CTL_DEFAULT]\"",
+ ("\$","\@","\%","\&")[$v[CTL_DEST] || 0],
+ $v[CTL_AMIN] || '',
+ $v[CTL_AMAX] || '',
+# $v[CTL_RANGE] || '',
+# $v[CTL_REPEAT] || '',
+ ). "]";
+}
+
+# Parse an option specification and fill the tables.
+sub ParseOptionSpec ($$) {
+ my ($opt, $opctl) = @_;
+
+ # Match option spec.
+ if ( $opt !~ m;^
+ (
+ # Option name
+ (?: \w+[-\w]* )
+ # Alias names, or "?"
+ (?: \| (?: \? | \w[-\w]* )? )*
+ )?
+ (
+ # Either modifiers ...
+ [!+]
+ |
+ # ... or a value/dest/repeat specification
+ [=:] [ionfs] [@%]? (?: \{\d*,?\d*\} )?
+ |
+ # ... or an optional-with-default spec
+ : (?: -?\d+ | \+ ) [@%]?
+ )?
+ $;x ) {
+ return (undef, "Error in option spec: \"$opt\"\n");
+ }
+
+ my ($names, $spec) = ($1, $2);
+ $spec = '' unless defined $spec;
+
+ # $orig 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 $orig;
+
+ my @names;
+ if ( defined $names ) {
+ @names = split (/\|/, $names);
+ $orig = $names[0];
+ }
+ else {
+ @names = ('');
+ $orig = '';
+ }
+
+ # Construct the opctl entries.
+ my $entry;
+ if ( $spec eq '' || $spec eq '+' || $spec eq '!' ) {
+ # Fields are hard-wired here.
+ $entry = [$spec,$orig,undef,CTL_DEST_SCALAR,0,0];
+ }
+ elsif ( $spec =~ /^:(-?\d+|\+)([@%])?$/ ) {
+ my $def = $1;
+ my $dest = $2;
+ my $type = $def eq '+' ? 'I' : 'i';
+ $dest ||= '$';
+ $dest = $dest eq '@' ? CTL_DEST_ARRAY
+ : $dest eq '%' ? CTL_DEST_HASH : CTL_DEST_SCALAR;
+ # Fields are hard-wired here.
+ $entry = [$type,$orig,$def eq '+' ? undef : $def,
+ $dest,0,1];
+ }
+ else {
+ my ($mand, $type, $dest) =
+ $spec =~ /^([=:])([ionfs])([@%])?(\{(\d+)?(,)?(\d+)?\})?$/;
+ return (undef, "Cannot repeat while bundling: \"$opt\"\n")
+ if $bundling && defined($4);
+ my ($mi, $cm, $ma) = ($5, $6, $7);
+ return (undef, "{0} is useless in option spec: \"$opt\"\n")
+ if defined($mi) && !$mi && !defined($ma) && !defined($cm);
+
+ $type = 'i' if $type eq 'n';
+ $dest ||= '$';
+ $dest = $dest eq '@' ? CTL_DEST_ARRAY
+ : $dest eq '%' ? CTL_DEST_HASH : CTL_DEST_SCALAR;
+ # Default minargs to 1/0 depending on mand status.
+ $mi = $mand eq '=' ? 1 : 0 unless defined $mi;
+ # Adjust mand status according to minargs.
+ $mand = $mi ? '=' : ':';
+ # Adjust maxargs.
+ $ma = $mi ? $mi : 1 unless defined $ma || defined $cm;
+ return (undef, "Max must be greater than zero in option spec: \"$opt\"\n")
+ if defined($ma) && !$ma;
+ return (undef, "Max less than min in option spec: \"$opt\"\n")
+ if defined($ma) && $ma < $mi;
+
+ # Fields are hard-wired here.
+ $entry = [$type,$orig,undef,$dest,$mi,$ma||-1];
+ }
+
+ # Process all names. First is canonical, the rest are aliases.
+ my $dups = '';
+ foreach ( @names ) {
+
+ $_ = lc ($_)
+ if $ignorecase > (($bundling && length($_) == 1) ? 1 : 0);
+
+ if ( exists $opctl->{$_} ) {
+ $dups .= "Duplicate specification \"$opt\" for option \"$_\"\n";
}
- elsif ( $try eq 'debug' ) {
- $debug = $action;
+
+ if ( $spec eq '!' ) {
+ $opctl->{"no$_"} = $entry;
+ $opctl->{"no-$_"} = $entry;
+ $opctl->{$_} = [@$entry];
+ $opctl->{$_}->[CTL_TYPE] = '';
}
else {
- &$croak ("Getopt::Long: unknown config parameter \"$opt\"")
+ $opctl->{$_} = $entry;
+ }
+ }
+
+ if ( $dups && $^W ) {
+ foreach ( split(/\n+/, $dups) ) {
+ warn($_."\n");
}
}
+ ($names[0], $orig);
}
-# To prevent Carp from being loaded unnecessarily.
-$croak = sub {
- require 'Carp.pm';
- $Carp::CarpLevel = 1;
- Carp::croak(@_);
-};
+# Option lookup.
+sub FindOption ($$$$$) {
-################ Private Subroutines ################
+ # returns (1, $opt, $ctl, $arg, $key) if okay,
+ # returns (1, undef) if option in error,
+ # returns (0) otherwise.
-$find_option = sub {
+ my ($argv, $prefix, $argend, $opt, $opctl) = @_;
- print STDERR ("=> find \"$opt\", genprefix=\"$genprefix\"\n") if $debug;
+ print STDERR ("=> find \"$opt\"\n") if $debug;
- return 0 unless $opt =~ /^$genprefix(.*)$/s;
+ return (0) unless $opt =~ /^$prefix(.*)$/s;
+ return (0) if $opt eq "-" && !defined $opctl->{''};
$opt = $+;
- my ($starter) = $1;
+ 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
+ my $optarg; # value supplied with --opt=value
+ my $rest; # remainder from unbundling
# If it is a long option, it may include the value.
- if (($starter eq "--" || ($getopt_compat && !$bundling))
- && $opt =~ /^([^=]+)=(.*)$/s ) {
+ # With getopt_compat, only if not bundling.
+ if ( ($starter=~/^$longprefix$/
+ || ($getopt_compat && ($bundling == 0 || $bundling == 2)))
+ && $opt =~ /^([^=]+)=(.*)$/s ) {
$opt = $1;
$optarg = $2;
- print STDERR ("=> option \"", $opt,
+ 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;
if ( $bundling && $starter eq '-' ) {
- # Unbundle single letter option.
- $rest = 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
+
+ # To try overrides, obey case ignore.
+ $tryopt = $ignorecase ? lc($opt) : $opt;
# If bundling == 2, long options can override bundles.
- if ( $bundling == 2 and
- defined ($type = $opctl{$tryopt.$rest}) ) {
- print STDERR ("=> $starter$tryopt rebundled to ",
+ if ( $bundling == 2 && length($tryopt) > 1
+ && defined ($opctl->{$tryopt}) ) {
+ print STDERR ("=> $starter$tryopt overrides unbundling\n")
+ if $debug;
+ }
+ else {
+ $tryopt = $opt;
+ # Unbundle single letter option.
+ $rest = length ($tryopt) > 0 ? substr ($tryopt, 1) : '';
+ $tryopt = substr ($tryopt, 0, 1);
+ $tryopt = lc ($tryopt) if $ignorecase > 1;
+ print STDERR ("=> $starter$tryopt unbundled from ",
"$starter$tryopt$rest\n") if $debug;
- $tryopt .= $rest;
- undef $rest;
+ $rest = undef unless $rest ne '';
}
- }
+ }
# Try auto-abbreviation.
elsif ( $autoabbrev ) {
+ # Sort the possible long option names.
+ my @names = sort(keys (%$opctl));
# Downcase if allowed.
- $tryopt = $opt = lc ($opt) if $ignorecase;
+ $opt = lc ($opt) if $ignorecase;
+ $tryopt = $opt;
# Turn option name into pattern.
my $pat = quotemeta ($opt);
# Look up in option names.
- my @hits = grep (/^$pat/, @opctl);
+ my @hits = grep (/^$pat/, @names);
print STDERR ("=> ", scalar(@hits), " hits (@hits) with \"$pat\" ",
- "out of ", scalar(@opctl), "\n") if $debug;
+ "out of ", scalar(@names), "\n") if $debug;
# Check for ambiguous results.
unless ( (@hits <= 1) || (grep ($_ eq $opt, @hits) == 1) ) {
# See if all matches are for the same option.
my %hit;
foreach ( @hits ) {
- $_ = $aliases{$_} if defined $aliases{$_};
- $hit{$_} = 1;
+ my $hit = $_;
+ $hit = $opctl->{$hit}->[CTL_CNAME]
+ if defined $opctl->{$hit}->[CTL_CNAME];
+ $hit{$hit} = 1;
+ }
+ # Remove auto-supplied options (version, help).
+ if ( keys(%hit) == 2 ) {
+ if ( $auto_version && exists($hit{version}) ) {
+ delete $hit{version};
+ }
+ elsif ( $auto_help && exists($hit{help}) ) {
+ delete $hit{help};
+ }
}
# Now see if it really is ambiguous.
unless ( keys(%hit) == 1 ) {
- return 0 if $passthrough;
+ return (0) if $passthrough;
warn ("Option ", $opt, " is ambiguous (",
join(", ", @hits), ")\n");
$error++;
- undef $opt;
- return 1;
+ return (1, undef);
}
@hits = keys(%hit);
}
}
# Check validity by fetching the info.
- $type = $optbl->{$tryopt} unless defined $type;
- unless ( defined $type ) {
- return 0 if $passthrough;
+ my $ctl = $opctl->{$tryopt};
+ unless ( defined $ctl ) {
+ return (0) if $passthrough;
+ # Pretend one char when bundling.
+ if ( $bundling == 1 && length($starter) == 1 ) {
+ $opt = substr($opt,0,1);
+ unshift (@$argv, $starter.$rest) if defined $rest;
+ }
warn ("Unknown option: ", $opt, "\n");
$error++;
- return 1;
+ return (1, undef);
}
# Apparently valid.
$opt = $tryopt;
- print STDERR ("=> found \"$type\" for ", $opt, "\n") if $debug;
+ print STDERR ("=> found ", OptCtl($ctl),
+ " 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 '!' ) {
+ my $type = $ctl->[CTL_TYPE];
+ my $arg;
+
+ if ( $type eq '' || $type eq '!' || $type eq '+' ) {
if ( defined $optarg ) {
- return 0 if $passthrough;
+ return (0) if $passthrough;
warn ("Option ", $opt, " does not take an argument\n");
$error++;
undef $opt;
}
- elsif ( $type eq '' ) {
- $arg = 1; # supply explicit value
+ elsif ( $type eq '' || $type eq '+' ) {
+ # Supply explicit value.
+ $arg = 1;
}
else {
- substr ($opt, 0, 2) = ''; # strip NO prefix
+ $opt =~ s/^no-?//i; # strip NO prefix
$arg = 0; # supply explicit value
}
- unshift (@ARGV, $starter.$rest) if defined $rest;
- return 1;
+ unshift (@$argv, $starter.$rest) if defined $rest;
+ return (1, $opt, $ctl, $arg);
}
# Get mandatory status and type info.
- my $mand;
- ($mand, $type, $array, $hash) = $type =~ /^(.)(.)(@?)(%?)$/;
+ my $mand = $ctl->[CTL_AMIN];
# Check if there is an option argument available.
- if ( defined $optarg ? ($optarg eq '')
- : !(defined $rest || @ARGV > 0) ) {
+ if ( $gnu_compat && defined $optarg && $optarg eq '' ) {
+ return (1, $opt, $ctl, $type eq 's' ? '' : 0) ;#unless $mand;
+ $optarg = 0 unless $type eq 's';
+ }
+
+ # Check if there is an option argument available.
+ if ( defined $optarg
+ ? ($optarg eq '')
+ : !(defined $rest || @$argv > 0) ) {
# Complain if this option needs an argument.
- if ( $mand eq "=" ) {
- return 0 if $passthrough;
+# if ( $mand && !($type eq 's' ? defined($optarg) : 0) ) {
+ if ( $mand ) {
+ return (0) if $passthrough;
warn ("Option ", $opt, " requires an argument\n");
$error++;
- undef $opt;
+ return (1, undef);
}
- if ( $mand eq ":" ) {
- $arg = $type eq "s" ? '' : 0;
+ if ( $type eq 'I' ) {
+ # Fake incremental type.
+ my @c = @$ctl;
+ $c[CTL_TYPE] = '+';
+ return (1, $opt, \@c, 1);
}
- return 1;
+ return (1, $opt, $ctl,
+ defined($ctl->[CTL_DEFAULT]) ? $ctl->[CTL_DEFAULT] :
+ $type eq 's' ? '' : 0);
}
# Get (possibly optional) argument.
$arg = (defined $rest ? $rest
- : (defined $optarg ? $optarg : shift (@ARGV)));
+ : (defined $optarg ? $optarg : shift (@$argv)));
# Get key if this is a "name=value" pair for a hash option.
- $key = undef;
- if ($hash && defined $arg) {
- ($key, $arg) = ($arg =~ /^(.*)=(.*)$/s) ? ($1, $2) : ($arg, 1);
+ my $key;
+ if ($ctl->[CTL_DEST] == CTL_DEST_HASH && defined $arg) {
+ ($key, $arg) = ($arg =~ /^([^=]*)=(.*)$/s) ? ($1, $2)
+ : ($arg, defined($ctl->[CTL_DEFAULT]) ? $ctl->[CTL_DEFAULT] :
+ ($mand ? undef : ($type eq 's' ? "" : 1)));
+ if (! defined $arg) {
+ warn ("Option $opt, key \"$key\", requires a value\n");
+ $error++;
+ # Push back.
+ unshift (@$argv, $starter.$rest) if defined $rest;
+ return (1, undef);
+ }
}
#### Check if the argument is valid for this option ####
- if ( $type eq "s" ) { # string
- # A mandatory string takes anything.
- return 1 if $mand eq "=";
+ my $key_valid = $ctl->[CTL_DEST] == CTL_DEST_HASH ? "[^=]+=" : "";
- # An optional string takes almost anything.
- return 1 if defined $optarg || defined $rest;
- return 1 if $arg eq "-"; # ??
+ if ( $type eq 's' ) { # string
+ # A mandatory string takes anything.
+ return (1, $opt, $ctl, $arg, $key) if $mand;
+
+ # Same for optional string as a hash value
+ return (1, $opt, $ctl, $arg, $key)
+ if $ctl->[CTL_DEST] == CTL_DEST_HASH;
+
+ # An optional string takes almost anything.
+ return (1, $opt, $ctl, $arg, $key)
+ if defined $optarg || defined $rest;
+ return (1, $opt, $ctl, $arg, $key) if $arg eq "-"; # ??
# Check for option or option list terminator.
if ($arg eq $argend ||
- $arg =~ /^$genprefix.+/) {
+ $arg =~ /^$prefix.+/) {
# Push back.
- unshift (@ARGV, $arg);
+ 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 ( $type eq 'i' # numeric/integer
+ || $type eq 'I' # numeric/integer w/ incr default
+ || $type eq 'o' ) { # dec/oct/hex/bin value
+
+ my $o_valid = $type eq 'o' ? PAT_XINT : PAT_INT;
+
+ if ( $bundling && defined $rest
+ && $rest =~ /^($key_valid)($o_valid)(.*)$/si ) {
+ ($key, $arg, $rest) = ($1, $2, $+);
+ chop($key) if $key;
+ $arg = ($type eq 'o' && $arg =~ /^0/) ? oct($arg) : 0+$arg;
+ unshift (@$argv, $starter.$rest) if defined $rest && $rest ne '';
}
- elsif ( $arg !~ /^-?[0-9]+$/ ) {
- if ( defined $optarg || $mand eq "=" ) {
+ elsif ( $arg =~ /^$o_valid$/si ) {
+ $arg =~ tr/_//d;
+ $arg = ($type eq 'o' && $arg =~ /^0/) ? oct($arg) : 0+$arg;
+ }
+ else {
+ if ( defined $optarg || $mand ) {
if ( $passthrough ) {
- unshift (@ARGV, defined $rest ? $starter.$rest : $arg)
+ unshift (@$argv, defined $rest ? $starter.$rest : $arg)
unless defined $optarg;
- return 0;
+ return (0);
}
warn ("Value \"", $arg, "\" invalid for option ",
- $opt, " (number expected)\n");
+ $opt, " (",
+ $type eq 'o' ? "extended " : '',
+ "number expected)\n");
$error++;
- undef $opt;
# Push back.
- unshift (@ARGV, $starter.$rest) if defined $rest;
+ unshift (@$argv, $starter.$rest) if defined $rest;
+ return (1, undef);
}
else {
# Push back.
- unshift (@ARGV, defined $rest ? $starter.$rest : $arg);
+ unshift (@$argv, defined $rest ? $starter.$rest : $arg);
+ if ( $type eq 'I' ) {
+ # Fake incremental type.
+ my @c = @$ctl;
+ $c[CTL_TYPE] = '+';
+ return (1, $opt, \@c, 1);
+ }
# Supply default value.
- $arg = 0;
+ $arg = defined($ctl->[CTL_DEFAULT]) ? $ctl->[CTL_DEFAULT] : 0;
}
}
}
- elsif ( $type eq "f" ) { # real number, int is also ok
+ elsif ( $type eq 'f' ) { # real number, int is also ok
# We require at least one digit before a point or 'e',
# and at least one digit following the point and 'e'.
# [-]NN[.NN][eNN]
+ my $o_valid = PAT_FLOAT;
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 '';
+ $rest =~ /^($key_valid)($o_valid)(.*)$/s ) {
+ $arg =~ tr/_//d;
+ ($key, $arg, $rest) = ($1, $2, $+);
+ chop($key) if $key;
+ unshift (@$argv, $starter.$rest) if defined $rest && $rest ne '';
+ }
+ elsif ( $arg =~ /^$o_valid$/ ) {
+ $arg =~ tr/_//d;
}
- elsif ( $arg !~ /^-?[0-9.]+(\.[0-9]+)?([eE]-?[0-9]+)?$/ ) {
- if ( defined $optarg || $mand eq "=" ) {
+ else {
+ if ( defined $optarg || $mand ) {
if ( $passthrough ) {
- unshift (@ARGV, defined $rest ? $starter.$rest : $arg)
+ unshift (@$argv, defined $rest ? $starter.$rest : $arg)
unless defined $optarg;
- return 0;
+ return (0);
}
warn ("Value \"", $arg, "\" invalid for option ",
$opt, " (real number expected)\n");
$error++;
- undef $opt;
# Push back.
- unshift (@ARGV, $starter.$rest) if defined $rest;
+ unshift (@$argv, $starter.$rest) if defined $rest;
+ return (1, undef);
}
else {
# Push back.
- unshift (@ARGV, defined $rest ? $starter.$rest : $arg);
+ unshift (@$argv, defined $rest ? $starter.$rest : $arg);
# Supply default value.
$arg = 0.0;
}
}
}
else {
- &$croak ("GetOpt::Long internal error (Can't happen)\n");
+ die("Getopt::Long internal error (Can't happen)\n");
}
- return 1;
-};
+ return (1, $opt, $ctl, $arg, $key);
+}
-$config_defaults = sub {
- # Handle POSIX compliancy.
- if ( defined $ENV{"POSIXLY_CORRECT"} ) {
- $gen_prefix = "(--|-)";
- $autoabbrev = 0; # no automatic abbrev of options
- $bundling = 0; # no bundling of single letter switches
- $getopt_compat = 0; # disallow '+' to start options
- $order = $REQUIRE_ORDER;
- }
- else {
- $gen_prefix = "(--|-|\\+)";
- $autoabbrev = 1; # automatic abbrev of options
- $bundling = 0; # bundling off by default
- $getopt_compat = 1; # allow '+' to start options
- $order = $PERMUTE;
+sub ValidValue ($$$$$) {
+ my ($ctl, $arg, $mand, $argend, $prefix) = @_;
+
+ if ( $ctl->[CTL_DEST] == CTL_DEST_HASH ) {
+ return 0 unless $arg =~ /[^=]+=(.*)/;
+ $arg = $1;
}
- # Other configurable settings.
- $debug = 0; # for debugging
- $error = 0; # error tally
- $ignorecase = 1; # ignore case when matching options
- $passthrough = 0; # leave unrecognized options alone
-};
-################ Initialization ################
+ my $type = $ctl->[CTL_TYPE];
-# 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+)/;
+ if ( $type eq 's' ) { # string
+ # A mandatory string takes anything.
+ return (1) if $mand;
-# Set defaults.
-&$config_defaults ();
+ return (1) if $arg eq "-";
-################ Package return ################
+ # Check for option or option list terminator.
+ return 0 if $arg eq $argend || $arg =~ /^$prefix.+/;
+ return 1;
+ }
-1;
+ elsif ( $type eq 'i' # numeric/integer
+ || $type eq 'I' # numeric/integer w/ incr default
+ || $type eq 'o' ) { # dec/oct/hex/bin value
-__END__
+ my $o_valid = $type eq 'o' ? PAT_XINT : PAT_INT;
+ return $arg =~ /^$o_valid$/si;
+ }
-=head1 NAME
+ 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]
+ my $o_valid = PAT_FLOAT;
+ return $arg =~ /^$o_valid$/;
+ }
+ die("ValidValue: Cannot happen\n");
+}
-GetOptions - extended processing of command line options
+# Getopt::Long Configuration.
+sub Configure (@) {
+ my (@options) = @_;
-=head1 SYNOPSIS
+ my $prevconfig =
+ [ $error, $debug, $major_version, $minor_version,
+ $autoabbrev, $getopt_compat, $ignorecase, $bundling, $order,
+ $gnu_compat, $passthrough, $genprefix, $auto_version, $auto_help,
+ $longprefix ];
+
+ if ( ref($options[0]) eq 'ARRAY' ) {
+ ( $error, $debug, $major_version, $minor_version,
+ $autoabbrev, $getopt_compat, $ignorecase, $bundling, $order,
+ $gnu_compat, $passthrough, $genprefix, $auto_version, $auto_help,
+ $longprefix ) = @{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;
+ $genprefix = $action ? "(--|-|\\+)" : "(--|-)";
+ }
+ elsif ( $try eq 'gnu_getopt' ) {
+ if ( $action ) {
+ $gnu_compat = 1;
+ $bundling = 1;
+ $getopt_compat = 0;
+ $genprefix = "(--|-)";
+ $order = $PERMUTE;
+ }
+ }
+ elsif ( $try eq 'gnu_compat' ) {
+ $gnu_compat = $action;
+ }
+ elsif ( $try =~ /^(auto_?)?version$/ ) {
+ $auto_version = $action;
+ }
+ elsif ( $try =~ /^(auto_?)?help$/ ) {
+ $auto_help = $action;
+ }
+ elsif ( $try eq 'ignorecase' or $try eq 'ignore_case' ) {
+ $ignorecase = $action;
+ }
+ elsif ( $try eq 'ignorecase_always' or $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/; };
+ die("Getopt::Long: invalid pattern \"$genprefix\"") if $@;
+ }
+ elsif ( $try =~ /^prefix_pattern=(.+)$/ && $action ) {
+ $genprefix = $1;
+ # Parenthesize if needed.
+ $genprefix = "(" . $genprefix . ")"
+ unless $genprefix =~ /^\(.*\)$/;
+ eval { '' =~ m"$genprefix"; };
+ die("Getopt::Long: invalid pattern \"$genprefix\"") if $@;
+ }
+ elsif ( $try =~ /^long_prefix_pattern=(.+)$/ && $action ) {
+ $longprefix = $1;
+ # Parenthesize if needed.
+ $longprefix = "(" . $longprefix . ")"
+ unless $longprefix =~ /^\(.*\)$/;
+ eval { '' =~ m"$longprefix"; };
+ die("Getopt::Long: invalid long prefix pattern \"$longprefix\"") if $@;
+ }
+ elsif ( $try eq 'debug' ) {
+ $debug = $action;
+ }
+ else {
+ die("Getopt::Long: unknown config parameter \"$opt\"")
+ }
+ }
+ $prevconfig;
+}
+
+# Deprecated name.
+sub config (@) {
+ Configure (@_);
+}
+
+# Issue a standard message for --version.
+#
+# The arguments are mostly the same as for Pod::Usage::pod2usage:
+#
+# - a number (exit value)
+# - a string (lead in message)
+# - a hash with options. See Pod::Usage for details.
+#
+sub VersionMessage(@) {
+ # Massage args.
+ my $pa = setup_pa_args("version", @_);
+
+ my $v = $main::VERSION;
+ my $fh = $pa->{-output} ||
+ ($pa->{-exitval} eq "NOEXIT" || $pa->{-exitval} < 2) ? \*STDOUT : \*STDERR;
+
+ print $fh (defined($pa->{-message}) ? $pa->{-message} : (),
+ $0, defined $v ? " version $v" : (),
+ "\n",
+ "(", __PACKAGE__, "::", "GetOptions",
+ " version ",
+ defined($Getopt::Long::VERSION_STRING)
+ ? $Getopt::Long::VERSION_STRING : $VERSION, ";",
+ " Perl version ",
+ $] >= 5.006 ? sprintf("%vd", $^V) : $],
+ ")\n");
+ exit($pa->{-exitval}) unless $pa->{-exitval} eq "NOEXIT";
+}
+
+# Issue a standard message for --help.
+#
+# The arguments are the same as for Pod::Usage::pod2usage:
+#
+# - a number (exit value)
+# - a string (lead in message)
+# - a hash with options. See Pod::Usage for details.
+#
+sub HelpMessage(@) {
+ eval {
+ require Pod::Usage;
+ import Pod::Usage;
+ 1;
+ } || die("Cannot provide help: cannot load Pod::Usage\n");
+
+ # Note that pod2usage will issue a warning if -exitval => NOEXIT.
+ pod2usage(setup_pa_args("help", @_));
+
+}
+
+# Helper routine to set up a normalized hash ref to be used as
+# argument to pod2usage.
+sub setup_pa_args($@) {
+ my $tag = shift; # who's calling
+
+ # If called by direct binding to an option, it will get the option
+ # name and value as arguments. Remove these, if so.
+ @_ = () if @_ == 2 && $_[0] eq $tag;
+
+ my $pa;
+ if ( @_ > 1 ) {
+ $pa = { @_ };
+ }
+ else {
+ $pa = shift || {};
+ }
+
+ # At this point, $pa can be a number (exit value), string
+ # (message) or hash with options.
+
+ if ( UNIVERSAL::isa($pa, 'HASH') ) {
+ # Get rid of -msg vs. -message ambiguity.
+ $pa->{-message} = $pa->{-msg};
+ delete($pa->{-msg});
+ }
+ elsif ( $pa =~ /^-?\d+$/ ) {
+ $pa = { -exitval => $pa };
+ }
+ else {
+ $pa = { -message => $pa };
+ }
+
+ # These are _our_ defaults.
+ $pa->{-verbose} = 0 unless exists($pa->{-verbose});
+ $pa->{-exitval} = 0 unless exists($pa->{-exitval});
+ $pa;
+}
+
+# Sneak way to know what version the user requested.
+sub VERSION {
+ $requested_version = $_[1];
+ shift->SUPER::VERSION(@_);
+}
+
+package Getopt::Long::CallBack;
+
+sub new {
+ my ($pkg, %atts) = @_;
+ bless { %atts }, $pkg;
+}
+
+sub name {
+ my $self = shift;
+ ''.$self->{name};
+}
+
+use overload
+ # Treat this object as an oridinary string for legacy API.
+ '""' => \&name,
+ '0+' => sub { 0 },
+ fallback => 1;
+
+1;
+
+################ Documentation ################
+
+=head1 NAME
+
+Getopt::Long - Extended processing of command line options
+
+=head1 SYNOPSIS
use Getopt::Long;
- $result = GetOptions (...option-descriptions...);
+ my $data = "file.dat";
+ my $length = 24;
+ my $verbose;
+ $result = GetOptions ("length=i" => \$length, # numeric
+ "file=s" => \$data, # string
+ "verbose" => \$verbose); # flag
=head1 DESCRIPTION
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. For example, the UNIX "ps" command can be
-given the command line "option"
+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. Single character
+options may be any alphabetic character, a question mark, and a dash.
+Long options may consist of a series of letters, digits, and dashes.
+Although this is currently not enforced by Getopt::Long, multiple
+consecutive dashes are not allowed, and the option name must not end
+with a dash.
+
+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 an 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:
+
+ GetOptions ("library=s" => \@libfiles);
+
+Alternatively, you can specify that the option can have multiple
+values by adding a "@", and pass a scalar reference as the
+destination:
+
+ GetOptions ("library=s@" => \$libfiles);
+
+Used with the example above, C<@libfiles> (or 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 acceptable 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:
+
+ GetOptions ("library=s" => \@libfiles);
+ @libfiles = split(/,/,join(',',@libfiles));
+
+Of course, it is important to choose the right separator string for
+each purpose.
+
+Warning: What follows is an experimental feature.
+
+Options can take multiple values at once, for example
+
+ --coordinates 52.2 16.4 --rgbcolor 255 255 149
+
+This can be accomplished by adding a repeat specifier to the option
+specification. Repeat specifiers are very similar to the C<{...}>
+repeat specifiers that can be used with regular expression patterns.
+For example, the above command line would be handled as follows:
+
+ GetOptions('coordinates=f{2}' => \@coor, 'rgbcolor=i{3}' => \@color);
+
+The destination for the option must be an array or array reference.
+
+It is also possible to specify the minimal and maximal number of
+arguments an option takes. C<foo=s{2,4}> indicates an option that
+takes at least two and at most 4 arguments. C<foo=s{,}> indicates one
+or more values; C<foo:s{,}> indicates zero or more option values.
+
+=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.
+
+ GetOptions ("define=s" => \%defines);
+
+Alternatively you can use:
+
+ GetOptions ("define=s%" => \$defines);
- -vax
+When used with command line options:
-which means the combination of B<-v>, B<-a> and B<-x>. With the new
-syntax B<--vax> would be a single option, probably indicating a
-computer architecture.
+ --define os=linux --define vendor=redhat
-Command line options can be used to set values. These values can be
-specified in one of two ways:
+the hash C<%defines> (or 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 acceptable values. The keys are always taken to be strings.
- --size 24
- --size=24
+=head2 User-defined subroutines to handle options
-GetOptions is called with a list of option-descriptions, each of which
-consists of two elements: the option specifier and the option linkage.
-The option specifier defines the name of the option and, optionally,
-the value it can take. The option linkage is usually a reference to a
-variable that will be set when the option is used. For example, the
-following call to GetOptions:
+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 or three arguments. The first
+argument is the name of the option. For a scalar or array destination,
+the second argument is the value to be stored. For a hash destination,
+the second arguments is the key to the hash, and the third argument
+the value to be stored. It is up to the subroutine to store the value,
+or do whatever it thinks is appropriate.
- GetOptions("size=i" => \$offset);
+A trivial application of this mechanism is to implement options that
+are related to each other. For example:
-will accept a command line option "size" that must have an integer
-value. With a command line of "--size 24" this will cause the variable
-$offset to get the value 24.
+ my $verbose = ''; # option variable with default value (false)
+ GetOptions ('verbose' => \$verbose,
+ 'quiet' => sub { $verbose = 0 });
-Alternatively, the first argument to GetOptions may be a reference to
-a HASH describing the linkage for the options, or an object whose
-class is based on a HASH. The following call is equivalent to the
-example above:
+Here C<--verbose> and C<--quiet> control the same variable
+C<$verbose>, but with opposite values.
- %optctl = ("size" => \$offset);
- GetOptions(\%optctl, "size=i");
+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.
-Linkage may be specified using either of the above methods, or both.
-Linkage specified in the argument list takes precedence over the
-linkage specified in the HASH.
+If the text of the error message starts with an exclamation 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<-->.
-The command line options are taken from array @ARGV. Upon completion
-of GetOptions, @ARGV will contain the rest (i.e. the non-options) of
-the command line.
-
-Each option specifier designates the name of the option, optionally
-followed by an argument specifier.
+=head2 Options with multiple names
-Options that do not take arguments will have no argument specifier.
-The option variable will be set to 1 if the option is used.
+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:
-For the other options, the values for argument specifiers are:
+ GetOptions ('length|height=f' => \$length);
-=over 8
+The first name is called the I<primary> name, the other names are
+called I<aliases>. When using a hash to store options, the key will
+always be the primary name.
+
+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 !
-Option does not take an argument and may be negated, i.e. prefixed by
-"no". E.g. "foo!" will allow B<--foo> (with value 1) and B<-nofoo>
-(with value 0).
-The option variable will be set to 1, or 0 if negated.
+The option does not take an argument and may be negated by prefixing
+it with "no" or "no-". E.g. C<"foo!"> will allow C<--foo> (a value of
+1 will be assigned) as well as C<--nofoo> and C<--no-foo> (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 +
-=item =s
+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).
-Option takes a mandatory string argument.
-This string will be assigned to the option variable.
-Note that even if the string argument starts with B<-> or B<-->, it
-will not be considered an option on itself.
+The C<+> specifier is ignored if the option destination is not a scalar.
-=item :s
+=item = I<type> [ I<desttype> ] [ I<repeat> ]
-Option takes an optional string argument.
-This string will be assigned to the option variable.
-If omitted, it will be assigned "" (an empty string).
-If the string argument starts with B<-> or B<-->, it
-will be considered an option on itself.
+The option requires an argument of the given type. Supported types
+are:
-=item =i
+=over 4
-Option takes a mandatory integer argument.
-This value will be assigned to the option variable.
-Note that the value may start with B<-> to indicate a negative
-value.
+=item s
-=item :i
+String. An arbitrary sequence of characters. It is valid for the
+argument to start with C<-> or C<-->.
-Option takes an optional integer argument.
-This value will be assigned to the option variable.
-If omitted, the value 0 will be assigned.
-Note that the value may start with B<-> to indicate a negative
-value.
+=item i
-=item =f
+Integer. An optional leading plus or minus sign, followed by a
+sequence of digits.
-Option takes a mandatory real number argument.
-This value will be assigned to the option variable.
-Note that the value may start with B<-> to indicate a negative
-value.
+=item o
-=item :f
+Extended integer, Perl style. This can be either an optional leading
+plus or minus sign, followed by a sequence of digits, or an octal
+string (a zero, optionally followed by '0', '1', .. '7'), or a
+hexadecimal string (C<0x> followed by '0' .. '9', 'a' .. 'f', case
+insensitive), or a binary string (C<0b> followed by a series of '0'
+and '1').
-Option takes an optional real number argument.
-This value will be assigned to the option variable.
-If omitted, the value 0 will be assigned.
+=item f
+
+Real number. For example C<3.14>, C<-6.23E24> and so on.
=back
-A lone dash B<-> is considered an option, the corresponding option
-name is the empty string.
+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.
-A double dash on itself B<--> signals end of the options list.
+The I<repeat> specifies the number of values this option takes per
+occurrence on the command line. It has the format C<{> [ I<min> ] [ C<,> [ I<max> ] ] C<}>.
-=head2 Linkage specification
+I<min> denotes the minimal number of arguments. It defaults to 1 for
+options with C<=> and to 0 for options with C<:>, see below. Note that
+I<min> overrules the C<=> / C<:> semantics.
-The linkage specifier is optional. If no linkage is explicitly
-specified but a ref HASH is passed, GetOptions will place the value in
-the HASH. For example:
+I<max> denotes the maximum number of arguments. It must be at least
+I<min>. If I<max> is omitted, I<but the comma is not>, there is no
+upper bound to the number of argument values taken.
- %optctl = ();
- GetOptions (\%optctl, "size=i");
+=item : I<type> [ I<desttype> ]
-will perform the equivalent of the assignment
+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.
- $optctl{"size"} = 24;
+Note that if a string argument starts with C<-> or C<-->, it will be
+considered an option on itself.
-For array options, a reference to an array is used, e.g.:
+=item : I<number> [ I<desttype> ]
- %optctl = ();
- GetOptions (\%optctl, "sizes=i@");
+Like C<:i>, but if the value is omitted, the I<number> will be assigned.
-with command line "-sizes 24 -sizes 48" will perform the equivalent of
-the assignment
+=item : + [ I<desttype> ]
- $optctl{"sizes"} = [24, 48];
+Like C<:i>, but if the value is omitted, the current value for the
+option will be incremented.
-For hash options (an option whose argument looks like "name=value"),
-a reference to a hash is used, e.g.:
+=back
- %optctl = ();
- GetOptions (\%optctl, "define=s%");
+=head1 Advanced Possibilities
-with command line "--define foo=hello --define bar=world" will perform the
-equivalent of the assignment
+=head2 Object oriented interface
- $optctl{"define"} = {foo=>'hello', bar=>'world')
+Getopt::Long can be used in an object oriented way as well:
-If no linkage is explicitly specified and no ref HASH is passed,
-GetOptions will put the value in a global variable named after the
-option, prefixed by "opt_". To yield a usable Perl variable,
-characters that are not part of the syntax for variables are
-translated to underscores. For example, "--fpp-struct-return" will set
-the variable $opt_fpp_struct_return. Note that this variable resides
-in the namespace of the calling program, not necessarily B<main>.
-For example:
+ use Getopt::Long;
+ $p = new Getopt::Long::Parser;
+ $p->configure(...configuration options...);
+ if ($p->getoptions(...options descriptions...)) ...
- GetOptions ("size=i", "sizes=i@");
+Configuration options can be passed to the constructor:
-with command line "-size 10 -sizes 24 -sizes 48" will perform the
-equivalent of the assignments
+ $p = new Getopt::Long::Parser
+ config => [...configuration options...];
- $opt_size = 10;
- @opt_sizes = (24, 48);
+=head2 Thread Safety
-A lone dash B<-> is considered an option, the corresponding Perl
-identifier is $opt_ .
+Getopt::Long is thread safe when using ithreads as of Perl 5.8. It is
+I<not> thread safe when using the older (experimental and now
+obsolete) threads implementation that was added to Perl 5.005.
-The linkage specifier can be a reference to a scalar, a reference to
-an array, a reference to a hash or a reference to a subroutine.
+=head2 Documentation and help texts
-Note that, if your code is running under the recommended C<use strict
-'vars'> pragma, it may be helpful to declare these package variables
-via C<use vars> perhaps something like this:
+Getopt::Long encourages the use of Pod::Usage to produce help
+messages. For example:
- use vars qw/ $opt_size @opt_sizes $opt_bar /;
+ use Getopt::Long;
+ use Pod::Usage;
-If a REF SCALAR is supplied, the new value is stored in the referenced
-variable. If the option occurs more than once, the previous value is
-overwritten.
+ my $man = 0;
+ my $help = 0;
-If a REF ARRAY is supplied, the new value is appended (pushed) to the
-referenced array.
+ GetOptions('help|?' => \$help, man => \$man) or pod2usage(2);
+ pod2usage(1) if $help;
+ pod2usage(-exitstatus => 0, -verbose => 2) if $man;
-If a REF HASH is supplied, the option value should look like "key" or
-"key=value" (if the "=value" is omitted then a value of 1 is implied).
-In this case, the element of the referenced hash with the key "key"
-is assigned "value".
+ __END__
-If a REF CODE is supplied, the referenced subroutine is called with
-two arguments: the option name and the option value.
-The option name is always the true name, not an abbreviation or alias.
+ =head1 NAME
-=head2 Aliases and abbreviations
+ sample - Using Getopt::Long and Pod::Usage
-The option name may actually be a list of option names, separated by
-"|"s, e.g. "foo|bar|blech=s". In this example, "foo" is the true name
-of this option. If no linkage is specified, options "foo", "bar" and
-"blech" all will set $opt_foo. For convenience, the single character
-"?" is allowed as an alias, e.g. "help|?".
+ =head1 SYNOPSIS
-Option names may be abbreviated to uniqueness, depending on
-configuration option B<auto_abbrev>.
+ sample [options] [file ...]
-=head2 Non-option call-back routine
+ Options:
+ -help brief help message
+ -man full documentation
-A special option specifier, E<lt>E<gt>, can be used to designate a subroutine
-to handle non-option arguments. GetOptions will immediately call this
-subroutine for every non-option it encounters in the options list.
-This subroutine gets the name of the non-option passed.
-This feature requires configuration option B<permute>, see section
-CONFIGURATION OPTIONS.
+ =head1 OPTIONS
-See also the examples.
+ =over 8
-=head2 Option starters
+ =item B<-help>
-On the command line, options can start with B<-> (traditional), B<-->
-(POSIX) and B<+> (GNU, now being phased out). The latter is not
-allowed if the environment variable B<POSIXLY_CORRECT> has been
-defined.
+ Print a brief help message and exits.
-Options that start with "--" may have an argument appended, separated
-with an "=", e.g. "--foo=bar".
+ =item B<-man>
-=head2 Return values and Errors
+ Prints the manual page and exits.
-Configuration errors and errors in the option definitions are
-signalled using C<die()> and will terminate the calling
-program unless the call to C<Getopt::Long::GetOptions()> was embedded
-in C<eval { ... }> or C<die()> was trapped using C<$SIG{__DIE__}>.
+ =back
-A return value of 1 (true) indicates success.
+ =head1 DESCRIPTION
-A return status of 0 (false) indicates that the function detected one
-or more errors during option parsing. These errors are signalled using
-C<warn()> and can be trapped with C<$SIG{__WARN__}>.
+ B<This program> will read the given input file(s) and do something
+ useful with the contents thereof.
-Errors that can't happen are signalled using C<Carp::croak()>.
+ =cut
-=head1 COMPATIBILITY
+See L<Pod::Usage> for details.
-Getopt::Long::GetOptions() is the successor of
-B<newgetopt.pl> that came with Perl 4. It is fully upward compatible.
-In fact, the Perl 5 version of newgetopt.pl is just a wrapper around
-the module.
+=head2 Parsing options from an arbitrary array
-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. If explicit linkage is supplied, this must be a reference
-to an ARRAY.
+By default, GetOptions parses the options that are present in the
+global array C<@ARGV>. A special entry C<GetOptionsFromArray> can be
+used to parse options from an arbitrary array.
-If an "%" sign is appended to the argument specifier, the option is
-treated as a hash. Value(s) of the form "name=value" are set by
-setting the element of the hash %opt_name with key "name" to "value"
-(if the "=value" portion is omitted it defaults to 1). If explicit
-linkage is supplied, this must be a reference to a HASH.
+ use Getopt::Long qw(GetOptionsFromArray);
+ $ret = GetOptionsFromArray(\@myopts, ...);
-If configuration option B<getopt_compat> is set (see section
-CONFIGURATION OPTIONS), options that start with "+" or "-" may also
-include their arguments, e.g. "+foo=bar". This is for compatiblity
-with older implementations of the GNU "getopt" routine.
+When used like this, the global C<@ARGV> is not touched at all.
-If the first argument to GetOptions is a string consisting of only
-non-alphanumeric characters, it is taken to specify the option starter
-characters. Everything starting with one of these characters from the
-starter will be considered an option. B<Using a starter argument is
-strongly deprecated.>
+The following two calls behave identically:
-For convenience, option specifiers may have a leading B<-> or B<-->,
-so it is possible to write:
+ $ret = GetOptions( ... );
+ $ret = GetOptionsFromArray(\@ARGV, ... );
- GetOptions qw(-foo=s --bar=i --ar=s);
+=head2 Parsing options from an arbitrary string
-=head1 EXAMPLES
+A special entry C<GetOptionsFromString> can be used to parse options
+from an arbitrary string.
-If the option specifier is "one:i" (i.e. takes an optional integer
-argument), then the following situations are handled:
+ use Getopt::Long qw(GetOptionsFromString);
+ $ret = GetOptionsFromString($string, ...);
- -one -two -> $opt_one = '', -two is next option
- -one -2 -> $opt_one = -2
+The contents of the string are split into arguments using a call to
+C<Text::ParseWords::shellwords>. As with C<GetOptionsFromArray>, the
+global C<@ARGV> is not touched.
-Also, assume specifiers "foo=s" and "bar:s" :
+It is possible that, upon completion, not all arguments in the string
+have been processed. C<GetOptionsFromString> will, when called in list
+context, return both the return status and an array reference to any
+remaining arguments:
- -bar -xxx -> $opt_bar = '', '-xxx' is next option
- -foo -bar -> $opt_foo = '-bar'
- -foo -- -> $opt_foo = '--'
+ ($ret, $args) = GetOptionsFromString($string, ... );
-In GNU or POSIX format, option names and values can be combined:
+If any arguments remain, and C<GetOptionsFromString> was not called in
+list context, a message will be given and C<GetOptionsFromString> will
+return failure.
- +foo=blech -> $opt_foo = 'blech'
- --bar= -> $opt_bar = ''
- --bar=-- -> $opt_bar = '--'
+=head2 Storing options values in a hash
-Example of using variable references:
+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 values in a
+hash.
- $ret = GetOptions ('foo=s', \$foo, 'bar=i', 'ar=s', \@ar);
+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.
-With command line options "-foo blech -bar 24 -ar xx -ar yy"
-this will result in:
+ my %h = ();
+ GetOptions (\%h, 'length=i'); # will store in $h{length}
- $foo = 'blech'
- $opt_bar = 24
- @ar = ('xx','yy')
+For options that take list or hash values, it is necessary to indicate
+this by appending an C<@> or C<%> sign after the type:
-Example of using the E<lt>E<gt> option specifier:
+ GetOptions (\%h, 'colours=s@'); # will push to @{$h{colours}}
- @ARGV = qw(-foo 1 bar -foo 2 blech);
- GetOptions("foo=i", \$myfoo, "<>", \&mysub);
+To make things more complicated, the hash may contain references to
+the actual destinations, for example:
-Results:
+ my $len = 0;
+ my %h = ('length' => \$len);
+ GetOptions (\%h, 'length=i'); # will store in $len
- mysub("bar") will be called (with $myfoo being 1)
- mysub("blech") will be called (with $myfoo being 2)
+This example is fully equivalent with:
-Compare this with:
+ my $len = 0;
+ GetOptions ('length=i' => \$len); # will store in $len
- @ARGV = qw(-foo 1 bar -foo 2 blech);
- GetOptions("foo=i", \$myfoo);
+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:
-This will leave the non-options in @ARGV:
+ 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 ... }
- $myfoo -> 2
- @ARGV -> qw(bar blech)
+=head2 Bundling
-=head1 CONFIGURATION OPTIONS
+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,
-B<GetOptions> can be configured by calling subroutine
-B<Getopt::Long::config>. This subroutine takes a list of quoted
-strings, each specifying a configuration option to be set, e.g.
-B<ignore_case>. Options can be reset by prefixing with B<no_>, e.g.
-B<no_ignore_case>. Case does not matter. Multiple calls to B<config>
-are possible.
+ -vax
-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 new B<config> routine. Besides, it
-is much easier.
+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
+ambiguity. 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 callback
+
+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 one parameter: the argument name.
+
+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:
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 set unless environment variable
-POSIXLY_CORRECT has been set, in which case B<auto_abbrev> is reset.
+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
-=item getopt_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.
-Allow '+' to start options.
-Default is set unless environment variable
-POSIXLY_CORRECT has been set, in which case B<getopt_compat> is reset.
+=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 non-options are allowed to be mixed with
-options.
-Default is set unless environment variable
-POSIXLY_CORRECT has been set, in which case b<require_order> is reset.
+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 B<permute>, which is the opposite of B<require_order>.
+See also C<permute>, which is the opposite of C<require_order>.
=item permute
-Whether non-options are allowed to be mixed with
-options.
-Default is set unless environment variable
-POSIXLY_CORRECT has been set, in which case B<permute> is reset.
-Note that B<permute> is the opposite of B<require_order>.
+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 B<permute> is set, this means that
+If C<permute> is enabled, this means that
- -foo arg1 -bar arg2 arg3
+ --foo arg1 --bar arg2 arg3
is equivalent to
- -foo -bar arg1 arg2 arg3
+ --foo --bar arg1 arg2 arg3
-If a non-option call-back routine is specified, @ARGV will always be
-empty upon succesful return of GetOptions since all options have been
-processed, except when B<--> is used:
+If an argument callback routine is specified, C<@ARGV> will always be
+empty upon successful return of GetOptions() since all options have been
+processed. The only exception is when C<--> is used:
- -foo arg1 -bar arg2 -- arg3
+ --foo arg1 --bar arg2 -- arg3
-will call the call-back routine for arg1 and arg2, and terminate
-leaving arg2 in @ARGV.
+This will call the callback routine for arg1 and arg2, and then
+terminate GetOptions() leaving C<"arg3"> in C<@ARGV>.
-If B<require_order> is set, options processing
+If C<require_order> is enabled, options processing
terminates when the first non-option is encountered.
- -foo arg1 -bar arg2 arg3
+ --foo arg1 --bar arg2 arg3
is equivalent to
- -foo -- arg1 -bar arg2 arg3
+ --foo -- arg1 --bar arg2 arg3
-=item bundling (default: reset)
+If C<pass_through> is also enabled, options processing will terminate
+at the first unrecognized option, or non-option, whichever comes
+first.
-Setting this variable to a non-zero value will allow single-character
-options to be bundled. To distinguish bundles from long option names,
-long options must be introduced with B<--> and single-character
-options (and bundles) with B<->. For example,
+=item bundling (default: disabled)
- ps -vax --vax
+Enabling this option will allow single-character options to be
+bundled. To distinguish bundles from long option names, long options
+I<must> be introduced with C<--> and bundles with C<->.
-would be equivalent to
+Note that, if you have options C<a>, C<l> and C<all>, and
+auto_abbrev enabled, possible arguments and option settings are:
- ps -v -a -x --vax
+ using argument sets option(s)
+ ------------------------------------------
+ -a, --a a
+ -l, --l l
+ -al, -la, -ala, -all,... a, l
+ --al, --all all
-provided "vax", "v", "a" and "x" have been defined to be valid
-options.
+The surprising part is that C<--a> sets option C<a> (due to auto
+completion), not C<all>.
-Bundled options can also include a value in the bundle; for strings
-this value is the rest of the bundle, but integer and floating values
-may be combined in the bundle, e.g.
+Note: disabling C<bundling> also disables C<bundling_override>.
- scale -h24w80
+=item bundling_override (default: disabled)
-is equivalent to
+If C<bundling_override> is enabled, bundling is enabled as with
+C<bundling> but now long option names override option bundles.
- scale -h 24 -w 80
+Note: disabling C<bundling_override> also disables C<bundling>.
-Note: resetting B<bundling> also resets B<bundling_override>.
+B<Note:> Using option bundling can easily lead to unexpected results,
+especially when mixing long options and bundles. Caveat emptor.
-=item bundling_override (default: reset)
+=item ignore_case (default: enabled)
-If B<bundling_override> is set, bundling is enabled as with
-B<bundling> but now long option names override option bundles. In the
-above example, B<-vax> would be interpreted as the option "vax", not
-the bundle "v", "a", "x".
+If enabled, case is ignored when matching long option names. If,
+however, bundling is enabled as well, single character options will be
+treated case-sensitive.
-Note: resetting B<bundling_override> also resets B<bundling>.
+With C<ignore_case>, option specifications for options that only
+differ in case, e.g., C<"foo"> and C<"Foo">, will be flagged as
+duplicates.
-B<Note:> Using option bundling can easily lead to unexpected results,
-especially when mixing long options and bundles. Caveat emptor.
+Note: disabling C<ignore_case> also disables C<ignore_case_always>.
-=item ignore_case (default: set)
+=item ignore_case_always (default: disabled)
-If set, case is ignored when matching options.
+When bundling is in effect, case is ignored on single-character
+options also.
-Note: resetting B<ignore_case> also resets B<ignore_case_always>.
+Note: disabling C<ignore_case_always> also disables C<ignore_case>.
-=item ignore_case_always (default: reset)
+=item auto_version (default:disabled)
-When bundling is in effect, case is ignored on single-character
-options also.
+Automatically provide support for the B<--version> option if
+the application did not specify a handler for this option itself.
+
+Getopt::Long will provide a standard version message that includes the
+program name, its version (if $main::VERSION is defined), and the
+versions of Getopt::Long and Perl. The message will be written to
+standard output and processing will terminate.
+
+C<auto_version> will be enabled if the calling program explicitly
+specified a version number higher than 2.32 in the C<use> or
+C<require> statement.
-Note: resetting B<ignore_case_always> also resets B<ignore_case>.
+=item auto_help (default:disabled)
-=item pass_through (default: reset)
+Automatically provide support for the B<--help> and B<-?> options if
+the application did not specify a handler for this option itself.
-Unknown options are passed through in @ARGV instead of being flagged
-as errors. This makes it possible to write wrapper scripts that
-process only part of the user supplied options, and passes the
+Getopt::Long will provide a help message using module L<Pod::Usage>. The
+message, derived from the SYNOPSIS POD section, will be written to
+standard output and processing will terminate.
+
+C<auto_help> will be enabled if the calling program explicitly
+specified a version number higher than 2.32 in the C<use> or
+C<require> statement.
+
+=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.
-This can be very confusing, especially when B<permute> is also set.
+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.
+
+Note that the options terminator (default C<-->), if present, will
+also be passed through in C<@ARGV>.
=item prefix
-The string that starts options. See also B<prefix_pattern>.
+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<(--|-)>.
+Default is C<--|-|\+> unless environment variable
+POSIXLY_CORRECT has been set, in which case it is C<--|->.
+
+=item long_prefix_pattern
-=item debug (default: reset)
+A Perl pattern that allows the disambiguation of long and short
+prefixes. Default is C<-->.
-Enable copious debugging output.
+Typically you only need to set this if you are using nonstandard
+prefixes and want some or all of them to have the same semantics as
+'--' does under normal circumstances.
+
+For example, setting prefix_pattern to C<--|-|\+|\/> and
+long_prefix_pattern to C<--|\/> would add Win32 style argument
+handling.
+
+=item debug (default: disabled)
+
+Enable debugging output.
=back
-=head1 OTHER USEFUL VARIABLES
+=head1 Exportable Methods
-=over 12
+=over
+
+=item VersionMessage
+
+This subroutine provides a standard version message. Its argument can be:
+
+=over 4
+
+=item *
+
+A string containing the text of a message to print I<before> printing
+the standard message.
+
+=item *
+
+A numeric value corresponding to the desired exit status.
+
+=item *
+
+A reference to a hash.
+
+=back
+
+If more than one argument is given then the entire argument list is
+assumed to be a hash. If a hash is supplied (either as a reference or
+as a list) it should contain one or more elements with the following
+keys:
+
+=over 4
+
+=item C<-message>
+
+=item C<-msg>
+
+The text of a message to print immediately prior to printing the
+program's usage message.
-=item $Getopt::Long::VERSION
+=item C<-exitval>
-The version number of this Getopt::Long implementation in the format
-C<major>.C<minor>. This can be used to have Exporter check the
-version, e.g.
+The desired exit status to pass to the B<exit()> function.
+This should be an integer, or else the string "NOEXIT" to
+indicate that control should simply be returned without
+terminating the invoking process.
- use Getopt::Long 3.00;
+=item C<-output>
-You can inspect $Getopt::Long::major_version and
-$Getopt::Long::minor_version for the individual components.
+A reference to a filehandle, or the pathname of a file to which the
+usage message should be written. The default is C<\*STDERR> unless the
+exit value is less than 2 (in which case the default is C<\*STDOUT>).
-=item $Getopt::Long::error
+=back
+
+You cannot tie this routine directly to an option, e.g.:
+
+ GetOptions("version" => \&VersionMessage);
+
+Use this instead:
+
+ GetOptions("version" => sub { VersionMessage() });
-Internal error flag. May be incremented from a call-back routine to
-cause options parsing to fail.
+=item HelpMessage
+
+This subroutine produces a standard help message, derived from the
+program's POD section SYNOPSIS using L<Pod::Usage>. It takes the same
+arguments as VersionMessage(). In particular, you cannot tie it
+directly to an option, e.g.:
+
+ GetOptions("help" => \&HelpMessage);
+
+Use this instead:
+
+ GetOptions("help" => sub { HelpMessage() });
=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__}>.
+
+=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 Tips and Techniques
+
+=head2 Pushing multiple values in a hash option
+
+Sometimes you want to combine the best of hashes and arrays. For
+example, the command line:
+
+ --list add=first --list add=second --list add=third
+
+where each successive 'list add' option will push the value of add
+into array ref $list->{'add'}. The result would be like
+
+ $list->{add} = [qw(first second third)];
+
+This can be accomplished with a destination routine:
+
+ GetOptions('list=s%' =>
+ sub { push(@{$list{$_[1]}}, $_[2]) });
+
+=head1 Trouble Shooting
+
+=head2 GetOptions does not return a false result when an option is not supplied
+
+That's why they're called 'options'.
+
+=head2 GetOptions does not split the command line correctly
+
+The command line is not split by GetOptions, but by the command line
+interpreter (CLI). On Unix, this is the shell. On Windows, it is
+COMMAND.COM or CMD.EXE. Other operating systems have other CLIs.
+
+It is important to know that these CLIs may behave different when the
+command line contains special characters, in particular quotes or
+backslashes. For example, with Unix shells you can use single quotes
+(C<'>) and double quotes (C<">) to group words together. The following
+alternatives are equivalent on Unix:
+
+ "two words"
+ 'two words'
+ two\ words
+
+In case of doubt, insert the following statement in front of your Perl
+program:
+
+ print STDERR (join("|",@ARGV),"\n");
+
+to verify how your CLI passes the arguments to the program.
+
+=head2 Undefined subroutine &main::GetOptions called
+
+Are you running Windows, and did you write
+
+ use GetOpt::Long;
+
+(note the capital 'O')?
+
+=head2 How do I put a "-?" option into a Getopt::Long?
+
+You can only obtain this using an alias, and Getopt::Long of at least
+version 2.13.
+
+ use Getopt::Long;
+ GetOptions ("help|?"); # -help and -? will both set $opt_help
+
=head1 AUTHOR
-Johan Vromans E<lt>jvromans@squirrel.nlE<gt>
+Johan Vromans <jvromans@squirrel.nl>
=head1 COPYRIGHT AND DISCLAIMER
-This program is Copyright 1990,1998 by Johan Vromans.
+This program is Copyright 1990,2007 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
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.
=cut
+
https://perl5.git.perl.org / perl5.git / blobdiff