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
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);
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
$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.
local ($^W) = 0;
print STDERR
("Getopt::Long $Getopt::Long::VERSION (",
- '$Revision: 2.68 $', ") ",
+ '$Revision: 2.72 $', ") ",
"called from package \"$pkg\".",
"\n ",
"ARGV: (@ARGV)",
"ignorecase=$ignorecase,",
"requested_version=$requested_version,",
"passthrough=$passthrough,",
- "genprefix=\"$genprefix\".",
+ "genprefix=\"$genprefix\",",
+ "longprefix=\"$longprefix\".",
"\n");
}
}
$argcnt++;
- last if $argcnt >= $ctl->[CTL_AMAX];
+ last if $argcnt >= $ctl->[CTL_AMAX] && $ctl->[CTL_AMAX] != -1;
undef($arg);
# Need more args?
# 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;
# 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 ) {
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;
}
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;
# 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;
}
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()
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
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<-->.
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.
=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
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
--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
-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>.
=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)
=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
#!./perl -w
+no strict;
+
BEGIN {
if ($ENV{PERL_CORE}) {
@INC = '../lib';
use Getopt::Long;
-print "1..18\n";
+print "1..32\n";
@ARGV = qw(-Foo -baR --foo bar);
Getopt::Long::Configure ("no_ignore_case");
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");
+}
projects / p5sagit/p5-mst-13.2.git / commitdiff