summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--lib/Getopt/Long.pm86
-rw-r--r--lib/Getopt/Long/CHANGES26
-rw-r--r--lib/Getopt/Long/README16
-rw-r--r--lib/Getopt/Long/t/gol-basic.t7
-rw-r--r--lib/Getopt/Long/t/gol-compat.t2
-rw-r--r--lib/Getopt/Long/t/gol-linkage.t42
-rw-r--r--lib/Getopt/Long/t/gol-oo.t7
7 files changed, 143 insertions, 43 deletions
diff --git a/lib/Getopt/Long.pm b/lib/Getopt/Long.pm
index ace249a053..c1f64f416e 100644
--- a/lib/Getopt/Long.pm
+++ b/lib/Getopt/Long.pm
@@ -2,17 +2,17 @@
package Getopt::Long;
-# RCS Status : $Id: GetoptLong.pm,v 2.68 2003-09-23 15:24:53+02 jv Exp jv $
+# RCS Status : $Id: GetoptLong.pm,v 2.72 2005-04-28 21:18:33+02 jv Exp $
# Author : Johan Vromans
# Created On : Tue Sep 11 15:00:12 1990
# Last Modified By: Johan Vromans
-# Last Modified On: Wed Dec 31 20:48:15 2003
-# Update Count : 1440
+# Last Modified On: Thu Apr 28 21:14:19 2005
+# Update Count : 1456
# Status : Released
################ Copyright ################
-# This program is Copyright 1990,2002 by Johan Vromans.
+# This program is Copyright 1990,2005 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
@@ -35,10 +35,10 @@ use 5.004;
use strict;
use vars qw($VERSION);
-$VERSION = 2.3401;
+$VERSION = 2.3404;
# For testing versions only.
use vars qw($VERSION_STRING);
-$VERSION_STRING = "2.34_01";
+$VERSION_STRING = "2.34_04";
use Exporter;
use vars qw(@ISA @EXPORT @EXPORT_OK);
@@ -63,7 +63,7 @@ use vars qw($error $debug $major_version $minor_version);
use vars qw($autoabbrev $getopt_compat $ignorecase $bundling $order
$passthrough);
# Official invisible variables.
-use vars qw($genprefix $caller $gnu_compat $auto_help $auto_version);
+use vars qw($genprefix $caller $gnu_compat $auto_help $auto_version $longprefix);
# Public subroutines.
sub config(@); # deprecated name
@@ -106,6 +106,7 @@ sub ConfigDefaults() {
$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.
@@ -266,7 +267,7 @@ sub GetOptions(@) {
local ($^W) = 0;
print STDERR
("Getopt::Long $Getopt::Long::VERSION (",
- '$Revision: 2.68 $', ") ",
+ '$Revision: 2.72 $', ") ",
"called from package \"$pkg\".",
"\n ",
"ARGV: (@ARGV)",
@@ -280,7 +281,8 @@ sub GetOptions(@) {
"ignorecase=$ignorecase,",
"requested_version=$requested_version,",
"passthrough=$passthrough,",
- "genprefix=\"$genprefix\".",
+ "genprefix=\"$genprefix\",",
+ "longprefix=\"$longprefix\".",
"\n");
}
@@ -611,7 +613,7 @@ sub GetOptions(@) {
}
$argcnt++;
- last if $argcnt >= $ctl->[CTL_AMAX];
+ last if $argcnt >= $ctl->[CTL_AMAX] && $ctl->[CTL_AMAX] != -1;
undef($arg);
# Need more args?
@@ -858,7 +860,7 @@ sub FindOption ($$$$) {
# If it is a long option, it may include the value.
# With getopt_compat, only if not bundling.
- if ( ($starter eq "--"
+ if ( ($starter=~/^$longprefix$/
|| ($getopt_compat && ($bundling == 0 || $bundling == 2)))
&& $opt =~ /^([^=]+)=(.*)$/s ) {
$opt = $1;
@@ -913,9 +915,10 @@ sub FindOption ($$$$) {
# See if all matches are for the same option.
my %hit;
foreach ( @hits ) {
- $_ = $opctl->{$_}->[CTL_CNAME]
- if defined $opctl->{$_}->[CTL_CNAME];
- $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 ) {
@@ -956,7 +959,7 @@ sub FindOption ($$$$) {
unless ( defined $ctl ) {
return (0) if $passthrough;
# Pretend one char when bundling.
- if ( $bundling == 1) {
+ if ( $bundling == 1 && length($starter) == 1 ) {
$opt = substr($opt,0,1);
unshift (@ARGV, $starter.$rest) if defined $rest;
}
@@ -1202,13 +1205,14 @@ sub Configure (@) {
my $prevconfig =
[ $error, $debug, $major_version, $minor_version,
$autoabbrev, $getopt_compat, $ignorecase, $bundling, $order,
- $gnu_compat, $passthrough, $genprefix, $auto_version, $auto_help ];
+ $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 ) =
- @{shift(@options)};
+ $gnu_compat, $passthrough, $genprefix, $auto_version, $auto_help,
+ $longprefix ) = @{shift(@options)};
}
my $opt;
@@ -1283,9 +1287,17 @@ sub Configure (@) {
# Parenthesize if needed.
$genprefix = "(" . $genprefix . ")"
unless $genprefix =~ /^\(.*\)$/;
- eval { '' =~ /$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;
}
@@ -1605,7 +1617,7 @@ destination:
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.
+only integer or floating point numbers are acceptible values.
Often it is useful to allow comma-separated lists of values as well as
multiple occurrences of the options. This is easy using Perl's split()
@@ -1656,7 +1668,7 @@ When used with command line options:
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.
+are acceptible values. The keys are always taken to be strings.
=head2 User-defined subroutines to handle options
@@ -1686,7 +1698,7 @@ the desired error message as its argument. GetOptions() will catch the
die(), issue the error message, and record that an error result must
be returned upon completion.
-If the text of the error message starts with an exclamation mark C<!>
+If the text of the error message starts with an exclamantion mark C<!>
it is interpreted specially by GetOptions(). There is currently one
special command implemented: C<die("!FINISH")> will cause GetOptions()
to stop processing options, as if it encountered a double dash C<-->.
@@ -1702,7 +1714,8 @@ the above example:
GetOptions ('length|height=f' => \$length);
The first name is called the I<primary> name, the other names are
-called I<aliases>.
+called I<aliases>. When using a hash to store options, the key will
+always be the primary name.
Multiple alternate names are possible.
@@ -1890,7 +1903,7 @@ messages. For example:
=head1 DESCRIPTION
- B<This program> will read the given input file(s) and do something
+ B<This program> will read the given input file(s) and do someting
useful with the contents thereof.
=cut
@@ -1962,7 +1975,7 @@ The first level of bundling can be enabled with:
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
+abiguity. For example, when C<vax>, C<a>, C<v> and C<x> are all valid
options,
-vax
@@ -2115,7 +2128,7 @@ is equivalent to
--foo --bar arg1 arg2 arg3
If an argument callback routine is specified, C<@ARGV> will always be
-empty upon successful return of GetOptions() since all options have been
+empty upon succesful return of GetOptions() since all options have been
processed. The only exception is when C<--> is used:
--foo arg1 --bar arg2 -- arg3
@@ -2152,7 +2165,7 @@ auto_abbrev enabled, possible arguments and option settings are:
-al, -la, -ala, -all,... a, l
--al, --all all
-The surprising part is that C<--a> sets option C<a> (due to auto
+The suprising part is that C<--a> sets option C<a> (due to auto
completion), not C<all>.
Note: disabling C<bundling> also disables C<bundling_override>.
@@ -2236,8 +2249,21 @@ 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
+
+A Perl pattern that allows the disambiguation of long and short
+prefixes. Default is C<-->.
+
+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)
@@ -2449,7 +2475,7 @@ Johan Vromans <jvromans@squirrel.nl>
=head1 COPYRIGHT AND DISCLAIMER
-This program is Copyright 2003,1990 by Johan Vromans.
+This program is Copyright 1990,2005 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
diff --git a/lib/Getopt/Long/CHANGES b/lib/Getopt/Long/CHANGES
index 2c77c5e5c1..21b5596c44 100644
--- a/lib/Getopt/Long/CHANGES
+++ b/lib/Getopt/Long/CHANGES
@@ -1,6 +1,26 @@
Changes in version 2.35
-----------------------
+* long_prefix_pattern configuration variable.
+
+ prefix_pattern has now been complemented by a new configuration
+ option 'long_prefix_pattern' that allows the user to specify what
+ prefix patterns should have long option style sematics applied.
+ This will enable people to do things like
+
+ foo.pl /option=value
+
+ instead of forcing people to use the short option style
+
+ foo.pl /option value
+
+ This enhancement was suggested and implemented by Yves Orton.
+
+* Bugfix for Ticket #11377 (bug found and fixed by Ryan).
+* Bugfix for Ticket #12380.
+
+**************** WARNING -- EXPERIMENTAL CODE AHEAD ****************
+
* [Experimental] Options can take multiple values at once. E.g.,
--coordinates 52.2 16.4 --rgbcolor 255 255 149
@@ -14,6 +34,8 @@ Changes in version 2.35
The syntax for this is similar to that of regular expression
patterns: { min , max }.
+**************** END EXPERIMENTAL CODE ****************
+
Changes in version 2.34
-----------------------
@@ -39,8 +61,6 @@ Changes in version 2.34
Changes in version 2.33
-----------------------
-**************** WARNING -- EXPERIMENTAL CODE AHEAD ****************
-
The following new features are marked experimental. This means that if
you are going to use them you _must_ watch out for the next release of
Getopt::Long to see if the API has changed.
@@ -83,8 +103,6 @@ Getopt::Long to see if the API has changed.
use Getopt::Long 2.33 qw(GetOptions HelpMessage);
GetOptions(...) or HelpMessage(2);
-**************** END EXPERIMENTAL CODE ****************
-
* Subroutine Configure can now be exported on demand.
* Negatable options (with "!") now also support the "no-" prefix.
diff --git a/lib/Getopt/Long/README b/lib/Getopt/Long/README
index 691253ded6..cddaec1e78 100644
--- a/lib/Getopt/Long/README
+++ b/lib/Getopt/Long/README
@@ -69,6 +69,7 @@ By default, single-letter option names are case sensitive.
"nodebug" will switch it off.
- options can set values, but also add values producing an array
of values instead of a single scalar value, or set values in a hash.
+ - options can have multiple values, e.g., "--position 25 624".
* Options linkage
@@ -162,8 +163,15 @@ to reverse the effect:
- prefix_pattern
A Perl pattern that identifies the strings that introduce
- options. Default is (--|-|\+) unless environment variable
- POSIXLY_CORRECT has been set, in which case it is (--|-).
+ options. Default is --|-|\+ unless environment variable
+ POSIXLY_CORRECT has been set, in which case it is --|-.
+
+ - long_prefix_pattern
+
+ A perl pattern that is used to identify which prefixes
+ should be treated as long style. Any prefixes that don't
+ match this pattern will have short option semantics.
+ Defaults to --.
- debug
@@ -192,7 +200,7 @@ Or use the CPAN search engine:
COPYRIGHT AND DISCLAIMER
========================
-Module Getopt::Long is Copyright 2003,1990 by Johan Vromans.
+Module Getopt::Long is Copyright 2005,1990 by Johan Vromans.
This program is free software; you can redistribute it and/or
modify it under the terms of the Perl Artistic License or the
GNU General Public License as published by the Free Software
@@ -201,6 +209,6 @@ later version.
-------------------------------------------------------------------
Johan Vromans jvromans@squirrel.nl
-Squirrel Consultancy Haarlem, the Netherlands
+Squirrel Consultancy Exloo, the Netherlands
http://www.squirrel.nl http://www.squirrel.nl/people/jvromans
------------------ "Arms are made for hugging" --------------------
diff --git a/lib/Getopt/Long/t/gol-basic.t b/lib/Getopt/Long/t/gol-basic.t
index f1916b291c..24a71db528 100644
--- a/lib/Getopt/Long/t/gol-basic.t
+++ b/lib/Getopt/Long/t/gol-basic.t
@@ -1,5 +1,7 @@
#!./perl -w
+no strict;
+
BEGIN {
if ($ENV{PERL_CORE}) {
@INC = '../lib';
@@ -8,9 +10,10 @@ BEGIN {
}
use Getopt::Long qw(:config no_ignore_case);
-die("Getopt::Long version 2.23_03 required--this is only version ".
+my $want_version="2.24";
+die("Getopt::Long version $want_version required--this is only version ".
$Getopt::Long::VERSION)
- unless $Getopt::Long::VERSION ge "2.24";
+ unless $Getopt::Long::VERSION ge $want_version;
print "1..9\n";
diff --git a/lib/Getopt/Long/t/gol-compat.t b/lib/Getopt/Long/t/gol-compat.t
index e211eeaec7..c123ef27f1 100644
--- a/lib/Getopt/Long/t/gol-compat.t
+++ b/lib/Getopt/Long/t/gol-compat.t
@@ -1,5 +1,7 @@
#!./perl -w
+no strict;
+
BEGIN {
if ($ENV{PERL_CORE}) {
@INC = '../lib';
diff --git a/lib/Getopt/Long/t/gol-linkage.t b/lib/Getopt/Long/t/gol-linkage.t
index a3047cfc19..1302471fed 100644
--- a/lib/Getopt/Long/t/gol-linkage.t
+++ b/lib/Getopt/Long/t/gol-linkage.t
@@ -1,5 +1,7 @@
#!./perl -w
+no strict;
+
BEGIN {
if ($ENV{PERL_CORE}) {
@INC = '../lib';
@@ -9,7 +11,7 @@ BEGIN {
use Getopt::Long;
-print "1..18\n";
+print "1..32\n";
@ARGV = qw(-Foo -baR --foo bar);
Getopt::Long::Configure ("no_ignore_case");
@@ -37,3 +39,41 @@ print (($ARGV[0] eq "bar") ? "" : "not ", "ok 15\n");
print (!(exists $lnk{foo}) ? "" : "not ", "ok 16\n");
print (!(exists $lnk{baR}) ? "" : "not ", "ok 17\n");
print (!(exists $lnk{bar}) ? "" : "not ", "ok 18\n");
+
+@ARGV = qw(/Foo=-baR --bar bar);
+Getopt::Long::Configure ("default","prefix_pattern=--|/|-|\\+","long_prefix_pattern=--|/");
+%lnk = ();
+my $bar;
+print "ok 19\n" if GetOptions (\%lnk, "bar" => \$bar, "Foo=s");
+print ((defined $bar) ? "" : "not ", "ok 20\n");
+print (($bar == 1) ? "" : "not ", "ok 21\n");
+print ((defined $lnk{Foo}) ? "" : "not ", "ok 22\n");
+print (($lnk{Foo} eq "-baR") ? "" : "not ", "ok 23\n");
+print ((@ARGV == 1) ? "" : "not ", "ok 24\n");
+print (($ARGV[0] eq "bar") ? "" : "not ", "ok 25\n");
+print (!(exists $lnk{foo}) ? "" : "not ", "ok 26\n");
+print (!(exists $lnk{baR}) ? "" : "not ", "ok 27\n");
+print (!(exists $lnk{bar}) ? "" : "not ", "ok 28\n");
+{
+ my $errors;
+ %lnk = ();
+ local $SIG{__WARN__}= sub { $errors.=join("\n",@_,'') };
+
+ @ARGV = qw(/Foo=-baR);
+ Getopt::Long::Configure ("default","bundling","ignore_case_always",
+ "prefix_pattern=--|/|-|\\+","long_prefix_pattern=--");
+ %lnk = ();
+ undef $bar;
+ GetOptions (\%lnk, "bar" => \$bar, "Foo=s");
+ print (($errors=~/Unknown option:/) ? "" : "not ", "ok 29\n");
+ $errors="";
+ %lnk = ();
+ undef $bar;
+ @ARGV = qw(/Foo=-baR);
+ Getopt::Long::Configure ("default","bundling","ignore_case_always",
+ "prefix_pattern=--|/|-|\\+","long_prefix_pattern=--|/");
+ GetOptions (\%lnk, "bar" => \$bar, "Foo=s");
+ print (($errors eq '') ? "" : "not ", "ok 30\n");
+ print ((defined $lnk{Foo}) ? "" : "not ", "ok 31\n");
+ print (($lnk{Foo} eq "-baR") ? "" : "not ", "ok 32\n");
+}
diff --git a/lib/Getopt/Long/t/gol-oo.t b/lib/Getopt/Long/t/gol-oo.t
index f8191d1db1..df49cb63b2 100644
--- a/lib/Getopt/Long/t/gol-oo.t
+++ b/lib/Getopt/Long/t/gol-oo.t
@@ -1,5 +1,7 @@
#!./perl -w
+no strict;
+
BEGIN {
if ($ENV{PERL_CORE}) {
@INC = '../lib';
@@ -8,9 +10,10 @@ BEGIN {
}
use Getopt::Long;
-die("Getopt::Long version 2.23_03 required--this is only version ".
+my $want_version="2.24";
+die("Getopt::Long version $want_version required--this is only version ".
$Getopt::Long::VERSION)
- unless $Getopt::Long::VERSION ge "2.24";
+ unless $Getopt::Long::VERSION ge $want_version;
print "1..9\n";
@ARGV = qw(-Foo -baR --foo bar);
View Lorry Controller Status