# GetOpt::Long.pm -- POSIX compatible options parsing
-# RCS Status : $Id: GetoptLong.pm,v 2.1 1996/02/02 20:24:35 jv Exp $
+# RCS Status : $Id: GetoptLong.pm,v 2.3 1996-04-05 21:03:05+02 jv Exp $
# Author : Johan Vromans
# Created On : Tue Sep 11 15:00:12 1990
# Last Modified By: Johan Vromans
-# Last Modified On: Fri Feb 2 21:24:32 1996
-# Update Count : 347
+# Last Modified On: Fri Apr 5 21:02:52 1996
+# Update Count : 433
# Status : Released
package Getopt::Long;
@ISA = qw(Exporter);
@EXPORT = qw(&GetOptions $REQUIRE_ORDER $PERMUTE $RETURN_IN_ORDER);
-$VERSION = sprintf("%d.%02d", q$Revision: 2.1 $ =~ /(\d+)\.(\d+)/);
+$VERSION = sprintf("%d.%02d", '$Revision: 2.3 $ ' =~ /(\d+)\.(\d+)/);
+use vars qw($autoabbrev $getopt_compat $ignorecase $bundling $order
+ $error $debug $REQUIRE_ORDER $PERMUTE $RETURN_IN_ORDER
+ $VERSION $major_version $minor_version);
use strict;
=head1 NAME
GetOptions(). This function adheres to the POSIX syntax for command
line options, with GNU extensions. In general, this means that options
have long names instead of single letters, and are introduced with a
-double dash "--". There is no bundling of command line options, as was
-the case with the more traditional single-letter approach. For
-example, the UNIX "ps" command can be given the command line "option"
+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"
-vax
$RETURN_IN_ORDER is not supported by GetOptions().
-=item $Getopt::Long::ignorecase
+=item $Getopt::Long::bundling
-Ignore case when matching options. Default is 1.
+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,
+
+ ps -vax --vax
+
+would be equivalent to
+
+ ps -v -a -x --vax
+
+provided "vax", "v", "a" and "x" have been defined to be valid
+options.
+
+Bundled options can also include a value in the bundle; this value has
+to be the last part of the bundle, e.g.
+
+ scale -h24 -w80
+
+is equivalent to
+
+ scale -h 24 -w 80
+
+B<Note:> Using option bundling can easily lead to unexpected results,
+especially when mixing long options and bundles. Caveat emptor.
+
+=item $Getopt::Long::ignorecase
+
+Ignore case when matching options. Default is 1. When bundling is in
+effect, case is ignored on single-character options only if
+$Getopt::Long::ignorecase is greater than 1.
=item $Getopt::Long::VERSION
################ Introduction ################
#
-# This package implements an extended getopt function. This function
-# adheres to the new syntax (long option names, no bundling). It tries
-# to implement the better functionality of traditional, GNU and POSIX
-# getopt functions.
-#
# This program is Copyright 1990,1996 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
# the Free Software Foundation, Inc., 675 Mass Ave, Cambridge,
# MA 02139, USA.
-################ History ################
-#
-# 13-Jan-1996 Johan Vromans
-# Generalized the linkage interface.
-# Eliminated the linkage argument.
-# Add code references as a possible value for the option linkage.
-# Add option specifier <> to have a call-back for non-options.
-#
-# 26-Dec-1995 Johan Vromans
-# Import from netgetopt.pl.
-# Turned into a decent module.
-# Added linkage argument.
-
################ Configuration Section ################
# Values for $order. See GNU getopt.c for details.
-($Getopt::Long::REQUIRE_ORDER,
- $Getopt::Long::PERMUTE,
- $Getopt::Long::RETURN_IN_ORDER) = (0..2);
+($REQUIRE_ORDER, $PERMUTE, $RETURN_IN_ORDER) = (0..2);
my $gen_prefix; # generic prefix (option starters)
# Handle POSIX compliancy.
if ( defined $ENV{"POSIXLY_CORRECT"} ) {
- $gen_prefix = "(--|-)";
- $Getopt::Long::autoabbrev = 0; # no automatic abbrev of options
- $Getopt::Long::getopt_compat = 0; # disallow '+' to start options
- $Getopt::Long::order = $Getopt::Long::REQUIRE_ORDER;
+ $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 = "(--|-|\\+)";
- $Getopt::Long::autoabbrev = 1; # automatic abbrev of options
- $Getopt::Long::getopt_compat = 1; # allow '+' to start options
- $Getopt::Long::order = $Getopt::Long::PERMUTE;
+ $gen_prefix = "--|-|\\+";
+ $autoabbrev = 1; # automatic abbrev of options
+ $bundling = 0; # bundling off by default
+ $getopt_compat = 1; # allow '+' to start options
+ $order = $PERMUTE;
}
# Other configurable settings.
-$Getopt::Long::debug = 0; # for debugging
-$Getopt::Long::error = 0; # error tally
-$Getopt::Long::ignorecase = 1; # ignore case when matching options
-($Getopt::Long::version,
- $Getopt::Long::major_version,
- $Getopt::Long::minor_version) = '$Revision: 2.1 $ ' =~ /: ((\d+)\.(\d+))/;
-$Getopt::Long::version .= '*' if length('$Locker: $ ') > 12;
+$debug = 0; # for debugging
+$error = 0; # error tally
+$ignorecase = 1; # ignore case when matching options
+($major_version, $minor_version) = $VERSION =~ /^(\d+)\.(\d+)/;
################ Subroutines ################
my @optionlist = @_; # local copy of the option descriptions
my $argend = '--'; # option list terminator
- my %opctl; # table of arg.specs
+ my %opctl; # table of arg.specs (long and abbrevs)
+ my %bopctl; # table of arg.specs (bundles)
my $pkg = (caller)[0]; # current context
# Needed if linkage is omitted.
my %aliases; # alias table
my @ret = (); # accum for non-options
my %linkage; # linkage
my $userlinkage; # user supplied HASH
- my $debug = $Getopt::Long::debug; # convenience
my $genprefix = $gen_prefix; # so we can call the same module more
# than once in differing environments
- $Getopt::Long::error = 0;
+ $error = 0;
- print STDERR ("GetOptions $Getopt::Long::version",
- " [GetOpt::Long $Getopt::Long::VERSION] -- ",
+ print STDERR ('GetOptions $Revision: 2.3 $ ',
+ "[GetOpt::Long $Getopt::Long::VERSION] -- ",
"called from package \"$pkg\".\n",
- " autoabbrev=$Getopt::Long::autoabbrev".
- ",getopt_compat=$Getopt::Long::getopt_compat",
+ " autoabbrev=$autoabbrev".
+ ",bundling=$bundling",
+ ",getopt_compat=$getopt_compat",
",genprefix=\"$genprefix\"",
- ",order=$Getopt::Long::order",
- ",ignorecase=$Getopt::Long::ignorecase",
+ ",order=$order",
+ ",ignorecase=$ignorecase",
".\n")
if $debug;
# Verify correctness of optionlist.
%opctl = ();
+ %bopctl = ();
while ( @optionlist > 0 ) {
my $opt = shift (@optionlist);
# Strip leading prefix so people can specify "-foo=i" if they like.
- $opt = $' if $opt =~ /^($genprefix)+/;
+ $opt = $2 if $opt =~ /^($genprefix)+([\x00-\xff]*)/;
if ( $opt eq '<>' ) {
if ( (defined $userlinkage)
unless ( @optionlist > 0
&& ref($optionlist[0]) && ref($optionlist[0]) eq 'CODE' ) {
warn ("Option spec <> requires a reference to a subroutine\n");
- $Getopt::Long::error++;
+ $error++;
next;
}
$linkage{'<>'} = shift (@optionlist);
next;
}
- $opt =~ tr/A-Z/a-z/ if $Getopt::Long::ignorecase;
if ( $opt !~ /^(\w+[-\w|]*)?(!|[=:][infse]@?)?$/ ) {
warn ("Error in option spec: \"", $opt, "\"\n");
- $Getopt::Long::error++;
+ $error++;
next;
}
my ($o, $c, $a) = ($1, $2);
+ $c = '' unless defined $c;
if ( ! defined $o ) {
# empty -> '-' option
- $opctl{$o = ''} = defined $c ? $c : '';
+ $opctl{$o = ''} = $c;
}
else {
# Handle alias names
my @o = split (/\|/, $o);
$o = $o[0];
+ $o = lc ($o)
+ if $ignorecase > 1
+ || ($ignorecase
+ && ($bundling ? length($o) > 1 : 1));
+
foreach ( @o ) {
- if ( defined $c && $c eq '!' ) {
- $opctl{"no$_"} = $c;
- $c = '';
+ if ( $bundling && length($_) == 1 ) {
+ $_ = lc ($_) if $ignorecase > 1;
+ if ( $c eq '!' ) {
+ $opctl{"no$_"} = $c;
+ warn ("Ignoring '!' modifier for short option $_\n");
+ $c = '';
+ }
+ $bopctl{$_} = $c;
+ }
+ else {
+ $_ = lc ($_) if $ignorecase;
+ if ( $c eq '!' ) {
+ $opctl{"no$_"} = $c;
+ $c = '';
+ }
+ $opctl{$_} = $c;
}
- $opctl{$_} = defined $c ? $c : '';
if ( defined $a ) {
# Note alias.
$aliases{$_} = $a;
if ( @optionlist > 0 && ref($optionlist[0]) ) {
print STDERR ("=> link \"$o\" to $optionlist[0]\n")
if $debug;
- if ( ref($optionlist[0]) eq 'SCALAR'
- || ref($optionlist[0]) eq 'ARRAY'
- || ref($optionlist[0]) eq 'CODE' ) {
+ if ( ref($optionlist[0]) =~ /^(SCALAR|ARRAY|CODE)$/ ) {
$linkage{$o} = shift (@optionlist);
}
else {
warn ("Invalid option linkage for \"", $opt, "\"\n");
- $Getopt::Long::error++;
+ $error++;
}
}
else {
# Make sure a valid perl identifier results.
my $ov = $o;
$ov =~ s/\W/_/g;
- if ( $c && $c =~ /@/ ) {
+ if ( defined($c) && $c =~ /@/ ) {
print STDERR ("=> link \"$o\" to \@$pkg","::opt_$ov\n")
if $debug;
eval ("\$linkage{\$o} = \\\@".$pkg."::opt_$ov;");
}
# Bail out if errors found.
- return 0 if $Getopt::Long::error;
+ return 0 if $error;
- # Sort the possible option names.
- my @opctl = sort(keys (%opctl)) if $Getopt::Long::autoabbrev;
+ # Sort the possible long option names.
+ my @opctl = sort(keys (%opctl)) if $autoabbrev;
- # Show if debugging.
+ # Show the options tables if debugging.
if ( $debug ) {
my ($arrow, $k, $v);
$arrow = "=> ";
print STDERR ($arrow, "\$opctl{\"$k\"} = \"$v\"\n");
$arrow = " ";
}
+ $arrow = "=> ";
+ while ( ($k,$v) = each(%bopctl) ) {
+ print STDERR ($arrow, "\$bopctl{\"$k\"} = \"$v\"\n");
+ $arrow = " ";
+ }
}
my $opt; # current option
- my $arg; # current option value
+ my $arg; # current option value, if any
my $array; # current option is array typed
# Process argument list
#### Get next argument ####
+ my $starter; # option starter string, e.g. '-' or '--'
+ my $rest = undef; # remainder from unbundling
+ my $optarg = undef; # value supplied with --opt=value
+
$opt = shift (@ARGV);
$arg = undef;
- my $optarg = undef;
$array = 0;
print STDERR ("=> option \"", $opt, "\"\n") if $debug;
if ( $opt eq $argend ) {
# Finish. Push back accumulated arguments and return.
unshift (@ARGV, @ret)
- if $Getopt::Long::order == $Getopt::Long::PERMUTE;
- return ($Getopt::Long::error == 0);
+ if $order == $PERMUTE;
+ return ($error == 0);
}
- if ( $opt =~ /^$genprefix/ ) {
+ if ( $opt =~ /^($genprefix)([\x00-\xff]*)/ ) {
# Looks like an option.
- $opt = $'; # option name (w/o prefix)
- # If it is a long opt, it may include the value.
- if (($& eq "--" || ($Getopt::Long::getopt_compat && $& eq "+"))
- && $opt =~ /^([^=]+)=/ ) {
+ $opt = $2; # option name (w/o prefix)
+ $starter = $1; # option starter
+
+ # If it is a long option, it may include the value.
+ if (($starter eq "--"
+ || ($getopt_compat && $starter eq "+"))
+ && $opt =~ /^([^=]+)=([\x00-\xff]*)/ ) {
$opt = $1;
- $optarg = $';
+ $optarg = $2;
print STDERR ("=> option \"", $opt,
"\", optarg = \"$optarg\"\n") if $debug;
}
}
# Not an option. Save it if we $PERMUTE and don't have a <>.
- elsif ( $Getopt::Long::order == $Getopt::Long::PERMUTE ) {
+ elsif ( $order == $PERMUTE ) {
# Try non-options call-back.
my $cb;
if ( (defined ($cb = $linkage{'<>'})) ) {
&$cb($opt);
}
else {
+ print STDERR ("=> saving \"$opt\" ",
+ "(not an option, may permute)\n") if $debug;
push (@ret, $opt);
}
next;
else {
# Push this one back and exit.
unshift (@ARGV, $opt);
- return ($Getopt::Long::error == 0);
+ return ($error == 0);
}
#### Look it up ###
- $opt =~ tr/A-Z/a-z/ if $Getopt::Long::ignorecase;
-
- my $tryopt = $opt;
- if ( $Getopt::Long::autoabbrev ) {
- my $pat;
-
+ my $tryopt = $opt; # option to try
+ my $optbl = \%opctl; # table to look it up (long names)
+
+ 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
+ }
+
+ # Try auto-abbreviation.
+ elsif ( $autoabbrev ) {
+ # Downcase if allowed.
+ $tryopt = $opt = lc ($opt) if $ignorecase;
# Turn option name into pattern.
- ($pat = $opt) =~ s/(\W)/\\$1/g;
+ my $pat = quotemeta ($opt);
# Look up in option names.
my @hits = grep (/^$pat/, @opctl);
- print STDERR ("=> ", 0+@hits, " hits (@hits) with \"$pat\" ",
- "out of ", 0+@opctl, "\n") if $debug;
+ print STDERR ("=> ", scalar(@hits), " hits (@hits) with \"$pat\" ",
+ "out of ", scalar(@opctl), "\n") if $debug;
# Check for ambiguous results.
unless ( (@hits <= 1) || (grep ($_ eq $opt, @hits) == 1) ) {
print STDERR ("Option ", $opt, " is ambiguous (",
join(", ", @hits), ")\n");
- $Getopt::Long::error++;
+ $error++;
next;
}
}
}
- my $type;
- unless ( defined ( $type = $opctl{$tryopt} ) ) {
- print STDERR ("Unknown option: ", $opt, "\n");
- $Getopt::Long::error++;
+ # Check validity by fetching the info.
+ my $type = $optbl->{$tryopt};
+ unless ( defined $type ) {
+ warn ("Unknown option: ", $opt, "\n");
+ $error++;
next;
}
+ # Apparently valid.
$opt = $tryopt;
print STDERR ("=> found \"$type\" for ", $opt, "\n") if $debug;
if ( $type eq '' || $type eq '!' ) {
if ( defined $optarg ) {
print STDERR ("Option ", $opt, " does not take an argument\n");
- $Getopt::Long::error++;
+ $error++;
}
elsif ( $type eq '' ) {
$arg = 1; # supply explicit value
substr ($opt, 0, 2) = ''; # strip NO prefix
$arg = 0; # supply explicit value
}
+ # When unbundling, unshift the rest with the starter.
+ unshift (@ARGV, $starter.$rest) if defined $rest;
next;
}
($mand, $type, $array) = $type =~ /^(.)(.)(@?)$/;
# Check if there is an option argument available.
- if ( defined $optarg ? ($optarg eq '') : (@ARGV <= 0) ) {
-
+ if ( defined $optarg ? ($optarg eq '')
+ : !(defined $rest || @ARGV > 0) ) {
# Complain if this option needs an argument.
if ( $mand eq "=" ) {
print STDERR ("Option ", $opt, " requires an argument\n");
- $Getopt::Long::error++;
+ $error++;
}
if ( $mand eq ":" ) {
$arg = $type eq "s" ? '' : 0;
}
# Get (possibly optional) argument.
- $arg = defined $optarg ? $optarg : shift (@ARGV);
+ $arg = (defined $rest ? $rest
+ : (defined $optarg ? $optarg : shift (@ARGV)));
#### Check if the argument is valid for this option ####
next if $mand eq "=";
# An optional string takes almost anything.
- next if defined $optarg;
- next if $arg eq "-";
+ next if defined $optarg || defined $rest;
+ next if $arg eq "-"; # ??
# Check for option or option list terminator.
if ($arg eq $argend ||
if ( defined $optarg || $mand eq "=" ) {
print STDERR ("Value \"", $arg, "\" invalid for option ",
$opt, " (number expected)\n");
- $Getopt::Long::error++;
+ $error++;
undef $arg; # don't assign it
+ # Push back.
+ unshift (@ARGV, $starter.$rest) if defined $rest;
}
else {
# Push back.
- unshift (@ARGV, $arg);
+ unshift (@ARGV, defined $rest ? $starter.$rest : $arg);
# Supply default value.
$arg = 0;
}
if ( defined $optarg || $mand eq "=" ) {
print STDERR ("Value \"", $arg, "\" invalid for option ",
$opt, " (real number expected)\n");
- $Getopt::Long::error++;
+ $error++;
undef $arg; # don't assign it
+ # Push back.
+ unshift (@ARGV, $starter.$rest) if defined $rest;
}
else {
# Push back.
- unshift (@ARGV, $arg);
+ unshift (@ARGV, defined $rest ? $starter.$rest : $arg);
# Supply default value.
$arg = 0.0;
}
}
# Finish.
- if ( $Getopt::Long::order == $Getopt::Long::PERMUTE ) {
+ if ( $order == $PERMUTE ) {
# Push back accumulated arguments
+ print STDERR ("=> restoring \"", join('" "', @ret), "\"\n")
+ if $debug && @ret > 0;
unshift (@ARGV, @ret) if @ret > 0;
}
- return ($Getopt::Long::error == 0);
+ return ($error == 0);
}
################ Package return ################
-# Returning 1 is so boring...
-$Getopt::Long::major_version * 1000 + $Getopt::Long::minor_version;
+1;
projects / p5sagit/p5-mst-13.2.git / commitdiff