@@ -4,8 +4,8 @@
# Author : Johan Vromans
# Created On : Tue Sep 11 15:00:12 1990
# Last Modified By: Johan Vromans
-# Last Modified On: Tue Mar 12 14:42:25 2013
-# Update Count : 1638
+# Last Modified On: Mon Feb 23 20:29:11 2015
+# Update Count : 1683
# Status : Released
################ Module Preamble ################
@@ -17,10 +17,10 @@ use 5.004;
use strict;
use vars qw($VERSION);
-$VERSION = 2.39;
+$VERSION = 2.45;
# For testing versions only.
use vars qw($VERSION_STRING);
-$VERSION_STRING = "2.39";
+$VERSION_STRING = "2.45";
use Exporter;
use vars qw(@ISA @EXPORT @EXPORT_OK);
@@ -50,6 +50,9 @@ use vars qw($autoabbrev $getopt_compat $ignorecase $bundling $order
# Official invisible variables.
use vars qw($genprefix $caller $gnu_compat $auto_help $auto_version $longprefix);
+# Really invisible variables.
+my $bundling_values;
+
# Public subroutines.
sub config(@); # deprecated name
@@ -92,6 +95,7 @@ sub ConfigDefaults() {
$passthrough = 0; # leave unrecognized options alone
$gnu_compat = 0; # require --opt=val if value is optional
$longprefix = "(--)"; # what does a long prefix look like
+ $bundling_values = 0; # no bundling of values
}
# Override import.
@@ -251,7 +255,7 @@ use constant PAT_XINT =>
"|".
"0[0-7_]*".
")";
-use constant PAT_FLOAT => "[-+]?[0-9._]+(\.[0-9_]+)?([eE][-+]?[0-9_]+)?";
+use constant PAT_FLOAT => "[-+]?[0-9_]+(\.[0-9_]+)?([eE][-+]?[0-9_]+)?";
sub GetOptions(@) {
# Shift in default array.
@@ -296,10 +300,14 @@ sub GetOptionsFromArray(@) {
("Getopt::Long $Getopt::Long::VERSION ",
"called from package \"$pkg\".",
"\n ",
- "argv: (@$argv)",
+ "argv: ",
+ defined($argv)
+ ? UNIVERSAL::isa( $argv, 'ARRAY' ) ? "(@$argv)" : $argv
+ : "<undef>",
"\n ",
"autoabbrev=$autoabbrev,".
"bundling=$bundling,",
+ "bundling_values=$bundling_values,",
"getopt_compat=$getopt_compat,",
"gnu_compat=$gnu_compat,",
"order=$order,",
@@ -458,6 +466,9 @@ sub GetOptionsFromArray(@) {
}
+ $error .= "GetOptionsFromArray: 1st parameter is not an array reference\n"
+ unless $argv && UNIVERSAL::isa( $argv, 'ARRAY' );
+
# Bail out if errors found.
die ($error) if $error;
$error = 0;
@@ -707,7 +718,7 @@ sub GetOptionsFromArray(@) {
elsif ( $order == $PERMUTE ) {
# Try non-options call-back.
my $cb;
- if ( (defined ($cb = $linkage{'<>'})) ) {
+ if ( defined ($cb = $linkage{'<>'}) ) {
print STDERR ("=> &L{$tryopt}(\"$tryopt\")\n")
if $debug;
my $eval_error = do {
@@ -942,7 +953,7 @@ sub FindOption ($$$$$) {
my $tryopt = $opt; # option to try
- if ( $bundling && $starter eq '-' ) {
+ if ( ( $bundling || $bundling_values ) && $starter eq '-' ) {
# To try overrides, obey case ignore.
$tryopt = $ignorecase ? lc($opt) : $opt;
@@ -953,6 +964,23 @@ sub FindOption ($$$$$) {
print STDERR ("=> $starter$tryopt overrides unbundling\n")
if $debug;
}
+
+ # If bundling_values, option may be followed by the value.
+ elsif ( $bundling_values ) {
+ $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;
+ # Whatever remains may not be considered an option.
+ $optarg = $rest eq '' ? undef : $rest;
+ $rest = undef;
+ }
+
+ # Split off a single letter and leave the rest for
+ # further processing.
else {
$tryopt = $opt;
# Unbundle single letter option.
@@ -984,9 +1012,9 @@ sub FindOption ($$$$$) {
# See if all matches are for the same option.
my %hit;
foreach ( @hits ) {
- my $hit = $_;
- $hit = $opctl->{$hit}->[CTL_CNAME]
- if defined $opctl->{$hit}->[CTL_CNAME];
+ my $hit = $opctl->{$_}->[CTL_CNAME]
+ if defined $opctl->{$_}->[CTL_CNAME];
+ $hit = "no" . $hit if $opctl->{$_}->[CTL_TYPE] eq '!';
$hit{$hit} = 1;
}
# Remove auto-supplied options (version, help).
@@ -1058,6 +1086,7 @@ sub FindOption ($$$$$) {
warn ("Option ", $opt, " does not take an argument\n");
$error++;
undef $opt;
+ undef $optarg if $bundling_values;
}
elsif ( $type eq '' || $type eq '+' ) {
# Supply explicit value.
@@ -1200,7 +1229,6 @@ sub FindOption ($$$$$) {
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 =~ /^($key_valid)($o_valid)(.*)$/s ) {
@@ -1287,13 +1315,13 @@ sub Configure (@) {
[ $error, $debug, $major_version, $minor_version,
$autoabbrev, $getopt_compat, $ignorecase, $bundling, $order,
$gnu_compat, $passthrough, $genprefix, $auto_version, $auto_help,
- $longprefix ];
+ $longprefix, $bundling_values ];
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)};
+ $longprefix, $bundling_values ) = @{shift(@options)};
}
my $opt;
@@ -1326,6 +1354,7 @@ sub Configure (@) {
$getopt_compat = 0;
$genprefix = "(--|-)";
$order = $PERMUTE;
+ $bundling_values = 0;
}
}
elsif ( $try eq 'gnu_compat' ) {
@@ -1345,9 +1374,15 @@ sub Configure (@) {
}
elsif ( $try eq 'bundling' ) {
$bundling = $action;
+ $bundling_values = 0 if $action;
}
elsif ( $try eq 'bundling_override' ) {
$bundling = $action ? 2 : 0;
+ $bundling_values = 0 if $action;
+ }
+ elsif ( $try eq 'bundling_values' ) {
+ $bundling_values = $action;
+ $bundling = 0 if $action;
}
elsif ( $try eq 'require_order' ) {
$order = $action ? $REQUIRE_ORDER : $PERMUTE;
@@ -2135,12 +2170,12 @@ at once. For example if C<a>, C<v> and C<x> are all valid options,
-vax
-would set all three.
+will set all three.
-Getopt::Long supports two levels of bundling. To enable bundling, a
+Getopt::Long supports three styles of bundling. To enable bundling, a
call to Getopt::Long::Configure is required.
-The first level of bundling can be enabled with:
+The simplest style of bundling can be enabled with:
Getopt::Long::Configure ("bundling");
@@ -2151,21 +2186,21 @@ options,
-vax
-would set C<a>, C<v> and C<x>, but
+will set C<a>, C<v> and C<x>, but
--vax
-would set C<vax>.
+will set C<vax>.
-The second level of bundling lifts this restriction. It can be enabled
+The second style of bundling lifts this restriction. It can be enabled
with:
Getopt::Long::Configure ("bundling_override");
-Now, C<-vax> would set the option C<vax>.
+Now, C<-vax> will set the option C<vax>.
-When any level of bundling is enabled, option values may be inserted
-in the bundle. For example:
+In all of the above cases, option values may be inserted in the
+bundle. For example:
-h24w80
@@ -2173,6 +2208,17 @@ is equivalent to
-h 24 -w 80
+A third style of bundling allows only values to be bundled with
+options. It can be enabled with:
+
+ Getopt::Long::Configure ("bundling_values");
+
+Now, C<-h24> will set the option C<h> to C<24>, but option bundles
+like C<-vxa> and C<-h24w80> are flagged as errors.
+
+Enabling C<bundling_values> will disable the other two styles of
+bundling.
+
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,
@@ -2400,15 +2446,18 @@ 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
+With C<pass_through> anything that is unknown, ambiguous or supplied with
+an invalid option will not be flagged as an error. Instead the unknown
+option(s) will be passed to the catchall C<< <> >> if present, otherwise
+through to C<@ARGV>. This makes it possible to write wrapper scripts that
+process only part of the user supplied command line arguments, and pass the
remaining options to some other program.
-If C<require_order> is enabled, options processing will terminate at
-the first unrecognized option, or non-option, whichever comes first.
-However, if C<permute> is enabled instead, results can become confusing.
+If C<require_order> is enabled, options processing will terminate at the
+first unrecognized option, or non-option, whichever comes first and all
+remaining arguments are passed to C<@ARGV> instead of the catchall
+C<< <> >> if present. 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>.
@@ -2546,7 +2595,7 @@ briefly some of these 'features'.
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
+I<XXX> is the primary name of this option. When a program executes
under C<use strict> (recommended), these variables must be
pre-declared with our() or C<use vars>.
@@ -2674,7 +2723,7 @@ Johan Vromans <jvromans@squirrel.nl>
=head1 COPYRIGHT AND DISCLAIMER
-This program is Copyright 1990,2010 by Johan Vromans.
+This program is Copyright 1990,2015 by Johan Vromans.
This program is free software; you can redistribute it and/or
modify it under the terms of the Perl Artistic License or the
GNU General Public License as published by the Free Software