perl 4.0 patch 7: patch #4, continued

See patch #4.

1 files changed, 204 insertions, 0 deletions

diff --git a/lib/newgetopt.pl b/lib/newgetopt.pl
new file mode 100644
index 0000000000..441213a538
--- /dev/null
+++ b/lib/newgetopt.pl
@@ -0,0 +1,204 @@
+# newgetopt.pl -- new options parsing
+
+# SCCS Status     : @(#)@ newgetopt.pl	1.7
+# Author          : Johan Vromans
+# Created On      : Tue Sep 11 15:00:12 1990
+# Last Modified By: Johan Vromans
+# Last Modified On: Sun Oct 14 14:35:36 1990
+# Update Count    : 34
+# Status          : Okay
+
+# This package implements a new getopt function. This function adheres
+# to the new syntax (long option names, no bundling).
+#
+# Arguments to the function are:
+#
+#  - a list of possible options. These should designate valid perl
+#    identifiers, optionally followed by an argument specifier ("="
+#    for mandatory arguments or ":" for optional arguments) and an
+#    argument type specifier: "n" or "i" for integer numbers, "f" for
+#    real (fix) numbers or "s" for strings.
+#
+#  - 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.
+#    Likewise, a double occurrence (e.g. "--") signals end of
+#    the options list.
+#    The default value for the starter is "-".
+#
+# Upon return, the option variables, prefixed with "opt_", are defined
+# and set to the respective option arguments, if any.
+# Options that do not take an argument are set to 1. Note that an
+# option with an optional argument will be defined, but set to '' if
+# no actual argument has been supplied.
+# A return status of 0 (false) indicates that the function detected
+# one or more errors.
+#
+# Special care is taken to give a correct treatment to optional arguments.
+#
+# E.g. 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 = '--'
+#
+
+# HISTORY 
+# 20-Sep-1990		Johan Vromans	
+#    Set options w/o argument to 1.
+#    Correct the dreadful semicolon/require bug.
+
+
+package newgetopt;
+
+$debug = 0;			# for debugging
+
+sub main'NGetOpt {
+    local (@optionlist) = @_;
+    local ($[) = 0;
+    local ($genprefix) = "-";
+    local ($error) = 0;
+    local ($opt, $optx, $arg, $type, $mand, @hits);
+
+    # See if the first element of the optionlist contains option
+    # starter characters.
+    $genprefix = shift (@optionlist) if $optionlist[0] =~ /^\W+$/;
+
+    # Turn into regexp.
+    $genprefix =~ s/(\W)/\\\1/g;
+    $genprefix = "[" . $genprefix . "]";
+
+    # Verify correctness of optionlist.
+    @hits = grep ($_ !~ /^\w+([=:][infse])?$/, @optionlist);
+    if ( $#hits >= 0 ) {
+	foreach $opt ( @hits ) {
+	    print STDERR ("Error in option spec: \"", $opt, "\"\n");
+	    $error++;
+	}
+	return 0;
+    }
+
+    # Process argument list
+
+    while ( $#main'ARGV >= 0 ) {		#'){
+
+	# >>> See also the continue block <<<
+
+	# Get next argument
+	$opt = shift (@main'ARGV);		#');
+	print STDERR ("=> option \"", $opt, "\"\n") if $debug;
+	$arg = undef;
+
+	# Check for exhausted list.
+	if ( $opt =~ /^$genprefix/o ) {
+	    # Double occurrence is terminator
+	    return ($error == 0) if $opt eq "$+$+";
+	    $opt = $';		# option name (w/o prefix)
+	}
+	else {
+	    # Apparently not an option - push back and exit.
+	    unshift (@main'ARGV, $opt);		#');
+	    return ($error == 0);
+	}
+
+	# Grep in option list. Hide regexp chars from option.
+	($optx = $opt) =~ s/(\W)/\\\1/g;
+	@hits = grep (/^$optx([=:].+)?$/, @optionlist);
+	if ( $#hits != 0 ) {
+	    print STDERR ("Unknown option: ", $opt, "\n");
+	    $error++;
+	    next;
+	}
+
+	# Determine argument status.
+	undef $type;
+	$type = $+ if $hits[0] =~ /[=:].+$/;
+	print STDERR ("=> found \"$hits[0]\" for ", $opt, "\n") if $debug;
+
+	# If it is an option w/o argument, we're almost finished with it.
+	if ( ! defined $type ) {
+	    $arg = 1;		# supply explicit value
+	    next;
+	}
+
+	# Get mandatory status and type info.
+	($mand, $type) = $type =~ /^(.)(.)$/;
+
+	# Check if the argument list is exhausted.
+	if ( $#main'ARGV < 0 ) {		#'){
+
+	    # Complain if this option needs an argument.
+	    if ( $mand eq "=" ) {
+		print STDERR ("Option ", $opt, " requires an argument\n");
+		$error++;
+	    }
+	    next;
+	}
+
+	# Get (possibly optional) argument.
+	$arg = shift (@main'ARGV);		#');
+
+	# Check if it is a valid argument. A mandatory string takes
+ 	# anything. 
+	if ( "$mand$type" ne "=s" && $arg =~ /^$genprefix/o ) {
+
+	    # Check for option list terminator.
+	    if ( $arg eq "$+$+" ) {
+		# Complain if an argument is required.
+		if ($mand eq "=") {
+		    print STDERR ("Option ", $opt, " requires an argument\n");
+		    $error++;
+		}
+		# Push back so the outer loop will terminate.
+		unshift (@main'ARGV, $arg);	#');
+		$arg = "";	# don't assign it
+		next;
+	    }
+
+	    # Maybe the optional argument is the next option?
+	    if ( $mand eq ":" && $' =~ /[a-zA-Z_]/ ) {
+		# Yep. Push back.
+		unshift (@main'ARGV, $arg);	#');
+		$arg = "";	# don't assign it
+		next;
+	    }
+	}
+
+	if ( $type eq "n" || $type eq "i" ) { # numeric/integer
+	    if ( $arg !~ /^-?[0-9]+$/ ) {
+		print STDERR ("Value \"", $arg, "\" invalid for option ",
+			       $opt, " (numeric required)\n");
+		$error++;
+	    }
+	    next;
+	}
+
+	if ( $type eq "f" ) { # fixed real number, int is also ok
+	    if ( $arg !~ /^-?[0-9.]+$/ ) {
+		print STDERR ("Value \"", $arg, "\" invalid for option ",
+			       $opt, " (real number required)\n");
+		$error++;
+	    }
+	    next;
+	}
+
+	if ( $type eq "s" ) { # string
+	    next;
+	}
+
+    }
+    continue {
+	print STDERR ("=> \$main'opt_$opt = $arg\n") if $debug;
+	eval ("\$main'opt_$opt = \$arg");
+    }
+
+    return ($error == 0);
+}
+1;