perl 5.000perl-5.000

[editor's note: this commit combines approximate 4 months of furious
releases of Andy Dougherty and Larry Wall - see pod/perlhist.pod for
details.  Andy notes that;
 
Alas neither my "Irwin AccuTrack" nor my DC 600A quarter-inch cartridge 
backup tapes from that era seem to be readable anymore.  I guess 13 years 
exceeds the shelf life for that backup technology :-(.
]

1 files changed, 513 insertions, 0 deletions

diff --git a/lib/Getopt/Long.pm b/lib/Getopt/Long.pm
new file mode 100644
index 0000000000..9c66264fdd
--- /dev/null
+++ b/lib/Getopt/Long.pm
@@ -0,0 +1,513 @@
+package Getopt::Long;
+require 5.000;
+require Exporter;
+
+@ISA = qw(Exporter);
+@EXPORT = qw(GetOptions);
+
+
+# newgetopt.pl -- new options parsing
+
+# SCCS Status     : @(#)@ newgetopt.pl	1.14
+# Author          : Johan Vromans
+# Created On      : Tue Sep 11 15:00:12 1990
+# Last Modified By: Johan Vromans
+# Last Modified On: Sat Feb 12 18:24:02 1994
+# Update Count    : 138
+# Status          : Okay
+
+################ 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,1994 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
+# as published by the Free Software Foundation; either version 2
+# of the License, or (at your option) any later version.
+# 
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+# GNU General Public License for more details.
+# 
+# If you do not have a copy of the GNU General Public License write to
+# the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, 
+# MA 02139, USA.
+
+################ Description ################
+#
+# Usage:
+# 
+#    require "newgetopt.pl";
+#    ...change configuration values, if needed...
+#    $result = &NGetOpt (...option-descriptions...);
+# 
+# Each description should designate a valid perl identifier, optionally
+# followed by an argument specifier.
+# 
+# Values for argument specifiers are:
+# 
+#   <none>   option does not take an argument
+#   !        option does not take an argument and may be negated
+#   =s :s    option takes a mandatory (=) or optional (:) string argument
+#   =i :i    option takes a mandatory (=) or optional (:) integer argument
+#   =f :f    option takes a mandatory (=) or optional (:) real number argument
+# 
+# If option "name" is set, it will cause the perl variable $opt_name to
+# be set to the specified value. The calling program can use this
+# variable to detect whether the option has been set. Options that do
+# not take an argument will be set to 1 (one).
+# 
+# Options that take an optional argument will be defined, but set to ''
+# if no actual argument has been supplied.
+# 
+# If an "@" sign is appended to the argument specifier, the option is
+# treated as an array. Value(s) are not set, but pushed into array
+# @opt_name.
+# 
+# Options that do not take a value may have an "!" argument spacifier to
+# indicate that they may be negated. E.g. "foo!" will allow -foo (which
+# sets $opt_foo to 1) and -nofoo (which will set $opt_foo to 0).
+# 
+# The option name may actually be a list of option names, separated by
+# '|'s, e.g. "foo|bar|blech=s". In this example, options 'bar' and
+# 'blech' will set $opt_foo instead.
+# 
+# Option names may be abbreviated to uniqueness, depending on
+# configuration variable $autoabbrev.
+# 
+# Dashes in option names are allowed (e.g. pcc-struct-return) and will
+# be translated to underscores in the corresponding perl variable (e.g.
+# $opt_pcc_struct_return).  Note that a lone dash "-" is considered an
+# option, corresponding perl identifier is $opt_ .
+# 
+# A double dash "--" signals end of the options list.
+# 
+# If the first option of the list consists of non-alphanumeric
+# characters only, it is interpreted as a generic option starter.
+# Everything starting with one of the characters from the starter will
+# be considered an option.
+# 
+# The default values for the option starters are "-" (traditional), "--"
+# (POSIX) and "+" (GNU, being phased out).
+# 
+# Options that start with "--" may have an argument appended, separated
+# with an "=", e.g. "--foo=bar".
+# 
+# If configuration varaible $getopt_compat is set to a non-zero value,
+# options that start with "+" may also include their arguments,
+# e.g. "+foo=bar".
+# 
+# A return status of 0 (false) indicates that the function detected
+# one or more errors.
+#
+################ Some examples ################
+# 
+# If option "one:i" (i.e. takes an optional integer argument), then
+# the following situations are handled:
+# 
+#    -one -two		-> $opt_one = '', -two is next option
+#    -one -2		-> $opt_one = -2
+# 
+# Also, assume "foo=s" and "bar:s" :
+# 
+#    -bar -xxx		-> $opt_bar = '', '-xxx' is next option
+#    -foo -bar		-> $opt_foo = '-bar'
+#    -foo --		-> $opt_foo = '--'
+# 
+# In GNU or POSIX format, option names and values can be combined:
+# 
+#    +foo=blech		-> $opt_foo = 'blech'
+#    --bar=		-> $opt_bar = ''
+#    --bar=--		-> $opt_bar = '--'
+# 
+################ Configuration values ################
+# 
+#   $autoabbrev      Allow option names to be abbreviated to uniqueness.
+#                    Default is 1 unless environment variable
+#                    POSIXLY_CORRECT has been set.
+# 
+#   $getopt_compat   Allow '+' to start options.
+#                    Default is 1 unless environment variable
+#                    POSIXLY_CORRECT has been set.
+# 
+#   $option_start    Regexp with option starters.
+#                    Default is (--|-) if environment variable
+#                    POSIXLY_CORRECT has been set, (--|-|\+) otherwise.
+# 
+#   $order           Whether non-options are allowed to be mixed with
+#                    options.
+#                    Default is $REQUIRE_ORDER if environment variable
+#                    POSIXLY_CORRECT has been set, $PERMUTE otherwise.
+# 
+#   $ignorecase      Ignore case when matching options. Default is 1.
+# 
+#   $debug           Enable debugging output. Default is 0.
+
+################ History ################
+# 
+# 12-Feb-1994		Johan Vromans	
+#    Added "!" for negation.
+#    Released to the net.
+#
+# 26-Aug-1992		Johan Vromans	
+#    More POSIX/GNU compliance.
+#    Lone dash and double-dash are now independent of the option prefix
+#      that is used.
+#    Make errors in NGetOpt parameters fatal.
+#    Allow options to be mixed with arguments.
+#      Check $ENV{"POSIXLY_CORRECT"} to suppress this.
+#    Allow --foo=bar and +foo=bar (but not -foo=bar).
+#    Allow options to be abbreviated to minimum needed for uniqueness.
+#      (Controlled by configuration variable $autoabbrev.)
+#    Allow alias names for options (e.g. "foo|bar=s").
+#    Allow "-" in option names (e.g. --pcc-struct-return). Dashes are
+#      translated to "_" to form valid perl identifiers
+#      (e.g. $opt_pcc_struct_return). 
+#
+# 2-Jun-1992		Johan Vromans	
+#    Do not use //o to allow multiple NGetOpt calls with different delimeters.
+#    Prevent typeless option from using previous $array state.
+#    Prevent empty option from being eaten as a (negative) number.
+#
+# 25-May-1992		Johan Vromans	
+#    Add array options. "foo=s@" will return an array @opt_foo that
+#    contains all values that were supplied. E.g. "-foo one -foo -two" will
+#    return @opt_foo = ("one", "-two");
+#    Correct bug in handling options that allow for a argument when followed
+#    by another option.
+#
+# 4-May-1992		Johan Vromans	
+#    Add $ignorecase to match options in either case.
+#    Allow '' option.
+#
+# 19-Mar-1992		Johan Vromans	
+#    Allow require from packages.
+#    NGetOpt is now defined in the package that requires it.
+#    @ARGV and $opt_... are taken from the package that calls it.
+#    Use standard (?) option prefixes: -, -- and +.
+#
+# 20-Sep-1990		Johan Vromans	
+#    Set options w/o argument to 1.
+#    Correct the dreadful semicolon/require bug.
+
+################ Configuration Section ################
+
+{ 
+
+    # Values for $order. See GNU getopt.c for details.
+    $REQUIRE_ORDER = 0;
+    $PERMUTE = 1;
+    $RETURN_IN_ORDER = 2;
+
+    # Handle POSIX compliancy.
+    if ( defined $ENV{"POSIXLY_CORRECT"} ) {
+	$autoabbrev = 0;	# no automatic abbrev of options (???)
+	$getopt_compat = 0;	# disallow '+' to start options
+	$option_start = "(--|-)";
+	$order = $REQUIRE_ORDER;
+    }
+    else {
+	$autoabbrev = 1;	# automatic abbrev of options
+	$getopt_compat = 1;	# allow '+' to start options
+	$option_start = "(--|-|\\+)";
+	$order = $PERMUTE;
+    }
+
+    # Other configurable settings.
+    $debug = 0;			# for debugging
+    $ignorecase = 1;		# ignore case when matching options
+    $argv_end = "--";		# don't change this!
+}
+
+################ Subroutines ################
+
+sub GetOptions {
+
+    @optionlist = @_;	#';
+
+    local ($[) = 0;
+    local ($genprefix) = $option_start;
+    local ($argend) = $argv_end;
+    local ($error) = 0;
+    local ($opt, $optx, $arg, $type, $mand, %opctl);
+    local ($pkg) = (caller)[0];
+    local ($optarg);
+    local (%aliases);
+    local (@ret) = ();
+
+    print STDERR "NGetOpt 1.14 -- called from $pkg\n" if $debug;
+
+    # See if the first element of the optionlist contains option
+    # starter characters.
+    if ( $optionlist[0] =~ /^\W+$/ ) {
+	$genprefix = shift (@optionlist);
+	# Turn into regexp.
+	$genprefix =~ s/(\W)/\\$1/g;
+	$genprefix = "[" . $genprefix . "]";
+    }
+
+    # Verify correctness of optionlist.
+    %opctl = ();
+    foreach $opt ( @optionlist ) {
+	$opt =~ tr/A-Z/a-z/ if $ignorecase;
+	if ( $opt !~ /^(\w+[-\w|]*)?(!|[=:][infse]@?)?$/ ) {
+	    die ("Error in option spec: \"", $opt, "\"\n");
+	    $error++;
+	    next;
+	}
+	local ($o, $c, $a) = ($1, $2);
+
+	if ( ! defined $o ) {
+	    $opctl{''} = defined $c ? $c : '';
+	}
+	else {
+	    # Handle alias names
+	    foreach ( split (/\|/, $o)) {
+		if ( defined $c && $c eq '!' ) {
+		    $opctl{"no$_"} = $c;
+		    $c = '';
+		}
+		$opctl{$_} = defined $c ? $c : '';
+		if ( defined $a ) {
+		    # Note alias.
+		    $aliases{$_} = $a;
+		}
+		else {
+		    # Set primary name.
+		    $a = $_;
+		}
+	    }
+	}
+    }
+    @opctl = sort(keys (%opctl)) if $autoabbrev;
+
+    return 0 if $error;
+
+    if ( $debug ) {
+	local ($arrow, $k, $v);
+	$arrow = "=> ";
+	while ( ($k,$v) = each(%opctl) ) {
+	    print STDERR ($arrow, "\$opctl{\"$k\"} = \"$v\"\n");
+	    $arrow = "   ";
+	}
+    }
+
+    # Process argument list
+
+    while ( $#ARGV >= 0 ) {
+
+	# >>> See also the continue block <<<
+
+	#### Get next argument ####
+
+	$opt = shift (@ARGV);
+	print STDERR ("=> option \"", $opt, "\"\n") if $debug;
+	$arg = undef;
+	$optarg = undef;
+	$array = 0;
+
+	#### Determine what we have ####
+
+	# Double dash is option list terminator.
+	if ( $opt eq $argend ) {
+	    unshift (@ret, @ARGV) if $order == $PERMUTE;
+	    return ($error == 0);
+	}
+	elsif ( $opt =~ /^$genprefix/ ) {
+	    # Looks like an option.
+	    $opt = $';		# option name (w/o prefix)
+	    # If it is a long opt, it may include the value.
+	    if (($+ eq "--" || ($getopt_compat && $+ eq "+")) && 
+		$opt =~ /^([^=]+)=/ ) {
+		$opt = $1;
+		$optarg = $';
+		print STDERR ("=> option \"", $opt, 
+			      "\", optarg = \"$optarg\"\n")
+		    if $debug;
+	    }
+
+	}
+	# Not an option. Save it if we may permute...
+	elsif ( $order == $PERMUTE ) {
+	    push (@ret, $opt);
+	    next;
+	}
+	# ...otherwise, terminate.
+	else {
+	    # Push back and exit.
+	    unshift (@ARGV, $opt);
+	    return ($error == 0);
+	}
+
+	#### Look it up ###
+
+	$opt =~ tr/A-Z/a-z/ if $ignorecase;
+
+	local ($tryopt) = $opt;
+	if ( $autoabbrev ) {
+	    local ($pat, @hits);
+
+	    # Turn option name into pattern.
+	    ($pat = $opt) =~ s/(\W)/\\$1/g;
+	    # Look up in option names.
+	    @hits = grep (/^$pat/, @opctl);
+	    print STDERR ("=> ", 0+@hits, " hits (@hits) with \"$pat\" ",
+			  "out of ", 0+@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");
+		$error++;
+		next;
+	    }
+
+	    # Complete the option name, if appropriate.
+	    if ( @hits == 1 && $hits[0] ne $opt ) {
+		$tryopt = $hits[0];
+		print STDERR ("=> option \"$opt\" -> \"$tryopt\"\n")
+		    if $debug;
+	    }
+	}
+
+	unless  ( defined ( $type = $opctl{$tryopt} ) ) {
+	    print STDERR ("Unknown option: ", $opt, "\n");
+	    $error++;
+	    next;
+	}
+	$opt = $tryopt;
+	print STDERR ("=> found \"$type\" for ", $opt, "\n") if $debug;
+
+	#### Determine argument status ####
+
+	# If it is an option w/o argument, we're almost finished with it.
+	if ( $type eq '' || $type eq '!' ) {
+	    if ( defined $optarg ) {
+		print STDERR ("Option ", $opt, " does not take an argument\n");
+		$error++;
+	    }
+	    elsif ( $type eq '' ) {
+		$arg = 1;		# supply explicit value
+	    }
+	    else {
+		substr ($opt, 0, 2) = ''; # strip NO prefix
+		$arg = 0;		# supply explicit value
+	    }
+	    next;
+	}
+
+	# Get mandatory status and type info.
+	($mand, $type, $array) = $type =~ /^(.)(.)(@?)$/;
+
+	# Check if there is an option argument available.
+	if ( defined $optarg ? ($optarg eq '') : ($#ARGV < 0) ) {
+
+	    # Complain if this option needs an argument.
+	    if ( $mand eq "=" ) {
+		print STDERR ("Option ", $opt, " requires an argument\n");
+		$error++;
+	    }
+	    if ( $mand eq ":" ) {
+		$arg = $type eq "s" ? '' : 0;
+	    }
+	    next;
+	}
+
+	# Get (possibly optional) argument.
+	$arg = defined $optarg ? $optarg : shift (@ARGV);
+
+	#### Check if the argument is valid for this option ####
+
+	if ( $type eq "s" ) {	# string
+	    # A mandatory string takes anything. 
+	    next if $mand eq "=";
+
+	    # An optional string takes almost anything. 
+	    next if defined $optarg;
+	    next if $arg eq "-";
+
+	    # Check for option or option list terminator.
+	    if ($arg eq $argend ||
+		$arg =~ /^$genprefix.+/) {
+		# Push back.
+		unshift (@ARGV, $arg);
+		# Supply empty value.
+		$arg = '';
+	    }
+	    next;
+	}
+
+	if ( $type eq "n" || $type eq "i" ) { # numeric/integer
+	    if ( $arg !~ /^-?[0-9]+$/ ) {
+		if ( defined $optarg || $mand eq "=" ) {
+		    print STDERR ("Value \"", $arg, "\" invalid for option ",
+				  $opt, " (number expected)\n");
+		    $error++;
+		    undef $arg;	# don't assign it
+		}
+		else {
+		    # Push back.
+		    unshift (@ARGV, $arg);
+		    # Supply default value.
+		    $arg = 0;
+		}
+	    }
+	    next;
+	}
+
+	if ( $type eq "f" ) { # fixed real number, int is also ok
+	    if ( $arg !~ /^-?[0-9.]+$/ ) {
+		if ( defined $optarg || $mand eq "=" ) {
+		    print STDERR ("Value \"", $arg, "\" invalid for option ",
+				  $opt, " (real number expected)\n");
+		    $error++;
+		    undef $arg;	# don't assign it
+		}
+		else {
+		    # Push back.
+		    unshift (@ARGV, $arg);
+		    # Supply default value.
+		    $arg = 0.0;
+		}
+	    }
+	    next;
+	}
+
+	die ("NGetOpt internal error (Can't happen)\n");
+    }
+
+    continue {
+	if ( defined $arg ) {
+	    $opt = $aliases{$opt} if defined $aliases{$opt};
+	    # Make sure a valid perl identifier results.
+	    $opt =~ s/\W/_/g;
+	    if ( $array ) {
+		print STDERR ('=> push (@', $pkg, '\'opt_', $opt, ", \"$arg\")\n")
+		    if $debug;
+	        eval ('push(@' . $pkg . '\'opt_' . $opt . ", \$arg);");
+	    }
+	    else {
+		print STDERR ('=> $', $pkg, '\'opt_', $opt, " = \"$arg\"\n")
+		    if $debug;
+	        eval ('$' . $pkg . '\'opt_' . $opt . " = \$arg;");
+	    }
+	}
+    }
+
+    if ( $order == $PERMUTE && @ret > 0 ) {
+	unshift (@ARGV, @ret);
+    }
+    return ($error == 0);
+}
+
+################ Package return ################
+
+1;
+
+