@@ -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: Wed Jan 14 15:03:41 2015
+# Update Count : 1680
# Status : Released
################ Module Preamble ################
@@ -17,10 +17,10 @@ use 5.004;
use strict;
use vars qw($VERSION);
-$VERSION = 2.39;
+$VERSION = 2.43;
# For testing versions only.
use vars qw($VERSION_STRING);
-$VERSION_STRING = "2.39";
+$VERSION_STRING = "2.43";
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,",
@@ -365,6 +373,9 @@ sub GetOptionsFromArray(@) {
next;
}
$linkage{'<>'} = shift (@optionlist);
+ if ( $passthrough ) {
+ $error .= "Option spec <> cannot be used with pass_through\n";
+ }
next;
}
@@ -458,6 +469,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 +721,7 @@ sub GetOptionsFromArray(@) {
elsif ( $order == $PERMUTE ) {
# Try non-options call-back.
my $cb;
- if ( (defined ($cb = $linkage{'<>'})) ) {
+ if ( !$passthrough && (defined ($cb = $linkage{'<>'})) ) {
print STDERR ("=> &L{$tryopt}(\"$tryopt\")\n")
if $debug;
my $eval_error = do {
@@ -942,7 +956,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 +967,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 +1015,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 +1089,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 +1232,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 +1318,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 +1357,7 @@ sub Configure (@) {
$getopt_compat = 0;
$genprefix = "(--|-)";
$order = $PERMUTE;
+ $bundling_values = 0;
}
}
elsif ( $try eq 'gnu_compat' ) {
@@ -1345,9 +1377,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 +2173,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 +2189,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 +2211,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,8 +2449,8 @@ 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
+Anything that is unknown, ambiguous or supplied with an invalid option
+value is 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.
@@ -2413,6 +2462,9 @@ 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>.
+For obvious reasons, B<pass_through> cannot be used with the
+non-option catchall C<< <> >>.
+
=item prefix
The string that starts options. If a constant string is not
@@ -2546,7 +2598,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 +2726,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